No OneTemporary
Actions

Size

7 MB

Subscribers

None

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.

	diff --git a/metadata/metadata b/metadata/metadata
	--- a/metadata/metadata
	+++ b/metadata/metadata
	@@ -1,11664 +1,12001 @@
	[Arith_Prog_Rel_Primes]
	title = Arithmetic progressions and relative primes
	author = José Manuel Rodríguez Caballero <https://josephcmac.github.io/>
	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
	<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?

	[Banach_Steinhaus]
	title = Banach-Steinhaus Theorem
	author = Dominique Unruh <http://kodu.ut.ee/~unruh/> <mailto:unruh@ut.ee>, Jose Manuel Rodriguez Caballero <https://josephcmac.github.io/> <mailto:jose.manuel.rodriguez.caballero@ut.ee>
	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ć <http://www.matf.bg.ac.rs/~filip>, Danijela Simić <http://poincare.matf.bg.ac.rs/~danijela>
	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ć <http://poincare.matf.bg.ac.rs/~danijela>, Filip Marić <http://www.matf.bg.ac.rs/~filip>, Pierre Boutry <mailto:boutry@unistra.fr>
	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 <https://www.cl.cam.ac.uk/~lp15/>
	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 <mailto:jonas.raedle@gmail.com>, Lars Hupel <https://www21.in.tum.de/~hupel/>
	topic = Computer science/Data structures
	date = 2018-11-06
	notify = jonas.raedle@gmail.com
	abstract =
	<p>We provide a framework for automatically deriving instances for
	generic type classes. Our approach is inspired by Haskell's
	<i>generic-deriving</i> package and Scala's
	<i>shapeless</i> 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.</p>
	<p>Note: There are already articles in the AFP that provide
	automatic instantiation for a number of classes. Concretely, <a href="https://www.isa-afp.org/entries/Deriving.html">Deriving</a> allows the automatic instantiation of comparators, linear orders, equality, and hashing. <a href="https://www.isa-afp.org/entries/Show.html">Show</a> instantiates a Haskell-style <i>show</i> class.</p><p>Our approach works for arbitrary classes (with some Isabelle/HOL overhead for each class), but a smaller set of datatypes.</p>


	[Partial_Order_Reduction]
	title = Partial Order Reduction
	author = Julian Brunner <http://www21.in.tum.de/~brunnerj/>
	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 <https://www21.in.tum.de/~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 <https://lars.hupel.info/>
	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 <http://lig-membres.imag.fr/mechenim/>
	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 <a
	href="https://hal.archives-ouvertes.fr/hal-01562944">paper</a>.
	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)<br>


	[Pell]
	title = Pell's Equation
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2018-06-23
	notify = manuel@pruvisto.org
	abstract =
	<p> This article gives the basic theory of Pell's equation
	<em>x</em><sup>2</sup> = 1 +
	<em>D</em> <em>y</em><sup>2</sup>,
	where
	<em>D</em> ∈ ℕ is
	a parameter and <em>x</em>, <em>y</em> are
	integer variables. </p> <p> The main result that is proven
	is the following: If <em>D</em> is not a perfect square,
	then there exists a <em>fundamental solution</em>
	(<em>x</em><sub>0</sub>,
	<em>y</em><sub>0</sub>) that is not the
	trivial solution (1, 0) and which generates all other solutions
	(<em>x</em>, <em>y</em>) in the sense that
	there exists some
	<em>n</em> ∈ ℕ
	such that \|<em>x</em>\| +
	\|<em>y</em>\| √<span
	style="text-decoration:
	overline"><em>D</em></span> =
	(<em>x</em><sub>0</sub> +
	<em>y</em><sub>0</sub> √<span
	style="text-decoration:
	overline"><em>D</em></span>)<sup><em>n</em></sup>.
	This also implies that the set of solutions is infinite, and it gives
	us an explicit and executable characterisation of all the solutions.
	</p> <p> Based on this, simple executable algorithms for
	computing the fundamental solution and the infinite sequence of all
	non-negative solutions are also provided. </p>

	[WebAssembly]
	title = WebAssembly
	author = Conrad Watt <http://www.cl.cam.ac.uk/~caw77/>
	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 <mailto:hellauer@in.tum.de>, Peter Lammich <http://www21.in.tum.de/~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 <i>s</i> in a text
	<i>t</i> can be solved deterministically in
	<i>O(\|s\| + \|t\|)</i> time. We use the Isabelle
	Refinement Framework to formulate and verify the algorithm. Via
	refinement, we apply some optimisations and finally use the
	<em>Sepref</em> tool to obtain executable code in
	<em>Imperative/HOL</em>.

	[Minkowskis_Theorem]
	title = Minkowski's Theorem
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Geometry, Mathematics/Number theory
	date = 2017-07-13
	notify = manuel@pruvisto.org
	abstract =
	<p>Minkowski's theorem relates a subset of
	ℝ<sup>n</sup>, the Lebesgue measure, and the
	integer lattice ℤ<sup>n</sup>: It states that
	any convex subset of ℝ<sup>n</sup> with volume
	greater than 2<sup>n</sup> contains at least one lattice
	point from ℤ<sup>n</sup>\{0}, i. e. a
	non-zero point with integer coefficients.</p> <p>A
	related theorem which directly implies this is Blichfeldt's
	theorem, which states that any subset of
	ℝ<sup>n</sup> with a volume greater than 1
	contains two different points whose difference vector has integer
	components.</p> <p>The entry contains a proof of both
	theorems.</p>

	[Name_Carrying_Type_Inference]
	title = Verified Metatheory and Type Inference for a Name-Carrying Simply-Typed Lambda Calculus
	author = Michael Rawson <mailto:michaelrawson76@gmail.com>
	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 <a
	href="http://www.openthesis.org/documents/Verified-Metatheory-Type-Inference-Simply-603182.html">undergraduate
	dissertation</a>.

	[Propositional_Proof_Systems]
	title = Propositional Proof Systems
	author = Julius Michaelis <http://liftm.de>, Tobias Nipkow <http://www21.in.tum.de/~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 <mailto:simon.foster@york.ac.uk>, Frank Zeyda <mailto:frank.zeyda@york.ac.uk>
	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, <em>get</em>, the return a value
	from the source type, and <em>put</em> 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)<br>
	[2021-01-27]
	Addition of new theorems throughout, particularly for prisms.
	New "chantype" command allows the definition of an algebraic datatype with generated prisms.
	New "dataspace" command allows the definition of a local-based state space, including lenses and prisms.
	Addition of various examples for the above.
	(revision 89cf045a)<br>
	- [2021-11-15]
	+ [2021-11-15]
	Improvement of alphabet and chantype commands to support code generation.
	Addition of a tactic "rename_alpha_vars" that removes the subscript vs in proof goals.
	Bug fixes and improvements to alphabet command ML implementation.
	Additional laws for scenes.
	(revisions 9f8bcd71c121 and c061bf9f46f3)<br>

	[Game_Based_Crypto]
	title = Game-based cryptography in HOL
	author = Andreas Lochbihler <http://www.andreas-lochbihler.de>, S. Reza Sefidgar <>, Bhargav Bhatt <mailto:bhargav.bhatt@inf.ethz.ch>
	topic = Computer science/Security/Cryptography
	date = 2017-05-05
	notify = mail@andreas-lochbihler.de
	abstract =
	<p>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.
	</p><p>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.</p>
	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 <http://homepages.inf.ed.ac.uk/da/>, David Butler <mailto:dbutler@turing.ac.uk>
	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 <https://www.turing.ac.uk/people/doctoral-students/david-butler>, Andreas Lochbihler <http://www.andreas-lochbihler.de>
	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 <http://www.andreas-lochbihler.de>
	topic = Computer science/Security/Cryptography, Computer science/Functional programming, Mathematics/Probability theory
	date = 2017-05-05
	notify = mail@andreas-lochbihler.de
	abstract =
	<p>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.
	</p><p>
	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.</p>

	[Constructive_Cryptography]
	title = Constructive Cryptography in HOL
	author = Andreas Lochbihler <http://www.andreas-lochbihler.de/>, 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 <http://www.andreas-lochbihler.de>
	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)<br>


	[Monad_Normalisation]
	title = Monad normalisation
	author = Joshua Schneider <>, Manuel Eberl <https://pruvisto.org>, Andreas Lochbihler <http://www.andreas-lochbihler.de>
	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 <http://www.andreas-lochbihler.de>
	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)<br>


	[Constructor_Funs]
	title = Constructor Functions
	author = Lars Hupel <https://www21.in.tum.de/~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 <https://www21.in.tum.de/~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, <tt>if-then-else</tt> 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 <tt>if-then-else</tt> as functions.

	[Dict_Construction]
	title = Dictionary Construction
	author = Lars Hupel <https://www21.in.tum.de/~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 <https://lars.hupel.info/>
	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 <a
	href="http://dx.doi.org/10.1007/978-3-319-89884-1_35">verified
	compiler from Isabelle to CakeML</a>. 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
	<a
	href="https://www.isa-afp.org/entries/Lambda_Free_RPOs.html">Blanchette’s
	λ-free higher-order terms</a>. Furthermore, I
	implement translation functions between de-Bruijn terms and named
	terms and prove their correctness.

	[Subresultants]
	title = Subresultants
	author = Sebastiaan Joosten <mailto:sebastiaan.joosten@uibk.ac.at>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@uibk.ac.at>
	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 <https://pruvisto.org>
	topic = Computer science/Algorithms
	date = 2017-03-15
	notify = manuel@pruvisto.org
	abstract =
	<p>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 <em>n</em> is at
	least <em>log<sub>2</sub> (n!)</em>
	in the worst case, i. e. <em>Ω(n log
	n)</em>.</p> <p>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.</p>

	[Quick_Sort_Cost]
	title = The number of comparisons in QuickSort
	author = Manuel Eberl <https://pruvisto.org>
	topic = Computer science/Algorithms
	date = 2017-03-15
	notify = manuel@pruvisto.org
	abstract =
	<p>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
	<em>2 (n+1) H<sub>n</sub> -
	4 n</em>, which is asymptotically equivalent to
	<em>2 n ln n</em>; second, the number of
	comparisons performed by the classic non-randomised QuickSort has the
	same distribution in the average case as the randomised one.</p>

	[Random_BSTs]
	title = Expected Shape of Random Binary Search Trees
	author = Manuel Eberl <https://pruvisto.org>
	topic = Computer science/Data structures
	date = 2017-04-04
	notify = manuel@pruvisto.org
	abstract =
	<p>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.</p> <p>In particular, we prove a logarithmic upper
	bound on the expected height and the <em>Θ(n log n)</em>
	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.</p>

	[Randomised_BSTs]
	title = Randomised Binary Search Trees
	author = Manuel Eberl <https://pruvisto.org>
	topic = Computer science/Data structures
	date = 2018-10-19
	notify = manuel@pruvisto.org
	abstract =
	<p>This work is a formalisation of the Randomised Binary Search
	Trees introduced by Martínez and Roura, including definitions and
	correctness proofs.</p> <p>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.</p>

	[E_Transcendental]
	title = The Transcendence of e
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Analysis, Mathematics/Number theory
	date = 2017-01-12
	notify = manuel@pruvisto.org
	abstract =
	<p>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.</p> <p>This kind of approach can be found in
	many different sources; this formalisation mostly follows a <a href="http://planetmath.org/proofoflindemannweierstrasstheoremandthateandpiaretranscendental">PlanetMath article</a> by Roger Lipsett.</p>

	[Pi_Transcendental]
	title = The Transcendence of π
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2018-09-28
	notify = manuel@pruvisto.org
	abstract =
	<p>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
	<em>e</em>.</p>

	[Hermite_Lindemann]
	title = The Hermite–Lindemann–Weierstraß Transcendence Theorem
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2021-03-03
	notify = manuel@pruvisto.org
	abstract =
	<p>This article provides a formalisation of the
	Hermite-Lindemann-Weierstraß Theorem (also known as simply
	Hermite-Lindemann or Lindemann-Weierstraß). This theorem is one of the
	crowning achievements of 19th century number theory.</p>
	<p>The theorem states that if $\alpha_1, \ldots,
	\alpha_n\in\mathbb{C}$ are algebraic numbers that are linearly
	independent over $\mathbb{Z}$, then $e^{\alpha_1},\ldots,e^{\alpha_n}$
	are algebraically independent over $\mathbb{Q}$.</p>
	<p>Like the <a
	href="https://doi.org/10.1007/978-3-319-66107-0_5">previous
	formalisation in Coq by Bernard</a>, I proceeded by formalising
	<a
	href="https://doi.org/10.1017/CBO9780511565977">Baker's
	version of the theorem and proof</a> and then deriving the
	original one from that. Baker's version states that for any
	algebraic numbers $\beta_1, \ldots, \beta_n\in\mathbb{C}$ and distinct
	algebraic numbers $\alpha_i, \ldots, \alpha_n\in\mathbb{C}$, we have
	$\beta_1 e^{\alpha_1} + \ldots + \beta_n e^{\alpha_n} = 0$ if and only
	if all the $\beta_i$ are zero.</p> <p>This has a number of
	direct corollaries, e.g.:</p> <ul> <li>$e$ and $\pi$
	are transcendental</li> <li>$e^z$, $\sin z$, $\tan z$,
	etc. are transcendental for algebraic
	$z\in\mathbb{C}\setminus\{0\}$</li> <li>$\ln z$ is
	transcendental for algebraic $z\in\mathbb{C}\setminus\{0,
	1\}$</li> </ul>

	[DFS_Framework]
	title = A Framework for Verifying Depth-First Search Algorithms
	author = Peter Lammich <http://www21.in.tum.de/~lammich>, René Neumann <mailto:neumannr@in.tum.de>
	notify = lammich@in.tum.de
	date = 2016-07-05
	topic = Computer science/Algorithms/Graph
	abstract =
	<p>
	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.
	</p><p>
	[CPP-2015] Peter Lammich, René Neumann: A Framework for Verifying
	Depth-First Search Algorithms. CPP 2015: 137-146</p>

	[Flow_Networks]
	title = Flow Networks and the Min-Cut-Max-Flow Theorem
	author = Peter Lammich <http://www21.in.tum.de/~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 <http://www21.in.tum.de/~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 <http://ualberta.ca/~jsylvest/>
	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 <i>group_add</i> 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 <mailto:victor.gomes@cl.cam.ac.uk>, Georg Struth <mailto:g.struth@sheffield.ac.uk>
	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 <mailto:maxime.buyse@polytechnique.edu>, Jason Jaskolka <https://carleton.ca/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 <mailto:lukas.bulwahn@gmail.com>
	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 <mailto:lukas.bulwahn@gmail.com>
	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 <mailto:lukas.bulwahn@gmail.com>
	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 <mailto:stark@cs.stonybrook.edu>
	notify = stark@cs.stonybrook.edu
	date = 2016-06-26
	topic = Mathematics/Category theory
	abstract =
	<p>
	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.
	</p><p>
	Revisions made subsequent to the first version of this article added
	material on equivalence of categories, cartesian categories,
	categories with pullbacks, categories with finite limits, and
	cartesian closed categories. A construction was given of the category
	of hereditarily finite sets and functions between them, and it was
	shown that this category is cartesian closed.
	</p>
	extra-history =
	Change history:
	[2018-05-29]:
	Revised axioms for the category locale. Introduced notation for composition and "in hom".
	(revision 8318366d4575)<br>
	[2020-02-15]:
	Move ConcreteCategory.thy from Bicategory to Category3 and use it systematically.
	Make other minor improvements throughout.
	(revision a51840d36867)<br>
	[2020-07-10]:
	Added new material, mostly centered around cartesian categories.
	(revision 06640f317a79)<br>
	[2020-11-04]:
	Minor modifications and extensions made in conjunction with the addition
	of new material to Bicategory.
	(revision 472cb2268826)<br>
	[2021-07-22]:
	Minor changes to sublocale declarations related to functor/natural transformation to
	avoid issues with global interpretations reported 2/2/2021 by Filip Smola.
	(revision 49d3aa43c180)<br>

	[MonoidalCategory]
	title = Monoidal Categories
	author = Eugene W. Stark <mailto:stark@cs.stonybrook.edu>
	topic = Mathematics/Category theory
	date = 2017-05-04
	notify = stark@cs.stonybrook.edu
	abstract =
	<p>
	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.
	</p><p>
	Revisions made subsequent to the first version of this article added
	material on cartesian monoidal categories; showing that the underlying
	category of a cartesian monoidal category is a cartesian category, and
	that every cartesian category extends to a cartesian monoidal
	category.
	</p>
	extra-history =
	Change history:
	[2017-05-18]:
	Integrated material from MonoidalCategory/Category3Adapter into Category3/ and deleted adapter.
	(revision 015543cdd069)<br>
	[2018-05-29]:
	Modifications required due to 'Category3' changes. Introduced notation for "in hom".
	(revision 8318366d4575)<br>
	[2020-02-15]:
	Cosmetic improvements.
	(revision a51840d36867)<br>
	[2020-07-10]:
	Added new material on cartesian monoidal categories.
	(revision 06640f317a79)<br>

	[Card_Multisets]
	title = Cardinality of Multisets
	author = Lukas Bulwahn <mailto:lukas.bulwahn@gmail.com>
	notify = lukas.bulwahn@gmail.com
	date = 2016-06-26
	topic = Mathematics/Combinatorics
	abstract =
	<p>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.</p> <p>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.</p>

	[Posix-Lexing]
	title = POSIX Lexing with Derivatives of Regular Expressions
	author = Fahad Ausaf <http://kcl.academia.edu/FahadAusaf>, Roy Dyckhoff <https://rd.host.cs.st-andrews.ac.uk>, Christian Urban <http://www.inf.kcl.ac.uk/staff/urbanc/>
	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 <mailto:steven@recursivemind.com>
	topic = Computer science/Automata and formal languages
	date = 2017-04-28
	notify = steven@recursivemind.com
	abstract =
	This formalisation accompanies the paper <a
	href="https://arxiv.org/abs/1702.03277">Local
	Lexing</a> 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 <http://www.andreas-lochbihler.de>
	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
	<emph>The Max-Flow Min-Cut theorem for countable networks</emph> 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 operation on discrete distributions from finite version of the max-flow min-cut theorem
	(revision a7a198f5bab0)<br>
	[2020-12-19]:
	simpler proof of linkability for bounded unhindered bipartite webs, leading to a simpler proof for networks with bounded out-capacities
	(revision 93ca33f4d915)<br>
	[2021-08-13]:
	generalize the derivation of the characterisation for the relator of discrete probability distributions to work for the bounded and unbounded MFMC theorem
	(revision 3c85bb52bbe6)<br>

	[Liouville_Numbers]
	title = Liouville numbers
	author = Manuel Eberl <https://pruvisto.org>
	date = 2015-12-28
	topic = Mathematics/Analysis, Mathematics/Number theory
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p><p>
	The proof is very elementary and requires only standard arithmetic, the Mean
	Value Theorem for polynomials, and the boundedness of polynomials on compact
	intervals.
	</p>
	notify = manuel@pruvisto.org

	[Triangle]
	title = Basic Geometric Properties of Triangles
	author = Manuel Eberl <https://pruvisto.org>
	date = 2015-12-28
	topic = Mathematics/Geometry
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p>
	notify = manuel@pruvisto.org

	[Prime_Harmonic_Series]
	title = The Divergence of the Prime Harmonic Series
	author = Manuel Eberl <https://pruvisto.org>
	date = 2015-12-28
	topic = Mathematics/Number theory
	abstract =
	<p>
	In this work, we prove the lower bound <span class="nobr">ln(H_n) -
	ln(5/3)</span> for the
	partial sum of the Prime Harmonic series and, based on this, the divergence of
	the Prime Harmonic Series
	<span class="nobr">∑[p prime] · 1/p.</span>
	</p><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.
	</p>
	notify = manuel@pruvisto.org

	[Descartes_Sign_Rule]
	title = Descartes' Rule of Signs
	author = Manuel Eberl <https://pruvisto.org>
	date = 2015-12-28
	topic = Mathematics/Analysis
	abstract =
	<p>
	Descartes' Rule of Signs relates the number of positive real roots of a
	polynomial with the number of sign changes in its coefficient sequence.
	</p><p>
	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.
	</p>
	notify = manuel@pruvisto.org

	[Euler_MacLaurin]
	title = The Euler–MacLaurin Formula
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Analysis
	date = 2017-03-10
	notify = manuel@pruvisto.org
	abstract =
	<p>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.</p> <p>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 <em>Concrete Mathematics</em> that is
	more useful for deriving asymptotic estimates.</p> <p>As
	example applications, we use that formula to derive the full
	asymptotic expansion of the harmonic numbers and the sum of inverse
	squares.</p>

	[Card_Partitions]
	title = Cardinality of Set Partitions
	author = Lukas Bulwahn <mailto:lukas.bulwahn@gmail.com>
	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 <mailto:lukas.bulwahn@gmail.com>
	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 <http://www.sci.kagoshima-u.ac.jp/~furusawa/>, Georg Struth <http://www.dcs.shef.ac.uk/~georg>
	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 <mailto:pasquale.noce.lavoro@gmail.com>
	date = 2015-06-11
	topic = Computer science/Security, Computer science/Concurrency/Process calculi
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p><p>
	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.
	</p><p>
	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.
	</p>
	notify =

	[Noninterference_Ipurge_Unwinding]
	title = The Ipurge Unwinding Theorem for CSP Noninterference Security
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	date = 2015-06-11
	topic = Computer science/Security
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p><p>
	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.
	</p><p>
	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.
	</p>
	notify =

	[Relational_Method]
	title = The Relational Method with Message Anonymity for the Verification of Cryptographic Protocols
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	topic = Computer science/Security
	date = 2020-12-05
	notify = pasquale.noce.lavoro@gmail.com
	abstract =
	This paper introduces a new method for the formal verification of
	cryptographic protocols, the relational method, derived from
	Paulson's inductive method by means of some enhancements aimed at
	streamlining formal definitions and proofs, specially for protocols
	using public key cryptography. Moreover, this paper proposes a method
	to formalize a further security property, message anonymity, in
	addition to message confidentiality and authenticity. The relational
	method, including message anonymity, is then applied to the
	verification of a sample authentication protocol, comprising Password
	Authenticated Connection Establishment (PACE) with Chip Authentication
	Mapping followed by the explicit verification of an additional
	password over the PACE secure channel.

	[List_Interleaving]
	title = Reasoning about Lists via List Interleaving
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	date = 2015-06-11
	topic = Computer science/Data structures
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p>
	notify =

	[Residuated_Lattices]
	title = Residuated Lattices
	author = Victor B. F. Gomes <mailto:vborgesferreiragomes1@sheffield.ac.uk>, Georg Struth <mailto:g.struth@sheffield.ac.uk>
	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 <http://peteg.org>, Tony Hosking <https://www.cs.purdue.edu/homes/hosking/>, Kai Engelhardt <>
	date = 2015-04-13
	topic = Computer science/Algorithms/Concurrent
	abstract =
	<p>
	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.</p>
	<p>
	This development accompanies the PLDI 2015 paper of the same name.
	</p>
	notify = peteg42@gmail.com

	[List_Update]
	title = Analysis of List Update Algorithms
	author = Maximilian P.L. Haslbeck <http://in.tum.de/~haslbema/>, Tobias Nipkow <http://www21.in.tum.de/~nipkow>
	date = 2016-02-17
	topic = Computer science/Algorithms/Online
	abstract =
	<p>
	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 <i>Online Computation
	and Competitive Analysis</i> by Borodin and El-Yaniv.
	</p>
	<p>
	For an informal description see the FSTTCS 2016 publication
	<a href="http://www21.in.tum.de/~nipkow/pubs/fsttcs16.html">Verified Analysis of List Update Algorithms</a>
	by Haslbeck and Nipkow.
	</p>
	notify = nipkow@in.tum.de

	[ConcurrentIMP]
	title = Concurrent IMP
	author = Peter Gammie <http://peteg.org>
	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 <http://peteg.org>
	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 <mailto:adbrucker@0x5f.org>, Lukas Brügger <mailto:lukas.a.bruegger@gmail.com>, Burkhart Wolff <mailto:wolff@lri.fr>
	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 <https://www.brucker.ch>, Lukas Brügger<>, Burkhart Wolff <https://www.lri.fr/~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 <http://www.tbrk.org>, Peter Höfner <http://www.hoefner-online.de/>
	date = 2014-10-23
	topic = Computer science/Concurrency/Process calculi
	abstract =
	<p>
	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.
	<p>
	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.
	</p><p>
	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.
	</p>
	notify = tim@tbrk.org

	[Show]
	title = Haskell's Show Class in Isabelle/HOL
	author = Christian Sternagel <mailto:c.sternagel@gmail.com>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	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.<br>
	[2015-04-10]: Moved development for old-style datatypes into subdirectory
	"Old_Datatype".<br>
	notify = christian.sternagel@uibk.ac.at, rene.thiemann@uibk.ac.at

	[Certification_Monads]
	title = Certification Monads
	author = Christian Sternagel <mailto:c.sternagel@gmail.com>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	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 <mailto:Freek.Verbeek@ou.nl>, Sergey Tverdyshev <mailto:stv@sysgo.com>, Oto Havle <mailto:oha@sysgo.com>, Holger Blasum <mailto:holger.blasum@sysgo.com>, Bruno Langenstein <mailto:langenstein@dfki.de>, Werner Stephan <mailto:stephan@dfki.de>, Yakoub Nemouchi <mailto:nemouchi@lri.fr>, Abderrahmane Feliachi <mailto:abderrahmane.feliachi@lri.fr>, Burkhart Wolff <mailto:wolff@lri.fr>, Julien Schmaltz <mailto:Julien.Schmaltz@ou.nl>
	date = 2014-07-18
	topic = Computer science/Security
	abstract =
	<p>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.</p>
	<p>
	This document corresponds to the deliverable D31.1 of the EURO-MILS
	Project <a href="http://www.euromils.eu">http://www.euromils.eu</a>.</p>
	notify =

	[pGCL]
	title = pGCL for Isabelle
	author = David Cock <mailto:david.cock@nicta.com.au>
	date = 2014-07-13
	topic = Computer science/Programming languages/Language definitions
	abstract =
	<p>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.</p>
	<p> This package provides both a shallow embedding of the language
	primitives, and an annotation and refinement framework. The generated
	document includes a brief tutorial.</p>
	notify =

	[Noninterference_CSP]
	title = Noninterference Security in Communicating Sequential Processes
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	date = 2014-05-23
	topic = Computer science/Security
	abstract =
	<p>
	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.
	</p>
	<p>
	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.
	</p>
	<p>
	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.
	</p>
	notify = pasquale.noce.lavoro@gmail.com

	[Floyd_Warshall]
	title = The Floyd-Warshall Algorithm for Shortest Paths
	author = Simon Wimmer <http://in.tum.de/~wimmers>, Peter Lammich <http://www21.in.tum.de/~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 <http://www.doc.ic.ac.uk/~jpw48>
	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 <http://www.tbrk.org>
	date = 2014-03-08
	topic = Computer science/Concurrency/Process calculi
	abstract =
	<p>
	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.</p>
	<p>
	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).</p>
	notify = tim@tbrk.org

	[Selection_Heap_Sort]
	title = Verification of Selection and Heap Sort Using Locales
	author = Danijela Petrovic <http://www.matf.bg.ac.rs/~danijela>
	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 <mailto:rene.thiemann@uibk.ac.at>
	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.
	<p>
	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 <https://www.mpi-inf.mpg.de/~crizkall/>
	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 <http://pp.ipd.kit.edu/~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 <http://pp.ipd.kit.edu/~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).
	<p>
	We use syntax and the denotational semantics from the entry
	"Launchbury", where we formalized Launchbury's natural semantics for
	lazy evaluation.
	<p>
	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.
	<p>
	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 <http://www.itu.dk/people/jebe>
	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.
	<p>
	This entry is described in detail in <a href="http://www.itu.dk/people/jebe/files/thesis.pdf">Bengtson's thesis</a>.
	notify =

	[Pi_Calculus]
	title = The pi-calculus in nominal logic
	author = Jesper Bengtson <http://www.itu.dk/people/jebe>
	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.
	<p>
	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.
	<p>
	This entry is described in detail in <a href="http://www.itu.dk/people/jebe/files/thesis.pdf">Bengtson's thesis</a>.
	notify =

	[Psi_Calculi]
	title = Psi-calculi in Isabelle
	author = Jesper Bengtson <http://www.itu.dk/people/jebe>
	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.
	<p>
	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.
	<p>
	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.
	<p>
	This entry is described in detail in <a href="http://www.itu.dk/people/jebe/files/thesis.pdf">Bengtson's thesis</a>.
	notify =

	[Encodability_Process_Calculi]
	title = Analysing and Comparing Encodability Criteria for Process Calculi
	author = Kirstin Peters <mailto:kirstin.peters@tu-berlin.de>, Rob van Glabbeek <http://theory.stanford.edu/~rvg/>
	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 <mailto:abderrahmane.feliachi@lri.fr>, Burkhart Wolff <mailto:wolff@lri.fr>, Marie-Claude Gaudel <mailto:mcg@lri.fr>
	contributors = Makarius Wenzel <mailto:Makarius.wenzel@lri.fr>
	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).
	<p>
	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 <mailto:b.n@wwu.de>, Peter Lammich <http://www21.in.tum.de/~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 <http://www21.in.tum.de/~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.
	<p>
	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.
	<p>
	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<br>
	[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.<br>
	[2012-07] New example: Nested DFS for emptiness check of Buchi-automata with witness.<br>
	New feature:
	fo_rule method to apply resolution using first-order matching. Useful for arg_conf, fun_cong.<br>
	[2012-08] Adaptation to ICF v2.<br>
	[2012-10-05] Adaptations to include support for Automatic Refinement Framework.<br>
	[2013-09] This entry now depends on Automatic Refinement<br>
	[2014-06] New feature: vc_solve method to solve verification conditions.
	Maintenace changes: VCG-rules for nfoldli, improved setup for FOREACH-loops.<br>
	[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.<br>
	[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 <http://www21.in.tum.de/~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 <mailto:lammich@in.tum.de>
	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.
	<p>
	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 <mailto:lammich@in.tum.de>, 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 <http://www21.in.tum.de/~lammich>, Simon Wimmer <http://in.tum.de/~wimmers>
	topic = Computer science/Algorithms
	date = 2018-04-27
	notify = lammich@in.tum.de
	abstract =
	<a
	href="http://www.pm.inf.ethz.ch/research/verifythis.html">VerifyThis
	2018</a> 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 <http://users.abo.fi/vpreotea/>
	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 <http://users.abo.fi/vpreotea/>
	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 <http://users.abo.fi/vpreotea/>
	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 <mailto:ralph.romanos@student.ecp.fr>, Lawrence C. Paulson <http://www.cl.cam.ac.uk/~lp15/>
	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 <http://net.in.tum.de/~diekmann>, Julius Michaelis <http://liftm.de>, Lars Hupel <https://www21.in.tum.de/~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 <http://net.in.tum.de/~diekmann>, Julius Michaelis <http://liftm.de>, Maximilian Haslbeck<http://cl-informatik.uibk.ac.at/users/mhaslbeck//>
	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
	<a href="http://dl.ifip.org/db/conf/networking/networking2016/1570232858.pdf">Verified iptables Firewall
	Analysis</a>, IFIP Networking 2016.

	[Iptables_Semantics]
	title = Iptables Semantics
	author = Cornelius Diekmann <http://net.in.tum.de/~diekmann>, Lars Hupel <https://www21.in.tum.de/~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 <a
	href="https://www.isa-afp.org/entries/Simple_Firewall.html">Simple_Firewall</a>)
	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 <a
	href="http://iptables.isabelle.systems">fffuu</a>. The tool does not
	require any input —except for the <tt>iptables-save</tt> 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 <http://liftm.de>, Cornelius Diekmann <http://net.in.tum.de/~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 <http://peteg.org>
	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 <mailto:tjm1983@gmail.com>
	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.
	<p>
	An earlier version of this work was the subject of the author's
	<a href="http://researcharchive.vuw.ac.nz/handle/10063/2315">MSc thesis</a>,
	which contains natural-language explanations of some of the
	more interesting proofs.
	notify = tjm1983@gmail.com

	[IsaGeoCoq]
	title = Tarski's Parallel Postulate implies the 5th Postulate of Euclid, the Postulate of Playfair and the original Parallel Postulate of Euclid
	author = Roland Coghetto <mailto:roland_coghetto@hotmail.com>
	topic = Mathematics/Geometry
	license = LGPL
	date = 2021-01-31
	notify = roland_coghetto@hotmail.com
	abstract =
	<p>The <a href="https://geocoq.github.io/GeoCoq/">GeoCoq library</a> contains a formalization
	of geometry using the Coq proof assistant. It contains both proofs
	about the foundations of geometry and high-level proofs in the same
	style as in high school. We port a part of the GeoCoq
	2.4.0 library to Isabelle/HOL: more precisely,
	the files Chap02.v to Chap13_3.v, suma.v as well as the associated
	definitions and some useful files for the demonstration of certain
	parallel postulates. The synthetic approach of the demonstrations is directly
	inspired by those contained in GeoCoq. The names of the lemmas and
	theorems used are kept as far as possible as well as the definitions.
	</p>
	<p>It should be noted that T.J.M. Makarios has done
	<a href="https://www.isa-afp.org/entries/Tarskis_Geometry.html">some proofs in Tarski's Geometry</a>. It uses a definition that does not quite
	coincide with the definition used in Geocoq and here.
	Furthermore, corresponding definitions in the <a href="https://www.isa-afp.org/entries/Poincare_Disc.html">Poincaré Disc Model
	development</a> are not identical to those defined in GeoCoq.
	</p>
	<p>In the last part, it is
	formalized that, in the neutral/absolute space, the axiom of the
	parallels of Tarski's system implies the Playfair axiom, the 5th
	postulate of Euclid and Euclid's original parallel postulate. These
	proofs, which are not constructive, are directly inspired by Pierre
	Boutry, Charly Gries, Julien Narboux and Pascal Schreck.
	</p>

	[General-Triangle]
	title = The General Triangle Is Unique
	author = Joachim Breitner <mailto:mail@joachim-breitner.de>
	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 <http://rok.strnisa.com/lj/>, Matthew Parkinson <http://research.microsoft.com/people/mattpark/>
	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 <mailto:grechukbogdan@yandex.ru>
	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 <mailto:immler@in.tum.de>
	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 <http://www.in.tum.de/~krauss>, Tobias Nipkow <http://www21.in.tum.de/~nipkow>
	contributors = Manuel Eberl <https://pruvisto.org>
	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. <i>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.</i> <P> 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<br>
	[2012-05-10]: Tobias Nipkow added extended regular expressions<br>
	[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 <http://www21.in.tum.de/~nipkow>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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.
	<a href="http://www21.in.tum.de/~nipkow/pubs/itp14.html">
	The formalization is described in a paper of the same name presented at
	Interactive Theorem Proving 2014</a>.
	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 <https://traytel.bitbucket.io>, Tobias Nipkow <http://www21.in.tum.de/~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.
	<p>
	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.
	<p>
	The formalization is described in this <a href="http://www21.in.tum.de/~nipkow/pubs/icfp13.html">ICFP 2013 functional pearl</a>.
	notify = traytel@in.tum.de, nipkow@in.tum.de

	[Formula_Derivatives]
	title = Derivatives of Logical Formulas
	author = Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <em>not</em> 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).
	<p>
	The WS1S instance is described in the draft paper <a
	href="https://people.inf.ethz.ch/trayteld/papers/csl15-ws1s_derivatives/index.html">A
	Coalgebraic Decision Procedure for WS1S</a> 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 <http://www.inf.kcl.ac.uk/staff/urbanc/>
	contributors = Manuel Eberl <https://pruvisto.org>
	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 <https://nms.kcl.ac.uk/christian.urban/>, Sebastiaan J. C. Joosten <https://sjcjoosten.nl/>
	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 <mailto:Maksym.Bortin@nicta.com.au>
	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 <http://www21.in.tum.de/~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 <http://www.in.tum.de/~berghofe>, 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 <http://www21.in.tum.de/~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 <mailto:helke@cs.tu-berlin.de>, Florian Kammüller <mailto:flokam@cs.tu-berlin.de>
	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 <http://www.loria.fr/~merz>
	topic = Computer science/Automata and formal languages
	date = 2012-05-07
	abstract = <p>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.</p> <p>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.</p>
	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 <https://traytel.bitbucket.io>
	topic = Computer science/Automata and formal languages
	date = 2013-11-15
	abstract = <p>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.</p>
	<p>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.</p>
	<p>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.</p>
	notify = traytel@in.tum.de

	[Tree-Automata]
	title = Tree Automata
	author = Peter Lammich <http://www21.in.tum.de/~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 <http://www21.in.tum.de/~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 <http://www21.in.tum.de/~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 <mailto:hoelzl@in.tum.de>
	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.
	<p>
	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 <http://users.abo.fi/vpreotea/>, Ralph-Johan Back <http://users.abo.fi/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 <i>next</i> 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 <mailto:c.sternagel@gmail.com>
	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.<br>
	[2018-09-17]:
	Added theory Efficient_Mergesort that works exclusively with the mutual
	induction schemas generated by the function package.<br>
	[2018-09-19]:
	Added theory Mergesort_Complexity that proves an upper bound on the number of
	comparisons that are required by mergesort.<br>
	[2018-09-19]:
	Theory Efficient_Mergesort replaces theory Efficient_Sort but keeping the old
	name Efficient_Sort.
	[2020-11-20]:
	Additional theory Natural_Mergesort that developes an efficient mergesort
	algorithm without key-functions for educational purposes.
	notify = c.sternagel@gmail.com

	[SATSolverVerification]
	title = Formal Verification of Modern SAT Solvers
	author = Filip Marić <http://poincare.matf.bg.ac.rs/~filip/>
	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: <ul> <li> a solver based on classical DPLL procedure (using only a backtrack-search with unit propagation),</li> <li> a very general solver with backjumping and learning (similar to the description given in (Nieuwenhuis et al., 2006)), and</li> <li> a solver with a specific conflict analysis algorithm (similar to the description given in (Krstic et al., 2007)).</li> </ul> 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 <mailto:c.sternagel@gmail.com>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	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 <mailto:rene.thiemann@uibk.ac.at>
	license = LGPL
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p>
	notify = rene.thiemann@uibk.ac.at

	[MuchAdoAboutTwo]
	title = Much Ado About Two
	author = Sascha Böhme <http://www21.in.tum.de/~boehmes/>
	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 <http://www.fceia.unr.edu.ar/~mauro/>, Stephan Merz <http://www.loria.fr/~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 <http://users.cecs.anu.edu.au/~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 <http://www.cs.famaf.unc.edu.ar/~damian/>
	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 <a href="http://users.rsise.anu.edu.au/~tiu/clocksync.pdf">"Verification of Clock Synchronization Algorithms: Experiments on a combination of deductive tools"</a> in proceedings of AVOCS 2005. In this work the correctness of Schneider schema was also verified using Isabelle (entry <a href="GenClock.html">GenClock</a> 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 <mailto:henri.debrat@loria.fr>, Stephan Merz <http://www.loria.fr/~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".
	<p>
	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.
	<p>
	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 <mailto:sprenger@inf.ethz.ch>
	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 <mailto:joseph.lallemand@loria.fr>, Christoph Sprenger <mailto:sprenger@inf.ethz.ch>
	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 <mailto:sprenger@inf.ethz.ch>, 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 <mailto:rachid.guerraoui@epfl.ch>, Viktor Kuncak <http://lara.epfl.ch/~kuncak/>, Giuliano Losa <mailto:giuliano.losa@epfl.ch>
	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 <http://www21.in.tum.de/~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.
	<p>
	A preliminary version of this work (without pairing heaps) is described
	in a <a href="http://www21.in.tum.de/~nipkow/pubs/itp15.html">paper</a>
	published in the proceedings of the conference on Interactive
	Theorem Proving ITP 2015. An extended version of this publication
	is available <a href="http://www21.in.tum.de/~nipkow/pubs/jfp16.html">here</a>.
	extra-history =
	Change history:
	[2015-03-17]: Added pairing heaps by Hauke Brinkop.<br>
	[2016-07-12]: Moved splay heaps from here to Splay_Tree<br>
	[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 <http://www21.in.tum.de/~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.
	<P>
	A full description is found in a
	<a href="http://www21.in.tum.de/~nipkow/pubs">companion paper</a>.
	notify = nipkow@in.tum.de

	[AVL-Trees]
	title = AVL Trees
	author = Tobias Nipkow <http://www21.in.tum.de/~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 <tt>gerwin.klein@nicta.com.au</tt>.
	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 <http://lara.epfl.ch/~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 <http://www21.in.tum.de/~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).
	<p>
	The amortized complexity of splay trees and heaps is analyzed in the AFP entry
	<a href="http://isa-afp.org/entries/Amortized_Complexity.html">Amortized Complexity</a>.
	extra-history =
	Change history:
	[2016-07-12]: Moved splay heaps here from Amortized_Complexity

	[Root_Balanced_Tree]
	title = Root-Balanced Tree
	author = Tobias Nipkow <http://www21.in.tum.de/~nipkow>
	notify = nipkow@in.tum.de
	date = 2017-08-20
	topic = Computer science/Data structures
	abstract =
	<p>
	Andersson introduced <em>general balanced trees</em>,
	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 <em>root-balanced trees</em>. Using a lightweight model
	of execution time, amortized logarithmic complexity is verified in
	the theorem prover Isabelle.
	</p>
	<p>
	This is the Isabelle formalization of the material decribed in the APLAS 2017 article
	<a href="http://www21.in.tum.de/~nipkow/pubs/aplas17.html">Verified Root-Balanced Trees</a>
	by the same author, which also presents experimental results that show
	competitiveness of root-balanced with AVL and red-black trees.
	</p>

	[Skew_Heap]
	title = Skew Heap
	author = Tobias Nipkow <http://www21.in.tum.de/~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.
	<p>
	The amortized complexity of skew heaps is analyzed in the AFP entry
	<a href="http://isa-afp.org/entries/Amortized_Complexity.html">Amortized Complexity</a>.
	notify = nipkow@in.tum.de

	[Pairing_Heap]
	title = Pairing Heap
	author = Hauke Brinkop <mailto:hauke.brinkop@googlemail.com>, Tobias Nipkow <http://www21.in.tum.de/~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.
	<p>
	The amortized complexity of pairing heaps is analyzed in the AFP article
	<a href="http://isa-afp.org/entries/Amortized_Complexity.html">Amortized Complexity</a>.
	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 <http://www21.in.tum.de/~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 <mailto:neumannr@in.tum.de>
	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 <mailto:rene.meis@uni-muenster.de>, Finn Nielsen <mailto:finn.nielsen@uni-muenster.de>, Peter Lammich <http://www21.in.tum.de/~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 <em>findMin</em>, <em>deleteMin</em>,
	<em>insert</em>, and <em>meld</em> operations,
	skew binomial heaps have constant time <em>findMin</em>, <em>insert</em>,
	and <em>meld</em> operations, and only the <em>deleteMin</em>-operation is
	logarithmic. This is achieved by using <em>skew links</em> to avoid
	cascading linking on <em>insert</em>-operations, and <em>data-structural
	bootstrapping</em> to get constant-time <em>findMin</em> and <em>meld</em>
	operations. Our implementation follows the paper by Brodal and Okasaki.
	notify = peter.lammich@uni-muenster.de

	[Finger-Trees]
	title = Finger Trees
	author = Benedikt Nordhoff <mailto:b_nord01@uni-muenster.de>, Stefan Körner <mailto:s_koer03@uni-muenster.de>, Peter Lammich <http://www21.in.tum.de/~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
	<em>monotone predicate</em> 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 <http://www.andreas-lochbihler.de>, Tobias Nipkow <http://www21.in.tum.de/~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 <http://www.andreas-lochbihler.de>
	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)<br>
	[2010-11-04]:
	new conversion function from FinFun to list of elements in the domain
	(revision 0c167102e6ed)<br>
	[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 <http://www21.in.tum.de/~lammich>
	contributors = Andreas Lochbihler <http://www.andreas-lochbihler.de>, 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.<br>
	[2010-12-01]: New Interfaces: Priority Queues, Annotated Lists. Implemented by finger trees, (skew) binomial queues.<br>
	[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<br>
	[2012-04-25]: New iterator foundation by Tuerk. Various maintenance changes.<br>
	[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.<br>
	[2013-09]: Added Generic Collection Framework based on Autoref. The GenCF provides: Arbitrary nesting, full integration with Autoref.<br>
	[2014-06]: Maintenace changes to GenCF: Optimized inj_image on list_set. op_set_cart (Cartesian product). big-Union operation. atLeastLessThan - operation ({a..<b})<br>
	notify = lammich@in.tum.de

	[Containers]
	title = Light-weight Containers
	author = Andreas Lochbihler <http://www.andreas-lochbihler.de>
	contributors = René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	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.
	<p>
	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)<br>
	[2013-09-20]:
	provide generators for canonical type class instantiations
	(revision 159f4401f4a8 by René Thiemann)<br>
	[2014-07-08]: add support for going from partial functions to mappings (revision 7a6fc957e8ed)<br>
	[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 <http://www.mit.edu/~kkz/>, Viktor Kuncak <http://lara.epfl.ch/~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 <mailto:rene.thiemann@uibk.ac.at>
	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.
	<p>
	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.
	<p>
	Our formalization was performed as part of the <a href="http://cl-informatik.uibk.ac.at/software/ceta">IsaFoR/CeTA</a> project.
	With our new tactic we could completely remove
	tedious proofs for linear orders of two datatypes.
	<p>
	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 <mailto:c.sternagel@gmail.com>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	date = 2015-03-11
	topic = Computer science/Data structures
	abstract =
	<p>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.</p>
	<p>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.</p>
	<p>Our formalization was performed as part of the <a href="http://cl-informatik.uibk.ac.at/software/ceta">IsaFoR/CeTA</a> 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.</p>
	notify = rene.thiemann@uibk.ac.at

	[List-Index]
	title = List Index
	date = 2010-02-20
	author = Tobias Nipkow <http://www21.in.tum.de/~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 <mailto:c.sternagel@gmail.com>, René Thiemann <http://cl-informatik.uibk.ac.at/~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 <a
	href="http://cl-informatik.uibk.ac.at/software/ceta">CeTA</a> 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 <mailto:prathamesh@imsc.res.in>
	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 <http://www21.in.tum.de/~blanchet>
	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 <mailto:rene.thiemann@uibk.ac.at>
	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 <mailto:rene.thiemann@uibk.ac.at>
	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 <tt>{x :: 'a. P x}</tt>,
	provided the definition is of the form
	<tt>f ys = (if check ys then Some(generate ys :: 'a) else None)</tt> where
	<tt>ys</tt> is a list of variables <tt>y1 ... yn</tt> and
	<tt>check ys ==> P(generate ys)</tt> can be proved.
	<p>
	In principle, such a definition is also directly possible using the
	<tt>lift_definition</tt> 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 <tt>check ys</tt> 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 <http://www.andreas-lochbihler.de>
	contributors = Johannes Hölzl <mailto:hoelzl@in.tum.de>
	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.<br>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)<br>
	[2010-06-28]:
	new codatatype terminated lazy lists
	(revision e12de475c558)<br>
	[2010-08-04]:
	terminated lazy lists: setup for quotient package;
	more lemmas
	(revision 6ead626f1d01)<br>
	[2010-08-17]:
	Koenig's lemma as an example application for coinductive lists
	(revision f81ce373fa96)<br>
	[2011-02-01]:
	lazy implementation of coinductive (terminated) lists for the code generator
	(revision 6034973dce83)<br>
	[2011-07-20]:
	new codatatype resumption
	(revision 811364c776c7)<br>
	[2012-06-27]:
	new codatatype stream with operations (with contributions by Peter Gammie)
	(revision dd789a56473c)<br>
	[2013-03-13]:
	construct codatatypes with the BNF package and adjust the definitions and proofs,
	setup for lifting and transfer packages
	(revision f593eda5b2c0)<br>
	[2013-09-20]:
	stream theory uses type and operations from HOL/BNF/Examples/Stream
	(revision 692809b2b262)<br>
	[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)<br>
	notify = mail@andreas-lochbihler.de

	[Stream-Fusion]
	title = Stream Fusion
	author = Brian Huffman <http://cs.pdx.edu/~brianh>
	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 <a href="http://hackage.haskell.org/package/stream-fusion">online</a>.)<br><br>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 <mailto:huffman@in.tum.de>
	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 <i>Formal Verification of Monad
	Transformers</i> by the author. The formalization is a revised and
	updated version of earlier joint work with Matthews and White.
	<P>
	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 <http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php>
	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 <http://www.cs.cornell.edu/~jnfoster/>, Dimitrios Vytiniotis <http://research.microsoft.com/en-us/people/dimitris/>
	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 <http://www.cse.unsw.edu.au/~kleing/>, Tobias Nipkow <http://www21.in.tum.de/~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 <http://www.andreas-lochbihler.de>
	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)<br>
	[2009-04-27]:
	added verified compiler from source code to bytecode;
	encapsulate native methods in separate semantics
	(revision e4f26541e58a)<br>
	[2009-11-30]:
	extended compiler correctness proof to infinite and deadlocking computations
	(revision e50282397435)<br>
	[2010-06-08]:
	added thread interruption;
	new abstract memory model with sequential consistency as implementation
	(revision 0cb9e8dbd78d)<br>
	[2010-06-28]:
	new thread interruption model
	(revision c0440d0a1177)<br>
	[2010-10-15]:
	preliminary version of the Java memory model for source code
	(revision 02fee0ef3ca2)<br>
	[2010-12-16]:
	improved version of the Java memory model, also for bytecode
	executable scheduler for source code semantics
	(revision 1f41c1842f5a)<br>
	[2011-02-02]:
	simplified code generator setup
	new random scheduler
	(revision 3059dafd013f)<br>
	[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)<br>
	[2012-02-16]:
	added example programs
	(revision bf0b06c8913d)<br>
	[2012-11-21]:
	type safety proof for the Java memory model,
	allow spurious wake-ups
	(revision 76063d860ae0)<br>
	[2013-05-16]:
	support for non-deterministic memory allocators
	(revision cc3344a49ced)<br>
	[2017-10-20]:
	add an atomic compare-and-swap operation for volatile fields
	(revision a6189b1d6b30)<br>
	notify = mail@andreas-lochbihler.de

	[Locally-Nameless-Sigma]
	title = Locally Nameless Sigma Calculus
	author = Ludovic Henrio <mailto:Ludovic.Henrio@sophia.inria.fr>, Florian Kammüller <mailto:flokam@cs.tu-berlin.de>, Bianca Lutz <mailto:sowilo@cs.tu-berlin.de>, Henry Sudhof <mailto:hsudhof@cs.tu-berlin.de>
	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 <http://www.cs.mdx.ac.uk/people/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 <mailto:maria.spichkova@rmit.edu.au>
	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 <mailto:tuong@users.gforge.inria.fr>, Burkhart Wolff <https://www.lri.fr/~wolff/>
	date = 2015-09-16
	topic = Computer science/Programming languages/Language definitions
	abstract =
	We represent a theory <i>of</i> (a fragment of) Isabelle/HOL <i>in</i>
	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.
	<p>
	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.
	<p>
	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.
	<p>
	This theory is drawn from the
	<a href="http://isa-afp.org/entries/Featherweight_OCL.html">Featherweight OCL</a>
	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.
	<p>
	Gained experience from this project shows that the compiled code is sufficiently
	efficient for practical purposes while being based on a formal <i>model</i>
	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 <https://www.lri.fr/~ftuong/>, Burkhart Wolff <https://www.lri.fr/~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 <mailto:peteg42@gmail.com>
	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 <http://www.in.tum.de/~berghofe>
	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<sub><:</sub>. 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<sub><:</sub>, 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 <mailto:doczkal@ps.uni-saarland.de>
	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 <http://www21.in.tum.de/~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 <i>W</i> for MiniML (simply-typed lambda terms with <tt>let</tt>) due to Milner. It proves the soundness and completeness of <i>W</i> 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 <mailto:kleing@cse.unsw.edu.au>, Rafal Kolanski <mailto:rafal.kolanski@nicta.com.au>, Andrew Boyton <mailto:andrew.boyton@nicta.com.au>
	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. <P> The ex directory contains example instantiations that include structures such as a heap or virtual memory. <P> 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. <P> 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 <http://www21.in.tum.de/~lammich>, Rene Meis <mailto:rene.meis@uni-due.de>
	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.
	<br>
	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 <http://www.dmi.unict.it/~giamp/>
	date = 2012-05-02
	topic = Computer science/Security
	abstract = This document contains the full theory files accompanying article <i>Inductive Study of Confidentiality --- for Everyone</i> in <i>Formal Aspects of Computing</i>. 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 <https://www.andreipopescu.uk>, Johannes Hölzl <mailto:hoelzl@in.tum.de>
	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.
	<p>
	An <a href="http://www21.in.tum.de/~nipkow/pubs/cpp12.html">article</a>
	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 <mailto:grewe@cs.tu-darmstadt.de>, Heiko Mantel <mailto:mantel@mais.informatik.tu-darmstadt.de>, Daniel Schoepe <mailto:daniel@schoepe.org>
	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.
	<p>
	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 =

	[Dependent_SIFUM_Type_Systems]
	title = A Dependent Security Type System for Concurrent Imperative Programs
	author = Toby Murray <http://people.eng.unimelb.edu.au/tobym/>, Robert Sison<>, Edward Pierzchalski<>, Christine Rizkallah<https://www.mpi-inf.mpg.de/~crizkall/>
	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 <http://people.eng.unimelb.edu.au/tobym/>, Robert Sison<>, Edward Pierzchalski<>, Christine Rizkallah<https://www.mpi-inf.mpg.de/~crizkall/>
	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 <https://people.eng.unimelb.edu.au/tobym/>
	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 <mailto:grewe@cs.tu-darmstadt.de>, Alexander Lux <mailto:lux@mais.informatik.tu-darmstadt.de>, Heiko Mantel <mailto:mantel@mais.informatik.tu-darmstadt.de>, Jens Sauer <mailto:sauer@mais.informatik.tu-darmstadt.de>
	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.
	<p>
	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.
	<p>
	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 =

	[WHATandWHERE_Security]
	title = A Formalization of Declassification with WHAT-and-WHERE-Security
	author = Sylvia Grewe <mailto:grewe@cs.tu-darmstadt.de>, Alexander Lux <mailto:lux@mais.informatik.tu-darmstadt.de>, Heiko Mantel <mailto:mantel@mais.informatik.tu-darmstadt.de>, Jens Sauer <mailto:sauer@mais.informatik.tu-darmstadt.de>
	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.
	<p>
	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.
	<p>
	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.
	<p>
	This Isabelle/HOL formalization uses theories from the entry
	Strong Security.
	notify =

	[VolpanoSmith]
	title = A Correctness Proof for the Volpano/Smith Security Typing System
	author = Gregor Snelting <http://pp.info.uni-karlsruhe.de/personhp/gregor_snelting.php>, Daniel Wasserrab <http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php>
	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 <http://www21.in.tum.de/~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 <http://www.cosc.canterbury.ac.nz/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 <http://staffwww.dcs.shef.ac.uk/people/G.Struth/>, Tjark Weber <http://user.it.uu.se/~tjawe125/>
	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.
	<p>
	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).
	<p>
	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 <http://www.dcs.shef.ac.uk/~victor>, Georg Struth <http://www.dcs.shef.ac.uk/~georg>
	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 <http://www.dcs.shef.ac.uk/~victor>, Walter Guttmann <http://www.cosc.canterbury.ac.nz/walter.guttmann/>, Peter Höfner <http://www.hoefner-online.de/>, Georg Struth <http://www.dcs.shef.ac.uk/~georg>, Tjark Weber <http://user.it.uu.se/~tjawe125/>
	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 <http://www-users.cs.york.ac.uk/~simonf>, Georg Struth <http://www.dcs.shef.ac.uk/~georg>
	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 <http://www.tcs.informatik.uni-muenchen.de/~mhofmann>
	date = 2008-12-12
	topic = Computer science/Programming languages/Logics
	abstract = This document contains the Isabelle/HOL sources underlying the paper <i>A bytecode logic for JML and types</i> 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 <http://users.abo.fi/vpreotea/>, Ralph-Johan Back <http://users.abo.fi/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 <mailto:viorel.preoteasa@aalto.fi>
	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 <http://www.tcs.informatik.uni-muenchen.de/~mhofmann>
	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.<br><br>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 <http://homepages.inf.ed.ac.uk/ggrov>, Stephan Merz <http://www.loria.fr/~merz>
	date = 2011-11-19
	topic = Computer science/Programming languages/Logics
	abstract = We mechanise the logic TLA*
	<a href="http://www.springerlink.com/content/ax3qk557qkdyt7n6/">[Merz 1999]</a>,
	an extension of Lamport's Temporal Logic of Actions (TLA)
	<a href="http://dl.acm.org/citation.cfm?doid=177492.177726">[Lamport 1994]</a>
	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:
	<ul>
	<li>a theory of infinite sequences, including a formalisation of the concepts of stuttering invariance central to TLA and TLA*;
	<li>a definition of the semantics of TLA*, which extends TLA by a mutually-recursive definition of formulas and pre-formulas, generalising TLA action formulas;
	<li>a substantial set of derived proof rules, including the TLA* axioms and Lamport's proof rules for system verification;
	<li>a set of examples illustrating the usage of Isabelle/TLA* for reasoning about systems.
	</ul>
	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 <a href="http://www.springerlink.com/content/354026160p14j175/">[Chaudhuri et al 2010]</a>.
	notify = ggrov@inf.ed.ac.uk

	[Compiling-Exceptions-Correctly]
	title = Compiling Exceptions Correctly
	author = Tobias Nipkow <http://www21.in.tum.de/~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 <a href="http://www.cs.nott.ac.uk/~gmh/">Hutton</a> and Wright.
	notify = nipkow@in.tum.de

	[NormByEval]
	title = Normalization by Evaluation
	author = Klaus Aehlig <http://www.linta.de/~aehlig/>, Tobias Nipkow <http://www21.in.tum.de/~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 <http://www21.in.tum.de/~lammich>, Markus Müller-Olm <http://cs.uni-muenster.de/u/mmo/>
	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 <mailto:mail@joachim-breitner.de>
	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 <http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php>
	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.<br><br>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 <http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php>
	date = 2009-11-13
	topic = Computer science/Programming languages/Static analysis
	abstract = After verifying <a href="Slicing.html">dynamic and static interprocedural slicing</a>, 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 <http://peteg.org>
	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 <mailto:rauch@informatik.uni-kl.de>, 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 <http://www21.in.tum.de/~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 <http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php>
	date = 2010-03-23
	topic = Computer science/Security
	abstract =
	<p>
	In this contribution, we show how correctness proofs for <a
	href="Slicing.html">intra-</a> and <a
	href="HRB-Slicing.html">interprocedural slicing</a> 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.
	</p>
	<p>
	This entry contains the part for intra-procedural slicing. See entry
	<a href="InformationFlowSlicing_Inter.html">InformationFlowSlicing_Inter</a>
	for the inter-procedural part.
	</p>
	extra-history =
	Change history:
	[2016-06-10]: The original entry <a
	href="InformationFlowSlicing.html">InformationFlowSlicing</a> contained both
	the <a href="InformationFlowSlicing_Inter.html">inter-</a> and <a
	href="InformationFlowSlicing.html">intra-procedural</a> case was split into
	two for easier maintenance.
	notify =

	[InformationFlowSlicing_Inter]
	title = Inter-Procedural Information Flow Noninterference via Slicing
	author = Daniel Wasserrab <http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php>
	date = 2010-03-23
	topic = Computer science/Security
	abstract =
	<p>
	In this contribution, we show how correctness proofs for <a
	href="Slicing.html">intra-</a> and <a
	href="HRB-Slicing.html">interprocedural slicing</a> 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.
	</p>
	<p>
	This entry contains the part for inter-procedural slicing. See entry
	<a href="InformationFlowSlicing.html">InformationFlowSlicing</a>
	for the intra-procedural part.
	</p>
	extra-history =
	Change history:
	[2016-06-10]: The original entry <a
	href="InformationFlowSlicing.html">InformationFlowSlicing</a> contained both
	the <a href="InformationFlowSlicing_Inter.html">inter-</a> and <a
	href="InformationFlowSlicing.html">intra-procedural</a> case was split into
	two for easier maintenance.
	notify =

	[ComponentDependencies]
	title = Formalisation and Analysis of Component Dependencies
	author = Maria Spichkova <mailto:maria.spichkova@rmit.edu.au>
	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 <i>Proof Theory</i> 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 <a href="Completeness-paper.pdf">[pdf]</a>.
	notify = lp15@cam.ac.uk

	[Ordinal]
	title = Countable Ordinals
	author = Brian Huffman <http://web.cecs.pdx.edu/~brianh/>
	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 <https://www.andreipopescu.uk>
	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 <http://www.in.tum.de/~berghofe>
	contributors = Asta Halkjær From <https://people.compute.dtu.dk/ahfrom/>
	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: Completeness of Modal Logics
	author = Asta Halkjær From <https://people.compute.dtu.dk/ahfrom/>
	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).
	The extensions of system K (T, KB, K4, S4, S5) and their completeness proofs
	are based on the textbook "Modal Logic" by Blackburn, de Rijke and Venema
	(Cambridge University Press 2001).
	Papers: <a href="https://doi.org/10.1007/978-3-030-88853-4_1">https://doi.org/10.1007/978-3-030-88853-4_1</a>, <a href="https://doi.org/10.1007/978-3-030-90138-7_2">https://doi.org/10.1007/978-3-030-90138-7_2</a>.
	extra-history =
	Change history:
	[2021-04-15]: Added completeness of modal logics T, KB, K4, S4 and S5.

	[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 <http://www21.in.tum.de/~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 <http://web.cecs.pdx.edu/~brianh/>
	date = 2010-03-29
	abstract = This theory defines a type constructor representing the free Boolean algebra over a set of generators. Values of type (α)<i>formula</i> 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 <http://www21.in.tum.de/~blanchet>, Andrei Popescu <https://www.andreipopescu.uk>
	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.
	<p>
	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.
	<p>
	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 <mailto:jasmin.blanchette@gmail.com>, Uwe Waldmann <mailto:waldmann@mpi-inf.mpg.de>, Daniel Wand <mailto:dwand@mpi-inf.mpg.de>
	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 <mailto:hbecker@mpi-sws.org>, Jasmin Christian Blanchette <mailto:jasmin.blanchette@gmail.com>, Uwe Waldmann <mailto:waldmann@mpi-inf.mpg.de>, Daniel Wand <mailto:dwand@mpi-inf.mpg.de>
	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 <https://www.cs.vu.nl/~abp290/>
	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 <mailto:jasmin.blanchette@gmail.com>, Mathias Fleury <mailto:fleury@mpi-inf.mpg.de>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <mailto:c.sternagel@gmail.com>, René Thiemann <http://cl-informatik.uibk.ac.at/~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
	<i>joinability</i>, <i>meetability</i>, <i>conversion</i>, 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 <a
	href="http://cl-informatik.uibk.ac.at/software/ceta">CeTA</a> (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. <br>
	[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 <mailto:c.sternagel@gmail.com>, René Thiemann <http://cl-informatik.uibk.ac.at/users/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 <i>Isabelle
	Formalization of Rewriting</i> <a
	href="http://cl-informatik.uibk.ac.at/isafor">IsaFoR</a>,
	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 <mailto:mail@joachim-breitner.de>
	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 <http://kasterma.net>
	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

	[Finitely_Generated_Abelian_Groups]
	title = Finitely Generated Abelian Groups
	author = Joseph Thommes<>, Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Algebra
	date = 2021-07-07
	notify = joseph-thommes@gmx.de, manuel@pruvisto.org
	abstract =
	This article deals with the formalisation of some group-theoretic
	results including the fundamental theorem of finitely generated
	abelian groups characterising the structure of these groups as a
	uniquely determined product of cyclic groups. Both the invariant
	factor decomposition and the primary decomposition are covered.
	Additional work includes results about the direct product, the
	internal direct product and more group-theoretic lemmas.

	[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, <i>A Complete Proof of the Robbins Conjecture</i>, 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 <http://www.unirioja.es/cu/jodivaso>, Jesús Aransay <http://www.unirioja.es/cu/jearansa>
	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 <i>Linear Algebra Done Right</i>. 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 <http://www21.in.tum.de/~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<br>
	[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 <https://home.in.tum.de/~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 <http://www-lti.informatik.rwth-aachen.de/~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 <http://www21.in.tum.de/~immler>, Johannes Hölzl <http://in.tum.de/~hoelzl>
	topic = Mathematics/Analysis
	date = 2012-04-26
	abstract =
	<p>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 <i>flow</i> of ODEs.</p>
	<p>
	Not in the generated document are the following sessions:
	<ul>
	<li> 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.</li>
	<li> HOL-ODE-Examples:
	Applications of the numerical algorithms to concrete systems of ODEs.</li>
	<li> Lorenz_C0, Lorenz_C1:
	Verified algorithms for checking C1-information according to Tucker's proof,
	computation of C0-information.</li>
	</ul>
	</p>
	extra-history =
	Change history:
	[2014-02-13]: added an implementation of the Euler method based on affine arithmetic<br>
	[2016-04-14]: added flow and variational equation<br>
	[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<br>
	[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 <mailto:c.sternagel@gmail.com>, René Thiemann <http://cl-informatik.uibk.ac.at/~thiemann>, Alexander Maletzky <https://risc.jku.at/m/alexander-maletzky/>, Fabian Immler <http://www21.in.tum.de/~immler>, Florian Haftmann <http://isabelle.in.tum.de/~haftmann>, Andreas Lochbihler <http://www.andreas-lochbihler.de>, Alexander Bentkamp <mailto:bentkamp@gmail.com>
	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 <a
	href="http://cl-informatik.uibk.ac.at/software/ceta">IsaFoR/CeTA-system</a>
	which contains several termination techniques. The provided theories have
	been essential to formalize polynomial interpretations.
	<p>
	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.<br>
	[2016-10-28]: Added abstract representation of polynomials and authors Maletzky/Immler.<br>
	[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".<br>
	[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 <mailto:rene.thiemann@uibk.ac.at>
	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 <https://pruvisto.org>
	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 = manuel@pruvisto.org

	[Sturm_Tarski]
	title = The Sturm-Tarski Theorem
	author = Wenda Li <https://www.cl.cam.ac.uk/~wl302/>
	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 <http://in.tum.de/~hoelzl>, Tobias Nipkow <http://www21.in.tum.de/~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.
	<p>
	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.
	<a href="http://arxiv.org/abs/1212.3870">See here for the corresponding paper.</a>
	notify = hoelzl@in.tum.de

	[MDP-Rewards]
	title = Markov Decision Processes with Rewards
	author = Maximilian Schäffeler <mailto:schaeffm@in.tum.de>, Mohammad Abdulaziz <mailto:mansour@in.tum.de>
	topic = Mathematics/Probability theory
	date = 2021-12-16
	notify = schaeffm@in.tum.de, mansour@in.tum.de
	-abstract =
	+abstract =
	We present a formalization of Markov Decision Processes with rewards.
	In particular we first build on Hölzl's formalization of MDPs
	(AFP entry: Markov_Models) and extend them with rewards. We proceed
	with an analysis of the expected total discounted reward criterion for
	infinite horizon MDPs. The central result is the construction of the
	iteration rule for the Bellman operator. We prove the optimality
	equations for this operator and show the existence of an optimal
	stationary deterministic solution. The analysis can be used to obtain
	dynamic programming algorithms such as value iteration and policy
	iteration to solve MDPs with formal guarantees. Our formalization is
	based on chapters 5 and 6 in Puterman's book "Markov
	Decision Processes: Discrete Stochastic Dynamic Programming".

	[MDP-Algorithms]
	title = Verified Algorithms for Solving Markov Decision Processes
	author = Maximilian Schäffeler <mailto:schaeffm@in.tum.de>, Mohammad Abdulaziz <mailto:mansour@in.tum.de>
	topic = Mathematics/Probability theory, Computer science/Algorithms
	date = 2021-12-16
	notify = schaeffm@in.tum.de, mansour@in.tum.de
	-abstract =
	+abstract =
	We present a formalization of algorithms for solving Markov Decision
	Processes (MDPs) with formal guarantees on the optimality of their
	solutions. In particular we build on our analysis of the Bellman
	operator for discounted infinite horizon MDPs. From the iterator rule
	on the Bellman operator we directly derive executable value iteration
	and policy iteration algorithms to iteratively solve finite MDPs. We
	also prove correct optimized versions of value iteration that use
	matrix splittings to improve the convergence rate. In particular, we
	formally verify Gauss-Seidel value iteration and modified policy
	iteration. The algorithms are evaluated on two standard examples from
	the literature, namely, inventory management and gridworld. Our
	formalization covers most of chapter 6 in Puterman's book
	"Markov Decision Processes: Discrete Stochastic Dynamic
	Programming".

	[Probabilistic_System_Zoo]
	title = A Zoo of Probabilistic Systems
	author = Johannes Hölzl <http://in.tum.de/~hoelzl>,
	Andreas Lochbihler <http://www.andreas-lochbihler.de>,
	Dmitriy Traytel <https://traytel.bitbucket.io>
	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.
	<p>
	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 <https://pruvisto.org>, Johannes Hölzl <http://in.tum.de/~hoelzl>, Tobias Nipkow <http://www21.in.tum.de/~nipkow>
	date = 2014-10-09
	topic = Mathematics/Probability theory, Computer science/Programming languages/Compiling
	abstract =
	<a href="https://doi.org/10.1007/978-3-642-36742-7_35">Bhat et al. [TACAS 2013]</a> 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.
	<p>
	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 <http://www21.in.tum.de/~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.
	<p>
	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.
	<p>
	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.
	<p>
	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 <https://www7.in.tum.de/~sickert>
	contributors = Benedikt Seidl <mailto:benedikt.seidl@tum.de>
	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. <br>
	notify = sickert@in.tum.de

	[LTL_to_GBA]
	title = Converting Linear-Time Temporal Logic to Generalized Büchi Automata
	author = Alexander Schimpf <mailto:schimpfa@informatik.uni-freiburg.de>, Peter Lammich <http://www21.in.tum.de/~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.
	<p>
	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 <http://www21.in.tum.de/~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 <mailto:rene.neumann@in.tum.de>
	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 <https://www7.in.tum.de/~esparza/>,
	Peter Lammich <http://www21.in.tum.de/~lammich>,
	René Neumann <mailto:rene.neumann@in.tum.de>,
	Tobias Nipkow <http://www21.in.tum.de/~nipkow>,
	Alexander Schimpf <mailto:schimpfa@informatik.uni-freiburg.de>,
	Jan-Georg Smaus <http://www.irit.fr/~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.
	<p>
	An early version of this model checker is described in the
	<a href="http://www21.in.tum.de/~nipkow/pubs/cav13.html">CAV 2013 paper</a>
	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<ul><li>Fermat's Last Theorem for exponents 3 and 4 and</li><li>the parametrisation of Pythagorean Triples.</li></ul>
	notify = nipkow@in.tum.de, roelofoosterhuis@gmail.com

	[Perfect-Number-Thm]
	title = Perfect Number Theorem
	author = Mark Ijbema <mailto:ijbema@fmf.nl>
	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:<ul><li>any prime number of the form 4m+1 can be written as the sum of two squares;</li><li>any natural number can be written as the sum of four squares</li></ul>
	notify = nipkow@in.tum.de, roelofoosterhuis@gmail.com

	[Lehmer]
	title = Lehmer's Theorem
	author = Simon Wimmer <mailto:simon.wimmer@tum.de>, Lars Noschinski <http://www21.in.tum.de/~noschinl/>
	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.
	<p>
	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 <mailto:simon.wimmer@tum.de>, Lars Noschinski <http://www21.in.tum.de/~noschinl/>
	date = 2013-07-22
	topic = Mathematics/Number theory
	abstract = In 1975, Pratt introduced a proof system for certifying primes. He showed that a number <i>p</i> is prime iff a primality certificate for <i>p</i> 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 <http://home.in.tum.de/~wimmers/>, Shuwei Hu <mailto:shuwei.hu@tum.de>, Tobias Nipkow <http://www21.in.tum.de/~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 <http://in.tum.de/~wimmers>, Johannes Hölzl <http://home.in.tum.de/~hoelzl>
	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 <http://in.tum.de/~wimmers>
	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 <http://www21.in.tum.de/~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.<br><br>An article about these proofs is found <a href="http://www21.in.tum.de/~nipkow/pubs/arrow.html">here</a>.
	notify = nipkow@in.tum.de

	[SenSocialChoice]
	title = Some classical results in Social Choice Theory
	author = Peter Gammie <http://peteg.org>
	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 <http://www.cs.bham.ac.uk/~mmk>, Christoph Lange<mailto:math.semantic.web@gmail.com>, Colin Rowat<mailto:c.rowat@bham.ac.uk>
	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

	+[Actuarial_Mathematics]
	+title = Actuarial Mathematics
	+author = Yosuke Ito <mailto:glacier345@gmail.com>
	+topic = Mathematics/Games and economics
	+date = 2022-01-23
	+notify = glacier345@gmail.com
	+abstract =
	+ Actuarial Mathematics is a theory in applied mathematics, which is
	+ mainly used for determining the prices of insurance products and
	+ evaluating the liability of a company associating with insurance
	+ contracts. It is related to calculus, probability theory and financial
	+ theory, etc. In this entry, I formalize the very basic part of
	+ Actuarial Mathematics in Isabelle/HOL. The first formalization is
	+ about the theory of interest which deals with interest rates, present
	+ value factors, an annuity certain, etc. I have already formalized the
	+ basic part of Actuarial Mathematics in Coq
	+ (https://github.com/Yosuke-Ito-345/Actuary). This entry is currently
	+ the partial translation and a little generalization of the Coq
	+ formalization. The further translation in Isabelle/HOL is now
	+ proceeding.
	+
	[Topology]
	title = Topology
	author = Stefan Friedrich <>
	date = 2004-04-26
	topic = Mathematics/Topology
	abstract = This entry contains two theories. The first, <tt>Topology</tt>, develops the basic notions of general topology. The second, which can be viewed as a demonstration of the first, is called <tt>LList_Topology</tt>. It develops the topology of lazy lists.
	notify = lcp@cl.cam.ac.uk

	[Knot_Theory]
	title = Knot Theory
	author = T.V.H. Prathamesh <mailto:prathamesh@imsc.res.in>
	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 <http://www21.in.tum.de/~noschinl/>
	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.
	<p>
	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 <http://www21.in.tum.de/~noschinl/>
	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 <https://www.mpi-inf.mpg.de/~crizkall/>
	date = 2011-07-21
	topic = Mathematics/Graph theory
	abstract =
	<p>
	A <em>matching</em> in a graph <i>G</i> is a subset <i>M</i> of the
	edges of <i>G</i> 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 <em>odd-set cover</em> <i>OSC</i> of a graph <i>G</i> is a
	labeling of the nodes of <i>G</i> with integers such that every edge of
	<i>G</i> is either incident to a node labeled 1 or connects two nodes
	labeled with the same number <i>i ≥ 2</i>.
	</p><p>
	This article proves Edmonds theorem:<br>
	Let <i>M</i> be a matching in a graph <i>G</i> and let <i>OSC</i> be an
	odd-set cover of <i>G</i>.
	For any <i>i ≥ 0</i>, let <var>n(i)</var> be the number of nodes
	labeled <i>i</i>. If <i>\|M\| = n(1) +
	∑<sub>i ≥ 2</sub>(n(i) div 2)</i>,
	then <i>M</i> is a maximum cardinality matching.
	</p>
	notify = nipkow@in.tum.de

	[Girth_Chromatic]
	title = A Probabilistic Proof of the Girth-Chromatic Number Theorem
	author = Lars Noschinski <http://www21.in.tum.de/~noschinl/>
	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 <mailto:hupel@in.tum.de>
	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 <http://www21.in.tum.de/~nipkow>
	date = 2006-05-22
	topic = Mathematics/Graph theory
	abstract =
	These theories present the verified enumeration of <i>tame</i> plane graphs
	as defined by Thomas C. Hales in his proof of the Kepler Conjecture in his
	book <i>Dense Sphere Packings. A Blueprint for Formal Proofs.</i> [CUP 2012].
	The values of the constants in the definition of tameness are identical to
	those in the <a href="https://code.google.com/p/flyspeck/">Flyspeck project</a>.
	The <a href="http://www21.in.tum.de/~nipkow/pubs/Flyspeck/">IJCAR 2006 paper by Nipkow, Bauer and Schultz</a> refers to the original version of Hales' proof,
	the <a href="http://www21.in.tum.de/~nipkow/pubs/itp11.html">ITP 2011 paper by Nipkow</a> 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.<br>
	[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 <mailto:c.sternagel@gmail.com>
	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:
	<ul>
	<li>If the sets A and B are wqo then their Cartesian product is wqo.</li>
	<li>If the set A is wqo then the set of finite lists over A is wqo.</li>
	<li>If the set A is wqo then the set of finite trees over A is wqo.</li>
	</ul>
	The research was funded by the Austrian Science Fund (FWF): J3202.
	extra-history =
	Change history:
	[2012-06-11]: Added Kruskal's Tree Theorem.<br>
	[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.<br>
	[2013-05-16]: Simplified construction of minimal bad sequences.<br>
	[2014-07-09]: Simplified proofs of Higman's lemma and Kruskal's tree theorem,
	based on homogeneous sequences.<br>
	[2016-01-03]: An alternative proof of Higman's lemma by open induction.<br>
	[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 <mailto:dongchenjiang@googlemail.com>, Tobias Nipkow <http://www21.in.tum.de/~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 <http://www.andrew.cmu.edu/user/avigad/>, Stefan Hetzl <http://www.logic.at/people/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, <i>Computability and Logic</i>, 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 <mailto:lukas.bulwahn@gmail.com>
	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
	``<a href="http://www.cs.ru.nl/~freek/100/">Top 100 Mathematical Theorems</a>''.
	notify = lukas.bulwahn@gmail.com

	[Euler_Partition]
	title = Euler's Partition Theorem
	author = Lukas Bulwahn <mailto:lukas.bulwahn@gmail.com>
	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 <http://isabelle.in.tum.de/~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 <mailto:c.sternagel@gmail.com>
	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, <i>Information Processing Letters</i> 29, 1988, pp.19-23.
	<p>This research was supported by the Austrian Science Fund (FWF): J3202.</p>
	notify = c.sternagel@gmail.com

	[Category]
	title = Category Theory to Yoneda's Lemma
	author = Greg O'Keefe <http://users.rsise.anu.edu.au/~okeefe/>
	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 <tt>equinumerous</tt> was slightly too weak in the original submission and has been fixed in revision <a href="https://foss.heptapod.net/isa-afp/afp-devel/-/commit/3498bb1e4c7ba468db8588eb7184c1849641f7d3">8c2b5b3c995f</a>.
	notify = lcp@cl.cam.ac.uk

	[Category2]
	title = Category Theory
	author = Alexander Katovsky <mailto:apk32@cam.ac.uk>
	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 <a href="http://www.srcf.ucam.org/~apk32/Isabelle/Category/Cat.pdf">here [pdf]</a>.
	notify = alexander.katovsky@cantab.net

	[FunWithFunctions]
	title = Fun With Functions
	author = Tobias Nipkow <http://www21.in.tum.de/~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 <http://www21.in.tum.de/~nipkow>, Lawrence C. Paulson <http://www.cl.cam.ac.uk/~lp15/>
	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 <a href="http://www.cl.cam.ac.uk/~lp15/">Larry Paulson</a>, 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. <p> 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 <https://www.cl.cam.ac.uk/~wl302/>
	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 <http://logic.las.tu-berlin.de/Members/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 <mailto:isabelle@christoph-d.de>
	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 <mailto:ly271@cam.ac.uk>
	contributors = Fabian Hellauer <mailto:hellauer@in.tum.de>, Fabian Immler <http://www21.in.tum.de/~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).<br>
	[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 <http://www.andreas-lochbihler.de>
	contributors = Peter Lammich <http://www21.in.tum.de/~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)<br>
	[2014-03-31]:
	added words of default size in the target language (by Peter Lammich)
	(revision 25caf5065833)<br>
	[2014-10-06]:
	proper test setup with compilation and execution of tests in all target languages
	(revision 5d7a1c9ae047)<br>
	[2017-09-02]:
	added 64-bit words (revision c89f86244e3c)<br>
	[2018-07-15]:
	added cast operators for default-size words (revision fc1f1fb8dd30)<br>
	notify = mail@andreas-lochbihler.de

	[XML]
	title = XML
	author = Christian Sternagel <mailto:c.sternagel@gmail.com>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	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 <http://www.cl.cam.ac.uk/~lp15/>
	date = 2013-11-17
	topic = Logic/Set theory
	abstract = The theory of hereditarily finite sets is formalised, following
	the <a href="http://journals.impan.gov.pl/dm/Inf/422-0-1.html">development</a> 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 <a href="Incompleteness.html">formalised separately</a>.
	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 <http://www.cl.cam.ac.uk/~lp15/>
	date = 2013-11-17
	topic = Logic/Proof theory
	abstract = Gödel's two incompleteness theorems are formalised, following a careful <a href="http://journals.impan.gov.pl/dm/Inf/422-0-1.html">presentation</a> by Swierczkowski, in the theory of <a href="HereditarilyFinite.html">hereditarily finite sets</a>. 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 <http://www.cl.cam.ac.uk/~lp15/>
	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 <http://cl-informatik.uibk.ac.at/users/hzankl>
	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 <mailto:bertram.felgenhauer@uibk.ac.at>
	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 <http://page.mi.fu-berlin.de/cbenzmueller/>, Bruno Woltzenlogel Paleo <http://www.logic.at/staff/bruno/>
	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 <mailto:davfuenmayor@gmail.com>, Christoph Benzmüller <http://www.christoph-benzmueller.de>
	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 <mailto:davfuenmayor@gmail.com>, Christoph Benzmüller <http://christoph-benzmueller.de>
	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)<br>

	[Lowe_Ontological_Argument]
	title = Computer-assisted Reconstruction and Assessment of E. J. Lowe's Modal Ontological Argument
	author = David Fuenmayor <mailto:davfuenmayor@gmail.com>, Christoph Benzmüller <http://www.christoph-benzmueller.de>
	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 <https://philpapers.org/profile/805>
	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 <mailto:pasquale.noce.lavoro@gmail.com>
	date = 2013-12-01
	topic = Computer science/Functional programming
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p>
	notify = pasquale.noce.lavoro@gmail.com

	[CryptoBasedCompositionalProperties]
	title = Compositional Properties of Crypto-Based Components
	author = Maria Spichkova <mailto:maria.spichkova@rmit.edu.au>
	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 <mailto:brucker@spamfence.net>, Frédéric Tuong <mailto:tuong@users.gforge.inria.fr>, Burkhart Wolff <mailto:wolff@lri.fr>
	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]:
	<a href="https://foss.heptapod.net/isa-afp/afp-devel/-/commit/e68e1996d5d4926397c9244e786446e99ab17e63">afp-devel@ea3b38fc54d6</a> and
	<a href="https://projects.brucker.ch/hol-testgen/log/trunk?rev=12148">hol-testgen@12148</a><br>
	Update of Featherweight OCL including a change in the abstract.<br>
	[2014-01-16]:
	<a href="https://foss.heptapod.net/isa-afp/afp-devel/-/commit/6217cc5b29c560f24ecc64c81047778becb69f51">afp-devel@9091ce05cb20</a> and
	<a href="https://projects.brucker.ch/hol-testgen/log/trunk?rev=10241">hol-testgen@10241</a><br>
	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 <mailto:simon.foster@york.ac.uk>,
	Georg Struth <http://staffwww.dcs.shef.ac.uk/people/G.Struth/>,
	Tjark Weber <http://user.it.uu.se/~tjawe125/>
	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 <mailto:brijesh.dongol@brunel.ac.uk>, Victor B. F. Gomes <mailto:victor.gomes@cl.cam.ac.uk>, Ian J. Hayes <mailto:ian.hayes@itee.uq.edu.au>, Georg Struth <mailto:g.struth@sheffield.ac.uk>
	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 <mailto:psxjv4@nottingham.ac.uk>
	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 <mailto:psxjv4@nottingham.ac.uk>
	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 <http://nm.wu.ac.at/nm/sadelsbe>,
	Stefan Hetzl <http://www.logic.at/people/hetzl/>,
	Florian Pollak <mailto:florian.pollak@gmail.com>
	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 <https://www.andreipopescu.uk>, Johannes Hölzl <http://in.tum.de/~hoelzl>
	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 <http://www.react.uni-saarland.de/people/rabe.html>, Peter Lammich <http://www21.in.tum.de/~lammich>, Andrei Popescu <https://www.andreipopescu.uk>
	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 <https://www.andreipopescu.uk>, Peter Lammich <http://www21.in.tum.de/~lammich>, Thomas Bauereiss <mailto:thomas@bauereiss.name>
	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 transition systems. 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, thomas@bauereiss.name
	extra-history =
	Change history:
	[2021-08-12]:
	Generalised BD Security from I/O automata to nondeterministic
	transition systems, with the former retained as an instance of the
	latter (renaming locale BD_Security to BD_Security_IO).
	Generalise unwinding conditions to allow making more than one
	transition at a time when constructing alternative traces.
	Add results about the expressivity of declassification triggers vs.
	bounds, due to Thomas Bauereiss (added as author).

	[Network_Security_Policy_Verification]
	title = Network Security Policy Verification
	author = Cornelius Diekmann <http://net.in.tum.de/~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.
	<ul>
	<li>Secure auto-completion of scenario-specific knowledge, which eases usability.</li>
	<li>Security violations can be repaired by tightening the policy iff the
	security invariants hold for the deny-all policy.</li>
	<li>An algorithm to compute a security policy.</li>
	<li>A formalization of stateful connection semantics in network security mechanisms.</li>
	<li>An algorithm to compute a secure stateful implementation of a policy.</li>
	<li>An executable implementation of all the theory.</li>
	<li>Examples, ranging from an aircraft cabin data network to the analysis
	of a large real-world firewall.</li>
	<li>More examples: A fully automated translation of high-level security goals to both
	firewall and SDN configurations (see Examples/Distributed_WebApp.thy).</li>
	</ul>
	For a detailed description, see
	<ul>
	<li>C. Diekmann, A. Korsten, and G. Carle.
	<a href="http://www.net.in.tum.de/fileadmin/bibtex/publications/papers/diekmann2015mansdnnfv.pdf">Demonstrating
	topoS: Theorem-prover-based synthesis of secure network configurations.</a>
	In 2nd International Workshop on Management of SDN and NFV Systems, manSDN/NFV, Barcelona, Spain, November 2015.</li>
	<li>C. Diekmann, S.-A. Posselt, H. Niedermayer, H. Kinkelin, O. Hanka, and G. Carle.
	<a href="http://www.net.in.tum.de/pub/diekmann/forte14.pdf">Verifying Security Policies using Host Attributes.</a>
	In FORTE, 34th IFIP International Conference on Formal Techniques for Distributed Objects,
	Components and Systems, Berlin, Germany, June 2014.</li>
	<li>C. Diekmann, L. Hupel, and G. Carle. Directed Security Policies:
	<a href="http://rvg.web.cse.unsw.edu.au/eptcs/paper.cgi?ESSS2014.3">A Stateful Network Implementation.</a>
	In J. Pang and Y. Liu, editors, Engineering Safety and Security Systems,
	volume 150 of Electronic Proceedings in Theoretical Computer Science,
	pages 20-34, Singapore, May 2014. Open Publishing Association.</li>
	</ul>
	extra-history =
	Change history:
	[2015-04-14]:
	Added Distributed WebApp example and improved graphviz visualization
	(revision 4dde08ca2ab8)<br>
	notify = diekmann@net.in.tum.de

	[Abstract_Completeness]
	title = Abstract Completeness
	author = Jasmin Christian Blanchette <http://www21.in.tum.de/~blanchet>, Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <http://www.kestrel.edu/~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 <mailto:holdenl@princeton.edu>
	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 <http://www.cl.cam.ac.uk/~lp15/>
	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 <https://pruvisto.org>
	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 = manuel@pruvisto.org

	[Error_Function]
	title = The Error Function
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Analysis
	date = 2018-02-06
	notify = manuel@pruvisto.org
	abstract =
	<p> 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. </p>

	[Akra_Bazzi]
	title = The Akra-Bazzi theorem and the Master theorem
	author = Manuel Eberl <https://pruvisto.org>
	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.
	<p>
	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 = manuel@pruvisto.org

	[Dirichlet_Series]
	title = Dirichlet Series
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2017-10-12
	notify = manuel@pruvisto.org
	abstract =
	This entry is a formalisation of much of Chapters 2, 3, and 11 of
	Apostol's “Introduction to Analytic Number
	Theory”. This includes: <ul> <li>Definitions and
	basic properties for several number-theoretic functions (Euler's
	φ, Möbius μ, Liouville's λ,
	the divisor function σ, von Mangoldt's
	Λ)</li> <li>Executable code for most of these
	functions, the most efficient implementations using the factoring
	algorithm by Thiemann <i>et al.</i></li>
	<li>Dirichlet products and formal Dirichlet series</li>
	<li>Analytic results connecting convergent formal Dirichlet
	series to complex functions</li> <li>Euler product
	expansions</li> <li>Asymptotic estimates of
	number-theoretic functions including the density of squarefree
	integers and the average number of divisors of a natural
	number</li> </ul> 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 <https://people.epfl.ch/rodrigo.raya>, Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2019-12-10
	notify = manuel.eberl@tum.de
	abstract =
	<p>This article provides a full formalisation of Chapter 8 of
	Apostol's <em><a
	href="https://www.springer.com/de/book/9780387901633">Introduction
	to Analytic Number Theory</a></em>. Subjects that are
	covered are:</p> <ul> <li>periodic arithmetic
	functions and their finite Fourier series</li>
	<li>(generalised) Ramanujan sums</li> <li>Gauss sums
	and separable characters</li> <li>induced moduli and
	primitive characters</li> <li>the
	Pólya—Vinogradov inequality</li> </ul>

	[Zeta_Function]
	title = The Hurwitz and Riemann ζ Functions
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory, Mathematics/Analysis
	date = 2017-10-12
	notify = manuel@pruvisto.org
	abstract =
	<p>This entry builds upon the results about formal and analytic Dirichlet
	series to define the Hurwitz ζ function ζ(<em>a</em>,<em>s</em>) and,
	based on that, the Riemann ζ function ζ(<em>s</em>).
	This is done by first defining them for &real;(<em>z</em>) > 1
	and then successively extending the domain to the left using the
	Euler–MacLaurin formula.</p>
	<p>Apart from the most basic facts such as analyticity, the following
	results are provided:</p>
	<ul>
	<li>the Stieltjes constants and the Laurent expansion of
	ζ(<em>s</em>) at <em>s</em> = 1</li>
	<li>the non-vanishing of ζ(<em>s</em>)
	for &real;(<em>z</em>) ≥ 1</li>
	<li>the relationship between ζ(<em>a</em>,<em>s</em>) and Γ</li>
	<li>the special values at negative integers and positive even integers</li>
	<li>Hurwitz's formula and the reflection formula for ζ(<em>s</em>)</li>
	<li>the <a href="https://arxiv.org/abs/math/0405478">
	Hadjicostas–Chapman formula</a></li>
	</ul>
	<p>The entry also contains Euler's analytic proof of the infinitude of primes,
	based on the fact that ζ(<i>s</i>) has a pole at <i>s</i> = 1.</p>

	[Linear_Recurrences]
	title = Linear Recurrences
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Analysis
	date = 2017-10-12
	notify = manuel@pruvisto.org
	abstract =
	<p> 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 <i>f</i>(<i>n</i>) =
	<i>f</i>(<i>n</i>-1) +
	<i>f</i>(<i>n</i> - 2) and the quite
	non-obvious closed form
	(<i>φ</i><sup><i>n</i></sup>
	-
	(-<i>φ</i>)<sup>-<i>n</i></sup>)
	/ √<span style="text-decoration:
	overline">5</span> where φ is the golden ratio.
	</p> <p> 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. </p>

	[Van_der_Waerden]
	title = Van der Waerden's Theorem
	author = Katharina Kreuzer <https://www21.in.tum.de/team/kreuzer/>, Manuel Eberl <https://pruvisto.org/>
	topic = Mathematics/Combinatorics
	date = 2021-06-22
	notify = kreuzerk@in.tum.de, manuel@pruvisto.org
	abstract =
	This article formalises the proof of Van der Waerden's Theorem
	from Ramsey theory. Van der Waerden's Theorem states that for
	integers $k$ and $l$ there exists a number $N$ which guarantees that
	if an integer interval of length at least $N$ is coloured with $k$
	colours, there will always be an arithmetic progression of length $l$
	of the same colour in said interval. The proof goes along the lines of
	\cite{Swan}. The smallest number $N_{k,l}$ fulfilling Van der
	Waerden's Theorem is then called the Van der Waerden Number.
	Finding the Van der Waerden Number is still an open problem for most
	values of $k$ and $l$.

	[Lambert_W]
	title = The Lambert W Function on the Reals
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Analysis
	date = 2020-04-24
	notify = manuel@pruvisto.org
	abstract =
	<p>The Lambert <em>W</em> function is a multi-valued
	function defined as the inverse function of <em>x</em>
	↦ <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>

	[Cartan_FP]
	title = The Cartan Fixed Point Theorems
	author = Lawrence C. Paulson <http://www.cl.cam.ac.uk/~lp15/>
	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 C<sup>n</sup>. 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 <http://www.unirioja.es/cu/jodivaso>, Jesús Aransay <http://www.unirioja.es/cu/jearansa>
	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 <http://www.unirioja.es/cu/jodivaso>, Jesús Aransay <http://www.unirioja.es/cu/jearansa>
	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 <http://www.unirioja.es/cu/jodivaso>, Jesús Aransay <http://www.unirioja.es/cu/jearansa>
	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 <http://www.unirioja.es/cu/jodivaso>, Jesús Aransay <http://www.unirioja.es/cu/jearansa>
	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 <mailto:c.sternagel@gmail.com>
	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 <http://www.andreas-lochbihler.de>, Alexandra Maximova <mailto:amaximov@student.ethz.ch>
	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 <a href="http://isa-afp.org/entries/Stream-Fusion.html">AFP entry</a> 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 <http://www21.in.tum.de/~noschinl/>
	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 <tt>casify</tt>, 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 <tt>casify</tt>.
	<p>
	As examples, this work contains verification condition generators
	producing named cases for three languages: The Hoare language from
	<tt>HOL/Library</tt>, 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 <tt>DPT_SAT_Solver</tt>, 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 <http://ualberta.ca/~jsylvest/>
	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 <mailto:pasquale.noce.lavoro@gmail.com>
	date = 2015-08-18
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p>
	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 <mailto:pasquale.noce.lavoro@gmail.com>
	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 <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@uibk.ac.at>
	contributors = Alexander Bentkamp <mailto:bentkamp@gmail.com>
	date = 2015-08-21
	abstract =
	<p>
	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.
	</p><p>
	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.
	</p><p>
	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.
	</p><p>
	All the results have been applied to improve CeTA, our certifier to validate termination and complexity proof certificates.
	</p>
	extra-history =
	Change history:
	[2016-01-07]: Added Schur-decomposition, Gram-Schmidt orthogonalization, uniqueness of Jordan normal forms<br/>
	[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 <mailto:sickert@in.tum.de>
	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.<br>
	[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 <http://in.tum.de/~wimmers>
	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 <http://logic.las.tu-berlin.de/Members/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 <mailto:sebastien.gouezel@univ-rennes1.fr>
	contributors = Manuel Eberl <https://pruvisto.org>
	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 <mailto:bentkamp@gmail.com>
	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 <mailto:bentkamp@gmail.com>
	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

	[Inductive_Inference]
	title = Some classical results in inductive inference of recursive functions
	author = Frank J. Balbach <mailto:frank-balbach@gmx.de>
	topic = Logic/Computability, Computer science/Machine learning
	date = 2020-08-31
	notify = frank-balbach@gmx.de
	abstract =
	<p> This entry formalizes some classical concepts and results
	from inductive inference of recursive functions. In the basic setting
	a partial recursive function ("strategy") must identify
	("learn") all functions from a set ("class") of
	recursive functions. To that end the strategy receives more and more
	values $f(0), f(1), f(2), \ldots$ of some function $f$ from the given
	class and in turn outputs descriptions of partial recursive functions,
	for example, Gödel numbers. The strategy is considered successful if
	the sequence of outputs ("hypotheses") converges to a
	description of $f$. A class of functions learnable in this sense is
	called "learnable in the limit". The set of all these
	classes is denoted by LIM. </p> <p> Other types of
	inference considered are finite learning (FIN), behaviorally correct
	learning in the limit (BC), and some variants of LIM with restrictions
	on the hypotheses: total learning (TOTAL), consistent learning (CONS),
	and class-preserving learning (CP). The main results formalized are
	the proper inclusions $\mathrm{FIN} \subset \mathrm{CP} \subset
	\mathrm{TOTAL} \subset \mathrm{CONS} \subset \mathrm{LIM} \subset
	\mathrm{BC} \subset 2^{\mathcal{R}}$, where $\mathcal{R}$ is the set
	of all total recursive functions. Further results show that for all
	these inference types except CONS, strategies can be assumed to be
	total recursive functions; that all inference types but CP are closed
	under the subset relation between classes; and that no inference type
	is closed under the union of classes. </p> <p> The above
	is based on a formalization of recursive functions heavily inspired by
	the <a
	href="https://www.isa-afp.org/entries/Universal_Turing_Machine.html">Universal
	Turing Machine</a> entry by Xu et al., but different in that it
	models partial functions with codomain <em>nat
	option</em>. The formalization contains a construction of a
	universal partial recursive function, without resorting to Turing
	machines, introduces decidability and recursive enumerability, and
	proves some standard results: existence of a Kleene normal form, the
	<em>s-m-n</em> theorem, Rice's theorem, and assorted
	fixed-point theorems (recursion theorems) by Kleene, Rogers, and
	Smullyan. </p>

	[Applicative_Lifting]
	title = Applicative Lifting
	author = Andreas Lochbihler <http://www.andreas-lochbihler.de>, 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.
	</p><p>
	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.
	</p><p>
	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.
	</p><p>
	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.
	</p>
	extra-history =
	Change history:
	[2016-03-03]: added formalisation of lifting with combinators<br>
	[2016-06-10]:
	implemented automatic derivation of lifted combinator reductions;
	support arbitrary lifted relations using relators;
	improved compatibility with locale interpretation
	(revision ec336f354f37)<br>
	notify = mail@andreas-lochbihler.de

	[Stern_Brocot]
	title = The Stern-Brocot Tree
	author = Peter Gammie <http://peteg.org>, Andreas Lochbihler <http://www.andreas-lochbihler.de>
	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.
	</p><p>
	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.
	</p>
	notify = mail@andreas-lochbihler.de

	[Algebraic_Numbers]
	title = Algebraic Numbers in Isabelle/HOL
	topic = Mathematics/Algebra
	author = René Thiemann <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@uibk.ac.at>, Sebastiaan Joosten <mailto:sebastiaan.joosten@uibk.ac.at>
	contributors = Manuel Eberl <https://pruvisto.org>
	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.
	</p><p>
	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.
	</p>
	extra-history =
	Change history:
	[2016-01-29]: Split off Polynomial Interpolation and Polynomial Factorization<br>
	[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 <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@uibk.ac.at>
	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 <i>p</i> such that
	<i>p(0) = 0</i> and <i>p(2) = 1</i>. 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.
	<p>
	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 <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@uibk.ac.at>
	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.
	<p>
	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

	[Cubic_Quartic_Equations]
	title = Solving Cubic and Quartic Equations
	author = René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	topic = Mathematics/Analysis
	date = 2021-09-03
	notify = rene.thiemann@uibk.ac.at
	abstract =
	<p>We formalize Cardano's formula to solve a cubic equation
	$$ax^3 + bx^2 + cx + d = 0,$$ as well as Ferrari's formula to
	solve a quartic equation. We further turn both formulas into
	executable algorithms based on the algebraic number implementation in
	the AFP. To this end we also slightly extended this library, namely by
	making the minimal polynomial of an algebraic number executable, and
	by defining and implementing $n$-th roots of complex
	numbers.</p>

	[Perron_Frobenius]
	title = Perron-Frobenius Theorem for Spectral Radius Analysis
	author = Jose Divasón <http://www.unirioja.es/cu/jodivaso>, Ondřej Kunčar <http://www21.in.tum.de/~kuncar/>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@uibk.ac.at>
	notify = rene.thiemann@uibk.ac.at
	date = 2016-05-20
	topic = Mathematics/Algebra
	abstract =
	<p>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 A<sup>n</sup> 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
	<em>complex</em> 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 <em>real</em> eigenvalues of A, i.e., applying Sturm's method can
	decide the polynomial growth of A<sup>n</sup>. </p><p> 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 A<sup>n</sup> is polynomially bounded in n. </p>
	extra-history =
	Change history:
	[2017-10-18]:
	added Perron-Frobenius theorem for irreducible matrices with generalization
	(revision bda1f1ce8a1c)<br/>
	[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 <http://cl-informatik.uibk.ac.at/~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 <mailto:sebasti@nullri.ch>, Denis Lohner <http://pp.ipd.kit.edu/person.php?id=88>
	date = 2016-02-05
	topic = Computer science/Algorithms, Computer science/Programming languages/Transformations
	abstract =
	<p>
	We define a functional variant of the static single assignment (SSA)
	form construction algorithm described by <a
	href="https://doi.org/10.1007/978-3-642-37051-9_6">Braun et al.</a>,
	which combines simplicity and efficiency. The definition is based on a
	general, abstract control flow graph representation using Isabelle locales.
	</p>
	<p>
	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.
	</p>
	<p>
	Furthermore, we use a generic instantiation based on typedefs in order
	to extract OCaml code and replace the unverified SSA construction
	algorithm of the <a href="https://doi.org/10.1145/2579080">CompCertSSA
	project</a> with it.
	</p>
	<p>
	A more detailed description of the verified SSA construction can be found
	in the paper <a href="https://doi.org/10.1145/2892208.2892211">Verified
	Construction of Static Single Assignment Form</a>, CC 2016.
	</p>
	notify = denis.lohner@kit.edu

	[Minimal_SSA]
	title = Minimal Static Single Assignment Form
	author = Max Wagner <mailto:max@trollbu.de>, Denis Lohner <http://pp.ipd.kit.edu/person.php?id=88>
	topic = Computer science/Programming languages/Transformations
	date = 2017-01-17
	notify = denis.lohner@kit.edu
	abstract =
	<p>This formalization is an extension to <a
	href="https://www.isa-afp.org/entries/Formal_SSA.html">"Verified
	Construction of Static Single Assignment Form"</a>. In
	their work, the authors have shown that <a
	href="https://doi.org/10.1007/978-3-642-37051-9_6">Braun
	et al.'s static single assignment (SSA) construction
	algorithm</a> 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.<br> In this
	formalization we support that claim by giving a mechanized proof.
	</p>
	<p>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 <a href="https://doi.org/10.1145/115372.115320">Cytron et
	al.</a>.</p>

	[PropResPI]
	title = Propositional Resolution and Prime Implicates Generation
	author = Nicolas Peltier <http://membres-lig.imag.fr/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 <http://membres-lig.imag.fr/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 <http://www.inf.kcl.ac.uk/staff/urbanc/>, Stefan Berghofer <http://www.in.tum.de/~berghofe>, Cezary Kaliszyk <http://cl-informatik.uibk.ac.at/users/cek/>
	date = 2013-02-21
	topic = Tools
	abstract =
	<p>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.
	</p><p>
	This entry can be used as a more advanced replacement for
	HOL/Nominal in the Isabelle distribution.
	</p>
	notify = christian.urban@kcl.ac.uk

	[First_Welfare_Theorem]
	title = Microeconomics and the First Welfare Theorem
	author = Julian Parsert <mailto:julian.parsert@gmail.com>, Cezary Kaliszyk<http://cl-informatik.uibk.ac.at/users/cek/>
	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
	<i>First Theorem of Welfare Economics</i> holds within
	both. The theorem is the mathematical formulation of Adam Smith's
	famous <i>invisible hand</i> 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.
	<br>

	[Noninterference_Sequential_Composition]
	title = Conservation of CSP Noninterference Security under Sequential Composition
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	date = 2016-04-26
	topic = Computer science/Security, Computer science/Concurrency/Process calculi
	abstract =
	<p>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.</p>
	<p>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.</p>
	notify = pasquale.noce.lavoro@gmail.com

	[Noninterference_Concurrent_Composition]
	title = Conservation of CSP Noninterference Security under Concurrent Composition
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	notify = pasquale.noce.lavoro@gmail.com
	date = 2016-06-13
	topic = Computer science/Security, Computer science/Concurrency/Process calculi
	abstract =
	<p>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.</p>
	<p>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.</p>

	[ROBDD]
	title = Algorithms for Reduced Ordered Binary Decision Diagrams
	author = Julius Michaelis <http://liftm.de>, Maximilian Haslbeck <http://cl-informatik.uibk.ac.at/users/mhaslbeck//>, Peter Lammich <http://www21.in.tum.de/~lammich>, Lars Hupel <https://www21.in.tum.de/~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 <mailto:m.stannett@sheffield.ac.uk>, István Németi <http://www.renyi.hu/~nemeti/>
	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

	[Schutz_Spacetime]
	title = Schutz' Independent Axioms for Minkowski Spacetime
	author = Richard Schmoetten <mailto:s1311325@sms.ed.ac.uk>, Jake Palmer <mailto:jake.palmer@ed.ac.uk>, Jacques Fleuriot <https://www.inf.ed.ac.uk/people/staff/Jacques_Fleuriot.html>
	topic = Mathematics/Physics, Mathematics/Geometry
	date = 2021-07-27
	notify = s1311325@sms.ed.ac.uk
	abstract =
	This is a formalisation of Schutz' system of axioms for Minkowski
	spacetime published under the name "Independent axioms for
	Minkowski space-time" in 1997, as well as most of the results in
	the third chapter ("Temporal Order on a Path") of the above
	monograph. Many results are proven here that cannot be found in
	Schutz, either preceding the theorem they are needed for, or within
	their own thematic section.

	[Real_Power]
	title = Real Exponents as the Limits of Sequences of Rational Exponents
	author = Jacques D. Fleuriot <https://www.inf.ed.ac.uk/people/staff/Jacques_Fleuriot.html>
	topic = Mathematics/Analysis
	date = 2021-11-08
	notify = jdf@ed.ac.uk
	abstract =
	In this formalisation, we construct real exponents as the limits of
	sequences of rational exponents. In particular, if $a \ge 1$ and $x
	\in \mathbb{R}$, we choose an increasing rational sequence $r_n$ such
	that $\lim_{n\to\infty} {r_n} = x$. Then the sequence $a^{r_n}$ is
	increasing and if $r$ is any rational number such that $r > x$,
	$a^{r_n}$ is bounded above by $a^r$. By the convergence criterion for
	monotone sequences, $a^{r_n}$ converges. We define $a^ x =
	\lim_{n\to\infty} a^{r_n}$ and show that it has the expected
	properties (for $a \ge 0$). This particular construction of real
	exponents is needed instead of the usual one using the natural
	logarithm and exponential functions (which already exists in Isabelle)
	to support our mechanical derivation of Euler's exponential
	series as an ``infinite polynomial". Aside from helping us avoid
	circular reasoning, this is, as far as we are aware, the first time
	real exponents are mechanised in this way within a proof assistant.

	[Groebner_Bases]
	title = Gröbner Bases Theory
	author = Fabian Immler <http://www21.in.tum.de/~immler>, Alexander Maletzky <https://risc.jku.at/m/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.<br>
	notify = alexander.maletzky@risc.jku.at

	[Nullstellensatz]
	title = Hilbert's Nullstellensatz
	author = Alexander Maletzky <https://risc.jku.at/m/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 <a
	href="https://link.springer.com/book/10.1007/978-0-387-35651-8">Ideals,
	Varieties, and Algorithms</a> by Cox, Little and O'Shea.

	[Bell_Numbers_Spivey]
	title = Spivey's Generalized Recurrence for Bell Numbers
	author = Lukas Bulwahn <mailto:lukas.bulwahn@gmail.com>
	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.
	<p>
	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 <mailto:manuel@pruvisto.org>
	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 = manuel@pruvisto.org

	[SDS_Impossibility]
	title = The Incompatibility of SD-Efficiency and SD-Strategy-Proofness
	author = Manuel Eberl <mailto:manuel@pruvisto.org>
	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 = manuel@pruvisto.org

	[Median_Of_Medians_Selection]
	title = The Median-of-Medians Selection Algorithm
	author = Manuel Eberl <https://pruvisto.org>
	topic = Computer science/Algorithms
	date = 2017-12-21
	notify = manuel@pruvisto.org
	abstract =
	<p>This entry provides an executable functional implementation
	of the Median-of-Medians algorithm for selecting the
	<em>k</em>-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. </p>

	[Mason_Stothers]
	title = The Mason–Stothers Theorem
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Algebra
	date = 2017-12-21
	notify = manuel@pruvisto.org
	abstract =
	<p>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.</p> <p>In short, the statement of the
	theorem is that three non-zero coprime polynomials
	<em>A</em>, <em>B</em>, <em>C</em>
	over a field which sum to 0 and do not all have vanishing derivatives
	fulfil max{deg(<em>A</em>), deg(<em>B</em>),
	deg(<em>C</em>)} < deg(rad(<em>ABC</em>))
	where the rad(<em>P</em>) denotes the
	<em>radical</em> of <em>P</em>,
	i. e. the product of all unique irreducible factors of
	<em>P</em>.</p> <p>This theorem also implies a
	kind of polynomial analogue of Fermat’s Last Theorem for polynomials:
	except for trivial cases,
	<em>A<sup>n</sup></em> +
	<em>B<sup>n</sup></em> +
	<em>C<sup>n</sup></em> = 0 implies
	n ≤ 2 for coprime polynomials
	<em>A</em>, <em>B</em>, <em>C</em>
	over a field.</em></p>

	[FLP]
	title = A Constructive Proof for FLP
	author = Benjamin Bisping <mailto:benjamin.bisping@campus.tu-berlin.de>, Paul-David Brodmann <mailto:p.brodmann@tu-berlin.de>, Tim Jungnickel <mailto:tim.jungnickel@tu-berlin.de>, Christina Rickmann <mailto:c.rickmann@tu-berlin.de>, Henning Seidler <mailto:henning.seidler@mailbox.tu-berlin.de>, Anke Stüber <mailto:anke.stueber@campus.tu-berlin.de>, Arno Wilhelm-Weidner <mailto:arno.wilhelm-weidner@tu-berlin.de>, Kirstin Peters <mailto:kirstin.peters@tu-berlin.de>, Uwe Nestmann <https://www.mtv.tu-berlin.de/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 <mailto:tim.jungnickel@tu-berlin.de>, 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 <http://pp.ipd.kit.edu/~breitner>, Denis Lohner <http://pp.ipd.kit.edu/person.php?id=88>
	date = 2016-05-20
	topic = Logic/Proof theory
	abstract =
	The <a href="http://incredible.pm">Incredible Proof Machine</a> 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 <http://www.cse.unsw.edu.au/~kleing/>, 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 <https://pruvisto.org>
	notify = manuel@pruvisto.org
	date = 2016-06-21
	topic = Mathematics/Combinatorics
	abstract =
	<p>In this work, we define the Catalan numbers <em>C<sub>n</sub></em>
	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 <em>n</em>), prove the asymptotic growth
	approximation <em>C<sub>n</sub> &sim; 4<sup>n</sup> / (√<span
	style="text-decoration: overline">π</span> ·
	n<sup>1.5</sup>)</em>, and provide reasonably efficient executable
	code to compute them.</p> <p>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.</p>

	[Fisher_Yates]
	title = Fisher–Yates shuffle
	author = Manuel Eberl <https://pruvisto.org>
	notify = manuel@pruvisto.org
	date = 2016-09-30
	topic = Computer science/Algorithms
	abstract =
	<p>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.</p>

	[Bertrands_Postulate]
	title = Bertrand's postulate
	author = Julian Biendarra<>, Manuel Eberl <https://pruvisto.org>
	contributors = Lawrence C. Paulson <http://www.cl.cam.ac.uk/~lp15/>
	topic = Mathematics/Number theory
	date = 2017-01-17
	notify = manuel@pruvisto.org
	abstract =
	<p>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. </p>

	[Rewriting_Z]
	title = The Z Property
	author = Bertram Felgenhauer<>, Julian Nagele<>, Vincent van Oostrom<>, Christian Sternagel <mailto:c.sternagel@gmail.com>
	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 <https://people.compute.dtu.dk/andschl/>
	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]. <p>
	<a name="Sch18"></a>[Sch18] Anders Schlichtkrull. "Formalization of the
	Resolution Calculus for First-Order Logic". Journal of Automated
	Reasoning, 2018.<br> <a name="Sch16"></a>[Sch16] Anders
	Schlichtkrull. "Formalization of the Resolution Calculus for First-Order
	Logic". In: ITP 2016. Vol. 9807. LNCS. Springer, 2016.<br>
	<a name="Sch15"></a>[Sch15] Anders Schlichtkrull. <a href="https://people.compute.dtu.dk/andschl/Thesis.pdf">
	"Formalization of Resolution Calculus in Isabelle"</a>.
	<a href="https://people.compute.dtu.dk/andschl/Thesis.pdf">https://people.compute.dtu.dk/andschl/Thesis.pdf</a>.
	MSc thesis. Technical University of Denmark, 2015.<br>
	<a name="BA12"></a>[BA12] Mordechai Ben-Ari. <i>Mathematical Logic for
	Computer Science</i>. 3rd. Springer, 2012.<br> <a
	name="CL73"></a>[CL73] Chin-Liang Chang and Richard Char-Tung Lee.
	<i>Symbolic Logic and Mechanical Theorem Proving</i>. 1st. Academic
	Press, Inc., 1973.<br> <a name="Lei97"></a>[Lei97] Alexander
	Leitsch. <i>The Resolution Calculus</i>. Texts in theoretical computer
	science. Springer, 1997.<br> <a name="IsaFoL"></a>[IsaFoL]
	IsaFoL authors. <a href="https://bitbucket.org/jasmin_blanchette/isafol">
	IsaFoL: Isabelle Formalization of Logic</a>.
	<a href="https://bitbucket.org/jasmin_blanchette/isafol">https://bitbucket.org/jasmin_blanchette/isafol</a>.
	extra-history =
	Change history:
	[2018-01-24]: added several new versions of the soundness and completeness theorems as described in the paper [Sch18]. <br>
	[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 <http://pp.ipd.kit.edu/~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 <mailto:lukas.bulwahn@gmail.com>
	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 <mailto:lukas.bulwahn@gmail.com>
	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 <mailto:wolff@lri.fr>
	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 <https://pruvisto.org>
	notify = manuel@pruvisto.org
	date = 2016-09-01
	topic = Mathematics/Analysis
	abstract =
	<p>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 <a
	href="http://www.maths.lancs.ac.uk/~jameson/stirlgamma.pdf">Graham Jameson</a>.</p>
	<p>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.</p>

	[Lp]
	title = Lp spaces
	author = Sebastien Gouezel <http://www.math.sciences.univ-nantes.fr/~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 <http://www.unirioja.es/cu/jodivaso>, Sebastiaan Joosten <mailto:sebastiaan.joosten@uibk.ac.at>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@uibk.ac.at>
	notify = rene.thiemann@uibk.ac.at
	date = 2016-10-14
	topic = Mathematics/Algebra
	abstract =
	<p>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.
	</p>
	<p>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.
	</p>
	<p>Through experiments we verify that our algorithm factors polynomials of degree
	100 within seconds.
	</p>

	[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 <mailto:qh225@cl.cam.ac.uk>, Lawrence C. Paulson <mailto:lp15@cam.ac.uk>
	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 <https://pruvisto.org>
	topic = Mathematics/Probability theory, Mathematics/Geometry
	date = 2017-06-06
	notify = manuel@pruvisto.org
	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 <mailto:zhe.hou@ntu.edu.sg>, David Sanan <mailto:sanan@ntu.edu.sg>, Alwen Tiu <mailto:ATiu@ntu.edu.sg>, Yang Liu <mailto:yangliu@ntu.edu.sg>
	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 <mailto:zhe.hou@ntu.edu.sg>, David Sanan <mailto:sanan@ntu.edu.sg>, Alwen Tiu <mailto:ATiu@ntu.edu.sg>, Rajeev Gore <mailto:rajeev.gore@anu.edu.au>, Ranald Clouston <mailto:ranald.clouston@cs.au.dk>
	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 <http://liftm.de>, Cornelius Diekmann <http://net.in.tum.de/~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 <http://peteg.org>
	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 <mailto:tjark.weber@it.uu.se>, Lars-Henrik Eriksson <mailto:lhe@it.uu.se>, Joachim Parrow <mailto:joachim.parrow@it.uu.se>, Johannes Borgström <mailto:johannes.borgstrom@it.uu.se>, Ramunas Gutkovas <mailto:ramunas.gutkovas@it.uu.se>
	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 <http://www21.in.tum.de/~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 <a href="https://doi.org/10.1007/978-3-642-32347-8_9">ITP 2012 paper</a>.
	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
	<a href="https://doi.org/10.1007/978-3-319-10542-0">Concrete Semantics</a>.

	[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 <https://people.compute.dtu.dk/andschl/>, Jørgen Villadsen <https://people.compute.dtu.dk/jovi/>
	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 <mailto:julian.fell@uq.net.au>, Ian J. Hayes <mailto:ian.hayes@itee.uq.edu.au>, Andrius Velykis <http://andrius.velykis.lt>
	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 <i>c</i> and
	<i>i</i> is the process that, if executed in parallel with
	<i>i</i> implements <i>c</i>. 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 <https://people.compute.dtu.dk/aleje/>, Anders Schlichtkrull <https://people.compute.dtu.dk/andschl/>, Jørgen Villadsen <https://people.compute.dtu.dk/jovi/>
	topic = Logic/General logic/Mechanization of proofs
	date = 2017-01-01
	notify = aleje@dtu.dk, andschl@dtu.dk, jovi@dtu.dk
	abstract =
	<p>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.</p>
	<p>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. <a href="https://content.iospress.com/articles/ai-communications/aic764">
	https://content.iospress.com/articles/ai-communications/aic764</a></p>
	<p>See also: Students' Proof Assistant (SPA).
	<a href=https://github.com/logic-tools/spa>
	https://github.com/logic-tools/spa</a></p>
	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<mailto:lukas.bulwahn@gmail.com>, Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Analysis, Mathematics/Number theory
	date = 2017-01-24
	notify = manuel@pruvisto.org
	abstract =
	<p>Bernoulli numbers were first discovered in the closed-form
	expansion of the sum 1<sup>m</sup> +
	2<sup>m</sup> + … + n<sup>m</sup>
	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.</p>
	<p>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.</p>
	<p>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.</p>

	[Stone_Relation_Algebras]
	title = Stone Relation Algebras
	author = Walter Guttmann <http://www.cosc.canterbury.ac.nz/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.
	extra-history =
	Change history:
	[2017-07-05]:
	generalised extended reals to linear orders
	(revision b8e703159177)

	[Stone_Kleene_Relation_Algebras]
	title = Stone-Kleene Relation Algebras
	author = Walter Guttmann <http://www.cosc.canterbury.ac.nz/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 <mailto:jasmin.blanchette@gmail.com>, Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <em>Journal of Automated
	Reasoning</em>. 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 <mailto:bbohrer@cs.cmu.edu>
	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.

	[Syntax_Independent_Logic]
	title = Syntax-Independent Logic Infrastructure
	author = Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	topic = Logic/Proof theory
	date = 2020-09-16
	notify = a.popescu@sheffield.ac.uk, traytel@di.ku.dk
	abstract =
	We formalize a notion of logic whose terms and formulas are kept
	abstract. In particular, logical connectives, substitution, free
	variables, and provability are not defined, but characterized by their
	general properties as locale assumptions. Based on this abstract
	characterization, we develop further reusable reasoning
	infrastructure. For example, we define parallel substitution (along
	with proving its characterizing theorems) from single-point
	substitution. Similarly, we develop a natural deduction style proof
	system starting from the abstract Hilbert-style one. These one-time
	efforts benefit different concrete logics satisfying our locales'
	assumptions. We instantiate the syntax-independent logic
	infrastructure to Robinson arithmetic (also known as Q) in the AFP
	entry <a
	href="https://www.isa-afp.org/entries/Robinson_Arithmetic.html">Robinson_Arithmetic</a>
	and to hereditarily finite set theory in the AFP entries <a
	href="https://www.isa-afp.org/entries/Goedel_HFSet_Semantic.html">Goedel_HFSet_Semantic</a>
	and <a
	href="https://www.isa-afp.org/entries/Goedel_HFSet_Semanticless.html">Goedel_HFSet_Semanticless</a>,
	which are part of our formalization of Gödel's
	Incompleteness Theorems described in our CADE-27 paper <a
	href="https://dx.doi.org/10.1007/978-3-030-29436-6_26">A
	Formally Verified Abstract Account of Gödel's Incompleteness
	Theorems</a>.

	[Goedel_Incompleteness]
	title = An Abstract Formalization of Gödel's Incompleteness Theorems
	author = Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	topic = Logic/Proof theory
	date = 2020-09-16
	notify = a.popescu@sheffield.ac.uk, traytel@di.ku.dk
	abstract =
	We present an abstract formalization of Gödel's
	incompleteness theorems. We analyze sufficient conditions for the
	theorems' applicability to a partially specified logic. Our
	abstract perspective enables a comparison between alternative
	approaches from the literature. These include Rosser's variation
	of the first theorem, Jeroslow's variation of the second theorem,
	and the Swierczkowski–Paulson semantics-based approach. This
	AFP entry is the main entry point to the results described in our
	CADE-27 paper <a
	href="https://dx.doi.org/10.1007/978-3-030-29436-6_26">A
	Formally Verified Abstract Account of Gödel's Incompleteness
	Theorems</a>. As part of our abstract formalization's
	validation, we instantiate our locales twice in the separate AFP
	entries <a
	href="https://www.isa-afp.org/entries/Goedel_HFSet_Semantic.html">Goedel_HFSet_Semantic</a>
	and <a
	href="https://www.isa-afp.org/entries/Goedel_HFSet_Semanticless.html">Goedel_HFSet_Semanticless</a>.

	[Goedel_HFSet_Semantic]
	title = From Abstract to Concrete Gödel's Incompleteness Theorems—Part I
	author = Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	topic = Logic/Proof theory
	date = 2020-09-16
	notify = a.popescu@sheffield.ac.uk, traytel@di.ku.dk
	abstract =
	We validate an abstract formulation of Gödel's First and
	Second Incompleteness Theorems from a <a
	href="https://www.isa-afp.org/entries/Goedel_Incompleteness.html">separate
	AFP entry</a> by instantiating them to the case of
	<i>finite sound extensions of the Hereditarily Finite (HF) Set
	theory</i>, i.e., FOL theories extending the HF Set theory with
	a finite set of axioms that are sound in the standard model. The
	concrete results had been previously formalised in an <a
	href="https://www.isa-afp.org/entries/Incompleteness.html">AFP
	entry by Larry Paulson</a>; our instantiation reuses the
	infrastructure developed in that entry.

	[Goedel_HFSet_Semanticless]
	title = From Abstract to Concrete Gödel's Incompleteness Theorems—Part II
	author = Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	topic = Logic/Proof theory
	date = 2020-09-16
	notify = a.popescu@sheffield.ac.uk, traytel@di.ku.dk
	abstract =
	We validate an abstract formulation of Gödel's Second
	Incompleteness Theorem from a <a
	href="https://www.isa-afp.org/entries/Goedel_Incompleteness.html">separate
	AFP entry</a> by instantiating it to the case of <i>finite
	consistent extensions of the Hereditarily Finite (HF) Set
	theory</i>, i.e., consistent FOL theories extending the HF Set
	theory with a finite set of axioms. The instantiation draws heavily
	on infrastructure previously developed by Larry Paulson in his <a
	href="https://www.isa-afp.org/entries/Incompleteness.html">direct
	formalisation of the concrete result</a>. It strengthens
	Paulson's formalization of Gödel's Second from that
	entry by <i>not</i> assuming soundness, and in fact not
	relying on any notion of model or semantic interpretation. The
	strengthening was obtained by first replacing some of Paulson’s
	semantic arguments with proofs within his HF calculus, and then
	plugging in some of Paulson's (modified) lemmas to instantiate
	our soundness-free Gödel's Second locale.

	[Robinson_Arithmetic]
	title = Robinson Arithmetic
	author = Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	topic = Logic/Proof theory
	date = 2020-09-16
	notify = a.popescu@sheffield.ac.uk, traytel@di.ku.dk
	abstract =
	We instantiate our syntax-independent logic infrastructure developed
	in <a
	href="https://www.isa-afp.org/entries/Syntax_Independent_Logic.html">a
	separate AFP entry</a> to the FOL theory of Robinson arithmetic
	(also known as Q). The latter was formalised using Nominal Isabelle by
	adapting <a
	href="https://www.isa-afp.org/entries/Incompleteness.html">Larry
	Paulson’s formalization of the Hereditarily Finite Set
	theory</a>.

	[Elliptic_Curves_Group_Law]
	title = The Group Law for Elliptic Curves
	author = Stefan Berghofer <http://www.in.tum.de/~berghofe>
	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 <http://www.cse.unsw.edu.au/~kleing/>
	topic = Mathematics/Analysis, Mathematics/Number theory
	date = 2004-02-25
	notify = kleing@cse.unsw.edu.au
	abstract =
	<p>This is an example submission to the Archive of Formal Proofs. It shows
	submission requirements and explains the structure of a simple typical
	submission.</p>
	<p>Note that you can use <em>HTML tags</em> 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
	<a href="../submitting.html">submission guidelines</a> before using this.</p>
	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 <mailto:vb358@cam.ac.uk>, Martin Kleppmann<mailto:martin.kleppmann@cl.cam.ac.uk>, Dominic P. Mulligan<mailto:dominic.p.mulligan@googlemail.com>, Alastair R. Beresford<mailto:arb33@cam.ac.uk>
	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<mailto:joachim@cis.upenn.edu>, Brian Huffman<>, Neil Mitchell<>, Christian Sternagel<mailto:c.sternagel@gmail.com>
	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 <http://homes.soic.indiana.edu/jsiek/>
	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.
	<br>
	The paper that accompanies these Isabelle theories is <a href="https://arxiv.org/abs/1707.03762">available on arXiv</a>.

	[DynamicArchitectures]
	title = Dynamic Architectures
	author = Diego Marmsoler <http://marmsoler.com>
	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)<br>

	[Stewart_Apollonius]
	title = Stewart's Theorem and Apollonius' Theorem
	author = Lukas Bulwahn <mailto:lukas.bulwahn@gmail.com>
	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 <mailto:cris.matache@gmail.com>, Victor B. F. Gomes <mailto:victorborgesfg@gmail.com>, Dominic P. Mulligan <mailto:dominic.p.mulligan@googlemail.com>
	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 <mailto:jonas.raedle@tum.de>
	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 <mailto:daniel@ekpyron.org>
	topic = Logic/Philosophical aspects
	date = 2017-09-17
	notify = daniel@ekpyron.org
	abstract =
	<p> We present an embedding of the second-order fragment of the
	Theory of Abstract Objects as described in Edward Zalta's
	upcoming work <a
	href="https://mally.stanford.edu/principia.pdf">Principia
	Logico-Metaphysica (PLM)</a> 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
	<b>abstract objects</b> 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 <a
	href="https://mally.stanford.edu/Papers/rtt.pdf">known to
	be challenging</a>. </p> <p> 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.
	</p> <p> Our work thereby supports the concept of shallow
	semantical embeddings of logical systems in HOL as a universal tool
	for logical reasoning <a
	href="http://www.mi.fu-berlin.de/inf/groups/ag-ki/publications/Universal-Reasoning/1703_09620_pd.pdf">as
	promoted by Christoph Benzmüller</a>. </p>
	<p> 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. </p>

	[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 <a
	href="https://dl.acm.org/citation.cfm?doid=361002.361007">Multidimensional
	binary search trees used for associative searching</a> and <a
	href="https://dl.acm.org/citation.cfm?doid=355744.355745">
	An Algorithm for Finding Best Matches in Logarithmic Expected
	Time</a>.
	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 <mailto:martin.rau@tum.de>, Tobias Nipkow <http://www.in.tum.de/~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 <em>Closest Pair of Points</em>
	problem in Computational Geometry. Functional correctness and the
	optimal running time of <em>O</em>(<em>n</em> log <em>n</em>) 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 <mailto:robin.essmann@tum.de>, Tobias Nipkow <http://www.in.tum.de/~nipkow/>,
	Simon Robillard <https://simon-robillard.net/>, Ujkan Sulejmani<>
	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, set cover, independent set,
	center selection, load balancing, and bin packing. The proofs correct incompletenesses
	in existing proofs and improve the approximation ratio in one case.
	A detailed description of our work (excluding center selection) has been published in the proceedings of
	<a href="https://doi.org/10.1007/978-3-030-51054-1_17">IJCAR 2020</a>.
	extra-history =
	Change history:
	[2021-02-08]:
	added theory Approx_SC_Hoare (Set Cover) by Robin Eßmann<br>
	[2021-06-29]:
	added theory Center_Selection by Ujkan Sulejmani

	[Diophantine_Eqns_Lin_Hom]
	title = Homogeneous Linear Diophantine Equations
	author = Florian Messner <mailto:florian.g.messner@uibk.ac.at>, Julian Parsert <mailto:julian.parsert@gmail.com>, Jonas Schöpf <mailto:jonas.schoepf@uibk.ac.at>, Christian Sternagel <mailto:c.sternagel@gmail.com>
	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 <https://www.cl.cam.ac.uk/~wl302/>
	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 <https://www.cl.cam.ac.uk/~wl302/>
	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 various shapes (e.g., rectangle,
	circle and 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).
	extra-history =
	Change history:
	[2021-10-26]: resolved the roots-on-the-border problem in the rectangular case (revision 82a159e398cf).

	[Buchi_Complementation]
	title = Büchi Complementation
	author = Julian Brunner <http://www21.in.tum.de/~brunnerj/>
	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: <ol>
	<li>Definition of odd rankings and proof that an automaton
	rejects a word iff there exists an odd ranking for it.</li>
	<li>Definition of the complement automaton and proof that it
	accepts exactly those words for which there is an odd
	ranking.</li> <li>Verified implementation of the
	complement automaton using the Isabelle Collections
	Framework.</li> </ol>

	[Transition_Systems_and_Automata]
	title = Transition Systems and Automata
	author = Julian Brunner <http://www21.in.tum.de/~brunnerj/>
	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 <http://peteg.org>, 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 <mailto:s.linker@liverpool.ac.uk>
	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 <https://pruvisto.org>
	topic = Mathematics/Number theory, Mathematics/Algebra
	date = 2017-12-21
	notify = manuel@pruvisto.org
	abstract =
	<p>This article provides a formalisation of Dirichlet characters
	and Dirichlet <em>L</em>-functions including proofs of
	their basic properties – most notably their analyticity,
	their areas of convergence, and their non-vanishing for &Re;(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.</p> <p>This
	also leads to a relatively short proof of Dirichlet’s Theorem, which
	states that, if <em>h</em> and <em>n</em> are
	coprime, there are infinitely many primes <em>p</em> with
	<em>p</em> &equiv; <em>h</em> (mod
	<em>n</em>).</p>

	[Symmetric_Polynomials]
	title = Symmetric Polynomials
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Algebra
	date = 2018-09-25
	notify = manuel@pruvisto.org
	abstract =
	<p>A symmetric polynomial is a polynomial in variables
	<em>X</em><sub>1</sub>,…,<em>X</em><sub>n</sub>
	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.</p> <p>This article provides a definition of
	symmetric polynomials and the elementary symmetric polynomials
	e<sub>1</sub>,…,e<sub>n</sub> and
	proofs of their basic properties, including three notable
	ones:</p> <ul> <li> Vieta's formula, which
	gives an explicit expression for the <em>k</em>-th
	coefficient of a univariate monic polynomial in terms of its roots
	<em>x</em><sub>1</sub>,…,<em>x</em><sub>n</sub>,
	namely
	<em>c</em><sub><em>k</em></sub> = (-1)<sup><em>n</em>-<em>k</em></sup> e<sub><em>n</em>-<em>k</em></sub>(<em>x</em><sub>1</sub>,…,<em>x</em><sub>n</sub>).</li>
	<li>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.</li> <li>Third, as a corollary of the
	previous two, that given a polynomial over some ring
	<em>R</em>, any symmetric polynomial combination of its
	roots is also in <em>R</em> even when the roots are not.
	</ul> <p> Both the symmetry property itself and the
	witness for the Fundamental Theorem are executable. </p>

	[Taylor_Models]
	title = Taylor Models
	author = Christoph Traut<>, Fabian Immler <http://www21.in.tum.de/~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 <http://home.in.tum.de/~mansour/>, Lawrence C. Paulson <http://www.cl.cam.ac.uk/~lp15/>
	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.

	[AI_Planning_Languages_Semantics]
	title = AI Planning Languages Semantics
	author = Mohammad Abdulaziz <http://home.in.tum.de/~mansour/>, Peter Lammich <http://www21.in.tum.de/~lammich>
	topic = Computer science/Artificial intelligence
	date = 2020-10-29
	notify = mohammad.abdulaziz8@gmail.com
	abstract =
	This is an Isabelle/HOL formalisation of the semantics of the
	multi-valued planning tasks language that is used by the planning
	system Fast-Downward, the STRIPS fragment of the Planning Domain
	Definition Language (PDDL), and the STRIPS soundness meta-theory
	developed by Vladimir Lifschitz. It also contains formally verified
	checkers for checking the well-formedness of problems specified in
	either language as well the correctness of potential solutions. The
	formalisation in this entry was described in an earlier publication.

	[Verified_SAT_Based_AI_Planning]
	title = Verified SAT-Based AI Planning
	author = Mohammad Abdulaziz <http://home.in.tum.de/~mansour/>, Friedrich Kurz <>
	topic = Computer science/Artificial intelligence
	date = 2020-10-29
	notify = mohammad.abdulaziz8@gmail.com
	abstract =
	We present an executable formally verified SAT encoding of classical
	AI planning that is based on the encodings by Kautz and Selman and the
	one by Rintanen et al. The encoding was experimentally tested and
	shown to be usable for reasonably sized standard AI planning
	benchmarks. We also use it as a reference to test a state-of-the-art
	SAT-based planner, showing that it sometimes falsely claims that
	problems have no solutions of certain lengths. The formalisation in
	this submission was described in an independent publication.

	[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 <https://people.compute.dtu.dk/andschl/>, Jasmin Christian Blanchette <mailto:j.c.blanchette@vu.nl>, Dmitriy Traytel <https://traytel.bitbucket.io>, Uwe Waldmann <mailto:uwe@mpi-inf.mpg.de>
	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
	<em>Handbook of Automated Reasoning</em>. 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 <mailto:ben.fiedler@inf.ethz.ch>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <mailto:jasmin.blanchette@gmail.com>, Andrei Popescu <https://www.andreipopescu.uk>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <http://www.unirioja.es/cu/jodivaso/>, Maximilian Haslbeck <http://cl-informatik.uibk.ac.at/users/mhaslbeck/>, Sebastiaan Joosten <https://sjcjoosten.nl/>, René Thiemann <http://cl-informatik.uibk.ac.at/users/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 <http://www.unirioja.es/cu/jodivaso/>, Sebastiaan Joosten <https://sjcjoosten.nl/>, René Thiemann <http://cl-informatik.uibk.ac.at/users/thiemann/>, Akihisa Yamada <mailto:ayamada@trs.cm.is.nagoya-u.ac.jp>
	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 <http://cl-informatik.uibk.ac.at/users/mhaslbeck/>, Manuel Eberl <https://www.in.tum.de/~eberlm>, Tobias Nipkow <https://www.in.tum.de/~nipkow>
	topic = Computer science/Data structures
	date = 2018-02-06
	notify = manuel@pruvisto.org
	abstract =
	<p> 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. </p>
	<p> In particular, by choosing these priorities at random upon
	insertion of an element, we can pretend that we inserted the elements
	in <em>random order</em>, 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.</p>

	[Skip_Lists]
	title = Skip Lists
	author = Max W. Haslbeck <http://cl-informatik.uibk.ac.at/users/mhaslbeck/>, Manuel Eberl <https://pruvisto.org/>
	topic = Computer science/Data structures
	date = 2020-01-09
	notify = max.haslbeck@gmx.de
	abstract =
	<p> 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. </p> <p> 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. </p>

	[Mersenne_Primes]
	title = Mersenne primes and the Lucas–Lehmer test
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2020-01-17
	notify = manuel@pruvisto.org
	abstract =
	<p>This article provides formal proofs of basic properties of
	Mersenne numbers, i. e. numbers of the form
	2<sup><em>n</em></sup> - 1, and especially of
	Mersenne primes.</p> <p>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 <em>n</em>.</p>

	[Hoare_Time]
	title = Hoare Logics for Time Bounds
	author = Maximilian P. L. Haslbeck <http://www.in.tum.de/~haslbema>, Tobias Nipkow <https://www.in.tum.de/~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 <i>et al.</i> and a <i>separation
	logic</i> 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 <http://marmsoler.com>
	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)<br>
	[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 <https://www.in.tum.de/~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 <a
	href="https://doi.org/10.1017/S0956796811000104">Hirai
	and Yamamoto</a> 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 <http://dss.in.tum.de/staff/brandt.html>, Manuel Eberl <https://pruvisto.org>, Christian Saile <http://dss.in.tum.de/staff/christian-saile.html>, Christian Stricker <http://dss.in.tum.de/staff/christian-stricker.html>
	topic = Mathematics/Games and economics
	date = 2018-03-22
	notify = manuel@pruvisto.org
	abstract =
	<p>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 <a
	href="http://dss.in.tum.de/files/brandt-research/stratset.pdf">Brandt
	<em>et al.</em></a>, 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.</p>

	[BNF_CC]
	title = Bounded Natural Functors with Covariance and Contravariance
	author = Andreas Lochbihler <http://www.andreas-lochbihler.de>, Joshua Schneider <mailto:joshua.schneider@inf.ethz.ch>
	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 BNF<sub>CC</sub> that extends the mapper
	and relator to covariant and contravariant parameters. We show that
	<ol> <li> BNF<sub>CC</sub>s are closed under
	functor composition and least and greatest fixpoints,</li>
	<li> subtypes inherit the BNF<sub>CC</sub> structure
	under conditions that generalise those for the BNF case,
	and</li> <li> BNF<sub>CC</sub>s preserve
	quotients under mild conditions.</li> </ol> These proofs
	are carried out for abstract BNF<sub>CC</sub>s similar to
	the AFP entry BNF Operations. In addition, we apply the
	BNF<sub>CC</sub> 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 <mailto:bracevac@st.informatik.tu-darmstadt.de>, Richard Gay <mailto:gay@mais.informatik.tu-darmstadt.de>, Sylvia Grewe <mailto:grewe@st.informatik.tu-darmstadt.de>, Heiko Mantel <mailto:mantel@mais.informatik.tu-darmstadt.de>, Henning Sudbrock <mailto:sudbrock@mais.informatik.tu-darmstadt.de>, Markus Tasch <mailto:tasch@mais.informatik.tu-darmstadt.de>
	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 <http://christoph-benzmueller.de>, Dana Scott <http://www.cs.cmu.edu/~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 <mailto:mk428@cl.cam.ac.uk>, Victor B. F. Gomes <mailto:vb358@cl.cam.ac.uk>, Dominic P. Mulligan <mailto:Dominic.Mulligan@arm.com>, Alastair R. Beresford <mailto:arb33@cl.cam.ac.uk>
	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 <http://www.cl.cam.ac.uk/~ak2110/>, Wenda Li <http://www.cl.cam.ac.uk/~wl302/>
	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 <https://www.in.tum.de/~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
	<a href="Monad_Memo_DP.html">Monadification, Memoization and Dynamic Programming</a>,
	thus yielding dynamic programming algorithms.

	[Projective_Geometry]
	title = Projective Geometry
	author = Anthony Bordg <https://sites.google.com/site/anthonybordg/>
	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 <https://sites.google.com/site/anthonybordg/>
	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 =
	<p> We formalize undecidablity results for Minsky machines. To
	this end, we also formalize recursive inseparability.
	</p><p> 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. </p><p> 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. </p><p> We do
	<em>not</em> prove that recursive functions can simulate
	Minsky machines. </p>

	[Neumann_Morgenstern_Utility]
	title = Von-Neumann-Morgenstern Utility Theorem
	author = Julian Parsert<mailto:julian.parsert@gmail.com>, Cezary Kaliszyk<http://cl-informatik.uibk.ac.at/users/cek/>
	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ć <mailto:filip@matf.bg.ac.rs>, Mirko Spasić <mailto:mirko@matf.bg.ac.rs>, René Thiemann <http://cl-informatik.uibk.ac.at/~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 <https://www.cl.cam.ac.uk/~wl302/>
	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 <https://www.cl.cam.ac.uk/~lp15/>
	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 <http://www.cl.cam.ac.uk/~ak2110/>
	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 <http://www.cosc.canterbury.ac.nz/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.
	extra-history =
	Change history:
	[2020-12-09]:
	moved Hoare logic to HOL-Hoare, moved spanning trees to Relational_Minimum_Spanning_Trees
	(revision dbb9bfaf4283)

	[Prime_Number_Theorem]
	title = The Prime Number Theorem
	author = Manuel Eberl <https://pruvisto.org>, Lawrence C. Paulson <https://www.cl.cam.ac.uk/~lp15/>
	topic = Mathematics/Number theory
	date = 2018-09-19
	notify = manuel@pruvisto.org
	abstract =
	<p>This article provides a short proof of the Prime Number
	Theorem in several equivalent forms, most notably
	π(<em>x</em>) ~ <em>x</em>/ln
	<em>x</em> where π(<em>x</em>) is the
	number of primes no larger than <em>x</em>. It also
	defines other basic number-theoretic functions related to primes like
	Chebyshev's functions &thetasym; and ψ and the
	“<em>n</em>-th prime number” function
	p<sub><em>n</em></sub>. We also show various
	bounds and relationship between these functions are shown. Lastly, we
	derive Mertens' First and Second Theorem, i. e.
	∑<sub><em>p</em>≤<em>x</em></sub>
	ln <em>p</em>/<em>p</em> = ln
	<em>x</em> + <em>O</em>(1) and
	∑<sub><em>p</em>≤<em>x</em></sub>
	1/<em>p</em> = ln ln <em>x</em> + M +
	<em>O</em>(1/ln <em>x</em>). We also give
	explicit bounds for the remainder terms.</p> <p>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
	∑<sub><em>p</em>≤<em>x</em></sub>
	ln <em>p</em>/<em>p</em> = ln
	<em>x</em> + c + <em>o</em>(1).</p>
	<p>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 <em>et al.</em> 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.</p>

	[Signature_Groebner]
	title = Signature-Based Gröbner Basis Algorithms
	author = Alexander Maletzky <https://risc.jku.at/m/alexander-maletzky/>
	topic = Mathematics/Algebra, Computer science/Algorithms/Mathematical
	date = 2018-09-20
	notify = alexander.maletzky@risc.jku.at
	abstract =
	<p>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.</p>
	<p>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.</p><p>The formalization follows the recent survey article by
	Eder and Faugère.</p>

	[Factored_Transition_System_Bounding]
	title = Upper Bounding Diameters of State Spaces of Factored Transition Systems
	author = Friedrich Kurz <>, Mohammad Abdulaziz <http://home.in.tum.de/~mansour/>
	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 <http://home.in.tum.de/~immler/>, Bohua Zhan <http://lcs.ios.ac.cn/~bzhan/>
	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 = manuel@pruvisto.org
	abstract =
	<p>This article defines the combinatorial structures known as
	<em>Independence Systems</em> and
	<em>Matroids</em> 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
	<a href="http://www.math.lsu.edu/~oxley/survey4.pdf">`What
	is a Matroid?'</a>.</p>

	[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 <a href="https://doi.org/10.1016/j.jlamp.2018.06.005">paper by the author</a> 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 <https://people.compute.dtu.dk/andschl/>, Jasmin Christian Blanchette <mailto:j.c.blanchette@vu.nl>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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
	<i>Handbook of Automated Reasoning</i>. The result is a
	functional implementation of a first-order prover.

	[Auto2_HOL]
	title = Auto2 Prover
	author = Bohua Zhan <http://lcs.ios.ac.cn/~bzhan/>
	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 <http://staffwww.dcs.shef.ac.uk/people/G.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 <http://staffwww.dcs.shef.ac.uk/people/G.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 <http://staffwww.dcs.shef.ac.uk/people/G.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 <mailto:Roy.Overbeek@cwi.nl>
	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 <em>determinacy</em>:
	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 <https://www.brucker.ch/>, Michael Herzberg <http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.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.

	[Core_SC_DOM]
	title = The Safely Composable DOM
	author = Achim D. Brucker <https://www.brucker.ch>, Michael Herzberg <http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg>
	topic = Computer science/Data structures
	date = 2020-09-28
	notify = adbrucker@0x5f.org, mail@michael-herzberg.de
	abstract =
	In this AFP entry, we formalize the core of the Safely Composable
	Document Object Model (SC DOM). The SC DOM improve the standard DOM
	(as formalized in the AFP entry "Core DOM") by strengthening
	the tree boundaries set by shadow roots: in the SC DOM, the shadow
	root is a sub-class of the document class (instead of a base class).
	This modifications also results in changes to some API methods (e.g.,
	getOwnerDocument) to return the nearest shadow root rather than the
	document root. As a result, many API methods that, when called on a
	node inside a shadow tree, would previously ``break out''
	and return or modify nodes that are possibly outside the shadow tree,
	now stay within its boundaries. This change in behavior makes programs
	that operate on shadow trees more predictable for the developer and
	allows them to make more assumptions about other code accessing the
	DOM.

	[Shadow_SC_DOM]
	title = A Formal Model of the Safely Composable Document Object Model with Shadow Roots
	author = Achim D. Brucker <https://www.brucker.ch>, Michael Herzberg <http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg>
	topic = Computer science/Data structures
	date = 2020-09-28
	notify = adbrucker@0x5f.org, mail@michael-herzberg.de
	abstract =
	In this AFP entry, we extend our formalization of the safely
	composable DOM with Shadow Roots. This is a proposal for Shadow Roots
	with stricter safety guarantess than the standard compliant
	formalization (see "Shadow DOM"). Shadow Roots are a recent
	proposal of the web community to support a component-based development
	approach for client-side web applications. Shadow roots are a
	significant extension to the DOM standard and, as web standards are
	condemned to be backward compatible, such extensions often result in
	complex specification that may contain unwanted subtleties that can be
	detected by a formalization. Our Isabelle/HOL formalization is, in
	the sense of object-orientation, an extension of our formalization of
	the core DOM and enjoys the same basic properties, i.e., it is
	extensible, i.e., can be extended without the need of re-proving
	already proven properties and executable, i.e., we can generate
	executable code from our specification. We exploit the executability
	to show that our formalization complies to the official standard of
	the W3C, respectively, the WHATWG.

	[SC_DOM_Components]
	title = A Formalization of Safely Composable Web Components
	author = Achim D. Brucker <https://www.brucker.ch>, Michael Herzberg <http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg>
	topic = Computer science/Data structures
	date = 2020-09-28
	notify = adbrucker@0x5f.org, mail@michael-herzberg.de
	abstract =
	While the (safely composable) DOM with shadow trees provide the
	technical basis for defining web components, it does neither defines
	the concept of web components nor specifies the safety properties that
	web components should guarantee. Consequently, the standard also does
	not discuss how or even if the methods for modifying the DOM respect
	component boundaries. In AFP entry, we present a formally verified
	model of safely composable web components and define safety properties
	which ensure that different web components can only interact with each
	other using well-defined interfaces. Moreover, our verification of the
	application programming interface (API) of the DOM revealed numerous
	invariants that implementations of the DOM API need to preserve to
	ensure the integrity of components. In comparison to the strict
	standard compliance formalization of Web Components in the AFP entry
	"DOM_Components", the notion of components in this entry
	(based on "SC_DOM" and "Shadow_SC_DOM") provides
	much stronger safety guarantees.

	[Store_Buffer_Reduction]
	title = A Reduction Theorem for Store Buffers
	author = Ernie Cohen <mailto:ecohen@amazon.com>, Norbert Schirmer <mailto:norbert.schirmer@web.de>
	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 <http://www21.in.tum.de/~lammich>, Simon Wimmer <http://in.tum.de/~wimmers>
	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: <ul> <li>Bisection
	Square Root, </li> <li>Extended Euclid, </li>
	<li>Exponentiation by Squaring, </li> <li>Binary
	Search, </li> <li>Insertion Sort, </li>
	<li>Quicksort, </li> <li>Depth First Search.
	</li> </ul> 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 <http://cl-informatik.uibk.ac.at/users/bottesch/>, Max W. Haslbeck <http://cl-informatik.uibk.ac.at/users/mhaslbeck/>, René Thiemann <http://cl-informatik.uibk.ac.at/~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 <http://lcs.ios.ac.cn/~bzhan/>
	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 <https://www-users.cs.york.ac.uk/~simonf/>, Frank Zeyda<>, Yakoub Nemouchi <mailto:yakoub.nemouchi@york.ac.uk>, Pedro Ribeiro<>, Burkhart Wolff<mailto:wolff@lri.fr>
	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 <mailto:safouan.taha@lri.fr>, Lina Ye <mailto:lina.ye@lri.fr>, Burkhart Wolff<mailto:wolff@lri.fr>
	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 <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2019-02-11
	notify = manuel@pruvisto.org
	abstract =
	<p>The most efficient known primality tests are
	<em>probabilistic</em> 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.</p> <p>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.</p>

	[Kruskal]
	title = Kruskal's Algorithm for Minimum Spanning Forest
	author = Maximilian P.L. Haslbeck <http://in.tum.de/~haslbema/>, Peter Lammich <http://www21.in.tum.de/~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 <https://pruvisto.org>
	topic = Computer science/Algorithms
	date = 2019-02-01
	notify = manuel@pruvisto.org
	abstract =
	<p>This entry defines the set of <em>inversions</em>
	of a list, i.e. the pairs of indices that violate sortedness. It also
	proves the correctness of the well-known
	<em>O</em>(<em>n log n</em>)
	divide-and-conquer algorithm to compute the number of
	inversions.</p>

	[Prime_Distribution_Elementary]
	title = Elementary Facts About the Distribution of Primes
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2019-02-21
	notify = manuel@pruvisto.org
	abstract =
	<p>This entry is a formalisation of Chapter 4 (and parts of
	Chapter 3) of Apostol's <a
	href="https://www.springer.com/de/book/9780387901633"><em>Introduction
	to Analytic Number Theory</em></a>. 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
	<em>n</em>, the divisor function
	<em>d(n)</em>, Euler's totient function
	<em>φ(n)</em>, and
	lcm(1,…,<em>n</em>).</p>

	[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 =
	<p>The theory is a formalization of the
	<a href="https://www.omg.org/spec/OCL/">OCL</a> type system, its abstract
	syntax and expression typing rules. The theory does not define a concrete
	syntax and a semantics. In contrast to
	<a href="https://www.isa-afp.org/entries/Featherweight_OCL.html">Featherweight OCL</a>,
	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.</p>
	<p>The Safe OCL distincts nullable and non-nullable types. Also the theory gives a
	formal definition of <a href="http://ceur-ws.org/Vol-1512/paper07.pdf">safe
	navigation operations</a>. 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.</p>
	<p>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.</p>
	<p>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.</p>

	[QHLProver]
	title = Quantum Hoare Logic
	author = Junyi Liu<>, Bohua Zhan <http://lcs.ios.ac.cn/~bzhan/>, 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 <https://www.cl.cam.ac.uk/~ak2110/>, Wenda Li <https://www.cl.cam.ac.uk/~wl302/>
	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 <mailto:lor.gheri@gmail.com>, Andrei Popescu <https://www.andreipopescu.uk>
	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 <mailto:benedikt.seidl@tum.de>, Salomon Sickert <mailto:s.sickert@tum.de>
	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.
	<p>
	[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 <https://traytel.bitbucket.io>
	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. <a
	href="https://doi.org/10.1145/2535838.2535851">Miller et
	al.</a> introduced λ• (pronounced
	<i>lambda auth</i>)—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 an <a
	href="https://doi.org/10.4230/LIPIcs.ITP.2019.10">ITP'19 paper</a>.

	[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 <https://risc.jku.at/m/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 <http://cl-informatik.uibk.ac.at/users/bottesch/>, Alban Reynaud <>, René Thiemann <http://cl-informatik.uibk.ac.at/~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 <http://www.parsert.com/>, Cezary Kaliszyk <http://cl-informatik.uibk.ac.at/cek/>
	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 <http://www.cs.cmu.edu/~aplatzer/>
	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.

	[BenOr_Kozen_Reif]
	title = The BKR Decision Procedure for Univariate Real Arithmetic
	author = Katherine Cordwell <https://www.cs.cmu.edu/~kcordwel/>, Yong Kiam Tan <https://www.cs.cmu.edu/~yongkiat/>, André Platzer <https://www.cs.cmu.edu/~aplatzer/>
	topic = Computer science/Algorithms/Mathematical
	date = 2021-04-24
	notify = kcordwel@cs.cmu.edu, yongkiat@cs.cmu.edu, aplatzer@cs.cmu.edu
	abstract =
	We formalize the univariate case of Ben-Or, Kozen, and Reif's
	decision procedure for first-order real arithmetic (the BKR
	algorithm). We also formalize the univariate case of Renegar's
	variation of the BKR algorithm. The two formalizations differ
	mathematically in minor ways (that have significant impact on the
	multivariate case), but are quite similar in proof structure. Both
	rely on sign-determination (finding the set of consistent sign
	assignments for a set of polynomials). The method used for
	sign-determination is similar to Tarski's original quantifier
	elimination algorithm (it stores key information in a matrix
	equation), but with a reduction step to keep complexity low.

	[Complete_Non_Orders]
	title = Complete Non-Orders and Fixed Points
	author = Akihisa Yamada <http://group-mmm.org/~ayamada/>, Jérémy Dubut <http://group-mmm.org/~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 <http://www21.in.tum.de/~lammich>, Tobias Nipkow <http://www21.in.tum.de/~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 <em>priority search tree</em>. 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 <em>Purely Functional, Simple and Efficient Priority
	Search Trees and Applications to Prim and Dijkstra</em>.

	[Prim_Dijkstra_Simple]
	title = Purely Functional, Simple, and Efficient Implementation of Prim and Dijkstra
	author = Peter Lammich <http://www21.in.tum.de/~lammich>, Tobias Nipkow <http://www21.in.tum.de/~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 <em>Purely Functional, Simple and Efficient
	Priority Search Trees and Applications to Prim and Dijkstra</em>.

	[MFOTL_Monitor]
	title = Formalization of a Monitoring Algorithm for Metric First-Order Temporal Logic
	author = Joshua Schneider <mailto:joshua.schneider@inf.ethz.ch>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <a href="https://doi.org/10.1007/978-3-030-32079-9_18">RV
	2019 paper</a>, 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)<br>

	[FOL_Seq_Calc1]
	title = A Sequent Calculus for First-Order Logic
	author = Asta Halkjær From <https://people.compute.dtu.dk/ahfrom/>
	contributors = Alexander Birch Jensen <https://people.compute.dtu.dk/aleje/>,
	Anders Schlichtkrull <https://people.compute.dtu.dk/andschl/>,
	Jørgen Villadsen <https://people.compute.dtu.dk/jovi/>
	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.
	Paper: <a href="http://ceur-ws.org/Vol-3002/paper7.pdf">http://ceur-ws.org/Vol-3002/paper7.pdf</a>.

	+[FOL_Seq_Calc2]
	+title = A Sequent Calculus Prover for First-Order Logic with Functions
	+author = Asta Halkjær From <https://people.compute.dtu.dk/ahfrom/>, Frederik Krogsdal Jacobsen <http://people.compute.dtu.dk/fkjac/>
	+topic = Logic/General logic/Classical first-order logic, Logic/Proof theory, Logic/General logic/Mechanization of proofs
	+date = 2022-01-31
	+notify = ahfrom@dtu.dk, fkjac@dtu.dk
	+abstract =
	+ We formalize an automated theorem prover for first-order logic with
	+ functions. The proof search procedure is based on sequent calculus and
	+ we verify its soundness and completeness using the Abstract Soundness
	+ and Abstract Completeness theories. Our analytic completeness proof
	+ covers both open and closed formulas. Since our deterministic prover
	+ considers only the subset of terms relevant to proving a given
	+ sequent, we do so as well when building a countermodel from a failed
	+ proof. We formally connect our prover with the proof system and
	+ semantics of the existing SeCaV system. In particular, the
	+ prover's output can be post-processed in Haskell to generate
	+ human-readable SeCaV proofs which are also machine-verifiable proof
	+ certificates.
	+
	[Szpilrajn]
	title = Order Extension and Szpilrajn's Extension Theorem
	author = Peter Zeller <mailto:p_zeller@cs.uni-kl.de>, Lukas Stevens <https://www21.in.tum.de/team/stevensl>
	topic = Mathematics/Order
	date = 2019-07-27
	notify = p_zeller@cs.uni-kl.de
	abstract =
	This entry is concerned with the principle of order extension, i.e. the extension of an order relation to a total order relation.
	To this end, we prove a more general version of Szpilrajn's extension theorem employing terminology from the book "Consistency, Choice, and Rationality" by Bossert and Suzumura.
	We also formalize theorem 2.7 of their book.
	extra-history =
	Change history:
	[2021-03-22]:
	(by Lukas Stevens) generalise Szpilrajn's extension theorem and add material from the book "Consistency, Choice, and Rationality"

	[TESL_Language]
	title = A Formal Development of a Polychronous Polytimed Coordination Language
	author = Hai Nguyen Van <mailto:hai.nguyenvan.phie@gmail.com>, Frédéric Boulanger <mailto:frederic.boulanger@centralesupelec.fr>, Burkhart Wolff <mailto:burkhart.wolff@lri.fr>
	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:
	<ul><li>the
	behavior of the sub-systems is observed only at a series of discrete
	instants,</li><li>events may occur in different sub-systems at unrelated
	times, leading to polychronous systems, which do not necessarily have
	a common base clock,</li><li>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,</li><li>the domain of time
	(discrete, rational, continuous...) may be different in the
	subsystems, leading to polytimed systems,</li><li>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).</li></ul>
	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 <mailto:giuliano@galois.com>
	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 <https://pruvisto.org>
	topic = Mathematics/Misc
	date = 2019-08-05
	notify = manuel@pruvisto.org
	abstract =
	<p>This entry contains formalisations of the answers to three of
	the six problem of the International Mathematical Olympiad 2019,
	namely Q1, Q4, and Q5.</p> <p>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.</p>

	[Adaptive_State_Counting]
	title = Formalisation of an Adaptive State Counting Algorithm
	author = Robert Sachtleben <mailto:rob_sac@uni-bremen.de>
	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 <a
	href="https://doi.org/10.1109/TC.2004.85">Testing from a
	Non-Deterministic Finite State Machine Using Adaptive State
	Counting</a>. 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 <http://www21.in.tum.de/~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 <i>Basic Algebra</i>
	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.
	extra-history =
	Change history:
	[2020-12-13]: added components based on Kleene algebras with tests. These implement differential Hoare logic (dH) and a Morgan-style differential refinement calculus (dR) for verification of hybrid programs.

	[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, <a
	href="https://doi.org/10.1145/2590989.2590991">Ngo, Ré,
	and Rudra</a> 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 <https://www.cl.cam.ac.uk/~ak2110/>
	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 <a
	href="https://plato.stanford.edu/entries/aristotle-logic/">article from the Stanford Encyclopedia of Philosophy by Robin Smith.</a> 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<http://home.in.tum.de/~wimmers/>
	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 <https://www.cl.cam.ac.uk/~lp15/>
	topic = Logic/Set theory
	date = 2019-10-24
	notify = lp15@cam.ac.uk
	abstract =
	<p>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.</p>
	<p>There is a type <em>V</em> of sets and a function <em>elts :: V => V
	set</em> mapping a set to its elements. Classes simply have type <em>V
	set</em>, 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.</p>
	<p>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.</p>
	<p>The theory provides two type classes with the aim of facilitating
	developments that combine <em>V</em> with other Isabelle/HOL types:
	<em>embeddable</em>, the class of types that can be injected into <em>V</em>
	(including <em>V</em> itself as well as <em>V*V</em>, etc.), and
	<em>small</em>, the class of types that correspond to some ZF set.</p>
	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 <mailto:bbohrer@cs.cmu.edu>
	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 <a href="https://www.isa-afp.org/entries/Differential_Dynamic_Logic.html">Differential_Dynamic_Logic</a> 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 <mailto:pasquale.noce.lavoro@gmail.com>
	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 <http://home.in.tum.de/~immler/>, Yong Kiam Tan <https://www.cs.cmu.edu/~yongkiat/>
	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 <https://www.lri.fr/~ftuong/>, Burkhart Wolff <https://www.lri.fr/~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 <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2019-12-27
	notify = manuel.eberl@tum.de
	abstract =
	<p>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 <a
	href="http://people.math.sc.edu/filaseta/gradcourses/Math785/Math785Notes4.pdf">Filaseta's
	presentation</a> of Beukers's proof.</p>

	[Hybrid_Logic]
	title = Formalizing a Seligman-Style Tableau System for Hybrid Logic
	author = Asta Halkjær From <https://people.compute.dtu.dk/ahfrom/>
	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 <mailto:stark@cs.stonybrook.edu>
	topic = Mathematics/Category theory
	date = 2020-01-06
	notify = stark@cs.stonybrook.edu
	abstract =
	<p>
	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.
	</p><p>
	Revisions made subsequent to the first version of this article added
	additional material on pseudofunctors, pseudonatural transformations,
	modifications, and equivalence of bicategories; the main thrust being
	to give a proof that a pseudofunctor is a biequivalence if and only
	if it can be extended to an equivalence of bicategories.
	</p>
	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)<br>
	[2020-11-04]:
	Added new material on equivalence of bicategories, with associated changes.
	(revision 472cb2268826)<br>
	[2021-07-22]:
	Added new material: "concrete bicategories" and "bicategory of categories".
	(revision 49d3aa43c180)<br>

	[Subset_Boolean_Algebras]
	title = A Hierarchy of Algebras for Boolean Subsets
	author = Walter Guttmann <http://www.cosc.canterbury.ac.nz/walter.guttmann/>, Bernhard Möller <https://www.informatik.uni-augsburg.de/en/chairs/dbis/pmi/staff/moeller/>
	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 <mailto:int-e@gmx.de>
	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 <https://martin.desharnais.me>
	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 <http://net.in.tum.de/~diekmann>, Lars Hupel <https://www21.in.tum.de/~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 <https://orcid.org/0000-0003-3290-5034>, Edgar Gonzàlez <mailto:edgargip@google.com>
	topic = Computer science/Algorithms/Distributed
	date = 2020-03-25
	-notify = eminkarayel@google.com, edgargip@google.com, me@eminkarayel.de
	+notify = 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 <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2020-03-22
	notify = manuel.eberl@tum.de
	abstract =
	<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>

	[Saturation_Framework]
	title = A Comprehensive Framework for Saturation Theorem Proving
	author = Sophie Tourret <https://www.mpi-inf.mpg.de/departments/automation-of-logic/people/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 <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.

	[Saturation_Framework_Extensions]
	title = Extensions to the Comprehensive Framework for Saturation Theorem Proving
	author = Jasmin Blanchette <https://www.cs.vu.nl/~jbe248/>, Sophie Tourret <https://www.mpi-inf.mpg.de/departments/automation-of-logic/people/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
	<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>

	[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 <mailto:martin.raszyk@inf.ethz.ch>, Joshua Schneider <mailto:joshua.schneider@inf.ethz.ch>, Dmitriy Traytel <https://traytel.bitbucket.io>
	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 <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.
	extra-history =
	Change history:
	[2021-10-19]: corrected a mistake in the calculation of median aggregations
	(reported by Nicolas Kaletsch, revision 02b14c9bf3da)<br>

	[Sliding_Window_Algorithm]
	title = Formalization of an Algorithm for Greedily Computing Associative Aggregations on Sliding Windows
	author = Lukas Heimes<>, Dmitriy Traytel <https://traytel.bitbucket.io>, 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 <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.

	[Lucas_Theorem]
	title = Lucas's Theorem
	author = Chelsea Edmonds <mailto:cle47@cam.ac.uk>
	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 <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.

	[ADS_Functor]
	title = Authenticated Data Structures As Functors
	author = Andreas Lochbihler <http://www.andreas-lochbihler.de>, Ognjen Marić <mailto:ogi.afp@mynosefroze.com>
	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 <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.

	[Power_Sum_Polynomials]
	title = Power Sum Polynomials
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Algebra
	date = 2020-04-24
	notify = manuel@pruvisto.org
	abstract =
	<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>,…,
	<em>X</em><sub><em>k</em></sub>) =
	<em>X</em><sub>1</sub><sup>n</sup>
	+ … +
	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>
	=
	∑<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> .</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>,
	…,
	<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>
	+ … +
	<em>x</em><sub><em>k</em></sub><sup><em>j</em></sup>.
	Then for each vector <em>a</em> &isinv;
	ℂ<sup><em>k</em></sup>, show that
	there is exactly one solution to the system p<sub>1</sub>
	= a<sub>1</sub>, …,
	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>k.</p>

	[Formal_Puiseux_Series]
	title = Formal Puiseux Series
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Algebra
	date = 2021-02-17
	notify = manuel@pruvisto.org
	abstract =
	<p>Formal Puiseux series are generalisations of formal power
	series and formal Laurent series that also allow for fractional
	exponents. They have the following general form: \[\sum_{i=N}^\infty
	a_{i/d} X^{i/d}\] where <em>N</em> is an integer and
	<em>d</em> is a positive integer.</p> <p>This
	entry defines these series including their basic algebraic properties.
	Furthermore, it proves the Newton–Puiseux Theorem, namely that the
	Puiseux series over an algebraically closed field of characteristic 0
	are also algebraically closed.</p>

	[Gaussian_Integers]
	title = Gaussian Integers
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Number theory
	date = 2020-04-24
	notify = manuel@pruvisto.org
	abstract =
	<p>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.</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>

	[Forcing]
	title = Formalization of Forcing in Isabelle/ZF
	author = Emmanuel Gunther <mailto:gunther@famaf.unc.edu.ar>, Miguel Pagano <https://cs.famaf.unc.edu.ar/~mpagano/>, Pedro Sánchez Terraf <https://cs.famaf.unc.edu.ar/~pedro/home_en>
	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.

	[Delta_System_Lemma]
	title = Cofinality and the Delta System Lemma
	author = Pedro Sánchez Terraf <https://cs.famaf.unc.edu.ar/~pedro/home_en.html>
	topic = Mathematics/Combinatorics, Logic/Set theory
	date = 2020-12-27
	notify = sterraf@famaf.unc.edu.ar
	abstract =
	We formalize the basic results on cofinality of linearly ordered sets
	and ordinals and Šanin’s Lemma for uncountable families of finite
	sets. This last result is used to prove the countable chain condition
	for Cohen posets. We work in the set theory framework of Isabelle/ZF,
	using the Axiom of Choice as needed.

	[Recursion-Addition]
	title = Recursion Theorem in ZF
	author = Georgy Dunaev <mailto:georgedunaev@gmail.com>
	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 <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.

	[LTL_Normal_Form]
	title = An Efficient Normalisation Procedure for Linear Temporal Logic: Isabelle/HOL Formalisation
	author = Salomon Sickert <mailto:s.sickert@tum.de>
	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 <mailto:jjhuertaymunive1@sheffield.ac.uk>
	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 <https://www.cl.cam.ac.uk/~ak2110/>, Wenda Li <https://www.cl.cam.ac.uk/~wl302/>
	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
	<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.

	[Knuth_Bendix_Order]
	title = A Formalization of Knuth–Bendix Orders
	author = Christian Sternagel <mailto:c.sternagel@gmail.com>, René Thiemann <http://cl-informatik.uibk.ac.at/~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 <mailto:avhe@dtu.dk>, Sebastian Mödersheim <https://people.compute.dtu.dk/samo/>, Achim D. Brucker <https://www.brucker.ch/>
	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 <mailto:avhe@dtu.dk>, Sebastian Mödersheim <https://people.compute.dtu.dk/samo/>, Achim D. Brucker <https://www.brucker.ch/>, Anders Schlichtkrull <https://people.compute.dtu.dk/andschl/>
	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 <https://www.unirioja.es/cu/jodivaso/>
	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 <https://www.cl.cam.ac.uk/~lp15/>
	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 <mailto:albert.rizaldi@ntu.edu.sg>, Fabian Immler <http://home.in.tum.de/~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 <http://www.cosc.canterbury.ac.nz/walter.guttmann/>, Peter Höfner <http://www.hoefner-online.de/>
	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 <https://www.cl.cam.ac.uk/~ak2110/>
	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 <https://www.cl.cam.ac.uk/~lp15/>
	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 <http://www.cosc.canterbury.ac.nz/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.
	extra-history =
	Change history:
	[2021-06-19]:
	added path halving, path splitting, relational Peano structures, union by rank
	(revision 98c7aa03457d)

	[PAC_Checker]
	title = Practical Algebraic Calculus Checker
	author = Mathias Fleury <http://fmv.jku.at/fleury>, Daniela Kaufmann <http://fmv.jku.at/kaufmann>
	topic = Computer science/Algorithms
	date = 2020-08-31
	notify = mathias.fleury@jku.at
	abstract =
	Generating and checking proof certificates is important to increase
	the trust in automated reasoning tools. In recent years formal
	verification using computer algebra became more important and is
	heavily used in automated circuit verification. An existing proof
	format which covers algebraic reasoning and allows efficient proof
	checking is the practical algebraic calculus (PAC). In this
	development, we present the verified checker Pastèque that is obtained
	by synthesis via the Refinement Framework. This is the formalization
	going with our FMCAD'20 tool presentation.

	[BirdKMP]
	title = Putting the `K' into Bird's derivation of Knuth-Morris-Pratt string matching
	author = Peter Gammie <http://peteg.org>
	topic = Computer science/Functional programming
	date = 2020-08-25
	notify = peteg42@gmail.com
	abstract =
	Richard Bird and collaborators have proposed a derivation of an
	intricate cyclic program that implements the Morris-Pratt string
	matching algorithm. Here we provide a proof of total correctness for
	Bird's derivation and complete it by adding Knuth's
	optimisation.

	[Extended_Finite_State_Machines]
	title = A Formal Model of Extended Finite State Machines
	author = Michael Foster <mailto:m.foster@sheffield.ac.uk>, Achim D. Brucker <mailto:a.brucker@exeter.ac.uk>, Ramsay G. Taylor <mailto:r.g.taylor@sheffield.ac.uk>, John Derrick <mailto:j.derrick@sheffield.ac.uk>
	topic = Computer science/Automata and formal languages
	date = 2020-09-07
	notify = m.foster@sheffield.ac.uk, adbrucker@0x5f.org
	abstract =
	In this AFP entry, we provide a formalisation of extended finite state
	machines (EFSMs) where models are represented as finite sets of
	transitions between states. EFSMs execute traces to produce observable
	outputs. We also define various simulation and equality metrics for
	EFSMs in terms of traces and prove their strengths in relation to each
	other. Another key contribution is a framework of function definitions
	such that LTL properties can be phrased over EFSMs. Finally, we
	provide a simple example case study in the form of a drinks machine.

	[Extended_Finite_State_Machine_Inference]
	title = Inference of Extended Finite State Machines
	author = Michael Foster <mailto:m.foster@sheffield.ac.uk>, Achim D. Brucker <mailto:a.brucker@exeter.ac.uk>, Ramsay G. Taylor <mailto:r.g.taylor@sheffield.ac.uk>, John Derrick <mailto:j.derrick@sheffield.ac.uk>
	topic = Computer science/Automata and formal languages
	date = 2020-09-07
	notify = m.foster@sheffield.ac.uk, adbrucker@0x5f.org
	abstract =
	In this AFP entry, we provide a formal implementation of a
	state-merging technique to infer extended finite state machines
	(EFSMs), complete with output and update functions, from black-box
	traces. In particular, we define the subsumption in context relation
	as a means of determining whether one transition is able to account
	for the behaviour of another. Building on this, we define the direct
	subsumption relation, which lifts the subsumption in context relation
	to EFSM level such that we can use it to determine whether it is safe
	to merge a given pair of transitions. Key proofs include the
	conditions necessary for subsumption to occur and that subsumption
	and direct subsumption are preorder relations. We also provide a
	number of different heuristics which can be used to abstract away
	concrete values into registers so that more states and transitions can
	be merged and provide proofs of the various conditions which must hold
	for these abstractions to subsume their ungeneralised counterparts. A
	Code Generator setup to create executable Scala code is also defined.

	[Physical_Quantities]
	title = A Sound Type System for Physical Quantities, Units, and Measurements
	author = Simon Foster <https://www-users.cs.york.ac.uk/~simonf/>, Burkhart Wolff <https://www.lri.fr/~wolff/>
	topic = Mathematics/Physics, Computer science/Programming languages/Type systems
	date = 2020-10-20
	notify = simon.foster@york.ac.uk, wolff@lri.fr
	abstract =
	The present Isabelle theory builds a formal model for both the
	International System of Quantities (ISQ) and the International System
	of Units (SI), which are both fundamental for physics and engineering.
	Both the ISQ and the SI are deeply integrated into Isabelle's
	type system. Quantities are parameterised by dimension types, which
	correspond to base vectors, and thus only quantities of the same
	dimension can be equated. Since the underlying "algebra of
	quantities" induces congruences on quantity and SI types,
	specific tactic support is developed to capture these. Our
	construction is validated by a test-set of known equivalences between
	both quantities and SI units. Moreover, the presented theory can be
	used for type-safe conversions between the SI system and others, like
	the British Imperial System (BIS).

	[Shadow_DOM]
	title = A Formal Model of the Document Object Model with Shadow Roots
	author = Achim D. Brucker <https://www.brucker.ch>, Michael Herzberg <http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg>
	topic = Computer science/Data structures
	date = 2020-09-28
	notify = adbrucker@0x5f.org, mail@michael-herzberg.de
	abstract =
	In this AFP entry, we extend our formalization of the core DOM with
	Shadow Roots. Shadow roots are a recent proposal of the web community
	to support a component-based development approach for client-side web
	applications. Shadow roots are a significant extension to the DOM
	standard and, as web standards are condemned to be backward
	compatible, such extensions often result in complex specification that
	may contain unwanted subtleties that can be detected by a
	formalization. Our Isabelle/HOL formalization is, in the sense of
	object-orientation, an extension of our formalization of the core DOM
	and enjoys the same basic properties, i.e., it is extensible, i.e.,
	can be extended without the need of re-proving already proven
	properties and executable, i.e., we can generate executable code from
	our specification. We exploit the executability to show that our
	formalization complies to the official standard of the W3C,
	respectively, the WHATWG.

	[DOM_Components]
	title = A Formalization of Web Components
	author = Achim D. Brucker <https://www.brucker.ch>, Michael Herzberg <http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg>
	topic = Computer science/Data structures
	date = 2020-09-28
	notify = adbrucker@0x5f.org, mail@michael-herzberg.de
	abstract =
	While the DOM with shadow trees provide the technical basis for
	defining web components, the DOM standard neither defines the concept
	of web components nor specifies the safety properties that web
	components should guarantee. Consequently, the standard also does not
	discuss how or even if the methods for modifying the DOM respect
	component boundaries. In AFP entry, we present a formally verified
	model of web components and define safety properties which ensure that
	different web components can only interact with each other using
	well-defined interfaces. Moreover, our verification of the application
	programming interface (API) of the DOM revealed numerous invariants
	that implementations of the DOM API need to preserve to ensure the
	integrity of components.

	[Interpreter_Optimizations]
	title = Inline Caching and Unboxing Optimization for Interpreters
	author = Martin Desharnais <https://martin.desharnais.me>
	topic = Computer science/Programming languages/Misc
	date = 2020-12-07
	notify = martin.desharnais@unibw.de
	abstract =
	This Isabelle/HOL formalization builds on the
	<em>VeriComp</em> entry of the <em>Archive of Formal
	Proofs</em> to provide the following contributions: <ul>
	<li>an operational semantics for a realistic virtual machine
	(Std) for dynamically typed programming languages;</li>
	<li>the formalization of an inline caching optimization (Inca),
	a proof of bisimulation with (Std), and a compilation
	function;</li> <li>the formalization of an unboxing
	optimization (Ubx), a proof of bisimulation with (Inca), and a simple
	compilation function.</li> </ul> This formalization was
	described in the CPP 2021 paper <em>Towards Efficient and
	Verified Virtual Machines for Dynamic Languages</em>
	extra-history =
	Change history:
	[2021-06-14]: refactored function definitions to contain explicit basic blocks<br>
	[2021-06-25]: proved conditional completeness of compilation<br>

	[Isabelle_Marries_Dirac]
	title = Isabelle Marries Dirac: a Library for Quantum Computation and Quantum Information
	author = Anthony Bordg <https://sites.google.com/site/anthonybordg/>, Hanna Lachnitt<mailto:lachnitt@stanford.edu>, Yijun He<mailto:yh403@cam.ac.uk>
	topic = Computer science/Algorithms/Quantum computing, Mathematics/Physics/Quantum information
	date = 2020-11-22
	notify = apdb3@cam.ac.uk, lachnitt@stanford.edu
	abstract =
	This work is an effort to formalise some quantum algorithms and
	results in quantum information theory. Formal methods being critical
	for the safety and security of algorithms and protocols, we foresee
	their widespread use for quantum computing in the future. We have
	developed a large library for quantum computing in Isabelle based on a
	matrix representation for quantum circuits, successfully formalising
	the no-cloning theorem, quantum teleportation, Deutsch's
	algorithm, the Deutsch-Jozsa algorithm and the quantum Prisoner's
	Dilemma.

	[Projective_Measurements]
	title = Quantum projective measurements and the CHSH inequality
	author = Mnacho Echenim <https://lig-membres.imag.fr/mechenim/>
	topic = Computer science/Algorithms/Quantum computing, Mathematics/Physics/Quantum information
	date = 2021-03-03
	notify = mnacho.echenim@univ-grenoble-alpes.fr
	abstract =
	This work contains a formalization of quantum projective measurements,
	also known as von Neumann measurements, which are based on elements of
	spectral theory. We also formalized the CHSH inequality, an inequality
	involving expectations in a probability space that is violated by
	quantum measurements, thus proving that quantum mechanics cannot be modeled with an underlying local hidden-variable theory.

	[Finite-Map-Extras]
	title = Finite Map Extras
	author = Javier Díaz <mailto:javier.diaz.manzi@gmail.com>
	topic = Computer science/Data structures
	date = 2020-10-12
	notify = javier.diaz.manzi@gmail.com
	abstract =
	This entry includes useful syntactic sugar, new operators and functions, and
	their associated lemmas for finite maps which currently are not
	present in the standard Finite_Map theory.

	[Relational_Minimum_Spanning_Trees]
	title = Relational Minimum Spanning Tree Algorithms
	author = Walter Guttmann <http://www.cosc.canterbury.ac.nz/walter.guttmann/>, Nicolas Robinson-O'Brien<>
	topic = Computer science/Algorithms/Graph
	date = 2020-12-08
	notify = walter.guttmann@canterbury.ac.nz
	abstract =
	We verify the correctness of Prim's, Kruskal's and
	Borůvka's minimum spanning tree algorithms based on algebras for
	aggregation and minimisation.

	[Topological_Semantics]
	title = Topological semantics for paraconsistent and paracomplete logics
	author = David Fuenmayor <mailto:davfuenmayor@gmail.com>
	topic = Logic/General logic
	date = 2020-12-17
	notify = davfuenmayor@gmail.com
	abstract =
	We introduce a generalized topological semantics for paraconsistent
	and paracomplete logics by drawing upon early works on topological
	Boolean algebras (cf. works by Kuratowski, Zarycki, McKinsey &
	Tarski, etc.). In particular, this work exemplarily illustrates the
	shallow semantical embeddings approach (<a
	href="http://dx.doi.org/10.1007/s11787-012-0052-y">SSE</a>)
	employing the proof assistant Isabelle/HOL. By means of the SSE
	technique we can effectively harness theorem provers, model finders
	and 'hammers' for reasoning with quantified non-classical
	logics.

	[CSP_RefTK]
	title = The HOL-CSP Refinement Toolkit
	author = Safouan Taha <mailto:safouan.taha@lri.fr>, Burkhart Wolff <https://www.lri.fr/~wolff/>, Lina Ye <mailto:lina.ye@lri.fr>
	topic = Computer science/Concurrency/Process calculi, Computer science/Semantics
	date = 2020-11-19
	notify = wolff@lri.fr
	abstract =
	We use a formal development for CSP, called HOL-CSP2.0, to analyse a
	family of refinement notions, comprising classic and new ones. This
	analysis enables to derive a number of properties that allow to deepen
	the understanding of these notions, in particular with respect to
	specification decomposition principles for the case of infinite sets
	of events. The established relations between the refinement relations
	help to clarify some obscure points in the CSP literature, but also
	provide a weapon for shorter refinement proofs. Furthermore, we
	provide a framework for state-normalisation allowing to formally
	reason on parameterised process architectures. As a result, we have a
	modern environment for formal proofs of concurrent systems that allow
	for the combination of general infinite processes with locally finite
	ones in a logically safe way. We demonstrate these
	verification-techniques for classical, generalised examples: The
	CopyBuffer for arbitrary data and the Dijkstra's Dining
	Philosopher Problem of arbitrary size.

	[Hood_Melville_Queue]
	title = Hood-Melville Queue
	author = Alejandro Gómez-Londoño<mailto:alejandro.gomez@chalmers.se>
	topic = Computer science/Data structures
	date = 2021-01-18
	notify = nipkow@in.tum.de
	abstract =
	This is a verified implementation of a constant time queue. The
	original design is due to <a
	href="https://doi.org/10.1016/0020-0190(81)90030-2">Hood
	and Melville</a>. This formalization follows the presentation in
	<em>Purely Functional Data Structures</em>by Okasaki.

	[JinjaDCI]
	title = JinjaDCI: a Java semantics with dynamic class initialization
	author = Susannah Mansky <mailto:sjohnsn2@illinois.edu>
	topic = Computer science/Programming languages/Language definitions
	date = 2021-01-11
	notify = sjohnsn2@illinois.edu, susannahej@gmail.com
	abstract =
	We extend Jinja to include static fields, methods, and instructions,
	and dynamic class initialization, based on the Java SE 8
	specification. This includes extension of definitions and proofs. This
	work is partially described in Mansky and Gunter's paper at CPP
	2019 and Mansky's doctoral thesis (UIUC, 2020).

	[Blue_Eyes]
	title = Solution to the xkcd Blue Eyes puzzle
	author = Jakub Kądziołka <mailto:kuba@kadziolka.net>
	topic = Logic/General logic/Logics of knowledge and belief
	date = 2021-01-30
	notify = kuba@kadziolka.net
	abstract =
	In a <a href="https://xkcd.com/blue_eyes.html">puzzle published by
	Randall Munroe</a>, perfect logicians forbidden
	from communicating are stranded on an island, and may only leave once
	they have figured out their own eye color. We present a method of
	modeling the behavior of perfect logicians and formalize a solution of
	the puzzle.

	[Laws_of_Large_Numbers]
	title = The Laws of Large Numbers
	author = Manuel Eberl <https://pruvisto.org>
	topic = Mathematics/Probability theory
	date = 2021-02-10
	notify = manuel@pruvisto.org
	abstract =
	<p>The Law of Large Numbers states that, informally, if one
	performs a random experiment $X$ many times and takes the average of
	the results, that average will be very close to the expected value
	$E[X]$.</p> <p> More formally, let
	$(X_i)_{i\in\mathbb{N}}$ be a sequence of independently identically
	distributed random variables whose expected value $E[X_1]$ exists.
	Denote the running average of $X_1, \ldots, X_n$ as $\overline{X}_n$.
	Then:</p> <ul> <li>The Weak Law of Large Numbers
	states that $\overline{X}_{n} \longrightarrow E[X_1]$ in probability
	for $n\to\infty$, i.e. $\mathcal{P}(\|\overline{X}_{n} - E[X_1]\| >
	\varepsilon) \longrightarrow 0$ as $n\to\infty$ for any $\varepsilon
	> 0$.</li> <li>The Strong Law of Large Numbers states
	that $\overline{X}_{n} \longrightarrow E[X_1]$ almost surely for
	$n\to\infty$, i.e. $\mathcal{P}(\overline{X}_{n} \longrightarrow
	E[X_1]) = 1$.</li> </ul> <p>In this entry, I
	formally prove the strong law and from it the weak law. The approach
	used for the proof of the strong law is a particularly quick and slick
	one based on ergodic theory, which was formalised by Gouëzel in
	another AFP entry.</p>

	[BTree]
	title = A Verified Imperative Implementation of B-Trees
	author = Niels Mündler <mailto:n.muendler@tum.de>
	topic = Computer science/Data structures
	date = 2021-02-24
	notify = n.muendler@tum.de
	abstract =
	In this work, we use the interactive theorem prover Isabelle/HOL to
	verify an imperative implementation of the classical B-tree data
	structure invented by Bayer and McCreight [ACM 1970]. The
	implementation supports set membership, insertion and deletion queries with
	efficient binary search for intra-node navigation. This is
	accomplished by first specifying the structure abstractly in the
	functional modeling language HOL and proving functional correctness.
	Using manual refinement, we derive an imperative implementation in
	Imperative/HOL. We show the validity of this refinement using the
	separation logic utilities from the <a
	href="https://www.isa-afp.org/entries/Refine_Imperative_HOL.html">
	Isabelle Refinement Framework </a> . The code can be exported to
	the programming languages SML, OCaml and Scala. We examine the runtime of all
	operations indirectly by reproducing results of the logarithmic
	relationship between height and the number of nodes. The results are
	discussed in greater detail in the corresponding <a
	href="https://mediatum.ub.tum.de/1596550">Bachelor's
	Thesis</a>.
	extra-history =
	Change history:
	[2021-05-02]:
	Add implementation and proof of correctness of imperative deletion operations.
	Further add the option to export code to OCaml.
	<br>

	[Sunflowers]
	title = The Sunflower Lemma of Erdős and Rado
	author = René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	topic = Mathematics/Combinatorics
	date = 2021-02-25
	notify = rene.thiemann@uibk.ac.at
	abstract =
	We formally define sunflowers and provide a formalization of the
	sunflower lemma of Erd&odblac;s and Rado: whenever a set of
	size-<i>k</i>-sets has a larger cardinality than
	<i>(r - 1)<sup>k</sup> · k!</i>,
	then it contains a sunflower of cardinality <i>r</i>.

	[Mereology]
	title = Mereology
	author = Ben Blumson <https://philpeople.org/profiles/ben-blumson>
	topic = Logic/Philosophical aspects
	date = 2021-03-01
	notify = benblumson@gmail.com
	abstract =
	We use Isabelle/HOL to verify elementary theorems and alternative
	axiomatizations of classical extensional mereology.

	[Modular_arithmetic_LLL_and_HNF_algorithms]
	title = Two algorithms based on modular arithmetic: lattice basis reduction and Hermite normal form computation
	author = Ralph Bottesch <>, Jose Divasón <https://www.unirioja.es/cu/jodivaso/>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	topic = Computer science/Algorithms/Mathematical
	date = 2021-03-12
	notify = rene.thiemann@uibk.ac.at
	abstract =
	We verify two algorithms for which modular arithmetic plays an
	essential role: Storjohann's variant of the LLL lattice basis
	reduction algorithm and Kopparty's algorithm for computing the
	Hermite normal form of a matrix. To do this, we also formalize some
	facts about the modulo operation with symmetric range. Our
	implementations are based on the original papers, but are otherwise
	efficient. For basis reduction we formalize two versions: one that
	includes all of the optimizations/heuristics from Storjohann's
	paper, and one excluding a heuristic that we observed to often
	decrease efficiency. We also provide a fast, self-contained certifier
	for basis reduction, based on the efficient Hermite normal form
	algorithm.

	[Constructive_Cryptography_CM]
	title = Constructive Cryptography in HOL: the Communication Modeling Aspect
	author = Andreas Lochbihler <http://www.andreas-lochbihler.de>, S. Reza Sefidgar <>
	topic = Computer science/Security/Cryptography, Mathematics/Probability theory
	date = 2021-03-17
	notify = mail@andreas-lochbihler.de, reza.sefidgar@inf.ethz.ch
	abstract =
	Constructive Cryptography (CC) [<a
	href="https://conference.iiis.tsinghua.edu.cn/ICS2011/content/papers/14.html">ICS
	2011</a>, <a
	href="https://doi.org/10.1007/978-3-642-27375-9_3">TOSCA
	2011</a>, <a
	href="https://doi.org/10.1007/978-3-662-53641-4_1">TCC
	2016</a>] introduces an abstract approach to composable security
	statements that allows one to focus on a particular aspect of security
	proofs at a time. Instead of proving the properties of concrete
	systems, CC studies system classes, i.e., the shared behavior of
	similar systems, and their transformations. Modeling of systems
	communication plays a crucial role in composability and reusability of
	security statements; yet, this aspect has not been studied in any of
	the existing CC results. We extend our previous CC formalization
	[<a href="https://isa-afp.org/entries/Constructive_Cryptography.html">Constructive_Cryptography</a>,
	<a href="https://doi.org/10.1109/CSF.2019.00018">CSF
	2019</a>] with a new semantic domain called Fused Resource
	Templates (FRT) that abstracts over the systems communication patterns
	in CC proofs. This widens the scope of cryptography proof
	formalizations in the CryptHOL library [<a
	href="https://isa-afp.org/entries/CryptHOL.html">CryptHOL</a>,
	<a
	href="https://doi.org/10.1007/978-3-662-49498-1_20">ESOP
	2016</a>, <a
	href="https://doi.org/10.1007/s00145-019-09341-z">J
	Cryptol 2020</a>]. This formalization is described in <a
	href="http://www.andreas-lochbihler.de/pub/basin2021.pdf">Abstract
	Modeling of Systems Communication in Constructive Cryptography using
	CryptHOL</a>.

	[IFC_Tracking]
	title = Information Flow Control via Dependency Tracking
	author = Benedikt Nordhoff <mailto:b.n@wwu.de>
	topic = Computer science/Security
	date = 2021-04-01
	notify = b.n@wwu.de
	abstract =
	We provide a characterisation of how information is propagated by
	program executions based on the tracking data and control dependencies
	within executions themselves. The characterisation might be used for
	deriving approximative safety properties to be targeted by static
	analyses or checked at runtime. We utilise a simple yet versatile
	control flow graph model as a program representation. As our model is
	not assumed to be finite it can be instantiated for a broad class of
	programs. The targeted security property is indistinguishable
	security where executions produce sequences of observations and only
	non-terminating executions are allowed to drop a tail of those. A
	very crude approximation of our characterisation is slicing based on
	program dependence graphs, which we use as a minimal example and
	derive a corresponding soundness result. For further details and
	applications refer to the authors upcoming dissertation.

	[Grothendieck_Schemes]
	title = Grothendieck's Schemes in Algebraic Geometry
	author = Anthony Bordg <https://sites.google.com/site/anthonybordg/>, Lawrence Paulson <https://www.cl.cam.ac.uk/~lp15/>, Wenda Li <https://www.cl.cam.ac.uk/~wl302/>
	topic = Mathematics/Algebra, Mathematics/Geometry
	date = 2021-03-29
	notify = apdb3@cam.ac.uk, lp15@cam.ac.uk
	abstract =
	We formalize mainstream structures in algebraic geometry culminating
	in Grothendieck's schemes: presheaves of rings, sheaves of rings,
	ringed spaces, locally ringed spaces, affine schemes and schemes. We
	prove that the spectrum of a ring is a locally ringed space, hence an
	affine scheme. Finally, we prove that any affine scheme is a scheme.

	[Progress_Tracking]
	title = Formalization of Timely Dataflow's Progress Tracking Protocol
	author = Matthias Brun<>, Sára Decova<>, Andrea Lattuada<https://andrea.lattuada.me>, Dmitriy Traytel <https://traytel.bitbucket.io/>
	topic = Computer science/Algorithms/Distributed
	date = 2021-04-13
	notify = matthias.brun@inf.ethz.ch, traytel@di.ku.dk
	abstract =
	Large-scale stream processing systems often follow the dataflow
	paradigm, which enforces a program structure that exposes a high
	degree of parallelism. The Timely Dataflow distributed system supports
	expressive cyclic dataflows for which it offers low-latency data- and
	pipeline-parallel stream processing. To achieve high expressiveness
	and performance, Timely Dataflow uses an intricate distributed
	protocol for tracking the computation’s progress. We formalize this
	progress tracking protocol and verify its safety. Our formalization is
	described in detail in our forthcoming <a
	href="https://traytel.bitbucket.io/papers/itp21-progress_tracking/safe.pdf">ITP'21
	paper</a>.

	[GaleStewart_Games]
	title = Gale-Stewart Games
	author = Sebastiaan Joosten <https://sjcjoosten.nl>
	topic = Mathematics/Games and economics
	date = 2021-04-23
	notify = sjcjoosten@gmail.com
	abstract =
	This is a formalisation of the main result of Gale and Stewart from
	1953, showing that closed finite games are determined. This property
	is now known as the Gale Stewart Theorem. While the original paper
	shows some additional theorems as well, we only formalize this main
	result, but do so in a somewhat general way. We formalize games of a
	fixed arbitrary length, including infinite length, using co-inductive
	lists, and show that defensive strategies exist unless the other
	player is winning. For closed games, defensive strategies are winning
	for the closed player, proving that such games are determined. For
	finite games, which are a special case in our formalisation, all games
	are closed.

	[Metalogic_ProofChecker]
	title = Isabelle's Metalogic: Formalization and Proof Checker
	author = Tobias Nipkow <http://www21.in.tum.de/~nipkow>, Simon Roßkopf <http://www21.in.tum.de/~rosskops>
	topic = Logic/General logic
	date = 2021-04-27
	notify = rosskops@in.tum.de
	abstract =
	In this entry we formalize Isabelle's metalogic in Isabelle/HOL.
	Furthermore, we define a language of proof terms and an executable
	proof checker and prove its soundness wrt. the metalogic. The
	formalization is intentionally kept close to the Isabelle
	implementation(for example using de Brujin indices) to enable easy
	integration of generated code with the Isabelle system without a
	complicated translation layer. The formalization is described in our
	<a href="https://arxiv.org/pdf/2104.12224.pdf">CADE 28 paper</a>.

	[Regression_Test_Selection]
	title = Regression Test Selection
	author = Susannah Mansky <mailto:sjohnsn2@illinois.edu>
	topic = Computer science/Algorithms
	date = 2021-04-30
	notify = sjohnsn2@illinois.edu, susannahej@gmail.com
	abstract =
	This development provides a general definition for safe Regression
	Test Selection (RTS) algorithms. RTS algorithms select which tests to
	rerun on revised code, reducing the time required to check for newly
	introduced errors. An RTS algorithm is considered safe if and only if
	all deselected tests would have unchanged results. This definition is
	instantiated with two class-collection-based RTS algorithms run over
	the JVM as modeled by JinjaDCI. This is achieved with a general
	definition for Collection Semantics, small-step semantics instrumented
	to collect information during execution. As the RTS definition
	mandates safety, these instantiations include proofs of safety. This
	work is described in Mansky and Gunter's LSFA 2020 paper and
	Mansky's doctoral thesis (UIUC, 2020).

	[Padic_Ints]
	title = Hensel's Lemma for the p-adic Integers
	author = Aaron Crighton <mailto:crightoa@mcmaster.ca>
	topic = Mathematics/Number theory
	date = 2021-03-23
	notify = crightoa@mcmaster.ca
	abstract =
	We formalize the ring of <em>p</em>-adic integers within the framework of the
	HOL-Algebra library. The carrier of the ring is formalized as the
	inverse limit of quotients of the integers by powers of a fixed prime
	<em>p</em>. We define an integer-valued valuation, as well as an
	extended-integer valued valuation which sends 0 to the infinite
	element. Basic topological facts about the <em>p</em>-adic integers are
	formalized, including completeness and sequential compactness. Taylor
	expansions of polynomials over a commutative ring are defined,
	culminating in the formalization of Hensel's Lemma based on a
	proof due to Keith Conrad.

	[Combinatorics_Words]
	title = Combinatorics on Words Basics
	author = Štěpán Holub <https://www2.karlin.mff.cuni.cz/~holub/>, Martin Raška<>, Štěpán Starosta <https://users.fit.cvut.cz/~staroste/>
	topic = Computer science/Automata and formal languages
	date = 2021-05-24
	notify = holub@karlin.mff.cuni.cz, stepan.starosta@fit.cvut.cz
	abstract =
	We formalize basics of Combinatorics on Words. This is an extension of
	existing theories on lists. We provide additional properties related
	to prefix, suffix, factor, length and rotation. The topics include
	prefix and suffix comparability, mismatch, word power, total and
	reversed morphisms, border, periods, primitivity and roots. We also
	formalize basic, mostly folklore results related to word equations:
	equidivisibility, commutation and conjugation. Slightly advanced
	properties include the Periodicity lemma (often cited as the Fine and
	Wilf theorem) and the variant of the Lyndon-Schützenberger theorem for
	words. We support the algebraic point of view which sees words as
	generators of submonoids of a free monoid. This leads to the concepts
	of the (free) hull, the (free) basis (or code).

	[Combinatorics_Words_Lyndon]
	title = Lyndon words
	author = Štěpán Holub <https://www2.karlin.mff.cuni.cz/~holub/>, Štěpán Starosta <https://users.fit.cvut.cz/~staroste/>
	topic = Computer science/Automata and formal languages
	date = 2021-05-24
	notify = holub@karlin.mff.cuni.cz, stepan.starosta@fit.cvut.cz
	abstract =
	Lyndon words are words lexicographically minimal in their conjugacy
	class. We formalize their basic properties and characterizations, in
	particular the concepts of the longest Lyndon suffix and the Lyndon
	factorization. Most of the work assumes a fixed lexicographical order.
	Nevertheless we also define the smallest relation guaranteeing
	lexicographical minimality of a given word (in its conjugacy class).

	[Combinatorics_Words_Graph_Lemma]
	title = Graph Lemma
	author = Štěpán Holub <https://www2.karlin.mff.cuni.cz/~holub/>, Štěpán Starosta <https://users.fit.cvut.cz/~staroste/>
	topic = Computer science/Automata and formal languages
	date = 2021-05-24
	notify = holub@karlin.mff.cuni.cz, stepan.starosta@fit.cvut.cz
	abstract =
	Graph lemma quantifies the defect effect of a system of word
	equations. That is, it provides an upper bound on the rank of the
	system. We formalize the proof based on the decomposition of a
	solution into its free basis. A direct application is an alternative
	proof of the fact that two noncommuting words form a code.

	[Lifting_the_Exponent]
	title = Lifting the Exponent
	author = Jakub Kądziołka <mailto:kuba@kadziolka.net>
	topic = Mathematics/Number theory
	date = 2021-04-27
	notify = kuba@kadziolka.net
	abstract =
	We formalize the <i>Lifting the Exponent Lemma</i>, which
	shows how to find the largest power of $p$ dividing $a^n \pm b^n$, for
	a prime $p$ and positive integers $a$ and $b$. The proof follows <a
	href="https://s3.amazonaws.com/aops-cdn.artofproblemsolving.com/resources/articles/lifting-the-exponent.pdf">Amir Hossein Parvardi's</a>.

	[IMP_Compiler]
	title = A Shorter Compiler Correctness Proof for Language IMP
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	topic = Computer science/Programming languages/Compiling
	date = 2021-06-04
	notify = pasquale.noce.lavoro@gmail.com
	abstract =
	This paper presents a compiler correctness proof for the didactic
	imperative programming language IMP, introduced in Nipkow and
	Klein's book on formal programming language semantics (version of
	March 2021), whose size is just two thirds of the book's proof in
	the number of formal text lines. As such, it promises to constitute a
	further enhanced reference for the formal verification of compilers
	meant for larger, real-world programming languages. The presented
	proof does not depend on language determinism, so that the proposed
	approach can be applied to non-deterministic languages as well. As a
	confirmation, this paper extends IMP with an additional
	non-deterministic choice command, and proves compiler correctness,
	viz. the simulation of compiled code execution by source code, for
	such extended language.

	[Public_Announcement_Logic]
	title = Public Announcement Logic
	author = Asta Halkjær From <https://people.compute.dtu.dk/ahfrom/>
	topic = Logic/General logic/Logics of knowledge and belief
	date = 2021-06-17
	notify = ahfrom@dtu.dk
	abstract =
	This work is a formalization of public announcement logic with
	countably many agents. It includes proofs of soundness and
	completeness for a variant of the axiom system PA + DIST! + NEC!. The
	completeness proof builds on the Epistemic Logic theory.
	Paper: <a href="https://doi.org/10.1007/978-3-030-90138-7_2">https://doi.org/10.1007/978-3-030-90138-7_2</a>.

	[MiniSail]
	title = MiniSail - A kernel language for the ISA specification language SAIL
	author = Mark Wassell <mailto:mpwassell@gmail.com>
	topic = Computer science/Programming languages/Type systems
	date = 2021-06-18
	notify = mpwassell@gmail.com
	abstract =
	MiniSail is a kernel language for Sail, an instruction set
	architecture (ISA) specification language. Sail is an imperative
	language with a light-weight dependent type system similar to
	refinement type systems. From an ISA specification, the Sail compiler
	can generate theorem prover code and C (or OCaml) to give an
	executable emulator for an architecture. The idea behind MiniSail is
	to capture the key and novel features of Sail in terms of their
	syntax, typing rules and operational semantics, and to confirm that
	they work together by proving progress and preservation lemmas. We use
	the Nominal2 library to handle binding.

	[SpecCheck]
	title = SpecCheck - Specification-Based Testing for Isabelle/ML
	author = Kevin Kappelmann <https://www21.in.tum.de/team/kappelmk/>, Lukas Bulwahn <mailto:lukas.bulwahn@gmail.com>, Sebastian Willenbrink <mailto:sebastian.willenbrink@tum.de>
	topic = Tools
	date = 2021-07-01
	notify = kevin.kappelmann@tum.de
	abstract =
	SpecCheck is a <a
	href="https://en.wikipedia.org/wiki/QuickCheck">QuickCheck</a>-like
	testing framework for Isabelle/ML. You can use it to write
	specifications for ML functions. SpecCheck then checks whether your
	specification holds by testing your function against a given number of
	generated inputs. It helps you to identify bugs by printing
	counterexamples on failure and provides you timing information.
	SpecCheck is customisable and allows you to specify your own input
	generators, test output formats, as well as pretty printers and
	shrinking functions for counterexamples among other things.

	[Relational_Forests]
	title = Relational Forests
	author = Walter Guttmann <https://www.cosc.canterbury.ac.nz/walter.guttmann/>
	topic = Mathematics/Graph theory
	date = 2021-08-03
	notify = walter.guttmann@canterbury.ac.nz
	abstract =
	We study second-order formalisations of graph properties expressed as
	first-order formulas in relation algebras extended with a Kleene star.
	The formulas quantify over relations while still avoiding
	quantification over elements of the base set. We formalise the
	property of undirected graphs being acyclic this way. This involves a
	study of various kinds of orientation of graphs. We also verify basic
	algorithms to constructively prove several second-order properties.

	[Fresh_Identifiers]
	title = Fresh identifiers
	author = Andrei Popescu <https://www.andreipopescu.uk>, Thomas Bauereiss <mailto:thomas@bauereiss.name>
	topic = Computer science/Data structures
	date = 2021-08-16
	notify = thomas@bauereiss.name, a.popescu@sheffield.ac.uk
	abstract =
	This entry defines a type class with an operator returning a fresh
	identifier, given a set of already used identifiers and a preferred
	identifier. The entry provides a default instantiation for any
	infinite type, as well as executable instantiations for natural
	numbers and strings.

	[CoCon]
	title = CoCon: A Confidentiality-Verified Conference Management System
	author = Andrei Popescu <https://www.andreipopescu.uk>, Peter Lammich <mailto:lammich@in.tum.de>, Thomas Bauereiss <mailto:thomas@bauereiss.name>
	topic = Computer science/Security
	date = 2021-08-16
	notify = thomas@bauereiss.name, a.popescu@sheffield.ac.uk
	abstract =
	This entry contains the confidentiality verification of the
	(functional kernel of) the CoCon conference management system [<a
	href="https://doi.org/10.1007/978-3-319-08867-9_11">1</a>,
	<a href="https://doi.org/10.1007/s10817-020-09566-9">2</a>].
	The confidentiality properties refer to the documents managed by the
	system, namely papers, reviews, discussion logs and
	acceptance/rejection decisions, and also to the assignment of
	reviewers to papers. They have all been formulated as instances of BD
	Security [<a href="https://doi.org/10.4230/LIPIcs.ITP.2021.3">3</a>,
	<a href="https://www.isa-afp.org/entries/Bounded_Deducibility_Security.html">4</a>]
	and verified using the BD Security unwinding technique.

	[BD_Security_Compositional]
	title = Compositional BD Security
	author = Thomas Bauereiss <mailto:thomas@bauereiss.name>, Andrei Popescu <https://www.andreipopescu.uk>
	topic = Computer science/Security
	date = 2021-08-16
	notify = thomas@bauereiss.name, a.popescu@sheffield.ac.uk
	abstract =
	Building on a previous <a
	href="https://www.isa-afp.org/entries/Bounded_Deducibility_Security.html">AFP
	entry</a> that formalizes the Bounded-Deducibility Security (BD
	Security) framework <a href="https://doi.org/10.4230/LIPIcs.ITP.2021.3">[1]</a>,
	we formalize compositionality and transport theorems for information
	flow security. These results allow lifting BD Security properties from
	individual components specified as transition systems, to a
	composition of systems specified as communicating products of
	transition systems. The underlying ideas of these results are
	presented in the papers <a href="https://doi.org/10.4230/LIPIcs.ITP.2021.3">[1]</a>
	and <a href="https://doi.org/10.1109/SP.2017.24">[2]</a>.
	The latter paper also describes a major case study where these results
	have been used: on verifying the CoSMeDis distributed social media
	platform (itself formalized as an <a
	href="https://www.isa-afp.org/entries/CoSMeDis.html">AFP
	entry</a> that builds on this entry).

	[CoSMed]
	title = CoSMed: A confidentiality-verified social media platform
	author = Thomas Bauereiss <mailto:thomas@bauereiss.name>, Andrei Popescu <https://www.andreipopescu.uk>
	topic = Computer science/Security
	date = 2021-08-16
	notify = thomas@bauereiss.name, a.popescu@sheffield.ac.uk
	abstract =
	This entry contains the confidentiality verification of the
	(functional kernel of) the CoSMed social media platform. The
	confidentiality properties are formalized as instances of BD Security
	[<a href="https://doi.org/10.4230/LIPIcs.ITP.2021.3">1</a>,
	<a href="https://www.isa-afp.org/entries/Bounded_Deducibility_Security.html">2</a>].
	An innovation in the deployment of BD Security compared to previous
	work is the use of dynamic declassification triggers, incorporated as
	part of inductive bounds, for providing stronger guarantees that
	account for the repeated opening and closing of access windows. To
	further strengthen the confidentiality guarantees, we also prove
	"traceback" properties about the accessibility decisions
	affecting the information managed by the system.

	[CoSMeDis]
	title = CoSMeDis: A confidentiality-verified distributed social media platform
	author = Thomas Bauereiss <mailto:thomas@bauereiss.name>, Andrei Popescu <https://www.andreipopescu.uk>
	topic = Computer science/Security
	date = 2021-08-16
	notify = thomas@bauereiss.name, a.popescu@sheffield.ac.uk
	abstract =
	This entry contains the confidentiality verification of the
	(functional kernel of) the CoSMeDis distributed social media platform
	presented in [<a href="https://doi.org/10.1109/SP.2017.24">1</a>].
	CoSMeDis is a multi-node extension the CoSMed prototype social media
	platform [<a href="https://doi.org/10.1007/978-3-319-43144-4_6">2</a>,
	<a href="https://doi.org/10.1007/s10817-017-9443-3">3</a>,
	<a href="https://www.isa-afp.org/entries/CoSMed.html">4</a>].
	The confidentiality properties are formalized as instances of BD
	Security [<a href="https://doi.org/10.4230/LIPIcs.ITP.2021.3">5</a>,
	<a href="https://www.isa-afp.org/entries/Bounded_Deducibility_Security.html">6</a>].
	The lifting of confidentiality properties from single nodes to the
	entire CoSMeDis network is performed using compositionality and
	transport theorems for BD Security, which are described in [<a
	href="https://doi.org/10.1109/SP.2017.24">1</a>]
	and formalized in a separate <a
	href="https://www.isa-afp.org/entries/BD_Security_Compositional.html">AFP
	entry</a>.

	[Three_Circles]
	title = The Theorem of Three Circles
	author = Fox Thomson <mailto:foxthomson0@gmail.com>, Wenda Li <https://www.cl.cam.ac.uk/~wl302/>
	topic = Mathematics/Analysis
	date = 2021-08-21
	notify = foxthomson0@gmail.com, wl302@cam.ac.uk
	abstract =
	The Descartes test based on Bernstein coefficients and Descartes’ rule
	of signs effectively (over-)approximates the number of real roots of a
	univariate polynomial over an interval. In this entry we formalise the
	theorem of three circles, which gives sufficient conditions for when
	the Descartes test returns 0 or 1. This is the first step for
	efficient root isolation.

	[Design_Theory]
	title = Combinatorial Design Theory
	author = Chelsea Edmonds <https://www.cst.cam.ac.uk/people/cle47>, Lawrence Paulson <https://www.cl.cam.ac.uk/~lp15/>
	topic = Mathematics/Combinatorics
	date = 2021-08-13
	notify = cle47@cam.ac.uk
	abstract =
	Combinatorial design theory studies incidence set systems with certain
	balance and symmetry properties. It is closely related to hypergraph
	theory. This formalisation presents a general library for formal
	reasoning on incidence set systems, designs and their applications,
	including formal definitions and proofs for many key properties,
	operations, and theorems on the construction and existence of designs.
	Notably, this includes formalising t-designs, balanced incomplete
	block designs (BIBD), group divisible designs (GDD), pairwise balanced
	designs (PBD), design isomorphisms, and the relationship between
	graphs and designs. A locale-centric approach has been used to manage
	the relationships between the many different types of designs.
	Theorems of particular interest include the necessary conditions for
	existence of a BIBD, Wilson's construction on GDDs, and
	Bose's inequality on resolvable designs. Parts of this
	formalisation are explored in the paper "A Modular First
	Formalisation of Combinatorial Design Theory", presented at CICM 2021.

	[Logging_Independent_Anonymity]
	title = Logging-independent Message Anonymity in the Relational Method
	author = Pasquale Noce <mailto:pasquale.noce.lavoro@gmail.com>
	topic = Computer science/Security
	date = 2021-08-26
	notify = pasquale.noce.lavoro@gmail.com
	abstract =
	In the context of formal cryptographic protocol verification,
	logging-independent message anonymity is the property for a given
	message to remain anonymous despite the attacker's capability of
	mapping messages of that sort to agents based on some intrinsic
	feature of such messages, rather than by logging the messages
	exchanged by legitimate agents as with logging-dependent message
	anonymity.

	This paper illustrates how logging-independent message
	anonymity can be formalized according to the relational method for
	formal protocol verification by considering a real-world protocol,
	namely the Restricted Identification one by the BSI. This sample model
	is used to verify that the pseudonymous identifiers output by user
	identification tokens remain anonymous under the expected conditions.

	[Dominance_CHK]
	title = A data flow analysis algorithm for computing dominators
	author = Nan Jiang<>
	topic = Computer science/Programming languages/Static analysis
	date = 2021-09-05
	notify = nanjiang@whu.edu.cn
	abstract =
	This entry formalises the fast iterative algorithm for computing dominators
	due to Cooper, Harvey and Kennedy. It gives a specification of computing
	dominators on a control
	flow graph where each node refers to its reverse post order number. A
	semilattice of reversed-ordered list which represents dominators is
	built and a Kildall-style algorithm on the semilattice is defined for
	computing dominators. Finally the soundness and completeness of the
	algorithm are proved w.r.t. the specification.

	[Conditional_Simplification]
	title = Conditional Simplification
	author = Mihails Milehins <mailto:user9716869@gmail.com>
	topic = Tools
	date = 2021-09-06
	notify = mihailsmilehins@gmail.com
	abstract =
	The article provides a collection of experimental general-purpose
	proof methods for the object logic Isabelle/HOL of the formal proof
	assistant Isabelle. The methods in the collection offer functionality
	that is similar to certain aspects of the functionality provided by
	the standard proof methods of Isabelle that combine classical
	reasoning and rewriting, such as the method <i>auto</i>,
	but use a different approach for rewriting. More specifically, these
	methods allow for the side conditions of the rewrite rules to be
	solved via intro-resolution.

	[Intro_Dest_Elim]
	title = IDE: Introduction, Destruction, Elimination
	author = Mihails Milehins <mailto:user9716869@gmail.com>
	topic = Tools
	date = 2021-09-06
	notify = mihailsmilehins@gmail.com
	abstract =
	The article provides the command <b>mk_ide</b> for the
	object logic Isabelle/HOL of the formal proof assistant Isabelle. The
	command <b>mk_ide</b> enables the automated synthesis of
	the introduction, destruction and elimination rules from arbitrary
	definitions of constant predicates stated in Isabelle/HOL.

	[CZH_Foundations]
	title = Category Theory for ZFC in HOL I: Foundations: Design Patterns, Set Theory, Digraphs, Semicategories
	author = Mihails Milehins <mailto:user9716869@gmail.com>
	topic = Mathematics/Category theory, Logic/Set theory
	date = 2021-09-06
	notify = mihailsmilehins@gmail.com
	abstract =
	This article provides a foundational framework for the formalization
	of category theory in the object logic ZFC in HOL of the formal proof
	assistant Isabelle. More specifically, this article provides a
	formalization of canonical set-theoretic constructions internalized in
	the type <i>V</i> associated with the ZFC in HOL,
	establishes a design pattern for the formalization of mathematical
	structures using sequences and locales, and showcases the developed
	infrastructure by providing formalizations of the elementary theories
	of digraphs and semicategories. The methodology chosen for the
	formalization of the theories of digraphs and semicategories (and
	categories in future articles) rests on the ideas that were originally
	expressed in the article <i>Set-Theoretical Foundations of
	Category Theory</i> written by Solomon Feferman and Georg
	Kreisel. Thus, in the context of this work, each of the aforementioned
	mathematical structures is represented as a term of the type
	<i>V</i> embedded into a stage of the von Neumann
	hierarchy.

	[CZH_Elementary_Categories]
	title = Category Theory for ZFC in HOL II: Elementary Theory of 1-Categories
	author = Mihails Milehins <mailto:user9716869@gmail.com>
	topic = Mathematics/Category theory
	date = 2021-09-06
	notify = mihailsmilehins@gmail.com
	abstract =
	This article provides a formalization of the foundations of the theory
	of 1-categories in the object logic ZFC in HOL of the formal proof
	assistant Isabelle. The article builds upon the foundations that were
	established in the AFP entry <i>Category Theory for ZFC in HOL
	I: Foundations: Design Patterns, Set Theory, Digraphs,
	Semicategories</i>.

	[CZH_Universal_Constructions]
	title = Category Theory for ZFC in HOL III: Universal Constructions
	author = Mihails Milehins <mailto:user9716869@gmail.com>
	topic = Mathematics/Category theory
	date = 2021-09-06
	notify = mihailsmilehins@gmail.com
	abstract =
	The article provides a formalization of elements of the theory of
	universal constructions for 1-categories (such as limits, adjoints and
	Kan extensions) in the object logic ZFC in HOL of the formal proof
	assistant Isabelle. The article builds upon the foundations
	established in the AFP entry <i>Category Theory for ZFC in HOL
	II: Elementary Theory of 1-Categories</i>.

	[Conditional_Transfer_Rule]
	title = Conditional Transfer Rule
	author = Mihails Milehins <mailto:user9716869@gmail.com>
	topic = Tools
	date = 2021-09-06
	notify = mihailsmilehins@gmail.com
	abstract =
	This article provides a collection of experimental utilities for
	unoverloading of definitions and synthesis of conditional transfer
	rules for the object logic Isabelle/HOL of the formal proof assistant
	Isabelle written in Isabelle/ML.

	[Types_To_Sets_Extension]
	title = Extension of Types-To-Sets
	author = Mihails Milehins <mailto:user9716869@gmail.com>
	topic = Tools
	date = 2021-09-06
	notify = mihailsmilehins@gmail.com
	abstract =
	In their article titled <i>From Types to Sets by Local Type
	Definitions in Higher-Order Logic</i> and published in the
	proceedings of the conference <i>Interactive Theorem
	Proving</i> in 2016, Ondřej Kunčar and Andrei Popescu propose an
	extension of the logic Isabelle/HOL and an associated algorithm for
	the relativization of the <i>type-based theorems</i> to
	more flexible <i>set-based theorems</i>, collectively
	referred to as <i>Types-To-Sets</i>. One of the aims of
	their work was to open an opportunity for the development of a
	software tool for applied relativization in the implementation of the
	logic Isabelle/HOL of the proof assistant Isabelle. In this article,
	we provide a prototype of a software framework for the interactive
	automated relativization of theorems in Isabelle/HOL, developed as an
	extension of the proof language Isabelle/Isar. The software framework
	incorporates the implementation of the proposed extension of the
	logic, and builds upon some of the ideas for further work expressed in
	the original article on Types-To-Sets by Ondřej Kunčar and Andrei
	Popescu and the subsequent article <i>Smooth Manifolds and Types
	to Sets for Linear Algebra in Isabelle/HOL</i> that was written
	by Fabian Immler and Bohua Zhan and published in the proceedings of
	the <i>International Conference on Certified Programs and
	Proofs</i> in 2019.

	[Complex_Bounded_Operators]
	title = Complex Bounded Operators
	author = Jose Manuel Rodriguez Caballero <https://josephcmac.github.io/>, Dominique Unruh <https://www.ut.ee/~unruh/>
	topic = Mathematics/Analysis
	date = 2021-09-18
	notify = unruh@ut.ee
	abstract =
	We present a formalization of bounded operators on complex vector
	spaces. Our formalization contains material on complex vector spaces
	(normed spaces, Banach spaces, Hilbert spaces) that complements and
	goes beyond the developments of real vectors spaces in the
	Isabelle/HOL standard library. We define the type of bounded
	operators between complex vector spaces
	(<em>cblinfun</em>) and develop the theory of unitaries,
	projectors, extension of bounded linear functions (BLT theorem),
	adjoints, Loewner order, closed subspaces and more. For the
	finite-dimensional case, we provide code generation support by
	identifying finite-dimensional operators with matrices as formalized
	in the <a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a> AFP entry.

	[Weighted_Path_Order]
	title = A Formalization of Weighted Path Orders and Recursive Path Orders
	author = Christian Sternagel <mailto:c.sternagel@gmail.com>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>, Akihisa Yamada <mailto:akihisa.yamada@aist.go.jp>
	topic = Logic/Rewriting
	date = 2021-09-16
	notify = rene.thiemann@uibk.ac.at
	abstract =
	We define the weighted path order (WPO) and formalize several
	properties such as strong normalization, the subterm property, and
	closure properties under substitutions and contexts. Our definition of
	WPO extends the original definition by also permitting multiset
	comparisons of arguments instead of just lexicographic extensions.
	Therefore, our WPO not only subsumes lexicographic path orders (LPO),
	but also recursive path orders (RPO). We formally prove these
	subsumptions and therefore all of the mentioned properties of WPO are
	automatically transferable to LPO and RPO as well. Such a
	transformation is not required for Knuth–Bendix orders
	(KBO), since they have already been formalized. Nevertheless, we still
	provide a proof that WPO subsumes KBO and thereby underline the
	generality of WPO.

	[FOL_Axiomatic]
	title = Soundness and Completeness of an Axiomatic System for First-Order Logic
	author = Asta Halkjær From <https://people.compute.dtu.dk/ahfrom/>
	topic = Logic/General logic/Classical first-order logic, Logic/Proof theory
	date = 2021-09-24
	notify = ahfrom@dtu.dk
	abstract =
	This work is a formalization of the soundness and completeness of an
	axiomatic system for first-order logic. The proof system is based on
	System Q1 by Smullyan and the completeness proof follows his textbook
	"First-Order Logic" (Springer-Verlag 1968). The completeness
	proof is in the Henkin style where a consistent set is extended to a
	maximal consistent set using Lindenbaum's construction and Henkin
	witnesses are added during the construction to ensure saturation as
	well. The resulting set is a Hintikka set which, by the model
	existence theorem, is satisfiable in the Herbrand universe.


	[Virtual_Substitution]
	title = Verified Quadratic Virtual Substitution for Real Arithmetic
	author = Matias Scharager <mailto:mscharag@cs.cmu.edu>, Katherine Cordwell <mailto:kcordwel@cs.cmu.edu>, Stefan Mitsch <mailto:smitsch@cs.cmu.edu>, André Platzer <mailto:aplatzer@cs.cmu.edu>
	topic = Computer science/Algorithms/Mathematical
	date = 2021-10-02
	notify = mscharag@cs.cmu.edu, kcordwel@cs.cmu.edu, smitsch@cs.cmu.edu, aplatzer@cs.cmu.edu
	abstract =
	This paper presents a formally verified quantifier elimination (QE)
	algorithm for first-order real arithmetic by linear and quadratic
	virtual substitution (VS) in Isabelle/HOL. The Tarski-Seidenberg
	theorem established that the first-order logic of real arithmetic is
	decidable by QE. However, in practice, QE algorithms are highly
	complicated and often combine multiple methods for performance. VS is
	a practically successful method for QE that targets formulas with
	low-degree polynomials. To our knowledge, this is the first work to
	formalize VS for quadratic real arithmetic including inequalities. The
	proofs necessitate various contributions to the existing multivariate
	polynomial libraries in Isabelle/HOL. Our framework is modularized and
	easily expandable (to facilitate integrating future optimizations),
	and could serve as a basis for developing practical general-purpose QE
	algorithms. Further, as our formalization is designed with
	practicality in mind, we export our development to SML and test the
	resulting code on 378 benchmarks from the literature, comparing to
	Redlog, Z3, Wolfram Engine, and SMT-RAT. This identified
	inconsistencies in some tools, underscoring the significance of a
	verified approach for the intricacies of real arithmetic.

	[Correctness_Algebras]
	title = Algebras for Iteration, Infinite Executions and Correctness of Sequential Computations
	author = Walter Guttmann <https://www.cosc.canterbury.ac.nz/walter.guttmann/>
	topic = Computer science/Programming languages/Logics
	date = 2021-10-12
	notify = walter.guttmann@canterbury.ac.nz
	abstract =
	We study models of state-based non-deterministic sequential
	computations and describe them using algebras. We propose algebras
	that describe iteration for strict and non-strict computations. They
	unify computation models which differ in the fixpoints used to
	represent iteration. We propose algebras that describe the infinite
	executions of a computation. They lead to a unified approximation
	order and results that connect fixpoints in the approximation and
	refinement orders. This unifies the semantics of recursion for a range
	of computation models. We propose algebras that describe preconditions
	and the effect of while-programs under postconditions. They unify
	correctness statements in two dimensions: one statement applies in
	various computation models to various correctness claims.

	[Belief_Revision]
	title = Belief Revision Theory
	author = Valentin Fouillard <mailto:valentin.fouillard@limsi.fr>, Safouan Taha <mailto:safouan.taha@lri.fr>, Frédéric Boulanger <mailto:frederic.boulanger@centralesupelec.fr>, Nicolas Sabouret <>
	topic = Logic/General logic/Logics of knowledge and belief
	date = 2021-10-19
	notify = safouan.taha@lri.fr, valentin.fouillard@limsi.fr
	abstract =
	The 1985 paper by Carlos Alchourrón, Peter Gärdenfors, and David
	Makinson (AGM), “On the Logic of Theory Change: Partial Meet
	Contraction and Revision Functions” launches a large and rapidly
	growing literature that employs formal models and logics to handle
	changing beliefs of a rational agent and to take into account new
	piece of information observed by this agent. In 2011, a review book
	titled "AGM 25 Years: Twenty-Five Years of Research in Belief
	Change" was edited to summarize the first twenty five years of
	works based on AGM. This HOL-based AFP entry is a faithful
	formalization of the AGM operators (e.g. contraction, revision,
	remainder ...) axiomatized in the original paper. It also contains the
	proofs of all the theorems stated in the paper that show how these
	operators combine. Both proofs of Harper and Levi identities are
	established.

	[X86_Semantics]
	title = X86 instruction semantics and basic block symbolic execution
	author = Freek Verbeek <mailto:freek@vt.edu>, Abhijith Bharadwaj <>, Joshua Bockenek <>, Ian Roessle <>, Timmy Weerwag <>, Binoy Ravindran <>
	topic = Computer science/Hardware, Computer science/Semantics
	date = 2021-10-13
	notify = freek@vt.edu
	abstract =
	This AFP entry provides semantics for roughly 120 different X86-64
	assembly instructions. These instructions include various moves,
	arithmetic/logical operations, jumps, call/return, SIMD extensions and
	others. External functions are supported by allowing a user to provide
	custom semantics for these calls. Floating-point operations are mapped
	to uninterpreted functions. The model provides semantics for register
	aliasing and a byte-level little-endian memory model. The semantics
	are purposefully incomplete, but overapproximative. For example, the
	precise effect of flags may be undefined for certain instructions, or
	instructions may simply have no semantics at all. In those cases, the
	semantics are mapped to universally quantified uninterpreted terms
	from a locale. Second, this entry provides a method to symbolic
	execution of basic blocks. The method, called
	''se_step'' (for: symbolic execution step) fetches
	an instruction and updates the current symbolic state while keeping
	track of assumptions made over the memory model. A key component is a
	set of theorems that prove how reads from memory resolve after writes
	have occurred. Thirdly, this entry provides a parser that allows the
	user to copy-paste the output of the standard disassembly tool objdump
	into Isabelle/HOL. A couple small and explanatory examples are
	included, including functions from the word count program. Several
	examples can be supplied upon request (they are not included due to
	the running time of verification): functions from the floating-point
	modulo function from FDLIBM, the GLIBC strlen function and the
	CoreUtils SHA256 implementation.

	[Registers]
	title = Quantum and Classical Registers
	author = Dominique Unruh <https://www.ut.ee/~unruh/>
	topic = Computer science/Algorithms/Quantum computing, Computer science/Programming languages/Logics, Computer science/Semantics
	date = 2021-10-28
	notify = unruh@ut.ee
	abstract =
	A formalization of the theory of quantum and classical registers as
	developed by (Unruh, Quantum and Classical Registers). In a nutshell,
	a register refers to a part of a larger memory or system that can be
	accessed independently. Registers can be constructed from other
	registers and several (compatible) registers can be composed. This
	formalization develops both the generic theory of registers as well as
	specific instantiations for classical and quantum registers.

	[Szemeredi_Regularity]
	title = Szemerédi's Regularity Lemma
	author = Chelsea Edmonds <https://www.cst.cam.ac.uk/people/cle47>, Angeliki Koutsoukou-Argyraki <https://www.cst.cam.ac.uk/people/ak2110>, Lawrence C. Paulson <https://www.cl.cam.ac.uk/~lp15/>
	topic = Mathematics/Graph theory, Mathematics/Combinatorics
	date = 2021-11-05
	notify = lp15@cam.ac.uk
	abstract =
	<a
	href="https://en.wikipedia.org/wiki/Szemerédi_regularity_lemma">Szemerédi's
	regularity lemma</a> is a key result in the study of large
	graphs. It asserts the existence of an upper bound on the number of parts
	the vertices of a graph need to be partitioned into such that the
	edges between the parts are random in a certain sense. This bound
	depends only on the desired precision and not on the graph itself, in
	the spirit of Ramsey's theorem. The formalisation follows online
	course notes by <a
	href="https://www.dpmms.cam.ac.uk/~par31/notes/tic.pdf">Tim
	Gowers</a> and <a
	href="https://yufeizhao.com/gtac/gtac.pdf">Yufei
	Zhao</a>.

	[Factor_Algebraic_Polynomial]
	title = Factorization of Polynomials with Algebraic Coefficients
	author = Manuel Eberl <https://pruvisto.org>, René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	topic = Mathematics/Algebra
	date = 2021-11-08
	notify = rene.thiemann@uibk.ac.at
	abstract =
	The AFP already contains a verified implementation of algebraic
	numbers. However, it is has a severe limitation in its factorization
	algorithm of real and complex polynomials: the factorization is only
	guaranteed to succeed if the coefficients of the polynomial are
	rational numbers. In this work, we verify an algorithm to factor all
	real and complex polynomials whose coefficients are algebraic. The
	existence of such an algorithm proves in a constructive way that the
	set of complex algebraic numbers is algebraically closed. Internally,
	the algorithm is based on resultants of multivariate polynomials and
	an approximation algorithm using interval arithmetic.

	[PAL]
	title = Automating Public Announcement Logic and the Wise Men Puzzle in Isabelle/HOL
	author = Christoph Benzmüller <http://christoph-benzmueller.de>, Sebastian Reiche <https://www.linkedin.com/in/sebastian-reiche-0b2093178>
	topic = Logic/General logic/Logics of knowledge and belief
	date = 2021-11-08
	notify = c.benzmueller@gmail.com
	abstract =
	We present a shallow embedding of public announcement logic (PAL) with
	relativized general knowledge in HOL. We then use PAL to obtain an
	elegant encoding of the wise men puzzle, which we solve automatically
	using sledgehammer.

	[SimplifiedOntologicalArgument]
	title = Exploring Simplified Variants of Gödel’s Ontological Argument in Isabelle/HOL
	author = Christoph Benzmüller <http://christoph-benzmueller.de>
	topic = Logic/Philosophical aspects, Logic/General logic/Modal logic
	date = 2021-11-08
	notify = c.benzmueller@gmail.com
	-abstract =
	+abstract =
	<p>Simplified variants of Gödel's ontological argument are
	explored. Among those is a particularly interesting simplified
	argument which is (i) valid already in basic
	modal logics K or KT, (ii) which does not suffer from modal collapse,
	and (iii) which avoids the rather complex predicates of essence (Ess.)
	and necessary existence (NE) as used by Gödel.
	</p><p>
	Whether the presented variants increase or decrease the
	attractiveness and persuasiveness of the ontological argument is a
	question I would like to pass on to philosophy and theology.
	</p>

	[Van_Emde_Boas_Trees]
	title = van Emde Boas Trees
	author = Thomas Ammer<>, Peter Lammich<>
	topic = Computer science/Data structures
	date = 2021-11-23
	notify = lammich@in.tum.de
	-abstract =
	+abstract =
	The <em>van Emde Boas tree</em> or <em>van Emde Boas
	priority queue</em> is a data structure supporting membership
	test, insertion, predecessor and successor search, minimum and maximum
	determination and deletion in <em>O(log log U)</em> time, where <em>U =
	0,...,2<sup>n-1</sup></em> is the overall range to be
	considered. <p/> The presented formalization follows Chapter 20
	of the popular <em>Introduction to Algorithms (3rd
	ed.)</em> by Cormen, Leiserson, Rivest and Stein (CLRS),
	extending the list of formally verified CLRS algorithms. Our current
	formalization is based on the first author's bachelor's
	thesis. <p/> First, we prove correct a
	<em>functional</em> implementation, w.r.t. an abstract
	data type for sets. Apart from functional correctness, we show a
	resource bound, and runtime bounds w.r.t. manually defined timing
	functions for the operations. <p/> Next, we refine the
	operations to Imperative HOL with time, and show correctness and
	complexity. This yields a practically more efficient implementation,
	and eliminates the manually defined timing functions from the trusted
	base of the proof.

	[Hahn_Jordan_Decomposition]
	title = The Hahn and Jordan Decomposition Theorems
	author = Marie Cousin <mailto:marie.cousin@grenoble-inp.org>, Mnacho Echenim <mailto:mnacho.echenim@univ-grenoble-alpes.fr>, Hervé Guiol <mailto:herve.guiol@univ-grenoble-alpes.fr>
	topic = Mathematics/Measure theory
	date = 2021-11-19
	notify = mnacho.echenim@univ-grenoble-alpes.fr
	-abstract =
	+abstract =
	In this work we formalize the Hahn decomposition theorem for signed
	measures, namely that any measure space for a signed measure can be
	decomposed into a positive and a negative set, where every measurable
	subset of the positive one has a positive measure, and every
	measurable subset of the negative one has a negative measure. We also
	formalize the Jordan decomposition theorem as a corollary, which
	states that the signed measure under consideration admits a unique
	decomposition into a difference of two positive measures, at least one
	of which is finite.

	[Simplicial_complexes_and_boolean_functions]
	title = Simplicial Complexes and Boolean functions
	author = Jesús Aransay <https://www.unirioja.es/cu/jearansa>, Alejandro del Campo <mailto:alejandro.del-campo@alum.unirioja.es>, Julius Michaelis <http://liftm.de/>
	topic = Mathematics/Topology
	date = 2021-11-29
	notify = jesus-maria.aransay@unirioja.es
	abstract =
	In this work we formalise the isomorphism between simplicial complexes
	of dimension $n$ and monotone Boolean functions in $n$ variables,
	mainly following the definitions and results as introduced by N. A.
	Scoville. We also take advantage of the AFP
	representation of <a href="https://www.isa-afp.org/entries/ROBDD.html">ROBDD</a>
	(Reduced Ordered Binary Decision Diagrams) to compute the ROBDD representation of a
	given simplicial complex (by means of the isomorphism to Boolean
	functions). Some examples of simplicial complexes and associated
	Boolean functions are also presented.

	[Foundation_of_geometry]
	title = Foundation of geometry in planes, and some complements: Excluding the parallel axioms
	author = Fumiya Iwama <>
	topic = Mathematics/Geometry
	date = 2021-11-22
	notify = d1623001@s.konan-u.ac.jp
	abstract =
	"Foundations of Geometry" is a mathematical book written by
	Hilbert in 1899. This entry is a complete formalization of
	"Incidence" (excluding cubic axioms), "Order" and
	"Congruence" (excluding point sequences) of the axioms
	constructed in this book. In addition, the theorem of the problem
	about the part that is treated implicitly and is not clearly stated in
	it is being carried out in parallel.

	[Regular_Tree_Relations]
	title = Regular Tree Relations
	author = Alexander Lochmann <mailto:alexander.lochmann@uibk.ac.at>, Bertram Felgenhauer<>, Christian Sternagel <http://cl-informatik.uibk.ac.at/users/griff/>, René Thiemann <http://cl-informatik.uibk.ac.at/users/thiemann/>, Thomas Sternagel<>
	topic = Computer science/Automata and formal languages
	date = 2021-12-15
	notify = alexander.lochmann@uibk.ac.at
	-abstract =
	+abstract =
	Tree automata have good closure properties and therefore a commonly
	used to prove/disprove properties. This formalization contains among
	other things the proofs of many closure properties of tree automata
	(anchored) ground tree transducers and regular relations. Additionally
	it includes the well known pumping lemma and a lifting of the Myhill
	Nerode theorem for regular languages to tree languages. We want to
	mention the existence of a <a
	href="https://www.isa-afp.org/entries/Tree-Automata.html">tree
	automata APF-entry</a> developed by Peter Lammich. His work is
	based on epsilon free top-down tree automata, while this entry builds
	on bottom-up tree auotamta with epsilon transitions. Moreover our
	formalization relies on the <a
	href="https://www.isa-afp.org/entries/Collections.html">Collections
	Framework</a>, also by Peter Lammich, to obtain efficient code.
	All proven constructions of the closure properties are exportable
	using the Isabelle/HOL code generation facilities.

	[Roth_Arithmetic_Progressions]
	title = Roth's Theorem on Arithmetic Progressions
	author = Chelsea Edmonds <https://www.cst.cam.ac.uk/people/cle47>, Angeliki Koutsoukou-Argyraki <https://www.cl.cam.ac.uk/~ak2110/>, Lawrence C. Paulson <https://www.cl.cam.ac.uk/~lp15/>
	topic = Mathematics/Graph theory, Mathematics/Combinatorics
	date = 2021-12-28
	notify = lp15@cam.ac.uk
	-abstract =
	+abstract =
	We formalise a proof of Roth's Theorem on Arithmetic
	Progressions, a major result in additive combinatorics on the
	existence of 3-term arithmetic progressions in subsets of natural
	numbers. To this end, we follow a proof using graph regularity. We
	employ our recent formalisation of Szemerédi's Regularity Lemma,
	a major result in extremal graph theory, which we use here to prove
	the Triangle Counting Lemma and the Triangle Removal Lemma. Our
	- sources are Yufei Zhao's MIT lecture notes
	+ sources are Yufei Zhao's MIT lecture notes
	"<a href="https://ocw.mit.edu/courses/mathematics/18-217-graph-theory-and-additive-combinatorics-fall-2019/lecture-notes/MIT18_217F19_ch3.pdf">Graph Theory and Additive Combinatorics</a>"
	(revised version <a href="https://yufeizhao.com/gtac/gtac17.pdf">here</a>)
	- and W.T. Gowers's Cambridge lecture notes
	+ and W.T. Gowers's Cambridge lecture notes
	"<a href="https://www.dpmms.cam.ac.uk/~par31/notes/tic.pdf">Topics in Combinatorics</a>".
	We also refer to the University of
	- Georgia notes by Stephanie Bell and Will Grodzicki,
	+ Georgia notes by Stephanie Bell and Will Grodzicki,
	"<a href="http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.432.327">Using Szemerédi's Regularity Lemma to Prove Roth's Theorem</a>".

	[Gale_Shapley]
	title = Gale-Shapley Algorithm
	author = Tobias Nipkow <http://www21.in.tum.de/~nipkow>
	topic = Computer science/Algorithms, Mathematics/Games and economics
	date = 2021-12-29
	notify = nipkow@in.tum.de
	-abstract =
	+abstract =
	This is a stepwise refinement and proof of the Gale-Shapley stable
	matching (or marriage) algorithm down to executable code. Both a
	purely functional implementation based on lists and a functional
	implementation based on efficient arrays (provided by the Collections
	Framework in the AFP) are developed. The latter implementation runs in
	time <i>O(n<sup>2</sup>)</i> where
	<i>n</i> is the cardinality of the two sets to be matched.

	[Knights_Tour]
	title = Knight's Tour Revisited Revisited
	author = Lukas Koller <mailto:lukas.koller@tum.de>
	topic = Mathematics/Graph theory
	date = 2022-01-04
	notify = lukas.koller@tum.de
	abstract =
	This is a formalization of the article <i>Knight's Tour Revisited</i> by
	Cull and De Curtins where they prove the existence of a Knight's
	path for arbitrary <i>n × m</i>-boards with <i>min(n,m) ≥
	5</i>. If <i>n · m</i> is even, then there exists a Knight's
	circuit. A Knight's Path is a sequence of moves of a Knight on a
	chessboard s.t. the Knight visits every square of a chessboard
	exactly once. Finding a Knight's path is a an instance of the
	Hamiltonian path problem. A Knight's circuit is a Knight's path,
	where additionally the Knight can move from the last square to the
	first square of the path, forming a loop. During the formalization
	two mistakes in the original proof were discovered. These mistakes
	are corrected in this formalization.

	[Hyperdual]
	title = Hyperdual Numbers and Forward Differentiation
	author = Filip Smola <>, Jacques Fleuriot <https://www.inf.ed.ac.uk/people/staff/Jacques_Fleuriot.html>
	topic = Mathematics/Algebra, Mathematics/Analysis
	date = 2021-12-31
	notify = f.smola@sms.ed.ac.uk, Jacques.Fleuriot@ed.ac.uk
	-abstract =
	+abstract =
	<p>Hyperdual numbers are ones with a real component and a number
	of infinitesimal components, usually written as $a_0 + a_1 \cdot
	\epsilon_1 + a_2 \cdot \epsilon_2 + a_3 \cdot \epsilon_1\epsilon_2$.
	They have been proposed by <a
	href="https://doi.org/10.2514/6.2011-886">Fike and
	Alonso</a> in an approach to automatic
	differentiation.</p> <p>In this entry we formalise
	hyperdual numbers and their application to forward differentiation. We
	show them to be an instance of multiple algebraic structures and then,
	along with facts about twice-differentiability, we define what we call
	the hyperdual extensions of functions on real-normed fields. This
	extension formally represents the proposed way that the first and
	second derivatives of a function can be automatically calculated. We
	demonstrate it on the standard logistic function $f(x) = \frac{1}{1 +
	e^{-x}}$ and also reproduce the example analytic function $f(x) =
	\frac{e^x}{\sqrt{sin(x)^3 + cos(x)^3}}$ used for demonstration by Fike
	and Alonso.</p>

	+[Median_Method]
	+title = Median Method
	+author = Emin Karayel <https://orcid.org/0000-0003-3290-5034>
	+topic = Mathematics/Probability theory
	+date = 2022-01-25
	+notify = me@eminkarayel.de
	+abstract =
	+ <p>The median method is an amplification result for randomized
	+ approximation algorithms described in [<a
	+ href="https://doi.org/10.1006/jcss.1997.1545">1</a>].
	+ Given an algorithm whose result is in a desired interval with a
	+ probability larger than <i>1/2</i>, it is possible to
	+ improve the success probability, by running the algorithm multiple
	+ times independently and using the median. In contrast to using the
	+ mean, the amplification of the success probability grows exponentially
	+ with the number of independent runs.</p> <p>This entry
	+ contains a formalization of the underlying theorem: Given a sequence
	+ of n independent random variables, which are in a desired interval
	+ with a probability <i>1/2 + a</i>. Then their median will
	+ be in the desired interval with a probability of <i>1 −
	+ exp(−2a<sup>2</sup> n)</i>. In particular, the
	+ success probability approaches <i>1</i> exponentially with
	+ the number of variables.</p> <p>In addition to that, this
	+ entry also contains a proof that order-statistics of Borel-measurable
	+ random variables are themselves measurable and that generalized
	+ intervals in linearly ordered Borel-spaces are measurable.</p>
	+
	+[Irrationals_From_THEBOOK]
	+title = Irrational numbers from THE BOOK
	+author = Lawrence C Paulson <https://www.cl.cam.ac.uk/~lp15/>
	+topic = Mathematics/Number theory
	+date = 2022-01-08
	+notify = lp15@cam.ac.uk
	+abstract =
	+ An elementary proof is formalised: that <em>exp r</em> is irrational for
	+ every nonzero rational number <em>r</em>. The mathematical development comes
	+ from the well-known volume <em>Proofs from THE BOOK</em>,
	+ by Aigner and Ziegler, who credit the idea to Hermite. The development
	+ illustrates a number of basic Isabelle techniques: the manipulation of
	+ summations, the calculation of quite complicated derivatives and the
	+ estimation of integrals. We also see how to import another AFP entry (Stirling's formula).
	+ As for the theorem itself, note that a much stronger and more general
	+ result (the Hermite--Lindemann--Weierstraß transcendence theorem) is
	+ already available in the AFP.
	+
	+[Interpolation_Polynomials_HOL_Algebra]
	+title = Interpolation Polynomials (in HOL-Algebra)
	+author = Emin Karayel <https://orcid.org/0000-0003-3290-5034>
	+topic = Mathematics/Algebra
	+date = 2022-01-29
	+notify = me@eminkarayel.de
	+abstract =
	+ <p>A well known result from algebra is that, on any field, there
	+ is exactly one polynomial of degree less than n interpolating n points
	+ [<a
	+ href="https://doi.org/10.1017/CBO9780511814549">1</a>,
	+ §7].</p> <p>This entry contains a formalization of the
	+ above result, as well as the following generalization in the case of
	+ finite fields <i>F</i>: There are
	+ <i>\|F\|<sup>m-n</sup></i> polynomials of degree
	+ less than <i>m ≥ n</i> interpolating the same n points,
	+ where <i>\|F\|</i> denotes the size of the domain of the
	+ field. To establish the result the entry also includes a formalization
	+ of Lagrange interpolation, which might be of independent
	+ interest.</p> <p>The formalized results are defined on the
	+ algebraic structures from HOL-Algebra, which are distinct from the
	+ type-class based structures defined in HOL. Note that there is an
	+ existing formalization for polynomial interpolation and, in
	+ particular, Lagrange interpolation by Thiemann and Yamada [<a
	+ href="https://www.isa-afp.org/entries/Polynomial_Interpolation.html">2</a>]
	+ on the type-class based structures in HOL.</p>
	+
	+[Quasi_Borel_Spaces]
	+title = Quasi-Borel Spaces
	+author = Michikazu Hirata <>, Yasuhiko Minamide <https://sv.c.titech.ac.jp/minamide/index.en.html>, Tetsuya Sato <https://sites.google.com/view/tetsuyasato/>
	+topic = Computer science/Semantics
	+date = 2022-02-03
	+notify = hirata.m.ac@m.titech.ac.jp, minamide@is.titech.ac.jp, tsato@c.titech.ac.jp
	+abstract =
	+ The notion of quasi-Borel spaces was introduced by <a
	+ href="https://dl.acm.org/doi/10.5555/3329995.3330072">
	+ Heunen et al</a>. The theory provides a suitable
	+ denotational model for higher-order probabilistic programming
	+ languages with continuous distributions. This entry is a formalization
	+ of the theory of quasi-Borel spaces, including construction of
	+ quasi-Borel spaces (product, coproduct, function spaces), the
	+ adjunction between the category of measurable spaces and the category
	+ of quasi-Borel spaces, and the probability monad on quasi-Borel
	+ spaces. This entry also contains the formalization of the Bayesian
	+ regression presented in the work of Heunen et al. This work is a part
	+ of the work by same authors, <i>Program Logic for Higher-Order
	+ Probabilistic Programs in Isabelle/HOL</i>, which will be
	+ published in the proceedings of the 16th International Symposium on
	+ Functional and Logic Programming (FLOPS 2022).
	+
	+[Youngs_Inequality]
	+title = Young's Inequality for Increasing Functions
	+author = Lawrence C Paulson <https://www.cl.cam.ac.uk/~lp15/>
	+topic = Mathematics/Analysis
	+date = 2022-01-31
	+notify = lp15@cam.ac.uk
	+abstract =
	+ Young's inequality states that $$ ab \leq \int_0^a f(x)dx +
	+ \int_0^b f^{-1}(y) dy $$ where $a\geq 0$, $b\geq 0$ and $f$ is
	+ strictly increasing and continuous. Its proof is formalised following
	+ <a href="https://www.jstor.org/stable/2318018">the
	+ development</a> by Cunningham and Grossman. Their idea is to
	+ make the intuitive, geometric folklore proof rigorous by reasoning
	+ about step functions. The lack of the Riemann integral makes the
	+ development longer than one would like, but their argument is
	+ reproduced faithfully.
	+
	+[LP_Duality]
	+title = Duality of Linear Programming
	+author = René Thiemann <mailto:rene.thiemann@uibk.ac.at>
	+topic = Mathematics/Algebra
	+date = 2022-02-03
	+notify = rene.thiemann@uibk.ac.at
	+abstract =
	+ We formalize the weak and strong duality theorems of linear
	+ programming. For the strong duality theorem we provide three
	+ sufficient preconditions: both the primal problem and the dual problem
	+ are satisfiable, the primal problem is satisfiable and bounded, or the
	+ dual problem is satisfiable and bounded. The proofs are based on an
	+ existing formalization of Farkas' Lemma.
	+
	+[Equivalence_Relation_Enumeration]
	+title = Enumeration of Equivalence Relations
	+author = Emin Karayel <https://orcid.org/0000-0003-3290-5034>
	+topic = Mathematics/Combinatorics, Computer science/Algorithms/Mathematical
	+date = 2022-02-04
	+notify = me@eminkarayel.de
	+abstract =
	+ <p>This entry contains a formalization of an algorithm
	+ enumerating all equivalence relations on an initial segment of the
	+ natural numbers. The approach follows the method described by Stanton
	+ and White <a
	+ href="https://doi.org/10.1007/978-1-4612-4968-9">[5,§
	+ 1.5]</a> using restricted growth functions.</p>
	+ <p>The algorithm internally enumerates restricted growth
	+ functions (as lists), whose equivalence kernels then form the
	+ equivalence relations. This has the advantage that the representation
	+ is compact and lookup of the relation reduces to a list lookup
	+ operation.</p> <p>The algorithm can also be used within a
	+ proof and an example application is included, where a sequence of
	+ variables is split by the possible partitions they can form.</p>
	+
	+[FO_Theory_Rewriting]
	+title = First-Order Theory of Rewriting
	+author = Alexander Lochmann <mailto:alexander.lochmann@uibk.ac.at>, Bertram Felgenhauer<>
	+topic = Computer science/Automata and formal languages, Logic/Rewriting, Logic/Proof theory
	+date = 2022-02-02
	+notify = alexander.lochmann@uibk.ac.at
	+abstract =
	+ The first-order theory of rewriting (FORT) is a decidable theory for
	+ linear variable-separated rewrite systems. The decision procedure is
	+ based on tree automata technique and an inference system presented in
	+ "Certifying Proofs in the First-Order Theory of Rewriting".
	+ This AFP entry provides a formalization of the underlying decision
	+ procedure. Moreover it allows to generate a function that can verify
	+ each inference step via the code generation facility of Isabelle/HOL.
	+ Additionally it contains the specification of a certificate language
	+ (that allows to state proofs in FORT) and a formalized function that
	+ allows to verify the validity of the proof. This gives software tool
	+ authors, that implement the decision procedure, the possibility to
	+ verify their output.
	+
	+[VYDRA_MDL]
	+title = Multi-Head Monitoring of Metric Dynamic Logic
	+author = Martin Raszyk <mailto:martin.raszyk@inf.ethz.ch>
	+topic = Computer science/Algorithms
	+date = 2022-02-13
	+notify = martin.raszyk@inf.ethz.ch
	+abstract =
	+ <p>Runtime monitoring (or runtime verification) is an approach to
	+ checking compliance of a system's execution with a specification
	+ (e.g., a temporal formula). The system's execution is logged into a
	+ <i>trace</i>—a sequence of time-points, each consisting of a
	+ time-stamp and observed events. A <i>monitor</i> is an algorithm that
	+ produces <i>verdicts</i> on the satisfaction of a temporal formula on
	+ a trace.</p>
	+ <p>We formalize the time-stamps as an abstract algebraic structure
	+ satisfying certain assumptions. Instances of this structure include
	+ natural numbers, real numbers, and lexicographic combinations of
	+ them. We also include the formalization of a conversion from the
	+ abstract time domain introduced by Koymans (1990) to our
	+ time-stamps.</p>
	+ <p>We formalize a monitoring algorithm for metric dynamic logic, an
	+ extension of metric temporal logic with regular expressions. The
	+ monitor computes whether a given formula is satisfied at every
	+ position in an input trace of time-stamped events. Our monitor
	+ follows the multi-head paradigm: it reads the input simultaneously at
	+ multiple positions and moves its reading heads asynchronously. This
	+ mode of operation results in unprecedented time and space complexity
	+ guarantees for metric dynamic logic: The monitor's amortized time
	+ complexity to process a time-point and the monitor's space complexity
	+ neither depends on the event-rate, i.e., the number of events within
	+ a fixed time-unit, nor on the numeric constants occurring in the
	+ quantitative temporal constraints in the given formula.</p>
	+ <p>The multi-head monitoring algorithm for metric dynamic logic is
	+ reported in our paper ``Multi-Head Monitoring of Metric Dynamic
	+ Logic'' published at ATVA 2020. We have also formalized unpublished
	+ specialized algorithms for the temporal operators of metric temporal
	+ logic.</p>
	+extra-history =
	+ Change history:
	+ [2022-02-23]: added conversion from the abstract time
	+ domain by Koymans (1990) to our time domain; refactored assumptions
	+ on time domain (revision c9f94b0ae10e)<br>
	+
	+[Eval_FO]
	+title = First-Order Query Evaluation
	+author = Martin Raszyk <mailto:martin.raszyk@inf.ethz.ch>
	+topic = Logic/General logic/Classical first-order logic
	+date = 2022-02-15
	+notify = m.raszyk@gmail.com
	+abstract =
	+ We formalize first-order query evaluation over an infinite domain with
	+ equality. We first define the syntax and semantics of first-order
	+ logic with equality. Next we define a locale
	+ <i>eval&lowbar;fo</i> abstracting a representation of
	+ a potentially infinite set of tuples satisfying a first-order query
	+ over finite relations. Inside the locale, we define a function
	+ <i>eval</i> checking if the set of tuples satisfying a
	+ first-order query over a database (an interpretation of the
	+ query's predicates) is finite (i.e., deciding <i>relative
	+ safety</i>) and computing the set of satisfying tuples if it is
	+ finite. Altogether the function <i>eval</i> solves
	+ <i>capturability</i> (Avron and Hirshfeld, 1991) of
	+ first-order logic with equality. We also use the function
	+ <i>eval</i> to prove a code equation for the semantics of
	+ first-order logic, i.e., the function checking if a first-order query
	+ over a database is satisfied by a variable assignment.<br/> We provide an
	+ interpretation of the locale <i>eval&lowbar;fo</i>
	+ based on the approach by Ailamazyan et al. A core notion in the
	+ interpretation is the active domain of a query and a database that
	+ contains all domain elements that occur in the database or interpret
	+ the query's constants. We prove the main theorem of Ailamazyan et
	+ al. relating the satisfaction of a first-order query over an infinite
	+ domain to the satisfaction of this query over a finite domain
	+ consisting of the active domain and a few additional domain elements
	+ (outside the active domain) whose number only depends on the query. In
	+ our interpretation of the locale
	+ <i>eval&lowbar;fo</i>, we use a potentially higher
	+ number of the additional domain elements, but their number still only
	+ depends on the query and thus has no effect on the data complexity
	+ (Vardi, 1982) of query evaluation. Our interpretation yields an
	+ <i>executable</i> function <i>eval</i>. The
	+ time complexity of <i>eval</i> on a query is linear in the
	+ total number of tuples in the intermediate relations for the
	+ subqueries. Specifically, we build a database index to evaluate a
	+ conjunction. We also optimize the case of a negated subquery in a
	+ conjunction. Finally, we export code for the infinite domain of
	+ natural numbers.
	+
	+[Wetzels_Problem]
	+title = Wetzel's Problem and the Continuum Hypothesis
	+author = Lawrence C Paulson<>
	+topic = Mathematics/Analysis, Logic/Set theory
	+date = 2022-02-18
	+notify = lp15@cam.ac.uk
	+abstract =
	+ Let $F$ be a set of analytic functions on the complex plane such that,
	+ for each $z\in\mathbb{C}$, the set $\{f(z) \mid f\in F\}$ is
	+ countable; must then $F$ itself be countable? The answer is yes if the
	+ Continuum Hypothesis is false, i.e., if the cardinality of
	+ $\mathbb{R}$ exceeds $\aleph_1$. But if CH is true then such an $F$,
	+ of cardinality $\aleph_1$, can be constructed by transfinite
	+ recursion. The formal proof illustrates reasoning about complex
	+ analysis (analytic and homomorphic functions) and set theory
	+ (transfinite cardinalities) in a single setting. The mathematical text
	+ comes from <em>Proofs from THE BOOK</em> by Aigner and
	+ Ziegler.
	+
	+[Universal_Hash_Families]
	+title = Universal Hash Families
	+author = Emin Karayel <https://orcid.org/0000-0003-3290-5034>
	+topic = Mathematics/Probability theory, Computer science/Algorithms
	+date = 2022-02-20
	+notify = me@eminkarayel.de
	+abstract =
	+ A <i>k</i>-universal hash family is a probability
	+ space of functions, which have uniform distribution and form
	+ <i>k</i>-wise independent random variables. They can often be used
	+ in place of classic (or cryptographic) hash functions and allow the
	+ rigorous analysis of the performance of randomized algorithms and
	+ data structures that rely on hash functions. In 1981
	+ <a href="https://doi.org/10.1016/0022-0000(81)90033-7">Wegman and Carter</a>
	+ introduced a generic construction for such families with arbitrary
	+ <i>k</i> using polynomials over a finite field. This entry
	+ contains a formalization of them and establishes the property of
	+ <i>k</i>-universality. To be useful the formalization also provides
	+ an explicit construction of finite fields using the factor ring of
	+ integers modulo a prime. Additionally, some generic results about
	+ independent families are shown that might be of independent interest.
	+
	diff --git a/thys/Actuarial_Mathematics/Interest.thy b/thys/Actuarial_Mathematics/Interest.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Actuarial_Mathematics/Interest.thy
	@@ -0,0 +1,860 @@
	+theory Interest
	+ imports Preliminaries
	+begin
	+
	+
	+section \<open>List of Actuarial Notations (Global Scope)\<close>
	+
	+definition i_nom :: "real \<Rightarrow> nat \<Rightarrow> real" ("$i[_]^{_}" [0,0] 200)
	+ where "$i[i]^{m} \<equiv> m * ((1+i).^(1/m) - 1)" \<comment> \<open>nominal interest rate\<close>
	+definition i_force :: "real \<Rightarrow> real" ("$\<delta>[_]" [0] 200)
	+ where "$\<delta>[i] \<equiv> ln (1+i)" \<comment> \<open>force of interest\<close>
	+definition d_nom :: "real \<Rightarrow> nat \<Rightarrow> real" ("$d[_]^{_}" [0,0] 200)
	+ where "$d[i]^{m} \<equiv> $i[i]^{m} / (1 + $i[i]^{m}/m)" \<comment> \<open>discount rate\<close>
	+abbreviation d_nom_yr :: "real \<Rightarrow> real" ("$d[_]" [0] 200)
	+ where "$d[i] \<equiv> $d[i]^{1}" \<comment> \<open>Post-fix "yr" stands for "year".\<close>
	+definition v_pres :: "real \<Rightarrow> real" ("$v[_]" [0] 200)
	+ where "$v[i] \<equiv> 1 / (1+i)" \<comment> \<open>present value factor\<close>
	+definition ann :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$a[_]^{_}'__" [0,0,101] 200)
	+ where "$a[i]^{m}_n \<equiv> \<Sum>k<n*m. $v[i].^((k+1::nat)/m) / m"
	+ \<comment> \<open>present value of an immediate annuity\<close>
	+abbreviation ann_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$a[_]'__" [0,101] 200)
	+ where "$a[i]_n \<equiv> $a[i]^{1}_n"
	+definition acc :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$s[_]^{_}'__" [0,0,101] 200)
	+ where "$s[i]^{m}_n \<equiv> \<Sum>k<n*m. (1+i).^((k::nat)/m) / m"
	+ \<comment> \<open>future value of an immediate annuity\<close>
	+ \<comment> \<open>The name "acc" stands for "accumulation".\<close>
	+abbreviation acc_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$s[_]'__" [0] 200)
	+ where "$s[i]_n \<equiv> $s[i]^{1}_n"
	+definition ann_due :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$a''''[_]^{_}'__" [0,0,101] 200)
	+ where "$a''[i]^{m}_n \<equiv> \<Sum>k<n*m. $v[i].^((k::nat)/m) / m"
	+ \<comment> \<open>present value of an annuity-due\<close>
	+abbreviation ann_due_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$a''''[_]'__" [0,101] 200)
	+ where "$a''[i]_n \<equiv> $a''[i]^{1}_n"
	+definition acc_due :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$s''''[_]^{_}'__" [0,0,101] 200)
	+ where "$s''[i]^{m}_n \<equiv> \<Sum>k<n*m. (1+i).^((k+1::nat)/m) / m"
	+ \<comment> \<open>future value of an annuity-due\<close>
	+abbreviation acc_due_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$s''''[_]'__" [0,101] 200)
	+ where "$s''[i]_n \<equiv> $s''[i]^{1}_n"
	+definition ann_cont :: "real \<Rightarrow> real \<Rightarrow> real" ("$a''[_]'__" [0,101] 200)
	+ where "$a'[i]_n \<equiv> integral {0..n} (\<lambda>t::real. $v[i].^t)"
	+ \<comment> \<open>present value of a continuous annuity\<close>
	+definition acc_cont :: "real \<Rightarrow> real \<Rightarrow> real" ("$s''[_]'__" [0,101] 200)
	+ where "$s'[i]_n \<equiv> integral {0..n} (\<lambda>t::real. (1+i).^t)"
	+ \<comment> \<open>future value of a continuous annuity\<close>
	+definition perp :: "real \<Rightarrow> nat \<Rightarrow> real" ("$a[_]^{_}'_\<infinity>" [0,0] 200)
	+ where "$a[i]^{m}_\<infinity> \<equiv> 1 / $i[i]^{m}"
	+ \<comment> \<open>present value of a perpetual annuity\<close>
	+abbreviation perp_yr :: "real \<Rightarrow> real" ("$a[_]'_\<infinity>" [0] 200)
	+ where "$a[i]_\<infinity> \<equiv> $a[i]^{1}_\<infinity>"
	+definition perp_due :: "real \<Rightarrow> nat \<Rightarrow> real" ("$a''''[_]^{_}'_\<infinity>" [0,0] 200)
	+ where "$a''[i]^{m}_\<infinity> \<equiv> 1 / $d[i]^{m}"
	+ \<comment> \<open>present value of a perpetual annuity-due\<close>
	+abbreviation perp_due_yr :: "real \<Rightarrow> real" ("$a''''[_]'_\<infinity>" [0] 200)
	+ where "$a''[i]_\<infinity> \<equiv> $a''[i]^{1}_\<infinity>"
	+definition ann_incr :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(I^{_}a')[_]^{_}'__" [0,0,0,101] 200)
	+ where "$(I^{l}a)[i]^{m}_n \<equiv> \<Sum>k<nm. $v[i].^((k+1::nat)/m) \<lceil>l(k+1::nat)/m\<rceil> / (lm)"
	+ \<comment> \<open>present value of an increasing annuity\<close>
	+ \<comment> \<open>This is my original definition.\<close>
	+ \<comment> \<open>Here, "l" represents the number of increments per unit time.\<close>
	+abbreviation ann_incr_lvl :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(Ia')[_]^{_}'__" [0,0,101] 200)
	+ where "$(Ia)[i]^{m}_n \<equiv> $(I^{1}a)[i]^{m}_n"
	+ \<comment> \<open>The post-fix "lvl" stands for "level".\<close>
	+abbreviation ann_incr_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$'(Ia')[_]'__" [0,101] 200)
	+ where "$(Ia)[i]_n \<equiv> $(Ia)[i]^{1}_n"
	+definition acc_incr :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(I^{_}s')[_]^{_}'__" [0,0,0,101] 200)
	+ where "$(I^{l}s)[i]^{m}_n \<equiv> \<Sum>k<nm. (1+i).^(n-(k+1::nat)/m) \<lceil>l(k+1::nat)/m\<rceil> / (lm)"
	+ \<comment> \<open>future value of an increasing annuity\<close>
	+abbreviation acc_incr_lvl :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(Is')[_]^{_}'__" [0,0,101] 200)
	+ where "$(Is)[i]^{m}_n \<equiv> $(I^{1}s)[i]^{m}_n"
	+abbreviation acc_incr_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$'(Is')[_]'__" [0,101] 200)
	+ where "$(Is)[i]_n \<equiv> $(Is)[i]^{1}_n"
	+definition ann_due_incr :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(I^{_}a''''')[_]^{_}'__" [0,0,0,101] 200)
	+ where "$(I^{l}a'')[i]^{m}_n \<equiv> \<Sum>k<nm. $v[i].^((k::nat)/m) \<lceil>l(k+1::nat)/m\<rceil> / (lm)"
	+abbreviation ann_due_incr_lvl :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(Ia''''')[_]^{_}'__" [0,0,101] 200)
	+ where "$(Ia'')[i]^{m}_n \<equiv> $(I^{1}a'')[i]^{m}_n"
	+abbreviation ann_due_incr_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$'(Ia''''')[_]'__" [0,101] 200)
	+ where "$(Ia'')[i]_n \<equiv> $(Ia'')[i]^{1}_n"
	+definition acc_due_incr :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(I^{_}s''''')[_]^{_}'__" [0,0,0,101] 200)
	+ where "$(I^{l}s'')[i]^{m}_n \<equiv> \<Sum>k<nm. (1+i).^(n-(k::nat)/m) \<lceil>l(k+1::nat)/m\<rceil> / (lm)"
	+abbreviation acc_due_incr_lvl :: "real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real"
	+ ("$'(Is''''')[_]^{_}'__" [0,0,101] 200)
	+ where "$(Is'')[i]^{m}_n \<equiv> $(I^{1}s'')[i]^{m}_n"
	+abbreviation acc_due_incr_yr :: "real \<Rightarrow> nat \<Rightarrow> real" ("$'(Is''''')[_]'__" [0,101] 200)
	+ where "$(Is'')[i]_n \<equiv> $(Is'')[i]^{1}_n"
	+definition perp_incr :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}a')[_]^{_}'_\<infinity>" [0,0,0] 200)
	+ where "$(I^{l}a)[i]^{m}_\<infinity> \<equiv> lim (\<lambda>n. $(I^{l}a)[i]^{m}_n)"
	+abbreviation perp_incr_lvl :: "real \<Rightarrow> nat \<Rightarrow> real" ("$'(Ia')[_]^{_}'_\<infinity>" [0,0] 200)
	+ where "$(Ia)[i]^{m}_\<infinity> \<equiv> $(I^{1}a)[i]^{m}_\<infinity>"
	+abbreviation perp_incr_yr :: "real \<Rightarrow> real" ("$'(Ia')[_]'_\<infinity>" [0] 200)
	+ where "$(Ia)[i]_\<infinity> \<equiv> $(Ia)[i]^{1}_\<infinity>"
	+definition perp_due_incr :: "nat \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}a''''')[_]^{_}'_\<infinity>" [0,0,0] 200)
	+ where "$(I^{l}a'')[i]^{m}_\<infinity> \<equiv> lim (\<lambda>n. $(I^{l}a'')[i]^{m}_n)"
	+abbreviation perp_due_incr_lvl :: "real \<Rightarrow> nat \<Rightarrow> real" ("$'(Ia''''')[_]^{_}'_\<infinity>" [0,0] 200)
	+ where "$(Ia'')[i]^{m}_\<infinity> \<equiv> $(I^{1}a'')[i]^{m}_\<infinity>"
	+abbreviation perp_due_incr_yr :: "real \<Rightarrow> real" ("$'(Ia''''')[_]'_\<infinity>" [0] 200)
	+ where "$(Ia'')[i]_\<infinity> \<equiv> $(Ia'')[i]^{1}_\<infinity>"
	+
	+
	+section \<open>Theory of Interest\<close>
	+
	+locale interest =
	+ fixes i :: real \<comment> \<open>i stands for an interest rate.\<close>
	+ assumes v_futr_pos: "1 + i > 0" \<comment> \<open>Assume that the future value is positive.\<close>
	+
	+context interest
	+begin
	+
	+abbreviation i_nom' :: "nat \<Rightarrow> real" ("$i^{_}" [0] 200)
	+ where "$i^{m} \<equiv> $i[i]^{m}"
	+abbreviation i_force' :: real ("$\<delta>")
	+ where "$\<delta> \<equiv> $\<delta>[i]"
	+abbreviation d_nom' :: "nat \<Rightarrow> real" ("$d^{_}" [0] 200)
	+ where "$d^{m} \<equiv> $d[i]^{m}"
	+abbreviation d_nom_yr' :: real ("$d")
	+ where "$d \<equiv> $d[i]"
	+abbreviation v_pres' :: real ("$v")
	+ where "$v \<equiv> $v[i]"
	+abbreviation ann' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$a^{_}'__" [0,101] 200)
	+ where "$a^{m}_n \<equiv> $a[i]^{m}_n"
	+abbreviation ann_yr' :: "nat \<Rightarrow> real" ("$a'__" [101] 200)
	+ where "$a_n \<equiv> $a[i]_n"
	+abbreviation acc' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$s^{_}'__" [0,101] 200)
	+ where "$s^{m}_n \<equiv> $s[i]^{m}_n"
	+abbreviation acc_yr' :: "nat \<Rightarrow> real" ("$s'__" [101] 200)
	+ where "$s_n \<equiv> $s[i]_n"
	+abbreviation ann_due' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$a''''^{_}'__" [0,101] 200)
	+ where "$a''^{m}_n \<equiv> $a''[i]^{m}_n"
	+abbreviation ann_due_yr' :: "nat \<Rightarrow> real" ("$a'''''__" [101] 200)
	+ where "$a''_n \<equiv> $a''[i]_n"
	+abbreviation acc_due' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$s''''^{_}'__" [0,101] 200)
	+ where "$s''^{m}_n \<equiv> $s''[i]^{m}_n"
	+abbreviation acc_due_yr' :: "nat \<Rightarrow> real" ("$s'''''__" [101] 200)
	+ where "$s''_n \<equiv> $s''[i]_n"
	+abbreviation ann_cont' :: "real \<Rightarrow> real" ("$a'''__" [101] 200)
	+ where "$a'_n \<equiv> $a'[i]_n"
	+abbreviation acc_cont' :: "real \<Rightarrow> real" ("$s'''__" [101] 200)
	+ where "$s'_n \<equiv> $s'[i]_n"
	+abbreviation perp' :: "nat \<Rightarrow> real" ("$a^{_}'_\<infinity>" [0] 200)
	+ where "$a^{m}_\<infinity> \<equiv> $a[i]^{m}_\<infinity>"
	+abbreviation perp_yr' :: real ("$a'_\<infinity>")
	+ where "$a_\<infinity> \<equiv> $a[i]_\<infinity>"
	+abbreviation perp_due' :: "nat \<Rightarrow> real" ("$a''''^{_}'_\<infinity>" [0] 200)
	+ where "$a''^{m}_\<infinity> \<equiv> $a''[i]^{m}_\<infinity>"
	+abbreviation perp_due_yr' :: real ("$a'''''_\<infinity>")
	+ where "$a''_\<infinity> \<equiv> $a''[i]_\<infinity>"
	+abbreviation ann_incr' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}a')^{_}'__" [0,0,101] 200)
	+ where "$(I^{l}a)^{m}_n \<equiv> $(I^{l}a)[i]^{m}_n"
	+abbreviation ann_incr_lvl' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$'(Ia')^{_}'__" [0,101] 200)
	+ where "$(Ia)^{m}_n \<equiv> $(Ia)[i]^{m}_n"
	+abbreviation ann_incr_yr' :: "nat \<Rightarrow> real" ("$'(Ia')'__" [101] 200)
	+ where "$(Ia)_n \<equiv> $(Ia)[i]_n"
	+abbreviation acc_incr' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}s')^{_}'__" [0,0,101] 200)
	+ where "$(I^{l}s)^{m}_n \<equiv> $(I^{l}s)[i]^{m}_n"
	+abbreviation acc_incr_lvl' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$'(Is')^{_}'__" [0,101] 200)
	+ where "$(Is)^{m}_n \<equiv> $(Is)[i]^{m}_n"
	+abbreviation acc_incr_yr' :: "nat \<Rightarrow> real" ("$'(Is')'__" [101] 200)
	+ where "$(Is)_n \<equiv> $(Is)[i]_n"
	+abbreviation ann_due_incr' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}a''''')^{_}'__" [0,0,101] 200)
	+ where "$(I^{l}a'')^{m}_n \<equiv> $(I^{l}a'')[i]^{m}_n"
	+abbreviation ann_due_incr_lvl' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$'(Ia''''')^{_}'__" [0,101] 200)
	+ where "$(Ia'')^{m}_n \<equiv> $(Ia'')[i]^{m}_n"
	+abbreviation ann_due_incr_yr' :: "nat \<Rightarrow> real" ("$'(Ia''''')'__" [101] 200)
	+ where "$(Ia'')_n \<equiv> $(Ia'')[i]_n"
	+abbreviation acc_due_incr' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}s''''')^{_}'__" [0,0,101] 200)
	+ where "$(I^{l}s'')^{m}_n \<equiv> $(I^{l}s'')[i]^{m}_n"
	+abbreviation acc_due_incr_lvl' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$'(Is''''')^{_}'__" [0,101] 200)
	+ where "$(Is'')^{m}_n \<equiv> $(Is'')[i]^{m}_n"
	+abbreviation acc_due_incr_yr' :: "nat \<Rightarrow> real" ("$'(Is''''')'__" [101] 200)
	+ where "$(Is'')_n \<equiv> $(Is'')[i]_n"
	+abbreviation perp_incr' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}a')^{_}'_\<infinity>" [0,0] 200)
	+ where "$(I^{l}a)^{m}_\<infinity> \<equiv> $(I^{l}a)[i]^{m}_\<infinity>"
	+abbreviation perp_incr_lvl' :: "nat \<Rightarrow> real" ("$'(Ia')^{_}'_\<infinity>" [0] 200)
	+ where "$(Ia)^{m}_\<infinity> \<equiv> $(Ia)[i]^{m}_\<infinity>"
	+abbreviation perp_incr_yr' :: real ("$'(Ia')'_\<infinity>")
	+ where "$(Ia)_\<infinity> \<equiv> $(Ia)[i]_\<infinity>"
	+abbreviation perp_due_incr' :: "nat \<Rightarrow> nat \<Rightarrow> real" ("$'(I^{_}a''''')^{_}'_\<infinity>" [0,0] 200)
	+ where "$(I^{l}a'')^{m}_\<infinity> \<equiv> $(I^{l}a'')[i]^{m}_\<infinity>"
	+abbreviation perp_due_incr_lvl' :: "nat \<Rightarrow> real" ("$'(Ia''''')^{_}'_\<infinity>" [0] 200)
	+ where "$(Ia'')^{m}_\<infinity> \<equiv> $(Ia'')[i]^{m}_\<infinity>"
	+abbreviation perp_due_incr_yr' :: real ("$'(Ia''''')'_\<infinity>")
	+ where "$(Ia'')_\<infinity> \<equiv> $(Ia'')[i]_\<infinity>"
	+
	+lemma v_futr_m_pos: "1 + $i^{m}/m > 0" if "m \<noteq> 0" for m::nat
	+ using v_futr_pos i_nom_def by force
	+
	+lemma i_nom_1[simp]: "$i^{1} = i"
	+ using v_futr_pos i_nom_def by force
	+
	+lemma i_nom_eff: "(1 + $i^{m}/m)^m = 1 + i" if "m \<noteq> 0" for m::nat
	+ unfolding i_nom_def using less_imp_neq v_futr_pos that
	+ apply (simp, subst powr_realpow[THEN sym], simp)
	+ by (subst powr_powr, simp)
	+
	+lemma i_nom_i: "1 + $i^{m}/m = (1+i).^(1/m)" if "m \<noteq> 0" for m::nat
	+ unfolding i_nom_def by (simp add: that)
	+
	+lemma i_nom_0_iff_i_0: "$i^{m} = 0 \<longleftrightarrow> i = 0" if "m \<noteq> 0" for m::nat
	+proof
	+ assume "$i^{m} = 0"
	+ hence \<star>: "(1+i).^(1/m) = (1+i).^0"
	+ unfolding i_nom_def using v_futr_pos that by simp
	+ show "i = 0"
	+ proof (rule ccontr)
	+ assume "i \<noteq> 0"
	+ hence "1/m = 0" using powr_inj \<star> v_futr_pos by smt
	+ thus False using that by simp
	+ qed
	+next
	+ assume "i = 0"
	+ thus "$i^{m} = 0"
	+ unfolding i_nom_def by simp
	+qed
	+
	+lemma i_nom_pos_iff_i_pos: "$i^{m} > 0 \<longleftrightarrow> i > 0" if "m \<noteq> 0" for m::nat
	+proof
	+ assume "$i^{m} > 0"
	+ hence \<star>: "(1+i).^(1/m) > 1.^(1/m)"
	+ unfolding i_nom_def using v_futr_pos that by (simp add: zero_less_mult_iff)
	+ thus "i > 0"
	+ using powr_less_cancel2[of "1/m" 1 "1+i"] v_futr_pos that by simp
	+next
	+ assume "i > 0"
	+ hence "(1+i).^(1/m) > 1.^(1/m)"
	+ using powr_less_mono2 v_futr_pos that by simp
	+ thus "$i^{m} > 0"
	+ unfolding i_nom_def using that by (simp add: zero_less_mult_iff)
	+qed
	+
	+lemma e_delta: "exp $\<delta> = 1 + i"
	+ unfolding i_force_def by (simp add: v_futr_pos)
	+
	+lemma delta_0_iff_i_0: "$\<delta> = 0 \<longleftrightarrow> i = 0"
	+proof
	+ assume "$\<delta> = 0"
	+ thus "i = 0"
	+ using e_delta by auto
	+next
	+ assume "i = 0"
	+ thus "$\<delta> = 0"
	+ unfolding i_force_def by simp
	+qed
	+
	+lemma lim_i_nom: "(\<lambda>m. $i^{m}) \<longlonglongrightarrow> $\<delta>"
	+proof -
	+ let ?f = "\<lambda>h. ((1+i).^h - 1) / h"
	+ have D1ipwr: "DERIV (\<lambda>h. (1+i).^h) 0 :> $\<delta>"
	+ unfolding i_force_def
	+ using has_real_derivative_powr2[OF v_futr_pos, where x=0] v_futr_pos by simp
	+ hence limf: "(?f \<longlongrightarrow> $\<delta>) (at 0)"
	+ unfolding DERIV_def using v_futr_pos by auto
	+ hence "(\<lambda>m. $i^{Suc m}) \<longlonglongrightarrow> $\<delta>"
	+ unfolding i_nom_def using tendsto_at_iff_sequentially[of ?f "$\<delta>" 0 \<real>, THEN iffD1]
	+ apply simp
	+ apply (drule_tac x="\<lambda>m. 1 / Suc m" in spec, simp, drule mp)
	+ subgoal using lim_1_over_n LIMSEQ_Suc by force
	+ by (simp add: o_def mult.commute)
	+ thus ?thesis
	+ by (simp add: LIMSEQ_imp_Suc)
	+qed
	+
	+lemma d_nom_0_iff_i_0: "$d^{m} = 0 \<longleftrightarrow> i = 0" if "m \<noteq> 0" for m::nat
	+proof -
	+ have "$d^{m} = 0 \<longleftrightarrow> $i^{m} = 0"
	+ unfolding d_nom_def using v_futr_m_pos by (smt (verit) divide_eq_0_iff of_nat_0)
	+ thus ?thesis
	+ using i_nom_0_iff_i_0 that by auto
	+qed
	+
	+lemma d_nom_pos_iff_i_pos: "$d^{m} > 0 \<longleftrightarrow> i > 0" if "m \<noteq> 0" for m::nat
	+proof -
	+ have "$d^{m} > 0 \<longleftrightarrow> $i^{m} > 0"
	+ unfolding d_nom_def using zero_less_divide_iff i_nom_pos_iff_i_pos v_futr_m_pos that by smt
	+ thus ?thesis
	+ using i_nom_pos_iff_i_pos that by auto
	+qed
	+
	+lemma d_nom_i_nom: "1 - $d^{m}/m = 1 / (1 + $i^{m}/m)" if "m \<noteq> 0" for m::nat
	+proof -
	+ have "1 - $d^{m}/m = 1 - ($i^{m}/m) / (1 + $i^{m}/m)"
	+ by (simp add: d_nom_def)
	+ also have "\<dots> = 1 / (1 + $i^{m}/m)"
	+ using v_futr_m_pos
	+ by (smt (verit, ccfv_SIG) add_divide_distrib that div_self)
	+ finally show ?thesis .
	+qed
	+
	+lemma lim_d_nom: "(\<lambda>m. $d^{m}) \<longlonglongrightarrow> $\<delta>"
	+proof -
	+ have "(\<lambda>m. $i^{m}/m) \<longlonglongrightarrow> 0"
	+ using lim_i_nom tendsto_divide_0 tendsto_of_nat by blast
	+ hence "(\<lambda>m. 1 + $i^{m}/m) \<longlonglongrightarrow> 1"
	+ by (metis add.right_neutral tendsto_add_const_iff)
	+ thus ?thesis
	+ unfolding d_nom_def using lim_i_nom tendsto_divide div_by_1 by fastforce
	+qed
	+
	+lemma v_pos: "$v > 0"
	+ unfolding v_pres_def using v_futr_pos by auto
	+
	+lemma v_1_iff_i_0: "$v = 1 \<longleftrightarrow> i = 0"
	+proof
	+ assume "$v = 1"
	+ thus "i = 0"
	+ unfolding v_pres_def by simp
	+next
	+ assume "i = 0"
	+ thus "$v = 1"
	+ unfolding v_pres_def by simp
	+qed
	+
	+lemma v_lt_1_iff_i_pos: "$v < 1 \<longleftrightarrow> i > 0"
	+proof
	+ assume "$v < 1"
	+ thus "i > 0"
	+ unfolding v_pres_def by (simp add: v_futr_pos)
	+next
	+ assume "i > 0"
	+ thus "$v < 1"
	+ unfolding v_pres_def by (simp add: v_futr_pos)
	+qed
	+
	+lemma v_i_nom: "$v = (1 + $i^{m}/m).^-m" if "m \<noteq> 0" for m::nat
	+proof -
	+ have "$v = (1 + i).^-1"
	+ unfolding v_pres_def using v_futr_pos powr_real_def that by (simp add: powr_neg_one)
	+ also have "\<dots> = ((1 + $i^{m}/m)^m).^-1"
	+ using i_nom_eff that by presburger
	+ also have "\<dots> = (1 + $i^{m}/m).^-m"
	+ using powr_powr powr_realpow[THEN sym] v_futr_m_pos that by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma i_v: "1 + i = $v.^-1"
	+ unfolding v_pres_def powr_real_def using v_futr_pos powr_neg_one by simp
	+
	+lemma i_v_powr: "(1 + i).^a = $v.^-a" for a::real
	+ by (subst i_v, subst powr_powr, simp)
	+
	+lemma v_delta: "ln $v = - $\<delta>"
	+ unfolding i_force_def v_pres_def using v_futr_pos by (simp add: ln_div)
	+
	+lemma is_derive_vpow: "DERIV (\<lambda>t. $v.^t) t :> - $\<delta> * $v.^t"
	+ using v_delta has_real_derivative_powr2 v_pos by (metis mult.commute)
	+
	+lemma d_nom_v: "$d^{m} = m * (1 - $v.^(1/m))" if "m \<noteq> 0" for m::nat
	+proof -
	+ have "$d^{m} = m * (1 - 1 / (1 + $i^{m}/m))"
	+ using d_nom_i_nom[THEN sym] that by force
	+ also have "\<dots> = m * (1 - 1 / (1 + i).^(1/m))"
	+ using i_nom_i that powr_minus_divide by simp
	+ also have "\<dots> = m * (1 - $v.^(1/m))"
	+ using v_pres_def v_futr_pos powr_divide by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma d_nom_i_nom_v: "$d^{m} = $i^{m} * $v.^(1/m)" if "m \<noteq>0" for m::nat
	+ unfolding d_nom_def v_pres_def using i_nom_i powr_divide v_futr_pos that by auto
	+
	+lemma a_calc: "$a^{m}_n = (1 - $v^n) / $i^{m}" if "m \<noteq> 0" "i \<noteq> 0" for n m ::nat
	+proof -
	+ have "\<And>l::nat. l/m = (1/m) * l" by simp
	+ hence \<star>: "\<And>l::nat. $v.^(l/m) = ($v.^(1/m))^l"
	+ using powr_powr powr_realpow v_pos by (metis powr_gt_zero)
	+ hence "$a^{m}_n = (\<Sum>k<n*m. ($v.^(1/m))^(k+1::nat) / m)"
	+ unfolding ann_def by presburger
	+ also have "\<dots> = $v.^(1/m) * (\<Sum>k<n*m. ($v.^(1/m))^k) / m"
	+ by (simp, subst sum_divide_distrib[THEN sym], subst sum_distrib_left[THEN sym], simp)
	+ also have "\<dots> = $v.^(1/m) * ((($v.^(1/m))^(n*m) - 1) / ($v.^(1/m) - 1)) / m"
	+ apply (subst geometric_sum[of "$v.^(1/m)" "n*m"]; simp?)
	+ using powr_zero_eq_one[of "$v"] v_pos v_1_iff_i_0 powr_inj that
	+ by (smt (verit, del_insts) divide_eq_0_iff of_nat_eq_0_iff)
	+ also have "\<dots> = (($v.^(1/m))^(nm) - 1) / (m ($v.^(1/m) - 1) / $v.^(1/m))"
	+ by (simp add: field_simps)
	+ also have "\<dots> = ($v^n - 1) / (m * (1 - 1 / $v.^(1/m)))"
	+ apply (subst \<star>[of "n*m::nat", THEN sym], simp only: of_nat_simps)
	+ apply (subst nonzero_mult_div_cancel_right[where 'a=real, of m n], simp add: that)
	+ apply (subst powr_realpow[OF v_pos])
	+ apply (subst times_divide_eq_right[of _ _ "$v.^(1/m)", THEN sym])
	+ using v_pos by (subst diff_divide_distrib[of _ _ "$v.^(1/m)"], simp)
	+ also have "\<dots> = (1 - $v^n) / (m * (1 / $v.^(1/m) - 1))"
	+ using minus_divide_divide by (smt mult_minus_right)
	+ also have "\<dots> = (1 - $v^n) / $i^{m}"
	+ unfolding i_nom_def v_pres_def using v_futr_pos powr_divide by auto
	+ finally show ?thesis .
	+qed
	+
	+lemma a_calc_i_0: "$a^{m}_n = n" if "m \<noteq> 0" "i = 0" for n m :: nat
	+ unfolding ann_def v_pres_def using that by simp
	+
	+lemma s_calc_i_0: "$s^{m}_n = n" if "m \<noteq> 0" "i = 0" for n m :: nat
	+ unfolding acc_def using that by simp
	+
	+lemma s_a: "$s^{m}_n = (1+i)^n * $a^{m}_n" if "m \<noteq> 0" for n m :: nat
	+proof -
	+ have "(1+i)^n * $a^{m}_n = (\<Sum>k<nm. (1+i)^n ($v.^((k+1::nat)/m) / m))"
	+ unfolding ann_def using sum_distrib_left by blast
	+ also have "\<dots> = (\<Sum>k<nm. (1+i).^((nm - Suc k)/m) / m)"
	+ proof -
	+ have "\<And>k::nat. k < nm \<Longrightarrow> (1+i)^n ($v.^((k+1::nat)/m) / m) = (1+i).^((n*m - Suc k)/m) / m"
	+ unfolding v_pres_def
	+ apply (subst powr_realpow[THEN sym], simp add: v_futr_pos)
	+ apply (subst inverse_powr, simp add: v_futr_pos)
	+ apply (subst times_divide_eq_right, subst powr_add[THEN sym], simp add: that)
	+ by (subst of_nat_diff, simp add: Suc_le_eq, simp add: diff_divide_distrib that)
	+ thus ?thesis by (meson lessThan_iff sum.cong)
	+ qed
	+ also have "\<dots> = (\<Sum>k<n*m. (1+i).^(k/m) / m)"
	+ apply (subst atLeast0LessThan[THEN sym])+
	+ by (subst sum.atLeastLessThan_rev[THEN sym, of _ "n*m" 0, simplified add_0_right], simp)
	+ also have "\<dots> = $s^{m}_n"
	+ unfolding acc_def by simp
	+ finally show ?thesis ..
	+qed
	+
	+lemma s_calc: "$s^{m}_n = ((1+i)^n - 1) / $i^{m}" if "m \<noteq> 0" "i \<noteq> 0" for n m :: nat
	+ using that v_futr_pos
	+ apply (subst s_a, simp, subst a_calc; simp?)
	+ apply (rule disjI2)
	+ apply (subst right_diff_distrib, simp)
	+ apply (rule left_right_inverse_power)
	+ unfolding v_pres_def by auto
	+
	+lemma a''_a: "$a''^{m}_n = (1+i).^(1/m) * $a^{m}_n" if "m \<noteq> 0" for m::nat
	+ unfolding ann_def ann_due_def
	+ apply (subst sum_distrib_left, subst times_divide_eq_right, simp)
	+ by (subst i_v, subst powr_powr, subst powr_add[THEN sym], simp, subst add_divide_distrib, simp)
	+
	+lemma a_a'': "$a^{m}_n = $v.^(1/m) * $a''^{m}_n" if "m \<noteq> 0" for m::nat
	+ unfolding ann_def ann_due_def
	+ apply (subst sum_distrib_left, subst times_divide_eq_right, simp)
	+ by (subst powr_add[THEN sym], subst add_divide_distrib, simp)
	+
	+lemma a''_calc_i_0: "$a''^{m}_n = n" if "m \<noteq> 0" "i = 0" for n m :: nat
	+ unfolding ann_due_def v_pres_def using that by simp
	+
	+lemma s''_calc_i_0: "$s''^{m}_n = n" if "m \<noteq> 0" "i = 0" for n m :: nat
	+ unfolding acc_due_def using that by simp
	+
	+lemma a''_calc: "$a''^{m}_n = (1 - $v^n) / $d^{m}" if "m \<noteq> 0" "i \<noteq> 0" for n m :: nat
	+proof -
	+ have "$a''^{m}_n = (1+i).^(1/m) * ((1 - $v^n) / $i^{m})"
	+ using a''_a a_calc times_divide_eq_right that by simp
	+ also have "\<dots> = (1 - $v^n) / ($v.^(1/m) * $i^{m})"
	+ by (subst i_v, subst powr_powr, simp, subst powr_minus_divide, simp)
	+ also have "\<dots> = (1 - $v^n) / $d^{m}"
	+ using d_nom_i_nom_v that by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma s''_s: "$s''^{m}_n = (1+i).^(1/m) * $s^{m}_n" if "m \<noteq> 0" for m::nat
	+ unfolding acc_def acc_due_def
	+ by (simp add: sum_distrib_left add_divide_distrib powr_add)
	+
	+lemma s_s'': "$s^{m}_n = $v.^(1/m) * $s''^{m}_n" if "m \<noteq> 0" for m::nat
	+ unfolding acc_def acc_due_def v_pres_def using v_futr_pos
	+ apply (simp add: sum_distrib_left inverse_powr add_divide_distrib)
	+ by (metis (no_types) add_diff_cancel_left' powr_add uminus_add_conv_diff)
	+
	+lemma s''_calc: "$s''^{m}_n = ((1+i)^n - 1) / $d^{m}" if "m \<noteq> 0" "i \<noteq> 0" for n m :: nat
	+proof -
	+ have "$s''^{m}_n = (1+i).^(1/m) * ((1+i)^n - 1) / $i^{m}"
	+ using s''_s s_calc times_divide_eq_right that by simp
	+ also have "\<dots> = ((1+i)^n - 1) / ($v.^(1/m) * $i^{m})"
	+ by (subst i_v, subst powr_powr, simp, subst powr_minus_divide, simp)
	+ also have "\<dots> = ((1+i)^n - 1) / $d^{m}"
	+ using d_nom_i_nom_v that by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma s''_a'': "$s''^{m}_n = (1+i)^n * $a''^{m}_n" if "m \<noteq> 0" for m::nat
	+ using that s''_s a''_a s_a by simp
	+
	+lemma a'_calc: "$a'_n = (1 - $v.^n) / $\<delta>" if "i \<noteq> 0" "n \<ge> 0" for n::real
	+ unfolding ann_cont_def
	+ apply (rule integral_unique)
	+ using has_integral_powr2_from_0[OF v_pos _ that(2)] v_delta v_1_iff_i_0 that
	+ by (smt minus_divide_divide)
	+
	+lemma a'_calc_i_0: "$a'_n = n" if "i = 0" "n \<ge> 0" for n::real
	+ unfolding ann_cont_def
	+ apply (subst iffD2[OF v_1_iff_i_0], simp add: that)
	+ by (simp add: integral_cong that)
	+
	+lemma s'_calc: "$s'_n = ((1+i).^n - 1) / $\<delta>" if "i \<noteq> 0" "n \<ge> 0" for n::real
	+ unfolding acc_cont_def
	+ apply (rule integral_unique)
	+ using has_integral_powr2_from_0[OF v_futr_pos _ that(2)] i_force_def that
	+ by simp
	+
	+lemma s'_calc_i_0: "$s'_n = n" if "i = 0" "n \<ge> 0" for n::real
	+ unfolding acc_cont_def
	+ apply (subst \<open>i = 0\<close>, simp)
	+ by (simp add: integral_cong that)
	+
	+lemma s'_a': "$s'_n = (1+i).^n * $a'_n" if "n \<ge> 0" for n::real
	+proof -
	+ have "(1+i).^n * $a'_n = integral {0..n} (\<lambda>t. (1+i).^(n-t))"
	+ unfolding ann_cont_def
	+ using integrable_on_powr2_from_0_general[of "$v" n] v_pos v_futr_pos that
	+ apply (subst integral_mult, simp)
	+ apply (rule integral_cong)
	+ unfolding v_pres_def using inverse_powr powr_add[THEN sym] by smt
	+ also have "\<dots> = $s'_n"
	+ unfolding acc_cont_def using v_futr_pos that
	+ apply (subst has_integral_interval_reverse[of 0 n, simplified, THEN integral_unique]; simp?)
	+ by (rule continuous_on_powr; auto)
	+ finally show ?thesis ..
	+qed
	+
	+lemma lim_m_a: "(\<lambda>m. $a^{m}_n) \<longlonglongrightarrow> $a'_n" for n::nat
	+proof (rule LIMSEQ_imp_Suc)
	+ show "(\<lambda>m. $a^{Suc m}_n) \<longlonglongrightarrow> $a'_n"
	+ proof (cases "i = 0")
	+ case True
	+ show ?thesis
	+ using a_calc_i_0 a'_calc_i_0 True by simp
	+ next
	+ case False
	+ show ?thesis
	+ using False v_pos delta_0_iff_i_0
	+ apply (subst a_calc; simp?)
	+ apply (subst a'_calc; simp?)
	+ apply (subst powr_realpow, simp)
	+ apply (rule tendsto_divide; simp?)
	+ by (rule LIMSEQ_Suc[OF lim_i_nom])
	+ qed
	+qed
	+
	+lemma lim_m_a'': "(\<lambda>m. $a''^{m}_n) \<longlonglongrightarrow> $a'_n" for n::nat
	+proof (rule LIMSEQ_imp_Suc)
	+ show "(\<lambda>m. $a''^{Suc m}_n) \<longlonglongrightarrow> $a'_n"
	+ proof (cases "i = 0")
	+ case True
	+ show ?thesis
	+ using a''_calc_i_0 a'_calc_i_0 True by simp
	+ next
	+ case False
	+ show ?thesis
	+ using False v_pos delta_0_iff_i_0
	+ apply (subst a''_calc; simp?)
	+ apply (subst a'_calc; simp?)
	+ apply (subst powr_realpow, simp)
	+ apply (rule tendsto_divide; simp?)
	+ by (rule LIMSEQ_Suc[OF lim_d_nom])
	+ qed
	+qed
	+
	+lemma lim_m_s: "(\<lambda>m. $s^{m}_n) \<longlonglongrightarrow> $s'_n" for n::nat
	+proof (rule LIMSEQ_imp_Suc)
	+ show "(\<lambda>m. $s^{Suc m}_n) \<longlonglongrightarrow> $s'_n"
	+ proof (cases "i = 0")
	+ case True
	+ show ?thesis
	+ using s_calc_i_0 s'_calc_i_0 True by simp
	+ next
	+ case False
	+ show ?thesis
	+ using False v_futr_pos delta_0_iff_i_0
	+ apply (subst s_calc; simp?)
	+ apply (subst s'_calc; simp?)
	+ apply (subst powr_realpow, simp)
	+ apply (rule tendsto_divide; simp?)
	+ by (rule LIMSEQ_Suc[OF lim_i_nom])
	+ qed
	+qed
	+
	+lemma lim_m_s'': "(\<lambda>m. $s''^{m}_n) \<longlonglongrightarrow> $s'_n" for n::nat
	+proof (rule LIMSEQ_imp_Suc)
	+ show "(\<lambda>m. $s''^{Suc m}_n) \<longlonglongrightarrow> $s'_n"
	+ proof (cases "i = 0")
	+ case True
	+ show ?thesis
	+ using s''_calc_i_0 s'_calc_i_0 True by simp
	+ next
	+ case False
	+ show ?thesis
	+ using False v_futr_pos delta_0_iff_i_0
	+ apply (subst s''_calc; simp?)
	+ apply (subst s'_calc; simp?)
	+ apply (subst powr_realpow, simp)
	+ apply (rule tendsto_divide; simp?)
	+ by (rule LIMSEQ_Suc[OF lim_d_nom])
	+ qed
	+qed
	+
	+lemma lim_n_a: "(\<lambda>n. $a^{m}_n) \<longlonglongrightarrow> $a^{m}_\<infinity>" if "m \<noteq> 0" "i > 0" for m::nat
	+proof -
	+ have "$i^{m} \<noteq> 0" using i_nom_pos_iff_i_pos that by smt
	+ moreover have "(\<lambda>n. $v^n) \<longlonglongrightarrow> 0"
	+ using LIMSEQ_realpow_zero[of "$v"] v_pos v_lt_1_iff_i_pos that by simp
	+ ultimately show ?thesis
	+ using that apply (subst a_calc; simp?)
	+ unfolding perp_def apply (rule tendsto_divide; simp?)
	+ using tendsto_diff[where a=1 and b=0] by auto
	+qed
	+
	+lemma lim_n_a'': "(\<lambda>n. $a''^{m}_n) \<longlonglongrightarrow> $a''^{m}_\<infinity>" if "m \<noteq> 0" "i > 0" for m::nat
	+proof -
	+ have "$d^{m} \<noteq> 0" using d_nom_pos_iff_i_pos that by smt
	+ moreover have "(\<lambda>n. $v^n) \<longlonglongrightarrow> 0"
	+ using LIMSEQ_realpow_zero[of "$v"] v_pos v_lt_1_iff_i_pos that by simp
	+ ultimately show ?thesis
	+ using that apply (subst a''_calc; simp?)
	+ unfolding perp_due_def apply (rule tendsto_divide; simp?)
	+ using tendsto_diff[where a=1 and b=0] by auto
	+qed
	+
	+lemma Ilsm_Ilam: "$(I^{l}s)^{m}_n = (1+i)^n * $(I^{l}a)^{m}_n"
	+ if "l \<noteq> 0" "m \<noteq> 0" for l n m :: nat
	+ unfolding acc_incr_def ann_incr_def v_pres_def using v_futr_pos powr_realpow
	+ apply (subst inverse_powr, simp)
	+ apply (subst sum_distrib_left)
	+ by (subst minus_real_def, subst powr_add, subst times_divide_eq_right, subst mult.assoc, simp)
	+
	+lemma Iam_calc: "$(Ia)^{m}_n = (\<Sum>j<n. (j+1)/m * (\<Sum>k=jm..<(j+1)m. $v.^((k+1)/m)))"
	+ if "m \<noteq> 0" for n m :: nat
	+proof -
	+ let ?I = "{..<n}"
	+ let ?A = "\<lambda>j. {jm..<(j+1)m}"
	+ let ?g = "\<lambda>k. $v.^((k+1::nat)/m) * \<lceil>(k+1::nat)/m\<rceil> / m"
	+ have "$(Ia)^{m}_n = (\<Sum>j<n. \<Sum>k=jm..<(j+1)m. $v.^((k+1)/m) * \<lceil>(k+1)/m\<rceil> / m)"
	+ unfolding ann_incr_def using seq_part_multiple that
	+ apply (simp only: mult_1)
	+ by (subst sum.UNION_disjoint[of ?I ?A ?g, THEN sym]; simp)
	+ also have "\<dots> = (\<Sum>j<n. (j+1)/m * (\<Sum>k=jm..<(j+1)m. $v.^((k+1)/m)))"
	+ proof -
	+ { fix j k
	+ assume "jm \<le> k \<and> k < (j+1)m"
	+ hence "jm < k+1 \<and> k+1 \<le> (j+1)m" by force
	+ hence "j < (k+1)/m \<and> (k+1)/m \<le> j+1"
	+ using pos_less_divide_eq pos_divide_le_eq of_nat_less_iff of_nat_le_iff that
	+ by (smt (verit) of_nat_le_0_iff of_nat_mult)
	+ hence "\<lceil>(k+1)/m\<rceil> = j+1"
	+ by (simp add: ceiling_unique) }
	+ hence "\<And>j k. jm \<le> k \<and> k < (j+1)m \<Longrightarrow> \<lceil>(k+1)/m\<rceil> = j+1"
	+ by (metis (no_types) of_nat_1 of_nat_add)
	+ with v_pos show ?thesis
	+ apply (intro sum.cong, simp)
	+ apply (subst sum_distrib_left, rule sum.cong; simp)
	+ by (smt (verit, ccfv_SIG) of_int_1 of_int_diff of_int_of_nat_eq)
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+lemma Ism_calc: "$(Is)^{m}_n = (\<Sum>j<n. (j+1)/m * (\<Sum>k=jm..<(j+1)m. (1+i).^(n-(k+1)/m)))"
	+ if "m \<noteq> 0" for n m :: nat
	+ using v_pos that
	+ apply (subst Ilsm_Ilam; simp)
	+ apply (subst Iam_calc[simplified]; simp?)
	+ apply ((subst sum_distrib_left, rule sum.cong; simp))+
	+ unfolding v_pres_def using v_futr_pos
	+ apply (subst inverse_powr; simp)
	+ apply (subst powr_realpow[THEN sym], simp)
	+ by (subst powr_add[THEN sym]; simp)
	+
	+lemma Imam_calc_aux: "$(I^{m}a)^{m}_n = (\<Sum>k<nm. $v.^((k+1)/m) (k+1) / m^2)"
	+ if "m \<noteq> 0" for m::nat
	+ unfolding ann_incr_def power_def
	+ apply (rule sum.cong, simp)
	+ apply (subst of_nat_mult)
	+ using v_pos that
	+ apply (subst nonzero_mult_div_cancel_left, simp)
	+ by (subst ceiling_of_nat; simp)
	+
	+lemma Imam_calc:
	+ "$(I^{m}a)^{m}_n = ($v.^(1/m) * (1 - (nm+1)$v^n + nm$v.^(n+1/m))) / (m*(1-$v.^(1/m)))^2"
	+ if "i \<noteq> 0" "m \<noteq> 0" for n m :: nat
	+proof -
	+ have \<star>: "$v.^(1/m) > 0" using v_pos by force
	+ hence "$(I^{m}a)^{m}_n = (\<Sum>k<nm. (k+1)($v.^(1/m))^(k+1)) / m^2"
	+ using that
	+ apply (subst Imam_calc_aux, simp)
	+ apply (subst sum_divide_distrib[THEN sym], simp)
	+ apply (rule sum.cong; simp)
	+ using powr_realpow[THEN sym] powr_powr by (simp add: add_divide_distrib powr_add)
	+ also have "\<dots> = $v.^(1/m) * (\<Sum>k<nm. (k+1)($v.^(1/m))^k) / m^2"
	+ by (subst sum_distrib_left, simp add: that, rule sum.cong; simp)
	+ also have "\<dots> = $v.^(1/m) *
	+ ((1 - (nm+1)($v.^(1/m))^(nm) + nm($v.^(1/m))^(nm+1)) / (1 - $v.^(1/m))^2) / m^2"
	+ using v_pos v_1_iff_i_0 that by (subst geometric_increasing_sum; simp?)
	+ also have "\<dots> = ($v.^(1/m) * (1 - (nm+1)$v^n + nm$v.^(n+1/m))) / (m*(1-$v.^(1/m)))^2"
	+ using \<star>
	+ apply (subst powr_realpow[of "$v.^(1/m)", THEN sym], simp)+
	+ apply (subst powr_powr)+
	+ apply (subst times_divide_eq_right[THEN sym], subst divide_divide_eq_left)
	+ apply (subst power_mult_distrib)
	+ using powr_eq_one_iff_gen v_pos v_1_iff_i_0 apply (simp add: field_simps)
	+ by ((subst powr_realpow, simp)+, simp)
	+ finally show ?thesis .
	+qed
	+
	+lemma Imam_calc_i_0: "$(I^{m}a)^{m}_n = (nm+1)n / (2*m)" if "i = 0" "m \<noteq> 0" for n m :: nat
	+proof -
	+ have "$(I^{m}a)^{m}_n = (\<Sum>k<nm. $v.^((k+1)/m) (k+1) / m^2)"
	+ by (subst Imam_calc_aux, simp_all add: that)
	+ also have "\<dots> = (\<Sum>k<n*m. k+1) / m^2"
	+ apply (subst v_1_iff_i_0[THEN iffD2], simp_all add: that)
	+ by (subst sum_divide_distrib[THEN sym], simp)
	+ also have "\<dots> = (nm(n*m+1) div 2) / m^2"
	+ apply (subst Suc_eq_plus1[THEN sym], subst sum_bounds_lt_plus1[of id, simplified])
	+ by (subst Sum_Icc_nat, simp)
	+ also have "\<dots> = (nm+1)n / (2*m)"
	+ apply (subst real_of_nat_div, simp)
	+ using that by (subst power2_eq_square, simp add: field_simps)
	+ finally show ?thesis .
	+qed
	+
	+lemma Imsm_calc:
	+ "$(I^{m}s)^{m}_n = ((1+i).^(n+1/m) - (nm+1)(1+i).^(1/m) + nm) / (m((1+i).^(1/m)-1))^2"
	+ if "i \<noteq> 0" "m \<noteq> 0" for n m :: nat
	+proof -
	+ have "$(I^{m}a)^{m}_n =
	+ ($v^n * ((1+i).^(n+1/m) - (nm+1)(1+i).^(1/m) + nm)) / (m((1+i).^(1/m)-1))^2"
	+ proof -
	+ have "$(I^{m}a)^{m}_n =
	+ ($v.^(1/m) * (1 - (nm+1)$v^n + nm$v.^(n+1/m))) / (m*(1-$v.^(1/m)))^2"
	+ using that by (subst Imam_calc; simp)
	+ also have "\<dots> = (1 - (nm+1)$v^n + nm$v.^(n+1/m)) / ($v.^(1/m)(m($v.^(-1/m)-1))^2)"
	+ apply (subgoal_tac "$v.^(-1/m) = 1 / $v.^(1/m)", erule ssubst)
	+ apply ((subst power2_eq_square)+, simp add: field_simps that)
	+ by (simp add: powr_minus_divide)
	+ also have "\<dots> =
	+ ($v.^(n+1/m) * ($v.^(-n-1/m) - (nm+1)$v.^(-1/m) + nm)) / ($v.^(1/m)(m*($v.^(-1/m)-1))^2)"
	+ apply (subgoal_tac "$v.^(-n-1/m) = 1 / $v.^(n+1/m)" "$v.^(-1/m) = $v^n / $v.^(n+1/m)")
	+ apply ((erule ssubst)+, simp_all add: field_simps)
	+ using v_pos
	+ apply (simp add: powr_diff[THEN sym] powr_realpow[THEN sym])
	+ by (smt powr_minus_divide)
	+ also have "\<dots> =
	+ ($v^n * ($v.^(-n-1/m) - (nm+1)$v.^(-1/m) + nm)) / ((m($v.^(-1/m)-1))^2)"
	+ apply (subst powr_add[of _ n "1/m"])
	+ using v_pos powr_realpow by simp
	+ also have "\<dots> =
	+ ($v^n * ((1+i).^(n+1/m) - (nm+1)(1+i).^(1/m) + nm)) / ((m((1+i).^(1/m)-1))^2)"
	+ apply (subgoal_tac "-n-1/m = -(n+1/m)" "-1/m = -(1/m)", (erule ssubst)+)
	+ apply (subst i_v_powr[THEN sym])+
	+ by simp_all
	+ finally show ?thesis .
	+ qed
	+ thus ?thesis
	+ apply -
	+ using that v_futr_pos
	+ apply (subst Ilsm_Ilam, simp)
	+ apply (erule ssubst, simp)
	+ apply (rule disjI2)
	+ by (subst power_mult_distrib[THEN sym], simp add: v_pres_def)
	+qed
	+
	+lemma Imsm_calc_i_0: "$(I^{m}s)^{m}_n = (nm+1)n / (2*m)" if "i = 0" "m \<noteq> 0" for n m :: nat
	+ using that
	+ apply (subst Ilsm_Ilam, simp)
	+ by (subst Imam_calc_i_0; simp)
	+
	+lemma Ila''m_Ilam: "$(I^{l}a'')^{m}_n = (1+i).^(1/m) * $(I^{l}a)^{m}_n"
	+ if "l \<noteq> 0" "m \<noteq> 0" for l m n :: nat
	+ unfolding ann_incr_def ann_due_incr_def using that
	+ apply (subst i_v, subst powr_powr, simp)
	+ apply (subst sum_distrib_left)
	+ apply (rule sum.cong; simp)
	+ apply (rule disjI2)
	+ by (smt (verit) add_divide_distrib powr_add)
	+
	+lemma Ia''m_calc: "$(Ia'')^{m}_n = (\<Sum>j<n. (j+1)/m * (\<Sum>k=jm..<(j+1)m. $v.^(k/m)))"
	+ if "m \<noteq> 0" for n m :: nat
	+ using that
	+ apply (subst Ila''m_Ilam; simp del: One_nat_def)
	+ apply (subst Iam_calc; simp)
	+ apply (subst sum_distrib_left)
	+ apply (rule sum.cong; simp)
	+ apply (subst sum_distrib_left)+
	+ apply (rule sum.cong; simp)
	+ apply (subst i_v_powr)
	+ using powr_add[of "$v", THEN sym] by (simp add: field_simps)
	+
	+lemma Ima''m_calc_aux: "$(I^{m}a'')^{m}_n = (\<Sum>k<nm. $v.^(k/m) (k+1) / m^2)"
	+ if "m \<noteq> 0" for m::nat
	+ using that
	+ apply (subst Ila''m_Ilam, simp)
	+ apply (subst Imam_calc_aux, simp)
	+ apply (subst sum_distrib_left)
	+ apply (rule sum.cong; simp)
	+ using powr_add[of "$v", THEN sym] i_v_powr by (simp add: field_simps)
	+
	+lemma Ima''m_calc: "$(I^{m}a'')^{m}_n = (1 - (nm+1)$v^n + nm$v.^(n+1/m)) / (m*(1-$v.^(1/m)))^2"
	+ if "i \<noteq> 0" "m \<noteq> 0" for n m :: nat
	+ using that v_pos
	+ apply (subst Ila''m_Ilam, simp)
	+ apply (subst Imam_calc; simp)
	+ by (smt (verit, del_insts) i_v_powr powr_add powr_zero_eq_one)
	+
	+lemma Ils''m_Ilsm: "$(I^{l}s'')^{m}_n = (1+i).^(1/m) * $(I^{l}s)^{m}_n"
	+ if "l \<noteq> 0" "m \<noteq> 0" for l m n :: nat
	+ unfolding acc_incr_def acc_due_incr_def sum_distrib_left using that
	+ apply (intro sum.cong; simp)
	+ by (smt (verit, ccfv_SIG) add_divide_distrib powr_add)
	+
	+lemma Ims''m_calc:
	+ "$(I^{m}s'')^{m}_n =
	+ (1+i).^(1/m) * ((1+i).^(n+1/m) - (nm+1)(1+i).^(1/m) + nm) / (m((1+i).^(1/m)-1))^2"
	+ if "i \<noteq> 0" "m \<noteq> 0" for n m :: nat
	+ using that by (simp add: Ils''m_Ilsm Imsm_calc)
	+
	+lemma lim_Imam: "(\<lambda>n. $(I^{m}a)^{m}_n) \<longlonglongrightarrow> 1 / ($i^{m}*$d^{m})" if "m \<noteq> 0" "i > 0" for m::nat
	+proof -
	+ have "(\<lambda>n. $(I^{m}a)^{m}_n) =
	+ (\<lambda>n. $v.^(1/m) * (1 - (nm+1)$v^n + nm$v.^(n+1/m)) / (m*(1-$v.^(1/m)))^2)"
	+ using that by (subst Imam_calc; simp)
	+ moreover have "(\<lambda>n. $v.^(1/m) * (1 - (nm+1)$v^n + nm$v.^(n+1/m)) / (m*(1-$v.^(1/m)))^2)
	+ \<longlonglongrightarrow> 1 / ($i^{m}*$d^{m})"
	+ proof -
	+ have \<star>: "\<bar>$v\<bar> < 1"
	+ using v_lt_1_iff_i_pos v_pos that by force
	+ hence "(\<lambda>n. (nm+1)$v^n) \<longlonglongrightarrow> 0"
	+ apply (subst tendsto_cong[of _ "(\<lambda>n. nm$v^n + $v^n)"])
	+ apply (rule always_eventually, rule allI)
	+ apply (simp add: distrib_right)
	+ apply (subgoal_tac "0 = 0 + 0", erule ssubst, intro tendsto_intros; simp)
	+ apply (subst mult.commute, subst mult.assoc)
	+ apply (subgoal_tac "0 = real m * 0", erule ssubst, intro tendsto_intros; simp?)
	+ by (rule powser_times_n_limit_0; simp)
	+ moreover have "(\<lambda>n. nm$v.^(n+1/m)) \<longlonglongrightarrow> 0"
	+ apply (subst tendsto_cong[of _ "(\<lambda>n. (m$v.^(1/m))(n*$v^n))"])
	+ apply (rule always_eventually, rule allI)
	+ apply (simp add: powr_add powr_realpow v_pos)
	+ apply (subgoal_tac "0 = m$v.^(1/m) 0", erule ssubst, intro tendsto_intros; simp?)
	+ by (rule powser_times_n_limit_0, simp add: \<star>)
	+ ultimately have "(\<lambda>n. $v.^(1/m) * (1 - (nm+1)$v^n + nm$v.^(n+1/m)) / (m*(1-$v.^(1/m)))^2)
	+ \<longlonglongrightarrow> $v.^(1/m) * (1 - 0 + 0)/ (m*(1-$v.^(1/m)))^2"
	+ using v_lt_1_iff_i_pos v_pos that by (intro tendsto_intros; simp)
	+ thus ?thesis
	+ unfolding i_nom_def using v_pos that
	+ apply (subst i_v_powr, subst powr_minus_divide, subst d_nom_v; simp)
	+ by (subst(asm)(2) power2_eq_square, simp add: field_simps)
	+ qed
	+ ultimately show ?thesis by simp
	+qed
	+
	+lemma perp_incr_calc: "$(I^{m}a)^{m}_\<infinity> = 1 / ($i^{m}*$d^{m})" if "m \<noteq> 0" "i > 0" for m::nat
	+ unfolding perp_incr_def by (rule limI, rule lim_Imam; simp add: that)
	+
	+lemma lim_Ima''m: "(\<lambda>n. $(I^{m}a'')^{m}_n) \<longlonglongrightarrow> 1 / ($d^{m})^2" if "m \<noteq> 0" "i > 0" for m::nat
	+ unfolding perp_due_incr_def using that
	+ apply (subst Ila''m_Ilam, simp, subst mult.commute, subst i_v_powr, subst powr_minus_divide)
	+ apply (subgoal_tac "1/($d^{m})^2 = (1/($i^{m}$d^{m}))(1/$v.^(1/m))", erule ssubst)
	+ apply (intro tendsto_intros, simp add: lim_Imam)
	+ by (simp add: d_nom_i_nom_v power2_eq_square)
	+
	+lemma perp_due_incr_calc: "$(I^{m}a'')^{m}_\<infinity> = 1 / ($d^{m})^2" if "m \<noteq> 0" "i > 0" for m::nat
	+ unfolding perp_due_incr_def by (rule limI, rule lim_Ima''m; simp add: that)
	+
	+end
	+
	+end
	diff --git a/thys/Actuarial_Mathematics/Preliminaries.thy b/thys/Actuarial_Mathematics/Preliminaries.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Actuarial_Mathematics/Preliminaries.thy
	@@ -0,0 +1,183 @@
	+theory Preliminaries
	+ imports "HOL-Analysis.Analysis"
	+begin
	+
	+notation powr (infixr ".^" 80)
	+
	+
	+section \<open>Preliminary Definitions and Lemmas\<close>
	+
	+lemma seq_part_multiple: fixes m n :: nat assumes "m \<noteq> 0" defines "A \<equiv> \<lambda>i::nat. {im ..< (i+1)m}"
	+ shows "\<forall>i j. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}" and "(\<Union>i<n. A i) = {..< n*m}"
	+proof -
	+ { fix i j :: nat
	+ have "i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
	+ proof (erule contrapos_np)
	+ assume "A i \<inter> A j \<noteq> {}"
	+ then obtain k where "k \<in> A i \<inter> A j" by blast
	+ hence "im < (j+1)m \<and> jm < (i+1)m" unfolding A_def by force
	+ hence "i < j+1 \<and> j < i+1" using mult_less_cancel2 by blast
	+ thus "i = j" by force
	+ qed }
	+ thus "\<forall>i j. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}" by blast
	+next
	+ show "(\<Union>i<n. A i) = {..< n*m}"
	+ proof
	+ show "(\<Union>i<n. A i) \<subseteq> {..< n*m}"
	+ proof
	+ fix x::nat
	+ assume "x \<in> (\<Union>i<n. A i)"
	+ then obtain i where i_n: "i < n" and i_x: "x < (i+1)*m" unfolding A_def by force
	+ hence "i+1 \<le> n" by linarith
	+ hence "x < n*m" by (meson less_le_trans mult_le_cancel2 i_x)
	+ thus "x \<in> {..< n*m}"
	+ using diff_mult_distrib mult_1 i_n by auto
	+ qed
	+ next
	+ show "{..< n*m} \<subseteq> (\<Union>i<n. A i)"
	+ proof
	+ fix x::nat
	+ let ?i = "x div m"
	+ assume "x \<in> {..< n*m}"
	+ hence "?i < n" by (simp add: less_mult_imp_div_less)
	+ moreover have "?im \<le> x \<and> x < (?i+1)m"
	+ using assms div_times_less_eq_dividend dividend_less_div_times by auto
	+ ultimately show "x \<in> (\<Union>i<n. A i)" unfolding A_def by force
	+ qed
	+ qed
	+qed
	+
	+lemma(in field) divide_mult_cancel[simp]: fixes a b assumes "b \<noteq> 0"
	+ shows "a / b * b = a"
	+ by (simp add: assms)
	+
	+lemma inverse_powr: "(1/a).^b = a.^-b" if "a > 0" for a b :: real
	+ by (smt that powr_divide powr_minus_divide powr_one_eq_one)
	+
	+lemma powr_eq_one_iff_gen[simp]: "a.^x = 1 \<longleftrightarrow> x = 0" if "a > 0" "a \<noteq> 1" for a x :: real
	+ by (metis powr_eq_0_iff powr_inj powr_zero_eq_one that)
	+
	+lemma powr_less_cancel2: "0 < a \<Longrightarrow> 0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x.^a < y.^a \<Longrightarrow> x < y"
	+ for a x y ::real
	+proof -
	+ assume a_pos: "0 < a" and x_pos: "0 < x" and y_pos: "0 < y"
	+ show "x.^a < y.^a \<Longrightarrow> x < y"
	+ proof (erule contrapos_pp)
	+ assume "\<not> x < y"
	+ hence "x \<ge> y" by fastforce
	+ hence "x.^a \<ge> y.^a"
	+ proof (cases "x = y")
	+ case True
	+ thus ?thesis by simp
	+ next
	+ case False
	+ hence "x.^a > y.^a"
	+ using \<open>x \<ge> y\<close> powr_less_mono2 a_pos y_pos by auto
	+ thus ?thesis by auto
	+ qed
	+ thus "\<not> x.^a < y.^a" by fastforce
	+ qed
	+qed
	+
	+lemma geometric_increasing_sum_aux: "(1-r)^2 * (\<Sum>k<n. (k+1)r^k) = 1 - (n+1)r^n + n*r^(n+1)"
	+ for n::nat and r::real
	+proof (induct n)
	+ case 0
	+ thus ?case by simp
	+next
	+ case (Suc n)
	+ thus ?case
	+ by (simp add: distrib_left power2_diff field_simps power2_eq_square)
	+qed
	+
	+lemma geometric_increasing_sum: "(\<Sum>k<n. (k+1)r^k) = (1 - (n+1)r^n + n*r^(n+1)) / (1-r)^2"
	+ if "r \<noteq> 1" for n::nat and r::real
	+ by (subst geometric_increasing_sum_aux[THEN sym], simp add: that)
	+
	+lemma Reals_UNIV[simp]: "\<real> = {x::real. True}"
	+ unfolding Reals_def by auto
	+
	+lemma DERIV_fun_powr2:
	+ fixes a::real
	+ assumes a_pos: "a > 0"
	+ and f: "DERIV f x :> r"
	+ shows "DERIV (\<lambda>x. a.^(f x)) x :> a.^(f x) * r * ln a"
	+proof -
	+ let ?g = "(\<lambda>x. a)"
	+ have g: "DERIV ?g x :> 0" by simp
	+ have pos: "?g x > 0" by (simp add: a_pos)
	+ show ?thesis
	+ using DERIV_powr[OF g pos f] a_pos by (auto simp add: field_simps)
	+qed
	+
	+lemma has_real_derivative_powr2:
	+ assumes a_pos: "a > 0"
	+ shows "((\<lambda>x. a.^x) has_real_derivative a.^x * ln a) (at x)"
	+proof -
	+ let ?f = "(\<lambda>x. x::real)"
	+ have f: "DERIV ?f x :> 1" by simp
	+ thus ?thesis using DERIV_fun_powr2[OF a_pos f] by simp
	+qed
	+
	+lemma has_integral_powr2_from_0:
	+ fixes a c :: real
	+ assumes a_pos: "a > 0" and a_neq_1: "a \<noteq> 1" and c_nneg: "c \<ge> 0"
	+ shows "((\<lambda>x. a.^x) has_integral ((a.^c - 1) / (ln a))) {0..c}"
	+proof -
	+ have "((\<lambda>x. a.^x) has_integral ((a.^c)/(ln a) - (a.^0)/(ln a))) {0..c}"
	+ proof (rule fundamental_theorem_of_calculus[OF c_nneg])
	+ fix x::real
	+ assume "x \<in> {0..c}"
	+ show "((\<lambda>y. a.^y / ln a) has_vector_derivative a.^x) (at x within {0..c})"
	+ using has_real_derivative_powr2[OF a_pos, of x]
	+ apply -
	+ apply (drule DERIV_cdivide[where c = "ln a"], simp add: assms)
	+ apply (rule has_vector_derivative_within_subset[where S=UNIV and T="{0..c}"], auto)
	+ by (rule iffD1[OF has_field_derivative_iff_has_vector_derivative])
	+ qed
	+ thus ?thesis
	+ using assms powr_zero_eq_one by (simp add: field_simps)
	+qed
	+
	+lemma integrable_on_powr2_from_0:
	+ fixes a c :: real
	+ assumes a_pos: "a > 0" and a_neq_1: "a \<noteq> 1" and c_nneg: "c \<ge> 0"
	+ shows "(\<lambda>x. a.^x) integrable_on {0..c}"
	+ using has_integral_powr2_from_0[OF assms] unfolding integrable_on_def by blast
	+
	+lemma integrable_on_powr2_from_0_general:
	+ fixes a c :: real
	+ assumes a_pos: "a > 0" and c_nneg: "c \<ge> 0"
	+ shows "(\<lambda>x. a.^x) integrable_on {0..c}"
	+proof (cases "a = 1")
	+ case True
	+ thus ?thesis
	+ using has_integral_const_real by auto
	+next
	+ case False
	+ thus ?thesis
	+ using has_integral_powr2_from_0 False assms by auto
	+qed
	+
	+lemma has_integral_null_interval: fixes a b :: real and f::"real \<Rightarrow> real" assumes "a \<ge> b"
	+ shows "(f has_integral 0) {a..b}"
	+ using assms content_real_eq_0 by blast
	+
	+lemma has_integral_interval_reverse: fixes f :: "real \<Rightarrow> real" and a b :: real
	+ assumes "a \<le> b"
	+ and "continuous_on {a..b} f"
	+ shows "((\<lambda>x. f (a+b-x)) has_integral (integral {a..b} f)) {a..b}"
	+proof -
	+ let ?g = "\<lambda>x. a + b - x"
	+ let ?g' = "\<lambda>x. -1"
	+ have g_C0: "continuous_on {a..b} ?g" using continuous_on_op_minus by simp
	+ have Dg_g': "\<And>x. x\<in>{a..b} \<Longrightarrow> (?g has_field_derivative ?g' x) (at x within {a..b})"
	+ by (auto intro!: derivative_eq_intros)
	+ show ?thesis
	+ using has_integral_substitution_general
	+ [of "{}" a b ?g a b f, simplified, OF assms g_C0 Dg_g', simplified]
	+ apply (simp add: has_integral_null_interval[OF assms(1), THEN integral_unique])
	+ by (simp add: has_integral_neg_iff)
	+qed
	+
	+end
	diff --git a/thys/Actuarial_Mathematics/ROOT b/thys/Actuarial_Mathematics/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Actuarial_Mathematics/ROOT
	@@ -0,0 +1,9 @@
	+chapter AFP
	+
	+session "Actuarial_Mathematics" (AFP) = "HOL-Analysis" +
	+ options [timeout = 300]
	+ theories
	+ Preliminaries
	+ Interest
	+ document_files
	+ "root.tex"
	diff --git a/thys/Actuarial_Mathematics/document/root.tex b/thys/Actuarial_Mathematics/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Actuarial_Mathematics/document/root.tex
	@@ -0,0 +1,70 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amsfonts, amsmath, amssymb}
	+
	+%\usepackage{eurosym}
	+ %for \<euro>
	+
	+%\usepackage[only,bigsqcap,bigparallel,fatsemi,interleave,sslash]{stmaryrd}
	+ %for \<Sqinter>, \<Parallel>, \<Zsemi>, \<Parallel>, \<sslash>
	+
	+%\usepackage{eufrak}
	+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
	+
	+%\usepackage{textcomp}
	+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	+ %\<currency>
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+% for uniform font size
	+%\renewcommand{\isastyle}{\isastyleminor}
	+
	+
	+\begin{document}
	+
	+\title{Actuarial Mathematics}
	+\author{Yosuke Ito}
	+\maketitle
	+
	+\begin{abstract}
	+ Actuarial Mathematics is a theory in applied mathematics,
	+ which is mainly used for determining the prices of insurance products
	+ and evaluating the liability of a company associating with insurance contracts.
	+ It is related to calculus, probability theory and financial theory, etc.
	+
	+ In this entry, I formalize the very basic part of Actuarial Mathematics in Isabelle/HOL.
	+ The first formalization is about the theory of interest
	+ which deals with interest rates, present value factors, an annuity certain, etc.
	+
	+ I have already formalized the basic part of Actuarial Mathematics in Coq
	+ (https://github.com/Yosuke-Ito-345/Actuary).
	+ This entry is currently the partial translation and
	+ a little generalization of the Coq formalization.
	+ The further translation in Isabelle/HOL is now proceeding.
	+\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/Banach_Steinhaus/Banach_Steinhaus_Missing.thy b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
	--- a/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
	+++ b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
	@@ -1,899 +1,899 @@
	(*
	File: Banach_Steinhaus_Missing.thy
	Author: Dominique Unruh, University of Tartu
	Author: Jose Manuel Rodriguez Caballero, University of Tartu
	*)
	section \<open>Missing results for the proof of Banach-Steinhaus theorem\<close>

	theory Banach_Steinhaus_Missing
	imports
	"HOL-Analysis.Bounded_Linear_Function"
	"HOL-Analysis.Line_Segment"

	begin
	subsection \<open>Results missing for the proof of Banach-Steinhaus theorem\<close>
	text \<open>
	The results proved here are preliminaries for the proof of Banach-Steinhaus theorem using Sokal's
	- approach, but they do not explicitly appear in Sokal's paper ~\cite{sokal2011reall}.
	+ approach, but they do not explicitly appear in Sokal's paper @{cite sokal2011really}.
	\<close>

	text\<open>Notation for the norm\<close>
	bundle notation_norm begin
	notation norm ("\<parallel>_\<parallel>")
	end

	bundle no_notation_norm begin
	no_notation norm ("\<parallel>_\<parallel>")
	end

	unbundle notation_norm

	text\<open>Notation for apply bilinear function\<close>
	bundle notation_blinfun_apply begin
	notation blinfun_apply (infixr "*\<^sub>v" 70)
	end

	bundle no_notation_blinfun_apply begin
	no_notation blinfun_apply (infixr "*\<^sub>v" 70)
	end

	unbundle notation_blinfun_apply

	lemma bdd_above_plus:
	fixes f::\<open>'a \<Rightarrow> real\<close>
	assumes \<open>bdd_above (f ` S)\<close> and \<open>bdd_above (g ` S)\<close>
	shows \<open>bdd_above ((\<lambda> x. f x + g x) ` S)\<close>
	text \<open>
	Explanation: If the images of two real-valued functions \<^term>\<open>f\<close>,\<^term>\<open>g\<close> are bounded above on a
	set \<^term>\<open>S\<close>, then the image of their sum is bounded on \<^term>\<open>S\<close>.
	\<close>
	proof-
	obtain M where \<open>\<And> x. x\<in>S \<Longrightarrow> f x \<le> M\<close>
	using \<open>bdd_above (f ` S)\<close> unfolding bdd_above_def by blast
	obtain N where \<open>\<And> x. x\<in>S \<Longrightarrow> g x \<le> N\<close>
	using \<open>bdd_above (g ` S)\<close> unfolding bdd_above_def by blast
	have \<open>\<And> x. x\<in>S \<Longrightarrow> f x + g x \<le> M + N\<close>
	using \<open>\<And>x. x \<in> S \<Longrightarrow> f x \<le> M\<close> \<open>\<And>x. x \<in> S \<Longrightarrow> g x \<le> N\<close> by fastforce
	thus ?thesis unfolding bdd_above_def by blast
	qed

	text\<open>The maximum of two functions\<close>
	definition pointwise_max:: "('a \<Rightarrow> 'b::ord) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
	\<open>pointwise_max f g = (\<lambda>x. max (f x) (g x))\<close>

	lemma max_Sup_absorb_left:
	fixes f g::\<open>'a \<Rightarrow> real\<close>
	assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close> and \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>
	shows \<open>Sup ((pointwise_max f g) ` X) = Sup (f ` X)\<close>

	text \<open>Explanation: For real-valued functions \<^term>\<open>f\<close> and \<^term>\<open>g\<close>, if the supremum of \<^term>\<open>f\<close> is
	greater-equal the supremum of \<^term>\<open>g\<close>, then the supremum of \<^term>\<open>max f g\<close> equals the supremum of
	\<^term>\<open>f\<close>. (Under some technical conditions.)\<close>

	proof-
	have y_Sup: \<open>y \<in> ((\<lambda> x. max (f x) (g x)) ` X) \<Longrightarrow> y \<le> Sup (f ` X)\<close> for y
	proof-
	assume \<open>y \<in> ((\<lambda> x. max (f x) (g x)) ` X)\<close>
	then obtain x where \<open>y = max (f x) (g x)\<close> and \<open>x \<in> X\<close>
	by blast
	have \<open>f x \<le> Sup (f ` X)\<close>
	by (simp add: \<open>x \<in> X\<close> \<open>bdd_above (f ` X)\<close> cSUP_upper)
	moreover have \<open>g x \<le> Sup (g ` X)\<close>
	by (simp add: \<open>x \<in> X\<close> \<open>bdd_above (g ` X)\<close> cSUP_upper)
	ultimately have \<open>max (f x) (g x) \<le> Sup (f ` X)\<close>
	using \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close> by auto
	thus ?thesis by (simp add: \<open>y = max (f x) (g x)\<close>)
	qed
	have y_f_X: \<open>y \<in> f ` X \<Longrightarrow> y \<le> Sup ((\<lambda> x. max (f x) (g x)) ` X)\<close> for y
	proof-
	assume \<open>y \<in> f ` X\<close>
	then obtain x where \<open>x \<in> X\<close> and \<open>y = f x\<close>
	by blast
	have \<open>bdd_above ((\<lambda> \<xi>. max (f \<xi>) (g \<xi>)) ` X)\<close>
	by (metis (no_types) \<open>bdd_above (f ` X)\<close> \<open>bdd_above (g ` X)\<close> bdd_above_image_sup sup_max)
	moreover have \<open>e > 0 \<Longrightarrow> \<exists> k \<in> (\<lambda> \<xi>. max (f \<xi>) (g \<xi>)) ` X. y \<le> k + e\<close>
	for e::real
	using \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close> by (smt \<open>x \<in> X\<close> \<open>y = f x\<close> image_eqI)
	ultimately show ?thesis
	using \<open>x \<in> X\<close> \<open>y = f x\<close> cSUP_upper by fastforce
	qed
	have \<open>Sup ((\<lambda> x. max (f x) (g x)) ` X) \<le> Sup (f ` X)\<close>
	using y_Sup by (simp add: \<open>X \<noteq> {}\<close> cSup_least)
	moreover have \<open>Sup ((\<lambda> x. max (f x) (g x)) ` X) \<ge> Sup (f ` X)\<close>
	using y_f_X by (metis (mono_tags) cSup_least calculation empty_is_image)
	ultimately show ?thesis unfolding pointwise_max_def by simp
	qed

	lemma max_Sup_absorb_right:
	fixes f g::\<open>'a \<Rightarrow> real\<close>
	assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close> and \<open>Sup (f ` X) \<le> Sup (g ` X)\<close>
	shows \<open>Sup ((pointwise_max f g) ` X) = Sup (g ` X)\<close>
	text \<open>
	Explanation: For real-valued functions \<^term>\<open>f\<close> and \<^term>\<open>g\<close> and a nonempty set \<^term>\<open>X\<close>, such that
	the \<^term>\<open>f\<close> and \<^term>\<open>g\<close> are bounded above on \<^term>\<open>X\<close>, if the supremum of \<^term>\<open>f\<close> on \<^term>\<open>X\<close> is
	lower-equal the supremum of \<^term>\<open>g\<close> on \<^term>\<open>X\<close>, then the supremum of \<^term>\<open>pointwise_max f g\<close> on \<^term>\<open>X\<close>
	equals the supremum of \<^term>\<open>g\<close>. This is the right analog of @{text max_Sup_absorb_left}.
	\<close>
	proof-
	have \<open>Sup ((pointwise_max g f) ` X) = Sup (g ` X)\<close>
	using assms by (simp add: max_Sup_absorb_left)
	moreover have \<open>pointwise_max g f = pointwise_max f g\<close>
	unfolding pointwise_max_def by auto
	ultimately show ?thesis by simp
	qed

	lemma max_Sup:
	fixes f g::\<open>'a \<Rightarrow> real\<close>
	assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close>
	shows \<open>Sup ((pointwise_max f g) ` X) = max (Sup (f ` X)) (Sup (g ` X))\<close>
	text \<open>
	Explanation: Let \<^term>\<open>X\<close> be a nonempty set. Two supremum over \<^term>\<open>X\<close> of the maximum of two
	real-value functions is equal to the maximum of their suprema over \<^term>\<open>X\<close>, provided that the
	functions are bounded above on \<^term>\<open>X\<close>.
	\<close>
	proof(cases \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>)
	case True thus ?thesis by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_left)
	next
	case False
	have f1: "\<not> 0 \<le> Sup (f ` X) + - 1 * Sup (g ` X)"
	using False by linarith
	hence "Sup (Banach_Steinhaus_Missing.pointwise_max f g ` X) = Sup (g ` X)"
	by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_right)
	thus ?thesis
	using f1 by linarith
	qed


	lemma identity_telescopic:
	fixes x :: \<open>_ \<Rightarrow> 'a::real_normed_vector\<close>
	assumes \<open>x \<longlonglongrightarrow> l\<close>
	shows \<open>(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) \<longlonglongrightarrow> l - x n\<close>
	text\<open>
	Expression of a limit as a telescopic series.
	Explanation: If \<^term>\<open>x\<close> converges to \<^term>\<open>l\<close> then the sum \<^term>\<open>sum (\<lambda> k. x (Suc k) - x k) {n..N}\<close>
	converges to \<^term>\<open>l - x n\<close> as \<^term>\<open>N\<close> goes to infinity.
	\<close>
	proof-
	have \<open>(\<lambda> p. x (p + Suc n)) \<longlonglongrightarrow> l\<close>
	using \<open>x \<longlonglongrightarrow> l\<close> by (rule LIMSEQ_ignore_initial_segment)
	hence \<open>(\<lambda> p. x (Suc n + p)) \<longlonglongrightarrow> l\<close>
	by (simp add: add.commute)
	hence \<open>(\<lambda> p. x (Suc (n + p))) \<longlonglongrightarrow> l\<close>
	by simp
	hence \<open>(\<lambda> t. (- (x n)) + (\<lambda> p. x (Suc (n + p))) t ) \<longlonglongrightarrow> (- (x n)) + l\<close>
	using tendsto_add_const_iff by metis
	hence f1: \<open>(\<lambda> p. x (Suc (n + p)) - x n)\<longlonglongrightarrow> l - x n\<close>
	by simp
	have \<open>sum (\<lambda> k. x (Suc k) - x k) {n..n+p} = x (Suc (n+p)) - x n\<close> for p
	by (simp add: sum_Suc_diff)
	moreover have \<open>(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (n + t)
	= (\<lambda> p. sum (\<lambda> k. x (Suc k) - x k) {n..n+p}) t\<close> for t
	by blast
	ultimately have \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (n + p)) \<longlonglongrightarrow> l - x n\<close>
	using f1 by simp
	hence \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (p + n)) \<longlonglongrightarrow> l - x n\<close>
	by (simp add: add.commute)
	hence \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) p) \<longlonglongrightarrow> l - x n\<close>
	using Topological_Spaces.LIMSEQ_offset[where f = "(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N})"
	and a = "l - x n" and k = n] by blast
	hence \<open>(\<lambda> M. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) M) \<longlonglongrightarrow> l - x n\<close>
	by simp
	thus ?thesis by blast
	qed

	lemma bound_Cauchy_to_lim:
	assumes \<open>y \<longlonglongrightarrow> x\<close> and \<open>\<And>n. \<parallel>y (Suc n) - y n\<parallel> \<le> c^n\<close> and \<open>y 0 = 0\<close> and \<open>c < 1\<close>
	shows \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * c ^ n\<close>
	text\<open>
	Inequality about a sequence of approximations assuming that the sequence of differences is bounded
	by a geometric progression.
	Explanation: Let \<^term>\<open>y\<close> be a sequence converging to \<^term>\<open>x\<close>.
	If \<^term>\<open>y\<close> satisfies the inequality \<open>\<parallel>y (Suc n) - y n\<parallel> \<le> c ^ n\<close> for some \<^term>\<open>c < 1\<close> and
	assuming \<^term>\<open>y 0 = 0\<close> then the inequality \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * c ^ n\<close> holds.
	\<close>
	proof-
	have \<open>c \<ge> 0\<close>
	using \<open>\<And> n. \<parallel>y (Suc n) - y n\<parallel> \<le> c^n\<close> by (smt norm_imp_pos_and_ge power_Suc0_right)
	have norm_1: \<open>norm (\<Sum>k = Suc n..N. y (Suc k) - y k) \<le> (c ^ Suc n)/(1 - c)\<close> for N
	proof(cases \<open>N < Suc n\<close>)
	case True
	hence \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> = 0\<close>
	by auto
	thus ?thesis using \<open>c \<ge> 0\<close> \<open>c < 1\<close> by auto
	next
	case False
	hence \<open>N \<ge> Suc n\<close>
	by auto
	have \<open>c^(Suc N) \<ge> 0\<close>
	using \<open>c \<ge> 0\<close> by auto
	have \<open>1 - c > 0\<close>
	by (simp add: \<open>c < 1\<close>)
	hence \<open>(1 - c)/(1 - c) = 1\<close>
	by auto
	have \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> \<le> (sum (\<lambda>k. \<parallel>y (Suc k) - y k\<parallel>) {Suc n .. N})\<close>
	by (simp add: sum_norm_le)
	hence \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> \<le> (sum (power c) {Suc n .. N})\<close>
	by (simp add: assms(2) sum_norm_le)
	hence \<open>(1 - c) * \<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel>
	\<le> (1 - c) * (sum (power c) {Suc n .. N})\<close>
	using \<open>0 < 1 - c\<close> mult_le_cancel_iff2 by blast
	also have \<open>\<dots> = c^(Suc n) - c^(Suc N)\<close>
	using Set_Interval.sum_gp_multiplied \<open>Suc n \<le> N\<close> by blast
	also have \<open>\<dots> \<le> c^(Suc n)\<close>
	using \<open>c^(Suc N) \<ge> 0\<close> by auto
	finally have \<open>(1 - c) * \<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel> \<le> c ^ Suc n\<close>
	by blast
	hence \<open>((1 - c) * \<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel>)/(1 - c)
	\<le> (c ^ Suc n)/(1 - c)\<close>
	using \<open>0 < 1 - c\<close> by (smt divide_right_mono)
	thus \<open>\<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
	using \<open>0 < 1 - c\<close> by auto
	qed
	have \<open>(\<lambda> N. (sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N})) \<longlonglongrightarrow> x - y (Suc n)\<close>
	by (metis (no_types) \<open>y \<longlonglongrightarrow> x\<close> identity_telescopic)
	hence \<open>(\<lambda> N. \<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel>) \<longlonglongrightarrow> \<parallel>x - y (Suc n)\<parallel>\<close>
	using tendsto_norm by blast
	hence \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
	using norm_1 Lim_bounded by blast
	hence \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
	by auto
	moreover have \<open>(c ^ Suc n)/(1 - c) = (c / (1 - c)) * (c ^ n)\<close>
	by (simp add: divide_inverse_commute)
	ultimately show \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * (c ^ n)\<close> by linarith
	qed

	lemma onorm_open_ball:
	includes notation_norm
	shows \<open>\<parallel>f\<parallel> = Sup { \<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1 }\<close>
	text \<open>
	Explanation: Let \<^term>\<open>f\<close> be a bounded linear operator. The operator norm of \<^term>\<open>f\<close> is the
	supremum of \<^term>\<open>norm (f x)\<close> for \<^term>\<open>x\<close> such that \<^term>\<open>norm x < 1\<close>.
	\<close>
	proof(cases \<open>(UNIV::'a set) = 0\<close>)
	case True
	hence \<open>x = 0\<close> for x::'a
	by auto
	hence \<open>f *\<^sub>v x = 0\<close> for x
	by (metis (full_types) blinfun.zero_right)
	hence \<open>\<parallel>f\<parallel> = 0\<close>
	by (simp add: blinfun_eqI zero_blinfun.rep_eq)
	have \<open>{ \<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1} = {0}\<close>
	by (smt Collect_cong \<open>\<And>x. f *\<^sub>v x = 0\<close> norm_zero singleton_conv)
	hence \<open>Sup { \<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1} = 0\<close>
	by simp
	thus ?thesis using \<open>\<parallel>f\<parallel> = 0\<close> by auto
	next
	case False
	hence \<open>(UNIV::'a set) \<noteq> 0\<close>
	by simp
	have nonnegative: \<open>\<parallel>f *\<^sub>v x\<parallel> \<ge> 0\<close> for x
	by simp
	have \<open>\<exists> x::'a. x \<noteq> 0\<close>
	using \<open>UNIV \<noteq> 0\<close> by auto
	then obtain x::'a where \<open>x \<noteq> 0\<close>
	by blast
	hence \<open>\<parallel>x\<parallel> \<noteq> 0\<close>
	by auto
	define y where \<open>y = x /\<^sub>R \<parallel>x\<parallel>\<close>
	have \<open>norm y = \<parallel> x /\<^sub>R \<parallel>x\<parallel> \<parallel>\<close>
	unfolding y_def by auto
	also have \<open>\<dots> = \<parallel>x\<parallel> /\<^sub>R \<parallel>x\<parallel>\<close>
	by auto
	also have \<open>\<dots> = 1\<close>
	using \<open>\<parallel>x\<parallel> \<noteq> 0\<close> by auto
	finally have \<open>\<parallel>y\<parallel> = 1\<close>
	by blast
	hence norm_1_non_empty: \<open>{ \<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1} \<noteq> {}\<close>
	by blast
	have norm_1_bounded: \<open>bdd_above { \<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close>
	unfolding bdd_above_def apply auto
	by (metis norm_blinfun)
	have norm_less_1_non_empty: \<open>{\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1} \<noteq> {}\<close>
	by (metis (mono_tags, lifting) Collect_empty_eq_bot bot_empty_eq empty_iff norm_zero
	zero_less_one)
	have norm_less_1_bounded: \<open>bdd_above {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close>
	proof-
	have \<open>\<exists>r. \<parallel>a r\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v (a r)\<parallel> \<le> r\<close> for a :: "real \<Rightarrow> 'a"
	proof-
	obtain r :: "('a \<Rightarrow>\<^sub>L 'b) \<Rightarrow> real" where
	"\<And>f x. 0 \<le> r f \<and> (bounded_linear f \<longrightarrow> \<parallel>f \<^sub>v x\<parallel> \<le> \<parallel>x\<parallel> r f)"
	using bounded_linear.nonneg_bounded by moura
	have \<open>\<not> \<parallel>f\<parallel> < 0\<close>
	by simp
	hence "(\<exists>r. \<parallel>f\<parallel> * \<parallel>a r\<parallel> \<le> r) \<or> (\<exists>r. \<parallel>a r\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v a r\<parallel> \<le> r)"
	by (meson less_eq_real_def mult_le_cancel_left2)
	thus ?thesis using dual_order.trans norm_blinfun by blast
	qed
	hence \<open>\<exists> M. \<forall> x. \<parallel>x\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v x\<parallel> \<le> M\<close>
	by metis
	thus ?thesis by auto
	qed
	have Sup_non_neg: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<ge> 0\<close>
	by (smt Collect_empty_eq cSup_upper mem_Collect_eq nonnegative norm_1_bounded norm_1_non_empty)
	have \<open>{0::real} \<noteq> {}\<close>
	by simp
	have \<open>bdd_above {0::real}\<close>
	by simp
	show \<open>\<parallel>f\<parallel> = Sup {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close>
	proof(cases \<open>\<forall>x. f *\<^sub>v x = 0\<close>)
	case True
	have \<open>\<parallel>f *\<^sub>v x\<parallel> = 0\<close> for x
	by (simp add: True)
	hence \<open>{\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1 } \<subseteq> {0}\<close>
	by blast
	moreover have \<open>{\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1 } \<supseteq> {0}\<close>
	using calculation norm_less_1_non_empty by fastforce
	ultimately have \<open>{\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1 } = {0}\<close>
	by blast
	hence Sup1: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1 } = 0\<close>
	by simp
	have \<open>\<parallel>f\<parallel> = 0\<close>
	by (simp add: True blinfun_eqI)
	moreover have \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1} = 0\<close>
	using Sup1 by blast
	ultimately show ?thesis by simp
	next
	case False
	have norm_f_eq_leq: \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1} \<Longrightarrow>
	y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close> for y
	proof-
	assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close>
	hence \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> \<and> \<parallel>x\<parallel> = 1\<close>
	by blast
	then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> and \<open>\<parallel>x\<parallel> = 1\<close>
	by auto
	define y' where \<open>y' n = (1 - (inverse (real (Suc n)))) *\<^sub>R y\<close> for n
	have \<open>y' n \<in> {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close> for n
	proof-
	have \<open>y' n = (1 - (inverse (real (Suc n)))) \<^sub>R \<parallel>f \<^sub>v x\<parallel>\<close>
	using y'_def \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> by blast
	also have \<open>... = \<bar>(1 - (inverse (real (Suc n))))\<bar> \<^sub>R \<parallel>f \<^sub>v x\<parallel>\<close>
	by (metis (mono_tags, opaque_lifting) \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> abs_1 abs_le_self_iff abs_of_nat
	abs_of_nonneg add_diff_cancel_left' add_eq_if cancel_comm_monoid_add_class.diff_cancel
	diff_ge_0_iff_ge eq_iff_diff_eq_0 inverse_1 inverse_le_iff_le nat.distinct(1) of_nat_0
	of_nat_Suc of_nat_le_0_iff zero_less_abs_iff zero_neq_one)
	also have \<open>... = \<parallel>f \<^sub>v ((1 - (inverse (real (Suc n)))) \<^sub>R x)\<parallel>\<close>
	by (simp add: blinfun.scaleR_right)
	finally have y'_1: \<open>y' n = \<parallel>f \<^sub>v ( (1 - (inverse (real (Suc n)))) \<^sub>R x)\<parallel>\<close>
	by blast
	have \<open>\<parallel>(1 - (inverse (Suc n))) \<^sub>R x\<parallel> = (1 - (inverse (real (Suc n)))) \<parallel>x\<parallel>\<close>
	by (simp add: linordered_field_class.inverse_le_1_iff)
	hence \<open>\<parallel>(1 - (inverse (Suc n))) *\<^sub>R x\<parallel> < 1\<close>
	by (simp add: \<open>\<parallel>x\<parallel> = 1\<close>)
	thus ?thesis using y'_1 by blast
	qed
	have \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) ) \<longlonglongrightarrow> 1\<close>
	using Limits.LIMSEQ_inverse_real_of_nat_add_minus by simp
	hence \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) \<^sub>R y) \<longlonglongrightarrow> 1 \<^sub>R y\<close>
	using Limits.tendsto_scaleR by blast
	hence \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) *\<^sub>R y) \<longlonglongrightarrow> y\<close>
	by simp
	hence \<open>(\<lambda>n. y' n) \<longlonglongrightarrow> y\<close>
	using y'_def by simp
	hence \<open>y' \<longlonglongrightarrow> y\<close>
	by simp
	have \<open>y' n \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close> for n
	using cSup_upper \<open>\<And>n. y' n \<in> {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> < 1}\<close> norm_less_1_bounded by blast
	hence \<open>y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close>
	using \<open>y' \<longlonglongrightarrow> y\<close> Topological_Spaces.Sup_lim by (meson LIMSEQ_le_const2)
	thus ?thesis by blast
	qed
	hence \<open>Sup {\<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1} \<le> Sup {\<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close>
	by (metis (lifting) cSup_least norm_1_non_empty)
	have \<open>y \<in> {\<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1} \<Longrightarrow> y \<le> Sup {\<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close> for y
	proof(cases \<open>y = 0\<close>)
	case True thus ?thesis by (simp add: Sup_non_neg)
	next
	case False
	hence \<open>y \<noteq> 0\<close> by blast
	assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close>
	hence \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> \<and> \<parallel>x\<parallel> < 1\<close>
	by blast
	then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> and \<open>\<parallel>x\<parallel> < 1\<close>
	by blast
	have \<open>(1/\<parallel>x\<parallel>) * y = (1/\<parallel>x\<parallel>) * \<parallel>f x\<parallel>\<close>
	by (simp add: \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>)
	also have \<open>... = \<bar>1/\<parallel>x\<parallel>\<bar> * \<parallel>f *\<^sub>v x\<parallel>\<close>
	by simp
	also have \<open>... = \<parallel>(1/\<parallel>x\<parallel>) \<^sub>R (f \<^sub>v x)\<parallel>\<close>
	by simp
	also have \<open>... = \<parallel>f \<^sub>v ((1/\<parallel>x\<parallel>) \<^sub>R x)\<parallel>\<close>
	by (simp add: blinfun.scaleR_right)
	finally have \<open>(1/\<parallel>x\<parallel>) * y = \<parallel>f \<^sub>v ((1/\<parallel>x\<parallel>) \<^sub>R x)\<parallel>\<close>
	by blast
	have \<open>x \<noteq> 0\<close>
	using \<open>y \<noteq> 0\<close> \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> blinfun.zero_right by auto
	have \<open>\<parallel> (1/\<parallel>x\<parallel>) \<^sub>R x \<parallel> = \<bar> (1/\<parallel>x\<parallel>) \<bar> \<parallel>x\<parallel>\<close>
	by simp
	also have \<open>... = (1/\<parallel>x\<parallel>) * \<parallel>x\<parallel>\<close>
	by simp
	finally have \<open>\<parallel>(1/\<parallel>x\<parallel>) *\<^sub>R x\<parallel> = 1\<close>
	using \<open>x \<noteq> 0\<close> by simp
	hence \<open>(1/\<parallel>x\<parallel>) * y \<in> { \<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close>
	using \<open>1 / \<parallel>x\<parallel> * y = \<parallel>f \<^sub>v (1 / \<parallel>x\<parallel>) \<^sub>R x\<parallel>\<close> by blast
	hence \<open>(1/\<parallel>x\<parallel>) * y \<le> Sup { \<parallel>f *\<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close>
	by (simp add: cSup_upper norm_1_bounded)
	moreover have \<open>y \<le> (1/\<parallel>x\<parallel>) * y\<close>
	by (metis \<open>\<parallel>x\<parallel> < 1\<close> \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> mult_le_cancel_right1 norm_not_less_zero
	order.strict_implies_order \<open>x \<noteq> 0\<close> less_divide_eq_1_pos zero_less_norm_iff)
	ultimately show ?thesis by linarith
	qed
	hence \<open>Sup { \<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1} \<le> Sup { \<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close>
	by (smt cSup_least norm_less_1_non_empty)
	hence \<open>Sup { \<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1} = Sup { \<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1}\<close>
	using \<open>Sup {\<parallel>f \<^sub>v x\<parallel> \|x. norm x = 1} \<le> Sup { \<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> < 1}\<close> by linarith
	have f1: \<open>(SUP x. \<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup { \<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel> \| x. True}\<close>
	by (simp add: full_SetCompr_eq)
	have \<open>y \<in> { \<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel> \|x. True} \<Longrightarrow> y \<in> { \<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
	for y
	proof-
	assume \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> \|x. True}\<close> show ?thesis
	proof(cases \<open>y = 0\<close>)
	case True thus ?thesis by simp
	next
	case False
	have \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close>
	using \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> \|x. True}\<close> by auto
	then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close>
	by blast
	hence \<open>y = \<bar>(1/\<parallel>x\<parallel>)\<bar> * \<parallel> f *\<^sub>v x \<parallel>\<close>
	by simp
	hence \<open>y = \<parallel>(1/\<parallel>x\<parallel>) \<^sub>R (f \<^sub>v x)\<parallel>\<close>
	by simp
	hence \<open>y = \<parallel>f ((1/\<parallel>x\<parallel>) *\<^sub>R x)\<parallel>\<close>
	by (simp add: blinfun.scaleR_right)
	moreover have \<open>\<parallel> (1/\<parallel>x\<parallel>) *\<^sub>R x \<parallel> = 1\<close>
	using False \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close> by auto
	ultimately have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1}\<close>
	by blast
	thus ?thesis by blast
	qed
	qed
	moreover have \<open>y \<in> {\<parallel>f x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0} \<Longrightarrow> y \<in> {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> \|x. True}\<close>
	for y
	proof(cases \<open>y = 0\<close>)
	case True thus ?thesis by auto
	next
	case False
	hence \<open>y \<notin> {0}\<close>
	by simp
	moreover assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
	ultimately have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1}\<close>
	by simp
	then obtain x where \<open>\<parallel>x\<parallel> = 1\<close> and \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>
	by auto
	have \<open>y = \<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close> using \<open>\<parallel>x\<parallel> = 1\<close> \<open>y = \<parallel>f \<^sub>v x\<parallel>\<close>
	by simp
	thus ?thesis by auto
	qed
	ultimately have \<open>{\<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel> \|x. True} = {\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
	by blast
	hence \<open>Sup {\<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel> \|x. True} = Sup ({\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0})\<close>
	by simp
	have "\<And>r s. \<not> (r::real) \<le> s \<or> sup r s = s"
	by (metis (lifting) sup.absorb_iff1 sup_commute)
	hence \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {(0::real)})
	= max (Sup {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1}) (Sup {0::real})\<close>
	using \<open>0 \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1}\<close> \<open>bdd_above {0}\<close> \<open>{0} \<noteq> {}\<close> cSup_singleton
	cSup_union_distrib max.absorb_iff1 sup_commute norm_1_bounded norm_1_non_empty
	by (metis (no_types, lifting) )
	moreover have \<open>Sup {(0::real)} = (0::real)\<close>
	by simp
	ultimately have \<open>Sup ({\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0}) = Sup {\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1}\<close>
	using Sup_non_neg by linarith
	moreover have \<open>Sup ( {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0})
	= max (Sup {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1}) (Sup {0}) \<close>
	using Sup_non_neg \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0})
	= max (Sup {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1}) (Sup {0})\<close>
	by auto
	ultimately have f2: \<open>Sup {\<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel> \| x. True} = Sup {\<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close>
	using \<open>Sup {\<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel> \|x. True} = Sup ({\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} \<union> {0})\<close> by linarith
	have \<open>(SUP x. \<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup {\<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> = 1}\<close>
	using f1 f2 by linarith
	hence \<open>(SUP x. \<parallel>f \<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup {\<parallel>f \<^sub>v x\<parallel> \| x. \<parallel>x\<parallel> < 1 }\<close>
	by (simp add: \<open>Sup {\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> = 1} = Sup {\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> < 1}\<close>)
	thus ?thesis apply transfer by (simp add: onorm_def)
	qed
	qed

	lemma onorm_r:
	includes notation_norm
	assumes \<open>r > 0\<close>
	shows \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r)) / r\<close>
	text \<open>
	Explanation: The norm of \<^term>\<open>f\<close> is \<^term>\<open>1/r\<close> of the supremum of the norm of \<^term>\<open>f *\<^sub>v x\<close> for
	\<^term>\<open>x\<close> in the ball of radius \<^term>\<open>r\<close> centered at the origin.
	\<close>
	proof-
	have \<open>\<parallel>f\<parallel> = Sup {\<parallel>f *\<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> < 1}\<close>
	using onorm_open_ball by blast
	moreover have \<open>{\<parallel>f \<^sub>v x\<parallel> \|x. \<parallel>x\<parallel> < 1} = (\<lambda>x. \<parallel>f \<^sub>v x\<parallel>) ` (ball 0 1)\<close>
	unfolding ball_def by auto
	ultimately have onorm_f: \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 1))\<close>
	by simp
	have s2: \<open>x \<in> (\<lambda>t. r \<^sub>R \<parallel>f \<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close> for x
	proof-
	assume \<open>x \<in> (\<lambda>t. r \<^sub>R \<parallel>f \<^sub>v t\<parallel>) ` ball 0 1\<close>
	hence \<open>\<exists> t. x = r \<^sub>R \<parallel>f \<^sub>v t\<parallel> \<and> \<parallel>t\<parallel> < 1\<close>
	by auto
	then obtain t where \<open>x = r \<^sub>R \<parallel>f \<^sub>v t\<parallel>\<close> and \<open>\<parallel>t\<parallel> < 1\<close>
	by blast
	define y where \<open>y = x /\<^sub>R r\<close>
	have \<open>x = r * (inverse r * x)\<close>
	using \<open>x = r *\<^sub>R norm (f t)\<close> by auto
	hence \<open>x - (r * (inverse r * x)) \<le> 0\<close>
	by linarith
	hence \<open>x \<le> r * (x /\<^sub>R r)\<close>
	by auto
	have \<open>y \<in> (\<lambda>k. \<parallel>f *\<^sub>v k\<parallel>) ` ball 0 1\<close>
	unfolding y_def by (smt \<open>x \<in> (\<lambda>t. r \<^sub>R \<parallel>f \<^sub>v t\<parallel>) ` ball 0 1\<close> assms image_iff
	inverse_inverse_eq pos_le_divideR_eq positive_imp_inverse_positive)
	moreover have \<open>x \<le> r * y\<close>
	using \<open>x \<le> r * (x /\<^sub>R r)\<close> y_def by blast
	ultimately have y_norm_f: \<open>y \<in> (\<lambda>t. \<parallel>f \<^sub>v t\<parallel>) ` ball 0 1 \<and> x \<le> r y\<close>
	by blast
	have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<noteq> {}\<close>
	by simp
	moreover have \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close>
	by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above
	bounded_norm_comp)
	moreover have \<open>\<exists> y. y \<in> (\<lambda>t. \<parallel>f \<^sub>v t\<parallel>) ` ball 0 1 \<and> x \<le> r y\<close>
	using y_norm_f by blast
	ultimately show ?thesis
	by (smt \<open>0 < r\<close> cSup_upper ordered_comm_semiring_class.comm_mult_left_mono)
	qed
	have s3: \<open>(\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y) \<Longrightarrow>
	r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1) \<le> y\<close> for y
	proof-
	assume \<open>\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y\<close>
	have x_leq: \<open>x \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y / r\<close> for x
	proof-
	assume \<open>x \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
	then obtain t where \<open>t \<in> ball (0::'a) 1\<close> and \<open>x = \<parallel>f *\<^sub>v t\<parallel>\<close>
	by auto
	define x' where \<open>x' = r *\<^sub>R x\<close>
	have \<open>x' = r * \<parallel>f *\<^sub>v t\<parallel>\<close>
	by (simp add: \<open>x = \<parallel>f *\<^sub>v t\<parallel>\<close> x'_def)
	hence \<open>x' \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
	using \<open>t \<in> ball (0::'a) 1\<close> by auto
	hence \<open>x' \<le> y\<close>
	using \<open>\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y\<close> by blast
	thus \<open>x \<le> y / r\<close>
	unfolding x'_def using \<open>r > 0\<close> by (simp add: mult.commute pos_le_divide_eq)
	qed
	have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<noteq> {}\<close>
	by simp
	moreover have \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close>
	by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above
	bounded_norm_comp)
	ultimately have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1) \<le> y/r\<close>
	using x_leq by (simp add: \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close> cSup_least)
	thus ?thesis using \<open>r > 0\<close>
	by (smt divide_strict_right_mono nonzero_mult_div_cancel_left)
	qed
	have norm_scaleR: \<open>norm \<circ> ((\<^sub>R) r) = ((\<^sub>R) \<bar>r\<bar>) \<circ> (norm::'a \<Rightarrow> real)\<close>
	by auto
	have f_x1: \<open>f (r \<^sub>R x) = r \<^sub>R f x\<close> for x
	by (simp add: blinfun.scaleR_right)
	have \<open>ball (0::'a) r = ((*\<^sub>R) r) ` (ball 0 1)\<close>
	by (smt assms ball_scale nonzero_mult_div_cancel_left right_inverse_eq scale_zero_right)
	hence \<open>Sup ((\<lambda>t. \<parallel>f \<^sub>v t\<parallel>) ` (ball 0 r)) = Sup ((\<lambda>t. \<parallel>f \<^sub>v t\<parallel>) ` (((*\<^sub>R) r) ` (ball 0 1)))\<close>
	by simp
	also have \<open>\<dots> = Sup (((\<lambda>t. \<parallel>f \<^sub>v t\<parallel>) \<circ> ((\<^sub>R) r)) ` (ball 0 1))\<close>
	using Sup.SUP_image by auto
	also have \<open>\<dots> = Sup ((\<lambda>t. \<parallel>f \<^sub>v (r \<^sub>R t)\<parallel>) ` (ball 0 1))\<close>
	using f_x1 by (simp add: comp_assoc)
	also have \<open>\<dots> = Sup ((\<lambda>t. \<bar>r\<bar> \<^sub>R \<parallel>f \<^sub>v t\<parallel>) ` (ball 0 1))\<close>
	using norm_scaleR f_x1 by auto
	also have \<open>\<dots> = Sup ((\<lambda>t. r \<^sub>R \<parallel>f \<^sub>v t\<parallel>) ` (ball 0 1))\<close>
	using \<open>r > 0\<close> by auto
	also have \<open>\<dots> = r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 1))\<close>
	apply (rule cSup_eq_non_empty) apply simp using s2 apply auto using s3 by auto
	also have \<open>\<dots> = r * \<parallel>f\<parallel>\<close>
	using onorm_f by auto
	finally have \<open>Sup ((\<lambda>t. \<parallel>f \<^sub>v t\<parallel>) ` ball 0 r) = r \<parallel>f\<parallel>\<close>
	by blast
	thus \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r)) / r\<close> using \<open>r > 0\<close> by simp
	qed

	text\<open>Pointwise convergence\<close>
	definition pointwise_convergent_to ::
	\<open>( nat \<Rightarrow> ('a \<Rightarrow> 'b::topological_space) ) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool\<close>
	(\<open>((_)/ \<midarrow>pointwise\<rightarrow> (_))\<close> [60, 60] 60) where
	\<open>pointwise_convergent_to x l = (\<forall> t::'a. (\<lambda> n. (x n) t) \<longlonglongrightarrow> l t)\<close>

	lemma linear_limit_linear:
	fixes f :: \<open>_ \<Rightarrow> ('a::real_vector \<Rightarrow> 'b::real_normed_vector)\<close>
	assumes \<open>\<And>n. linear (f n)\<close> and \<open>f \<midarrow>pointwise\<rightarrow> F\<close>
	shows \<open>linear F\<close>
	text\<open>
	Explanation: If a family of linear operators converges pointwise, then the limit is also a linear
	operator.
	\<close>
	proof
	show "F (x + y) = F x + F y" for x y
	proof-
	have "\<forall>a. F a = lim (\<lambda>n. f n a)"
	using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by (metis (full_types) limI)
	moreover have "\<forall>f b c g. (lim (\<lambda>n. g n + f n) = (b::'b) + c \<or> \<not> f \<longlonglongrightarrow> c) \<or> \<not> g \<longlonglongrightarrow> b"
	by (metis (no_types) limI tendsto_add)
	moreover have "\<And>a. (\<lambda>n. f n a) \<longlonglongrightarrow> F a"
	using assms(2) pointwise_convergent_to_def by force
	ultimately have
	lim_sum: \<open>lim (\<lambda> n. (f n) x + (f n) y) = lim (\<lambda> n. (f n) x) + lim (\<lambda> n. (f n) y)\<close>
	by metis
	have \<open>(f n) (x + y) = (f n) x + (f n) y\<close> for n
	using \<open>\<And> n. linear (f n)\<close> unfolding linear_def using Real_Vector_Spaces.linear_iff assms(1)
	by auto
	hence \<open>lim (\<lambda> n. (f n) (x + y)) = lim (\<lambda> n. (f n) x + (f n) y)\<close>
	by simp
	hence \<open>lim (\<lambda> n. (f n) (x + y)) = lim (\<lambda> n. (f n) x) + lim (\<lambda> n. (f n) y)\<close>
	using lim_sum by simp
	moreover have \<open>(\<lambda> n. (f n) (x + y)) \<longlonglongrightarrow> F (x + y)\<close>
	using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
	moreover have \<open>(\<lambda> n. (f n) x) \<longlonglongrightarrow> F x\<close>
	using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
	moreover have \<open>(\<lambda> n. (f n) y) \<longlonglongrightarrow> F y\<close>
	using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
	ultimately show ?thesis
	by (metis limI)
	qed
	show "F (r \<^sub>R x) = r \<^sub>R F x" for r and x
	proof-
	have \<open>(f n) (r \<^sub>R x) = r \<^sub>R (f n) x\<close> for n
	using \<open>\<And> n. linear (f n)\<close>
	by (simp add: Real_Vector_Spaces.linear_def real_vector.linear_scale)
	hence \<open>lim (\<lambda> n. (f n) (r \<^sub>R x)) = lim (\<lambda> n. r \<^sub>R (f n) x)\<close>
	by simp
	have \<open>convergent (\<lambda> n. (f n) x)\<close>
	by (metis assms(2) convergentI pointwise_convergent_to_def)
	moreover have \<open>isCont (\<lambda> t::'b. r *\<^sub>R t) tt\<close> for tt
	by (simp add: bounded_linear_scaleR_right)
	ultimately have \<open>lim (\<lambda> n. r \<^sub>R ((f n) x)) = r \<^sub>R lim (\<lambda> n. (f n) x)\<close>
	using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def
	by (metis (mono_tags) isCont_tendsto_compose limI)
	hence \<open>lim (\<lambda> n. (f n) (r \<^sub>R x)) = r \<^sub>R lim (\<lambda> n. (f n) x)\<close>
	using \<open>lim (\<lambda> n. (f n) (r \<^sub>R x)) = lim (\<lambda> n. r \<^sub>R (f n) x)\<close> by simp
	moreover have \<open>(\<lambda> n. (f n) x) \<longlonglongrightarrow> F x\<close>
	using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
	moreover have \<open>(\<lambda> n. (f n) (r \<^sub>R x)) \<longlonglongrightarrow> F (r \<^sub>R x)\<close>
	using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
	ultimately show ?thesis
	by (metis limI)
	qed
	qed


	lemma non_Cauchy_unbounded:
	fixes a ::\<open>_ \<Rightarrow> real\<close>
	assumes \<open>\<And>n. a n \<ge> 0\<close> and \<open>e > 0\<close>
	and \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
	shows \<open>(\<lambda>n. (sum a {0..n})) \<longlonglongrightarrow> \<infinity>\<close>
	text\<open>
	Explanation: If the sequence of partial sums of nonnegative terms is not Cauchy, then it converges
	to infinite.
	\<close>
	proof-
	define S::"ereal set" where \<open>S = range (\<lambda>n. sum a {0..n})\<close>
	have \<open>\<exists>s\<in>S. k*e \<le> s\<close> for k::nat
	proof(induction k)
	case 0
	from \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
	obtain m n where \<open>m \<ge> 0\<close> and \<open>n \<ge> 0\<close> and \<open>m > n\<close> and \<open>sum a {Suc n..m} \<ge> e\<close> by blast
	have \<open>n < Suc n\<close>
	by simp
	hence \<open>{0..n} \<union> {Suc n..m} = {0..m}\<close>
	using Set_Interval.ivl_disj_un(7) \<open>n < m\<close> by auto
	moreover have \<open>finite {0..n}\<close>
	by simp
	moreover have \<open>finite {Suc n..m}\<close>
	by simp
	moreover have \<open>{0..n} \<inter> {Suc n..m} = {}\<close>
	by simp
	ultimately have \<open>sum a {0..n} + sum a {Suc n..m} = sum a {0..m}\<close>
	by (metis sum.union_disjoint)
	moreover have \<open>sum a {Suc n..m} > 0\<close>
	using \<open>e > 0\<close> \<open>sum a {Suc n..m} \<ge> e\<close> by linarith
	moreover have \<open>sum a {0..n} \<ge> 0\<close>
	by (simp add: assms(1) sum_nonneg)
	ultimately have \<open>sum a {0..m} > 0\<close>
	by linarith
	moreover have \<open>sum a {0..m} \<in> S\<close>
	unfolding S_def by blast
	ultimately have \<open>\<exists>s\<in>S. 0 \<le> s\<close>
	using ereal_less_eq(5) by fastforce
	thus ?case
	by (simp add: zero_ereal_def)
	next
	case (Suc k)
	assume \<open>\<exists>s\<in>S. k*e \<le> s\<close>
	then obtain s where \<open>s\<in>S\<close> and \<open>ereal (k * e) \<le> s\<close>
	by blast
	have \<open>\<exists>N. s = sum a {0..N}\<close>
	using \<open>s\<in>S\<close> unfolding S_def by blast
	then obtain N where \<open>s = sum a {0..N}\<close>
	by blast
	from \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
	obtain m n where \<open>m \<ge> Suc N\<close> and \<open>n \<ge> Suc N\<close> and \<open>m > n\<close> and \<open>sum a {Suc n..m} \<ge> e\<close>
	by blast
	have \<open>finite {Suc N..n}\<close>
	by simp
	moreover have \<open>finite {Suc n..m}\<close>
	by simp
	moreover have \<open>{Suc N..n} \<union> {Suc n..m} = {Suc N..m}\<close>
	using Set_Interval.ivl_disj_un
	by (smt \<open>Suc N \<le> n\<close> \<open>n < m\<close> atLeastSucAtMost_greaterThanAtMost less_imp_le_nat)
	moreover have \<open>{} = {Suc N..n} \<inter> {Suc n..m}\<close>
	by simp
	ultimately have \<open>sum a {Suc N..m} = sum a {Suc N..n} + sum a {Suc n..m}\<close>
	by (metis sum.union_disjoint)
	moreover have \<open>sum a {Suc N..n} \<ge> 0\<close>
	using \<open>\<And>n. a n \<ge> 0\<close> by (simp add: sum_nonneg)
	ultimately have \<open>sum a {Suc N..m} \<ge> e\<close>
	using \<open>e \<le> sum a {Suc n..m}\<close> by linarith
	have \<open>finite {0..N}\<close>
	by simp
	have \<open>finite {Suc N..m}\<close>
	by simp
	moreover have \<open>{0..N} \<union> {Suc N..m} = {0..m}\<close>
	using Set_Interval.ivl_disj_un(7) \<open>Suc N \<le> m\<close> by auto
	moreover have \<open>{0..N} \<inter> {Suc N..m} = {}\<close>
	by simp
	ultimately have \<open>sum a {0..N} + sum a {Suc N..m} = sum a {0..m}\<close>
	by (metis \<open>finite {0..N}\<close> sum.union_disjoint)
	hence \<open>e + k * e \<le> sum a {0..m}\<close>
	using \<open>ereal (real k * e) \<le> s\<close> \<open>s = ereal (sum a {0..N})\<close> \<open>e \<le> sum a {Suc N..m}\<close> by auto
	moreover have \<open>e + k * e = (Suc k) * e\<close>
	by (simp add: semiring_normalization_rules(3))
	ultimately have \<open>(Suc k) * e \<le> sum a {0..m}\<close>
	by linarith
	hence \<open>ereal ((Suc k) * e) \<le> sum a {0..m}\<close>
	by auto
	moreover have \<open>sum a {0..m}\<in>S\<close>
	unfolding S_def by blast
	ultimately show ?case by blast
	qed
	hence \<open>\<exists>s\<in>S. (real n) \<le> s\<close> for n
	by (meson assms(2) ereal_le_le ex_less_of_nat_mult less_le_not_le)
	hence \<open>Sup S = \<infinity>\<close>
	using Sup_le_iff Sup_subset_mono dual_order.strict_trans1 leD less_PInf_Ex_of_nat subsetI
	by metis
	hence Sup: \<open>Sup ((range (\<lambda> n. (sum a {0..n})))::ereal set) = \<infinity>\<close> using S_def
	by blast
	have \<open>incseq (\<lambda>n. (sum a {..<n}))\<close>
	using \<open>\<And>n. a n \<ge> 0\<close> using Extended_Real.incseq_sumI by auto
	hence \<open>incseq (\<lambda>n. (sum a {..< Suc n}))\<close>
	by (meson incseq_Suc_iff)
	hence \<open>incseq (\<lambda>n. (sum a {0..n})::ereal)\<close>
	using incseq_ereal by (simp add: atLeast0AtMost lessThan_Suc_atMost)
	hence \<open>(\<lambda>n. sum a {0..n}) \<longlonglongrightarrow> Sup (range (\<lambda>n. (sum a {0..n})::ereal))\<close>
	using LIMSEQ_SUP by auto
	thus ?thesis using Sup PInfty_neq_ereal by auto
	qed

	lemma sum_Cauchy_positive:
	fixes a ::\<open>_ \<Rightarrow> real\<close>
	assumes \<open>\<And>n. a n \<ge> 0\<close> and \<open>\<exists>K. \<forall>n. (sum a {0..n}) \<le> K\<close>
	shows \<open>Cauchy (\<lambda>n. sum a {0..n})\<close>
	text\<open>
	Explanation: If a series of nonnegative reals is bounded, then the series is
	Cauchy.
	\<close>
	proof (unfold Cauchy_altdef2, rule, rule)
	fix e::real
	assume \<open>e>0\<close>
	have \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
	proof(rule classical)
	assume \<open>\<not>(\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e)\<close>
	hence \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> \<not>(sum a {Suc n..m} < e)\<close>
	by blast
	hence \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
	by fastforce
	hence \<open>(\<lambda>n. (sum a {0..n}) ) \<longlonglongrightarrow> \<infinity>\<close>
	using non_Cauchy_unbounded \<open>0 < e\<close> assms(1) by blast
	from \<open>\<exists>K. \<forall>n. sum a {0..n} \<le> K\<close>
	obtain K where \<open>\<forall>n. sum a {0..n} \<le> K\<close>
	by blast
	from \<open>(\<lambda>n. sum a {0..n}) \<longlonglongrightarrow> \<infinity>\<close>
	have \<open>\<forall>B. \<exists>N. \<forall>n\<ge>N. (\<lambda> n. (sum a {0..n}) ) n \<ge> B\<close>
	using Lim_PInfty by simp
	hence \<open>\<exists>n. (sum a {0..n}) \<ge> K+1\<close>
	using ereal_less_eq(3) by blast
	thus ?thesis using \<open>\<forall>n. (sum a {0..n}) \<le> K\<close> by smt
	qed
	have \<open>sum a {Suc n..m} = sum a {0..m} - sum a {0..n}\<close>
	if "m > n" for m n
	apply (simp add: that atLeast0AtMost) using sum_up_index_split
	by (smt less_imp_add_positive that)
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {0..m} - sum a {0..n} < e\<close>
	using \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close> by smt
	from \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {0..m} - sum a {0..n} < e\<close>
	obtain M where \<open>\<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {0..m} - sum a {0..n} < e\<close>
	by blast
	moreover have \<open>m > n \<Longrightarrow> sum a {0..m} \<ge> sum a {0..n}\<close> for m n
	using \<open>\<And> n. a n \<ge> 0\<close> by (simp add: sum_mono2)
	ultimately have \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
	by auto
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m \<ge> n \<longrightarrow> \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
	by (metis \<open>0 < e\<close> abs_zero cancel_comm_monoid_add_class.diff_cancel diff_is_0_eq'
	less_irrefl_nat linorder_neqE_nat zero_less_diff)
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
	by (metis abs_minus_commute nat_le_linear)
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>
	by (simp add: dist_real_def)
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close> by blast
	thus \<open>\<exists>N. \<forall>n\<ge>N. dist (sum a {0..n}) (sum a {0..N}) < e\<close> by auto
	qed

	lemma convergent_series_Cauchy:
	fixes a::\<open>nat \<Rightarrow> real\<close> and \<phi>::\<open>nat \<Rightarrow> 'a::metric_space\<close>
	assumes \<open>\<exists>M. \<forall>n. sum a {0..n} \<le> M\<close> and \<open>\<And>n. dist (\<phi> (Suc n)) (\<phi> n) \<le> a n\<close>
	shows \<open>Cauchy \<phi>\<close>
	text\<open>
	Explanation: Let \<^term>\<open>a\<close> be a real-valued sequence and let \<^term>\<open>\<phi>\<close> be sequence in a metric space.
	If the partial sums of \<^term>\<open>a\<close> are uniformly bounded and the distance between consecutive terms of \<^term>\<open>\<phi>\<close>
	are bounded by the sequence \<^term>\<open>a\<close>, then \<^term>\<open>\<phi>\<close> is Cauchy.\<close>
	proof (unfold Cauchy_altdef2, rule, rule)
	fix e::real
	assume \<open>e > 0\<close>
	have \<open>\<And>k. a k \<ge> 0\<close>
	using \<open>\<And>n. dist (\<phi> (Suc n)) (\<phi> n) \<le> a n\<close> dual_order.trans zero_le_dist by blast
	hence \<open>Cauchy (\<lambda>k. sum a {0..k})\<close>
	using \<open>\<exists>M. \<forall>n. sum a {0..n} \<le> M\<close> sum_Cauchy_positive by blast
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>
	unfolding Cauchy_def using \<open>e > 0\<close> by blast
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> dist (sum a {0..m}) (sum a {0..n}) < e\<close>
	by blast
	have \<open>dist (sum a {0..m}) (sum a {0..n}) = sum a {Suc n..m}\<close> if \<open>n<m\<close> for m n
	proof -
	have \<open>n < Suc n\<close>
	by simp
	have \<open>finite {0..n}\<close>
	by simp
	moreover have \<open>finite {Suc n..m}\<close>
	by simp
	moreover have \<open>{0..n} \<union> {Suc n..m} = {0..m}\<close>
	using \<open>n < Suc n\<close> \<open>n < m\<close> by auto
	moreover have \<open>{0..n} \<inter> {Suc n..m} = {}\<close>
	by simp
	ultimately have sum_plus: \<open>(sum a {0..n}) + sum a {Suc n..m} = (sum a {0..m})\<close>
	by (metis sum.union_disjoint)
	have \<open>dist (sum a {0..m}) (sum a {0..n}) = \<bar>(sum a {0..m}) - (sum a {0..n})\<bar>\<close>
	using dist_real_def by blast
	moreover have \<open>(sum a {0..m}) - (sum a {0..n}) = sum a {Suc n..m}\<close>
	using sum_plus by linarith
	ultimately show ?thesis
	by (simp add: \<open>\<And>k. 0 \<le> a k\<close> sum_nonneg)
	qed
	hence sum_a: \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
	by (metis \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>)
	obtain M where \<open>\<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
	using sum_a \<open>e > 0\<close> by blast
	hence \<open>\<forall>m. \<forall>n. Suc m \<ge> Suc M \<and> Suc n \<ge> Suc M \<and> Suc m > Suc n \<longrightarrow> sum a {Suc n..Suc m - 1} < e\<close>
	by simp
	hence \<open>\<forall>m\<ge>1. \<forall>n\<ge>1. m \<ge> Suc M \<and> n \<ge> Suc M \<and> m > n \<longrightarrow> sum a {n..m - 1} < e\<close>
	by (metis Suc_le_D)
	hence sum_a2: \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {n..m-1} < e\<close>
	by (meson add_leE)
	have \<open>dist (\<phi> (n+p+1)) (\<phi> n) \<le> sum a {n..n+p}\<close> for p n :: nat
	proof(induction p)
	case 0 thus ?case by (simp add: assms(2))
	next
	case (Suc p) thus ?case
	by (smt Suc_eq_plus1 add_Suc_right add_less_same_cancel1 assms(2) dist_self dist_triangle2
	gr_implies_not0 sum.cl_ivl_Suc)
	qed
	hence \<open>m > n \<Longrightarrow> dist (\<phi> m) (\<phi> n) \<le> sum a {n..m-1}\<close> for m n :: nat
	by (metis Suc_eq_plus1 Suc_le_D diff_Suc_1 gr0_implies_Suc less_eq_Suc_le less_imp_Suc_add
	zero_less_Suc)
	hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> dist (\<phi> m) (\<phi> n) < e\<close>
	using sum_a2 \<open>e > 0\<close> by smt
	thus "\<exists>N. \<forall>n\<ge>N. dist (\<phi> n) (\<phi> N) < e"
	using \<open>0 < e\<close> by fastforce
	qed

	unbundle notation_blinfun_apply

	unbundle no_notation_norm

	end
	diff --git a/thys/Banach_Steinhaus/document/root.tex b/thys/Banach_Steinhaus/document/root.tex
	--- a/thys/Banach_Steinhaus/document/root.tex
	+++ b/thys/Banach_Steinhaus/document/root.tex
	@@ -1,31 +1,31 @@
	\documentclass[11pt,a4paper]{article}
	\usepackage[T1]{fontenc}
	\usepackage{isabelle,isabellesym}
	\usepackage{amsmath,amssymb}

	%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{Banach-Steinhaus theorem}
	+\title{Banach-Steinhaus theorem\thanks{Supported by the ERC consolidator grant CerQuS (819317), the PRG team grant “Secure Quantum Technology” (PRG946) from the Estonian Research Council, and the Estonian Centre of Exellence in IT (EXCITE) funded by ERDF.}}
	\author{Dominique Unruh \and Jos\'e Manuel Rodr\'iguez Caballero}
	\maketitle

	\begin{abstract}
	We formalize in Isabelle/HOL a result \cite{Weisstein_UBP} due to S. Banach and H. Steinhaus \cite{banach1927principe} known as 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 \cite{sokal2011really}.
	\end{abstract}

	\tableofcontents

	\input{session}


	\bibliographystyle{abbrv}
	\bibliography{root}

	\end{document}
	diff --git a/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy b/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy
	--- a/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy
	+++ b/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy
	@@ -1,1657 +1,1657 @@
	(*
	Authors: Jose Divasón
	Sebastiaan Joosten
	René Thiemann
	Akihisa Yamada
	*)
	subsection \<open>Finite Fields\<close>

	text \<open>We provide four implementations for $GF(p)$ -- the field with $p$ elements for some
	prime $p$ -- one by int, one by integers, one by 32-bit numbers and one 64-bit implementation.
	Correctness of the implementations is proven by
	transfer rules to the type-based version of $GF(p)$.\<close>

	theory Finite_Field_Record_Based
	imports
	Finite_Field
	Arithmetic_Record_Based
	Native_Word.Uint32
	Native_Word.Uint64
	- Native_Word.Code_Target_Bits_Int
	"HOL-Library.Code_Target_Numeral"
	+ Native_Word.Code_Target_Int_Bit
	begin

	(* mod on standard case which can immediately be mapped to
	target languages without considering special cases *)
	definition mod_nonneg_pos :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
	"x \<ge> 0 \<Longrightarrow> y > 0 \<Longrightarrow> mod_nonneg_pos x y = (x mod y)"

	code_printing \<comment> \<open>FIXME illusion of partiality\<close>
	constant mod_nonneg_pos \<rightharpoonup>
	(SML) "IntInf.mod/ ( _,/ _ )"
	and (Eval) "IntInf.mod/ ( _,/ _ )"
	and (OCaml) "Z.rem"
	and (Haskell) "Prelude.mod/ ( _ )/ ( _ )"
	and (Scala) "!((k: BigInt) => (l: BigInt) =>/ (k '% l))"

	definition mod_nonneg_pos_int :: "int \<Rightarrow> int \<Rightarrow> int" where
	"mod_nonneg_pos_int x y = int_of_integer (mod_nonneg_pos (integer_of_int x) (integer_of_int y))"

	lemma mod_nonneg_pos_int[simp]: "x \<ge> 0 \<Longrightarrow> y > 0 \<Longrightarrow> mod_nonneg_pos_int x y = (x mod y)"
	unfolding mod_nonneg_pos_int_def using mod_nonneg_pos_def by simp

	context
	fixes p :: int
	begin
	definition plus_p :: "int \<Rightarrow> int \<Rightarrow> int" where
	"plus_p x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

	definition minus_p :: "int \<Rightarrow> int \<Rightarrow> int" where
	"minus_p x y \<equiv> if y \<le> x then x - y else x + p - y"

	definition uminus_p :: "int \<Rightarrow> int" where
	"uminus_p x = (if x = 0 then 0 else p - x)"

	definition mult_p :: "int \<Rightarrow> int \<Rightarrow> int" where
	"mult_p x y = (mod_nonneg_pos_int (x * y) p)"

	fun power_p :: "int \<Rightarrow> nat \<Rightarrow> int" where
	"power_p x n = (if n = 0 then 1 else
	let (d,r) = Divides.divmod_nat n 2;
	rec = power_p (mult_p x x) d in
	if r = 0 then rec else mult_p rec x)"

	text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
	it turned out that taking the below implementation of inverse via exponentiation
	is faster than the one based on the extended Euclidean algorithm.\<close>

	definition inverse_p :: "int \<Rightarrow> int" where
	"inverse_p x = (if x = 0 then 0 else power_p x (nat (p - 2)))"

	definition divide_p :: "int \<Rightarrow> int \<Rightarrow> int" where
	"divide_p x y = mult_p x (inverse_p y)"

	definition finite_field_ops_int :: "int arith_ops_record" where
	"finite_field_ops_int \<equiv> Arith_Ops_Record
	0
	1
	plus_p
	mult_p
	minus_p
	uminus_p
	divide_p
	inverse_p
	(\<lambda> x y . if y = 0 then x else 0)
	(\<lambda> x . if x = 0 then 0 else 1)
	(\<lambda> x . x)
	(\<lambda> x . x)
	(\<lambda> x . x)
	(\<lambda> x. 0 \<le> x \<and> x < p)"

	end

	context
	fixes p :: uint32
	begin
	definition plus_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
	"plus_p32 x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

	definition minus_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
	"minus_p32 x y \<equiv> if y \<le> x then x - y else (x + p) - y"

	definition uminus_p32 :: "uint32 \<Rightarrow> uint32" where
	"uminus_p32 x = (if x = 0 then 0 else p - x)"

	definition mult_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
	"mult_p32 x y = (x * y mod p)"

	lemma int_of_uint32_shift: "int_of_uint32 (drop_bit k n) = (int_of_uint32 n) div (2 ^ k)"
	apply transfer
	apply transfer
	apply (simp add: take_bit_drop_bit min_def)
	apply (simp add: drop_bit_eq_div)
	done

	lemma int_of_uint32_0_iff: "int_of_uint32 n = 0 \<longleftrightarrow> n = 0"
	by (transfer, rule uint_0_iff)

	lemma int_of_uint32_0: "int_of_uint32 0 = 0" unfolding int_of_uint32_0_iff by simp

	lemma int_of_uint32_ge_0: "int_of_uint32 n \<ge> 0"
	by (transfer, auto)

	lemma two_32: "2 ^ LENGTH(32) = (4294967296 :: int)" by simp

	lemma int_of_uint32_plus: "int_of_uint32 (x + y) = (int_of_uint32 x + int_of_uint32 y) mod 4294967296"
	by (transfer, unfold uint_word_ariths two_32, rule refl)

	lemma int_of_uint32_minus: "int_of_uint32 (x - y) = (int_of_uint32 x - int_of_uint32 y) mod 4294967296"
	by (transfer, unfold uint_word_ariths two_32, rule refl)

	lemma int_of_uint32_mult: "int_of_uint32 (x * y) = (int_of_uint32 x * int_of_uint32 y) mod 4294967296"
	by (transfer, unfold uint_word_ariths two_32, rule refl)

	lemma int_of_uint32_mod: "int_of_uint32 (x mod y) = (int_of_uint32 x mod int_of_uint32 y)"
	by (transfer, unfold uint_mod two_32, rule refl)

	lemma int_of_uint32_inv: "0 \<le> x \<Longrightarrow> x < 4294967296 \<Longrightarrow> int_of_uint32 (uint32_of_int x) = x"
	by transfer (simp add: take_bit_int_eq_self unsigned_of_int)

	context
	includes bit_operations_syntax
	begin

	function power_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
	"power_p32 x n = (if n = 0 then 1 else
	let rec = power_p32 (mult_p32 x x) (drop_bit 1 n) in
	if n AND 1 = 0 then rec else mult_p32 rec x)"
	by pat_completeness auto

	termination
	proof -
	{
	fix n :: uint32
	assume "n \<noteq> 0"
	with int_of_uint32_ge_0[of n] int_of_uint32_0_iff[of n] have "int_of_uint32 n > 0" by auto
	hence "0 < int_of_uint32 n" "int_of_uint32 n div 2 < int_of_uint32 n" by auto
	} note * = this
	show ?thesis
	by (relation "measure (\<lambda> (x,n). nat (int_of_uint32 n))", auto simp: int_of_uint32_shift *)
	qed

	end

	text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
	it turned out that taking the below implementation of inverse via exponentiation
	is faster than the one based on the extended Euclidean algorithm.\<close>

	definition inverse_p32 :: "uint32 \<Rightarrow> uint32" where
	"inverse_p32 x = (if x = 0 then 0 else power_p32 x (p - 2))"

	definition divide_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
	"divide_p32 x y = mult_p32 x (inverse_p32 y)"

	definition finite_field_ops32 :: "uint32 arith_ops_record" where
	"finite_field_ops32 \<equiv> Arith_Ops_Record
	0
	1
	plus_p32
	mult_p32
	minus_p32
	uminus_p32
	divide_p32
	inverse_p32
	(\<lambda> x y . if y = 0 then x else 0)
	(\<lambda> x . if x = 0 then 0 else 1)
	(\<lambda> x . x)
	uint32_of_int
	int_of_uint32
	(\<lambda> x. 0 \<le> x \<and> x < p)"
	end

	lemma shiftr_uint32_code [code_unfold]: "drop_bit 1 x = (uint32_shiftr x 1)"
	by (simp add: uint32_shiftr_def)

	(* ******************************************************************************** *)
	subsubsection \<open>Transfer Relation\<close>
	locale mod_ring_locale =
	fixes p :: int and ty :: "'a :: nontriv itself"
	assumes p: "p = int CARD('a)"
	begin
	lemma nat_p: "nat p = CARD('a)" unfolding p by simp
	lemma p2: "p \<ge> 2" unfolding p using nontriv[where 'a = 'a] by auto
	lemma p2_ident: "int (CARD('a) - 2) = p - 2" using p2 unfolding p by simp

	definition mod_ring_rel :: "int \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
	"mod_ring_rel x x' = (x = to_int_mod_ring x')"

	(* domain transfer rules *)
	lemma Domainp_mod_ring_rel [transfer_domain_rule]:
	"Domainp (mod_ring_rel) = (\<lambda> v. v \<in> {0 ..< p})"
	proof -
	{
	fix v :: int
	assume *: "0 \<le> v" "v < p"
	have "Domainp mod_ring_rel v"
	proof
	show "mod_ring_rel v (of_int_mod_ring v)" unfolding mod_ring_rel_def using * p by auto
	qed
	} note * = this
	show ?thesis
	by (intro ext iffI, insert range_to_int_mod_ring[where 'a = 'a] *, auto simp: mod_ring_rel_def p)
	qed

	(* left/right/bi-unique *)
	lemma bi_unique_mod_ring_rel [transfer_rule]:
	"bi_unique mod_ring_rel" "left_unique mod_ring_rel" "right_unique mod_ring_rel"
	unfolding mod_ring_rel_def bi_unique_def left_unique_def right_unique_def
	by auto

	(* left/right-total *)
	lemma right_total_mod_ring_rel [transfer_rule]: "right_total mod_ring_rel"
	unfolding mod_ring_rel_def right_total_def by simp


	(* ************************************************************************************ *)
	subsubsection \<open>Transfer Rules\<close>

	(* 0 / 1 *)
	lemma mod_ring_0[transfer_rule]: "mod_ring_rel 0 0" unfolding mod_ring_rel_def by simp
	lemma mod_ring_1[transfer_rule]: "mod_ring_rel 1 1" unfolding mod_ring_rel_def by simp

	(* addition *)
	lemma plus_p_mod_def: assumes x: "x \<in> {0 ..< p}" and y: "y \<in> {0 ..< p}"
	shows "plus_p p x y = ((x + y) mod p)"
	proof (cases "p \<le> x + y")
	case False
	thus ?thesis using x y unfolding plus_p_def Let_def by auto
	next
	case True
	from True x y have *: "p > 0" "0 \<le> x + y - p" "x + y - p < p" by auto
	from True have id: "plus_p p x y = x + y - p" unfolding plus_p_def by auto
	show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
	qed

	lemma mod_ring_plus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (plus_p p) (+)"
	proof -
	{
	fix x y :: "'a mod_ring"
	have "plus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x + y)"
	by (transfer, subst plus_p_mod_def, auto, auto simp: p)
	} note * = this
	show ?thesis
	by (intro rel_funI, auto simp: mod_ring_rel_def *)
	qed

	(* subtraction *)
	lemma minus_p_mod_def: assumes x: "x \<in> {0 ..< p}" and y: "y \<in> {0 ..< p}"
	shows "minus_p p x y = ((x - y) mod p)"
	proof (cases "x - y < 0")
	case False
	thus ?thesis using x y unfolding minus_p_def Let_def by auto
	next
	case True
	from True x y have *: "p > 0" "0 \<le> x - y + p" "x - y + p < p" by auto
	from True have id: "minus_p p x y = x - y + p" unfolding minus_p_def by auto
	show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
	qed

	lemma mod_ring_minus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (minus_p p) (-)"
	proof -
	{
	fix x y :: "'a mod_ring"
	have "minus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x - y)"
	by (transfer, subst minus_p_mod_def, auto simp: p)
	} note * = this
	show ?thesis
	by (intro rel_funI, auto simp: mod_ring_rel_def *)
	qed

	(* unary minus *)
	lemma mod_ring_uminus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (uminus_p p) uminus"
	proof -
	{
	fix x :: "'a mod_ring"
	have "uminus_p p (to_int_mod_ring x) = to_int_mod_ring (uminus x)"
	by (transfer, auto simp: uminus_p_def p)
	} note * = this
	show ?thesis
	by (intro rel_funI, auto simp: mod_ring_rel_def *)
	qed

	(* multiplication *)
	lemma mod_ring_mult[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (mult_p p) ((*))"
	proof -
	{
	fix x y :: "'a mod_ring"
	have "mult_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x * y)"
	by (transfer, auto simp: mult_p_def p)
	} note * = this
	show ?thesis
	by (intro rel_funI, auto simp: mod_ring_rel_def *)
	qed

	(* equality *)
	lemma mod_ring_eq[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> (=)) (=) (=)"
	by (intro rel_funI, auto simp: mod_ring_rel_def)

	(* power *)
	lemma mod_ring_power[transfer_rule]: "(mod_ring_rel ===> (=) ===> mod_ring_rel) (power_p p) (^)"
	proof (intro rel_funI, clarify, unfold binary_power[symmetric], goal_cases)
	fix x y n
	assume xy: "mod_ring_rel x y"
	from xy show "mod_ring_rel (power_p p x n) (binary_power y n)"
	proof (induct y n arbitrary: x rule: binary_power.induct)
	case (1 x n y)
	note 1(2)[transfer_rule]
	show ?case
	proof (cases "n = 0")
	case True
	thus ?thesis by (simp add: mod_ring_1)
	next
	case False
	obtain d r where id: "Divides.divmod_nat n 2 = (d,r)" by force
	let ?int = "power_p p (mult_p p y y) d"
	let ?gfp = "binary_power (x * x) d"
	from False have id': "?thesis = (mod_ring_rel
	(if r = 0 then ?int else mult_p p ?int y)
	(if r = 0 then ?gfp else ?gfp * x))"
	unfolding power_p.simps[of _ _ n] binary_power.simps[of _ n] Let_def id split by simp
	have [transfer_rule]: "mod_ring_rel ?int ?gfp"
	by (rule 1(1)[OF False refl id[symmetric]], transfer_prover)
	show ?thesis unfolding id' by transfer_prover
	qed
	qed
	qed

	declare power_p.simps[simp del]

	lemma ring_finite_field_ops_int: "ring_ops (finite_field_ops_int p) mod_ring_rel"
	by (unfold_locales, auto simp:
	finite_field_ops_int_def
	bi_unique_mod_ring_rel
	right_total_mod_ring_rel
	mod_ring_plus
	mod_ring_minus
	mod_ring_uminus
	mod_ring_mult
	mod_ring_eq
	mod_ring_0
	mod_ring_1
	Domainp_mod_ring_rel)
	end

	locale prime_field = mod_ring_locale p ty for p and ty :: "'a :: prime_card itself"
	begin

	lemma prime: "prime p" unfolding p using prime_card[where 'a = 'a] by simp

	(* mod *)
	lemma mod_ring_mod[transfer_rule]:
	"(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) ((\<lambda> x y. if y = 0 then x else 0)) (mod)"
	proof -
	{
	fix x y :: "'a mod_ring"
	have "(if to_int_mod_ring y = 0 then to_int_mod_ring x else 0) = to_int_mod_ring (x mod y)"
	unfolding modulo_mod_ring_def by auto
	} note * = this
	show ?thesis
	by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
	qed

	(* normalize *)
	lemma mod_ring_normalize[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) ((\<lambda> x. if x = 0 then 0 else 1)) normalize"
	proof -
	{
	fix x :: "'a mod_ring"
	have "(if to_int_mod_ring x = 0 then 0 else 1) = to_int_mod_ring (normalize x)"
	unfolding normalize_mod_ring_def by auto
	} note * = this
	show ?thesis
	by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
	qed

	(* unit_factor *)
	lemma mod_ring_unit_factor[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (\<lambda> x. x) unit_factor"
	proof -
	{
	fix x :: "'a mod_ring"
	have "to_int_mod_ring x = to_int_mod_ring (unit_factor x)"
	unfolding unit_factor_mod_ring_def by auto
	} note * = this
	show ?thesis
	by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
	qed

	(* inverse *)
	lemma mod_ring_inverse[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (inverse_p p) inverse"
	proof (intro rel_funI)
	fix x y
	assume [transfer_rule]: "mod_ring_rel x y"
	show "mod_ring_rel (inverse_p p x) (inverse y)"
	unfolding inverse_p_def inverse_mod_ring_def
	apply (transfer_prover_start)
	apply (transfer_step)+
	apply (unfold p2_ident)
	apply (rule refl)
	done
	qed

	(* division *)
	lemma mod_ring_divide[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel)
	(divide_p p) (/)"
	unfolding divide_p_def[abs_def] divide_mod_ring_def[abs_def] inverse_mod_ring_def[symmetric]
	by transfer_prover

	lemma mod_ring_rel_unsafe: assumes "x < CARD('a)"
	shows "mod_ring_rel (int x) (of_nat x)" "0 < x \<Longrightarrow> of_nat x \<noteq> (0 :: 'a mod_ring)"
	proof -
	have id: "of_nat x = (of_int (int x) :: 'a mod_ring)" by simp
	show "mod_ring_rel (int x) (of_nat x)" "0 < x \<Longrightarrow> of_nat x \<noteq> (0 :: 'a mod_ring)" unfolding id
	unfolding mod_ring_rel_def
	proof (auto simp add: assms of_int_of_int_mod_ring)
	assume "0 < x" with assms
	have "of_int_mod_ring (int x) \<noteq> (0 :: 'a mod_ring)"
	by (metis (no_types) less_imp_of_nat_less less_irrefl of_nat_0_le_iff of_nat_0_less_iff to_int_mod_ring_hom.hom_zero to_int_mod_ring_of_int_mod_ring)
	thus "of_int_mod_ring (int x) = (0 :: 'a mod_ring) \<Longrightarrow> False" by blast
	qed
	qed

	lemma finite_field_ops_int: "field_ops (finite_field_ops_int p) mod_ring_rel"
	by (unfold_locales, auto simp:
	finite_field_ops_int_def
	bi_unique_mod_ring_rel
	right_total_mod_ring_rel
	mod_ring_divide
	mod_ring_plus
	mod_ring_minus
	mod_ring_uminus
	mod_ring_inverse
	mod_ring_mod
	mod_ring_unit_factor
	mod_ring_normalize
	mod_ring_mult
	mod_ring_eq
	mod_ring_0
	mod_ring_1
	Domainp_mod_ring_rel)

	end

	text \<open>Once we have proven the soundness of the implementation, we do not care any longer
	that @{typ "'a mod_ring"} has been defined internally via lifting. Disabling the transfer-rules
	will hide the internal definition in further applications of transfer.\<close>
	lifting_forget mod_ring.lifting

	text \<open>For soundness of the 32-bit implementation, we mainly prove that this implementation
	implements the int-based implementation of the mod-ring.\<close>
	context mod_ring_locale
	begin

	context fixes pp :: "uint32"
	assumes ppp: "p = int_of_uint32 pp"
	and small: "p \<le> 65535"
	begin

	lemmas uint32_simps =
	int_of_uint32_0
	int_of_uint32_plus
	int_of_uint32_minus
	int_of_uint32_mult


	definition urel32 :: "uint32 \<Rightarrow> int \<Rightarrow> bool" where "urel32 x y = (y = int_of_uint32 x \<and> y < p)"

	definition mod_ring_rel32 :: "uint32 \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
	"mod_ring_rel32 x y = (\<exists> z. urel32 x z \<and> mod_ring_rel z y)"

	lemma urel32_0: "urel32 0 0" unfolding urel32_def using p2 by (simp, transfer, simp)

	lemma urel32_1: "urel32 1 1" unfolding urel32_def using p2 by (simp, transfer, simp)

	lemma le_int_of_uint32: "(x \<le> y) = (int_of_uint32 x \<le> int_of_uint32 y)"
	by (transfer, simp add: word_le_def)

	lemma urel32_plus: assumes "urel32 x y" "urel32 x' y'"
	shows "urel32 (plus_p32 pp x x') (plus_p p y y')"
	proof -
	let ?x = "int_of_uint32 x"
	let ?x' = "int_of_uint32 x'"
	let ?p = "int_of_uint32 pp"
	from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' \<le> p" unfolding urel32_def by auto
	have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_uint32
	using rel small by (auto simp: uint32_simps)
	show ?thesis
	proof (cases "?p \<le> ?x + ?x'")
	case True
	hence True: "(?p \<le> ?x + ?x') = True" by simp
	show ?thesis unfolding id
	using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def
	unfolding ppp le True if_True
	using True by (auto simp: uint32_simps)
	next
	case False
	hence False: "(?p \<le> ?x + ?x') = False" by simp
	show ?thesis unfolding id
	using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def
	unfolding ppp le False if_False
	using False by (auto simp: uint32_simps)
	qed
	qed

	lemma urel32_minus: assumes "urel32 x y" "urel32 x' y'"
	shows "urel32 (minus_p32 pp x x') (minus_p p y y')"
	proof -
	let ?x = "int_of_uint32 x"
	let ?x' = "int_of_uint32 x'"
	from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' \<le> p" unfolding urel32_def by auto
	have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_uint32
	using rel small by (auto simp: uint32_simps)
	show ?thesis
	proof (cases "?x' \<le> ?x")
	case True
	hence True: "(?x' \<le> ?x) = True" by simp
	show ?thesis unfolding id
	using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def
	unfolding ppp le True if_True
	using True by (auto simp: uint32_simps)
	next
	case False
	hence False: "(?x' \<le> ?x) = False" by simp
	show ?thesis unfolding id
	using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def
	unfolding ppp le False if_False
	using False by (auto simp: uint32_simps)
	qed
	qed

	lemma urel32_uminus: assumes "urel32 x y"
	shows "urel32 (uminus_p32 pp x) (uminus_p p y)"
	proof -
	let ?x = "int_of_uint32 x"
	from assms int_of_uint32_ge_0 have id: "y = ?x"
	and rel: "0 \<le> ?x" "?x < p"
	unfolding urel32_def by auto
	have le: "(x = 0) = (?x = 0)" unfolding int_of_uint32_0_iff
	using rel small by (auto simp: uint32_simps)
	show ?thesis
	proof (cases "?x = 0")
	case True
	hence True: "(?x = 0) = True" by simp
	show ?thesis unfolding id
	using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def
	unfolding ppp le True if_True
	using True by (auto simp: uint32_simps)
	next
	case False
	hence False: "(?x = 0) = False" by simp
	show ?thesis unfolding id
	using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def
	unfolding ppp le False if_False
	using False by (auto simp: uint32_simps)
	qed
	qed

	lemma urel32_mult: assumes "urel32 x y" "urel32 x' y'"
	shows "urel32 (mult_p32 pp x x') (mult_p p y y')"
	proof -
	let ?x = "int_of_uint32 x"
	let ?x' = "int_of_uint32 x'"
	from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' < p" unfolding urel32_def by auto
	from rel have "?x * ?x' < p * p" by (metis mult_strict_mono')
	also have "\<dots> \<le> 65536 * 65536"
	by (rule mult_mono, insert p2 small, auto)
	finally have le: "?x * ?x' < 4294967296" by simp
	show ?thesis unfolding id
	using small rel unfolding mult_p32_def mult_p_def Let_def urel32_def
	unfolding ppp
	by (auto simp: uint32_simps, unfold int_of_uint32_mod int_of_uint32_mult,
	subst mod_pos_pos_trivial[of _ 4294967296], insert le, auto)
	qed

	lemma urel32_eq: assumes "urel32 x y" "urel32 x' y'"
	shows "(x = x') = (y = y')"
	proof -
	let ?x = "int_of_uint32 x"
	let ?x' = "int_of_uint32 x'"
	from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
	unfolding urel32_def by auto
	show ?thesis unfolding id by (transfer, transfer) rule
	qed

	lemma urel32_normalize:
	assumes x: "urel32 x y"
	shows "urel32 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
	unfolding urel32_eq[OF x urel32_0] using urel32_0 urel32_1 by auto

	lemma urel32_mod:
	assumes x: "urel32 x x'" and y: "urel32 y y'"
	shows "urel32 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
	unfolding urel32_eq[OF y urel32_0] using urel32_0 x by auto

	lemma urel32_power: "urel32 x x' \<Longrightarrow> urel32 y (int y') \<Longrightarrow> urel32 (power_p32 pp x y) (power_p p x' y')"
	including bit_operations_syntax proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
	case (1 x' y' x y)
	note x = 1(2) note y = 1(3)
	show ?case
	proof (cases "y' = 0")
	case True
	hence y: "y = 0" using urel32_eq[OF y urel32_0] by auto
	show ?thesis unfolding y True by (simp add: power_p.simps urel32_1)
	next
	case False
	hence id: "(y = 0) = False" "(y' = 0) = False" using urel32_eq[OF y urel32_0] by auto
	from y have \<open>int y' = int_of_uint32 y\<close> \<open>int y' < p\<close>
	by (simp_all add: urel32_def)
	obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
	from divmod_nat_def[of y' 2, unfolded dr']
	have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
	have "urel32 (y AND 1) r'"
	using \<open>int y' < p\<close> small
	apply (simp add: urel32_def and_one_eq r')
	apply (auto simp add: ppp and_one_eq)
	apply (simp add: of_nat_mod int_of_uint32.rep_eq modulo_uint32.rep_eq uint_mod \<open>int y' = int_of_uint32 y\<close>)
	done
	from urel32_eq[OF this urel32_0]
	have rem: "(y AND 1 = 0) = (r' = 0)" by simp
	have div: "urel32 (drop_bit 1 y) (int d')" unfolding d' using y unfolding urel32_def using small
	unfolding ppp
	apply transfer
	apply transfer
	apply (auto simp add: drop_bit_Suc take_bit_int_eq_self)
	done
	note IH = 1(1)[OF False refl dr'[symmetric] urel32_mult[OF x x] div]
	show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p32.simps[of _ _ y] dr' id if_False rem
	using IH urel32_mult[OF IH x] by (auto simp: Let_def)
	qed
	qed


	lemma urel32_inverse: assumes x: "urel32 x x'"
	shows "urel32 (inverse_p32 pp x) (inverse_p p x')"
	proof -
	have p: "urel32 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel32_def unfolding ppp
	by (simp add: int_of_uint32.rep_eq minus_uint32.rep_eq uint_sub_if')
	show ?thesis
	unfolding inverse_p32_def inverse_p_def urel32_eq[OF x urel32_0] using urel32_0 urel32_power[OF x p]
	by auto
	qed

	lemma mod_ring_0_32: "mod_ring_rel32 0 0"
	using urel32_0 mod_ring_0 unfolding mod_ring_rel32_def by blast

	lemma mod_ring_1_32: "mod_ring_rel32 1 1"
	using urel32_1 mod_ring_1 unfolding mod_ring_rel32_def by blast

	lemma mod_ring_uminus32: "(mod_ring_rel32 ===> mod_ring_rel32) (uminus_p32 pp) uminus"
	using urel32_uminus mod_ring_uminus unfolding mod_ring_rel32_def rel_fun_def by blast

	lemma mod_ring_plus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (plus_p32 pp) (+)"
	using urel32_plus mod_ring_plus unfolding mod_ring_rel32_def rel_fun_def by blast

	lemma mod_ring_minus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (minus_p32 pp) (-)"
	using urel32_minus mod_ring_minus unfolding mod_ring_rel32_def rel_fun_def by blast

	lemma mod_ring_mult32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (mult_p32 pp) ((*))"
	using urel32_mult mod_ring_mult unfolding mod_ring_rel32_def rel_fun_def by blast

	lemma mod_ring_eq32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> (=)) (=) (=)"
	using urel32_eq mod_ring_eq unfolding mod_ring_rel32_def rel_fun_def by blast

	lemma urel32_inj: "urel32 x y \<Longrightarrow> urel32 x z \<Longrightarrow> y = z"
	using urel32_eq[of x y x z] by auto

	lemma urel32_inj': "urel32 x z \<Longrightarrow> urel32 y z \<Longrightarrow> x = y"
	using urel32_eq[of x z y z] by auto

	lemma bi_unique_mod_ring_rel32:
	"bi_unique mod_ring_rel32" "left_unique mod_ring_rel32" "right_unique mod_ring_rel32"
	using bi_unique_mod_ring_rel urel32_inj'
	unfolding mod_ring_rel32_def bi_unique_def left_unique_def right_unique_def
	by (auto simp: urel32_def)

	lemma right_total_mod_ring_rel32: "right_total mod_ring_rel32"
	unfolding mod_ring_rel32_def right_total_def
	proof
	fix y :: "'a mod_ring"
	from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
	obtain z where zy: "mod_ring_rel z y" by auto
	hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
	hence "urel32 (uint32_of_int z) z" unfolding urel32_def using small unfolding ppp
	by (auto simp: int_of_uint32_inv)
	with zy show "\<exists> x z. urel32 x z \<and> mod_ring_rel z y" by blast
	qed

	lemma Domainp_mod_ring_rel32: "Domainp mod_ring_rel32 = (\<lambda>x. 0 \<le> x \<and> x < pp)"
	proof
	fix x
	show "Domainp mod_ring_rel32 x = (0 \<le> x \<and> x < pp)"
	unfolding Domainp.simps
	unfolding mod_ring_rel32_def
	proof
	let ?i = "int_of_uint32"
	assume *: "0 \<le> x \<and> x < pp"
	hence "0 \<le> ?i x \<and> ?i x < p" using small unfolding ppp
	by (transfer, auto simp: word_less_def)
	hence "?i x \<in> {0 ..< p}" by auto
	with Domainp_mod_ring_rel
	have "Domainp mod_ring_rel (?i x)" by auto
	from this[unfolded Domainp.simps]
	obtain b where b: "mod_ring_rel (?i x) b" by auto
	show "\<exists>a b. x = a \<and> (\<exists>z. urel32 a z \<and> mod_ring_rel z b)"
	proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
	show "urel32 x (?i x)" unfolding urel32_def using small * unfolding ppp
	by (transfer, auto simp: word_less_def)
	qed
	next
	assume "\<exists>a b. x = a \<and> (\<exists>z. urel32 a z \<and> mod_ring_rel z b)"
	then obtain b z where xz: "urel32 x z" and zb: "mod_ring_rel z b" by auto
	hence "Domainp mod_ring_rel z" by auto
	with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
	with xz show "0 \<le> x \<and> x < pp" unfolding urel32_def using small unfolding ppp
	by (transfer, auto simp: word_less_def)
	qed
	qed

	lemma ring_finite_field_ops32: "ring_ops (finite_field_ops32 pp) mod_ring_rel32"
	by (unfold_locales, auto simp:
	finite_field_ops32_def
	bi_unique_mod_ring_rel32
	right_total_mod_ring_rel32
	mod_ring_plus32
	mod_ring_minus32
	mod_ring_uminus32
	mod_ring_mult32
	mod_ring_eq32
	mod_ring_0_32
	mod_ring_1_32
	Domainp_mod_ring_rel32)
	end
	end

	context prime_field
	begin
	context fixes pp :: "uint32"
	assumes *: "p = int_of_uint32 pp" "p \<le> 65535"
	begin

	lemma mod_ring_normalize32: "(mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x. if x = 0 then 0 else 1) normalize"
	using urel32_normalize[OF ] mod_ring_normalize unfolding mod_ring_rel32_def[OF ] rel_fun_def by blast

	lemma mod_ring_mod32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x y. if y = 0 then x else 0) (mod)"
	using urel32_mod[OF ] mod_ring_mod unfolding mod_ring_rel32_def[OF ] rel_fun_def by blast

	lemma mod_ring_unit_factor32: "(mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x. x) unit_factor"
	using mod_ring_unit_factor unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

	lemma mod_ring_inverse32: "(mod_ring_rel32 ===> mod_ring_rel32) (inverse_p32 pp) inverse"
	using urel32_inverse[OF ] mod_ring_inverse unfolding mod_ring_rel32_def[OF ] rel_fun_def by blast

	lemma mod_ring_divide32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (divide_p32 pp) (/)"
	using mod_ring_inverse32 mod_ring_mult32[OF *]
	unfolding divide_p32_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
	rel_fun_def by blast

	lemma finite_field_ops32: "field_ops (finite_field_ops32 pp) mod_ring_rel32"
	by (unfold_locales, insert ring_finite_field_ops32[OF *], auto simp:
	ring_ops_def
	finite_field_ops32_def
	mod_ring_divide32
	mod_ring_inverse32
	mod_ring_mod32
	mod_ring_normalize32)

	end
	end

	(* now there is 64-bit time *)
	context
	fixes p :: uint64
	begin
	definition plus_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
	"plus_p64 x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

	definition minus_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
	"minus_p64 x y \<equiv> if y \<le> x then x - y else (x + p) - y"

	definition uminus_p64 :: "uint64 \<Rightarrow> uint64" where
	"uminus_p64 x = (if x = 0 then 0 else p - x)"

	definition mult_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
	"mult_p64 x y = (x * y mod p)"

	lemma int_of_uint64_shift: "int_of_uint64 (drop_bit k n) = (int_of_uint64 n) div (2 ^ k)"
	apply transfer
	apply transfer
	apply (simp add: take_bit_drop_bit min_def)
	apply (simp add: drop_bit_eq_div)
	done

	lemma int_of_uint64_0_iff: "int_of_uint64 n = 0 \<longleftrightarrow> n = 0"
	by (transfer, rule uint_0_iff)

	lemma int_of_uint64_0: "int_of_uint64 0 = 0" unfolding int_of_uint64_0_iff by simp

	lemma int_of_uint64_ge_0: "int_of_uint64 n \<ge> 0"
	by (transfer, auto)

	lemma two_64: "2 ^ LENGTH(64) = (18446744073709551616 :: int)" by simp

	lemma int_of_uint64_plus: "int_of_uint64 (x + y) = (int_of_uint64 x + int_of_uint64 y) mod 18446744073709551616"
	by (transfer, unfold uint_word_ariths two_64, rule refl)

	lemma int_of_uint64_minus: "int_of_uint64 (x - y) = (int_of_uint64 x - int_of_uint64 y) mod 18446744073709551616"
	by (transfer, unfold uint_word_ariths two_64, rule refl)

	lemma int_of_uint64_mult: "int_of_uint64 (x * y) = (int_of_uint64 x * int_of_uint64 y) mod 18446744073709551616"
	by (transfer, unfold uint_word_ariths two_64, rule refl)

	lemma int_of_uint64_mod: "int_of_uint64 (x mod y) = (int_of_uint64 x mod int_of_uint64 y)"
	by (transfer, unfold uint_mod two_64, rule refl)

	lemma int_of_uint64_inv: "0 \<le> x \<Longrightarrow> x < 18446744073709551616 \<Longrightarrow> int_of_uint64 (uint64_of_int x) = x"
	by transfer (simp add: take_bit_int_eq_self unsigned_of_int)

	context
	includes bit_operations_syntax
	begin

	function power_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
	"power_p64 x n = (if n = 0 then 1 else
	let rec = power_p64 (mult_p64 x x) (drop_bit 1 n) in
	if n AND 1 = 0 then rec else mult_p64 rec x)"
	by pat_completeness auto

	termination
	proof -
	{
	fix n :: uint64
	assume "n \<noteq> 0"
	with int_of_uint64_ge_0[of n] int_of_uint64_0_iff[of n] have "int_of_uint64 n > 0" by auto
	hence "0 < int_of_uint64 n" "int_of_uint64 n div 2 < int_of_uint64 n" by auto
	} note * = this
	show ?thesis
	by (relation "measure (\<lambda> (x,n). nat (int_of_uint64 n))", auto simp: int_of_uint64_shift *)
	qed

	end

	text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
	it turned out that taking the below implementation of inverse via exponentiation
	is faster than the one based on the extended Euclidean algorithm.\<close>

	definition inverse_p64 :: "uint64 \<Rightarrow> uint64" where
	"inverse_p64 x = (if x = 0 then 0 else power_p64 x (p - 2))"

	definition divide_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
	"divide_p64 x y = mult_p64 x (inverse_p64 y)"

	definition finite_field_ops64 :: "uint64 arith_ops_record" where
	"finite_field_ops64 \<equiv> Arith_Ops_Record
	0
	1
	plus_p64
	mult_p64
	minus_p64
	uminus_p64
	divide_p64
	inverse_p64
	(\<lambda> x y . if y = 0 then x else 0)
	(\<lambda> x . if x = 0 then 0 else 1)
	(\<lambda> x . x)
	uint64_of_int
	int_of_uint64
	(\<lambda> x. 0 \<le> x \<and> x < p)"
	end

	lemma shiftr_uint64_code [code_unfold]: "drop_bit 1 x = (uint64_shiftr x 1)"
	by (simp add: uint64_shiftr_def)

	text \<open>For soundness of the 64-bit implementation, we mainly prove that this implementation
	implements the int-based implementation of GF(p).\<close>
	context mod_ring_locale
	begin

	context fixes pp :: "uint64"
	assumes ppp: "p = int_of_uint64 pp"
	and small: "p \<le> 4294967295"
	begin

	lemmas uint64_simps =
	int_of_uint64_0
	int_of_uint64_plus
	int_of_uint64_minus
	int_of_uint64_mult


	definition urel64 :: "uint64 \<Rightarrow> int \<Rightarrow> bool" where "urel64 x y = (y = int_of_uint64 x \<and> y < p)"

	definition mod_ring_rel64 :: "uint64 \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
	"mod_ring_rel64 x y = (\<exists> z. urel64 x z \<and> mod_ring_rel z y)"

	lemma urel64_0: "urel64 0 0" unfolding urel64_def using p2 by (simp, transfer, simp)

	lemma urel64_1: "urel64 1 1" unfolding urel64_def using p2 by (simp, transfer, simp)

	lemma le_int_of_uint64: "(x \<le> y) = (int_of_uint64 x \<le> int_of_uint64 y)"
	by (transfer, simp add: word_le_def)

	lemma urel64_plus: assumes "urel64 x y" "urel64 x' y'"
	shows "urel64 (plus_p64 pp x x') (plus_p p y y')"
	proof -
	let ?x = "int_of_uint64 x"
	let ?x' = "int_of_uint64 x'"
	let ?p = "int_of_uint64 pp"
	from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' \<le> p" unfolding urel64_def by auto
	have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_uint64
	using rel small by (auto simp: uint64_simps)
	show ?thesis
	proof (cases "?p \<le> ?x + ?x'")
	case True
	hence True: "(?p \<le> ?x + ?x') = True" by simp
	show ?thesis unfolding id
	using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def
	unfolding ppp le True if_True
	using True by (auto simp: uint64_simps)
	next
	case False
	hence False: "(?p \<le> ?x + ?x') = False" by simp
	show ?thesis unfolding id
	using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def
	unfolding ppp le False if_False
	using False by (auto simp: uint64_simps)
	qed
	qed

	lemma urel64_minus: assumes "urel64 x y" "urel64 x' y'"
	shows "urel64 (minus_p64 pp x x') (minus_p p y y')"
	proof -
	let ?x = "int_of_uint64 x"
	let ?x' = "int_of_uint64 x'"
	from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' \<le> p" unfolding urel64_def by auto
	have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_uint64
	using rel small by (auto simp: uint64_simps)
	show ?thesis
	proof (cases "?x' \<le> ?x")
	case True
	hence True: "(?x' \<le> ?x) = True" by simp
	show ?thesis unfolding id
	using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def
	unfolding ppp le True if_True
	using True by (auto simp: uint64_simps)
	next
	case False
	hence False: "(?x' \<le> ?x) = False" by simp
	show ?thesis unfolding id
	using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def
	unfolding ppp le False if_False
	using False by (auto simp: uint64_simps)
	qed
	qed

	lemma urel64_uminus: assumes "urel64 x y"
	shows "urel64 (uminus_p64 pp x) (uminus_p p y)"
	proof -
	let ?x = "int_of_uint64 x"
	from assms int_of_uint64_ge_0 have id: "y = ?x"
	and rel: "0 \<le> ?x" "?x < p"
	unfolding urel64_def by auto
	have le: "(x = 0) = (?x = 0)" unfolding int_of_uint64_0_iff
	using rel small by (auto simp: uint64_simps)
	show ?thesis
	proof (cases "?x = 0")
	case True
	hence True: "(?x = 0) = True" by simp
	show ?thesis unfolding id
	using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def
	unfolding ppp le True if_True
	using True by (auto simp: uint64_simps)
	next
	case False
	hence False: "(?x = 0) = False" by simp
	show ?thesis unfolding id
	using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def
	unfolding ppp le False if_False
	using False by (auto simp: uint64_simps)
	qed
	qed

	lemma urel64_mult: assumes "urel64 x y" "urel64 x' y'"
	shows "urel64 (mult_p64 pp x x') (mult_p p y y')"
	proof -
	let ?x = "int_of_uint64 x"
	let ?x' = "int_of_uint64 x'"
	from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' < p" unfolding urel64_def by auto
	from rel have "?x * ?x' < p * p" by (metis mult_strict_mono')
	also have "\<dots> \<le> 4294967296 * 4294967296"
	by (rule mult_mono, insert p2 small, auto)
	finally have le: "?x * ?x' < 18446744073709551616" by simp
	show ?thesis unfolding id
	using small rel unfolding mult_p64_def mult_p_def Let_def urel64_def
	unfolding ppp
	by (auto simp: uint64_simps, unfold int_of_uint64_mod int_of_uint64_mult,
	subst mod_pos_pos_trivial[of _ 18446744073709551616], insert le, auto)
	qed

	lemma urel64_eq: assumes "urel64 x y" "urel64 x' y'"
	shows "(x = x') = (y = y')"
	proof -
	let ?x = "int_of_uint64 x"
	let ?x' = "int_of_uint64 x'"
	from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
	unfolding urel64_def by auto
	show ?thesis unfolding id by (transfer, transfer) rule
	qed

	lemma urel64_normalize:
	assumes x: "urel64 x y"
	shows "urel64 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
	unfolding urel64_eq[OF x urel64_0] using urel64_0 urel64_1 by auto

	lemma urel64_mod:
	assumes x: "urel64 x x'" and y: "urel64 y y'"
	shows "urel64 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
	unfolding urel64_eq[OF y urel64_0] using urel64_0 x by auto

	lemma urel64_power: "urel64 x x' \<Longrightarrow> urel64 y (int y') \<Longrightarrow> urel64 (power_p64 pp x y) (power_p p x' y')"
	including bit_operations_syntax proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
	case (1 x' y' x y)
	note x = 1(2) note y = 1(3)
	show ?case
	proof (cases "y' = 0")
	case True
	hence y: "y = 0" using urel64_eq[OF y urel64_0] by auto
	show ?thesis unfolding y True by (simp add: power_p.simps urel64_1)
	next
	case False
	hence id: "(y = 0) = False" "(y' = 0) = False" using urel64_eq[OF y urel64_0] by auto
	from y have \<open>int y' = int_of_uint64 y\<close> \<open>int y' < p\<close>
	by (simp_all add: urel64_def)
	obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
	from divmod_nat_def[of y' 2, unfolded dr']
	have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
	have "urel64 (y AND 1) r'"
	using \<open>int y' < p\<close> small
	apply (simp add: urel64_def and_one_eq r')
	apply (auto simp add: ppp and_one_eq)
	apply (simp add: of_nat_mod int_of_uint64.rep_eq modulo_uint64.rep_eq uint_mod \<open>int y' = int_of_uint64 y\<close>)
	done
	from urel64_eq[OF this urel64_0]
	have rem: "(y AND 1 = 0) = (r' = 0)" by simp
	have div: "urel64 (drop_bit 1 y) (int d')" unfolding d' using y unfolding urel64_def using small
	unfolding ppp
	apply transfer
	apply transfer
	apply (auto simp add: drop_bit_Suc take_bit_int_eq_self)
	done
	note IH = 1(1)[OF False refl dr'[symmetric] urel64_mult[OF x x] div]
	show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p64.simps[of _ _ y] dr' id if_False rem
	using IH urel64_mult[OF IH x] by (auto simp: Let_def)
	qed
	qed


	lemma urel64_inverse: assumes x: "urel64 x x'"
	shows "urel64 (inverse_p64 pp x) (inverse_p p x')"
	proof -
	have p: "urel64 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel64_def unfolding ppp
	by (simp add: int_of_uint64.rep_eq minus_uint64.rep_eq uint_sub_if')
	show ?thesis
	unfolding inverse_p64_def inverse_p_def urel64_eq[OF x urel64_0] using urel64_0 urel64_power[OF x p]
	by auto
	qed

	lemma mod_ring_0_64: "mod_ring_rel64 0 0"
	using urel64_0 mod_ring_0 unfolding mod_ring_rel64_def by blast

	lemma mod_ring_1_64: "mod_ring_rel64 1 1"
	using urel64_1 mod_ring_1 unfolding mod_ring_rel64_def by blast

	lemma mod_ring_uminus64: "(mod_ring_rel64 ===> mod_ring_rel64) (uminus_p64 pp) uminus"
	using urel64_uminus mod_ring_uminus unfolding mod_ring_rel64_def rel_fun_def by blast

	lemma mod_ring_plus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (plus_p64 pp) (+)"
	using urel64_plus mod_ring_plus unfolding mod_ring_rel64_def rel_fun_def by blast

	lemma mod_ring_minus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (minus_p64 pp) (-)"
	using urel64_minus mod_ring_minus unfolding mod_ring_rel64_def rel_fun_def by blast

	lemma mod_ring_mult64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (mult_p64 pp) ((*))"
	using urel64_mult mod_ring_mult unfolding mod_ring_rel64_def rel_fun_def by blast

	lemma mod_ring_eq64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> (=)) (=) (=)"
	using urel64_eq mod_ring_eq unfolding mod_ring_rel64_def rel_fun_def by blast

	lemma urel64_inj: "urel64 x y \<Longrightarrow> urel64 x z \<Longrightarrow> y = z"
	using urel64_eq[of x y x z] by auto

	lemma urel64_inj': "urel64 x z \<Longrightarrow> urel64 y z \<Longrightarrow> x = y"
	using urel64_eq[of x z y z] by auto

	lemma bi_unique_mod_ring_rel64:
	"bi_unique mod_ring_rel64" "left_unique mod_ring_rel64" "right_unique mod_ring_rel64"
	using bi_unique_mod_ring_rel urel64_inj'
	unfolding mod_ring_rel64_def bi_unique_def left_unique_def right_unique_def
	by (auto simp: urel64_def)

	lemma right_total_mod_ring_rel64: "right_total mod_ring_rel64"
	unfolding mod_ring_rel64_def right_total_def
	proof
	fix y :: "'a mod_ring"
	from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
	obtain z where zy: "mod_ring_rel z y" by auto
	hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
	hence "urel64 (uint64_of_int z) z" unfolding urel64_def using small unfolding ppp
	by (auto simp: int_of_uint64_inv)
	with zy show "\<exists> x z. urel64 x z \<and> mod_ring_rel z y" by blast
	qed

	lemma Domainp_mod_ring_rel64: "Domainp mod_ring_rel64 = (\<lambda>x. 0 \<le> x \<and> x < pp)"
	proof
	fix x
	show "Domainp mod_ring_rel64 x = (0 \<le> x \<and> x < pp)"
	unfolding Domainp.simps
	unfolding mod_ring_rel64_def
	proof
	let ?i = "int_of_uint64"
	assume *: "0 \<le> x \<and> x < pp"
	hence "0 \<le> ?i x \<and> ?i x < p" using small unfolding ppp
	by (transfer, auto simp: word_less_def)
	hence "?i x \<in> {0 ..< p}" by auto
	with Domainp_mod_ring_rel
	have "Domainp mod_ring_rel (?i x)" by auto
	from this[unfolded Domainp.simps]
	obtain b where b: "mod_ring_rel (?i x) b" by auto
	show "\<exists>a b. x = a \<and> (\<exists>z. urel64 a z \<and> mod_ring_rel z b)"
	proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
	show "urel64 x (?i x)" unfolding urel64_def using small * unfolding ppp
	by (transfer, auto simp: word_less_def)
	qed
	next
	assume "\<exists>a b. x = a \<and> (\<exists>z. urel64 a z \<and> mod_ring_rel z b)"
	then obtain b z where xz: "urel64 x z" and zb: "mod_ring_rel z b" by auto
	hence "Domainp mod_ring_rel z" by auto
	with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
	with xz show "0 \<le> x \<and> x < pp" unfolding urel64_def using small unfolding ppp
	by (transfer, auto simp: word_less_def)
	qed
	qed

	lemma ring_finite_field_ops64: "ring_ops (finite_field_ops64 pp) mod_ring_rel64"
	by (unfold_locales, auto simp:
	finite_field_ops64_def
	bi_unique_mod_ring_rel64
	right_total_mod_ring_rel64
	mod_ring_plus64
	mod_ring_minus64
	mod_ring_uminus64
	mod_ring_mult64
	mod_ring_eq64
	mod_ring_0_64
	mod_ring_1_64
	Domainp_mod_ring_rel64)
	end
	end

	context prime_field
	begin
	context fixes pp :: "uint64"
	assumes *: "p = int_of_uint64 pp" "p \<le> 4294967295"
	begin

	lemma mod_ring_normalize64: "(mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x. if x = 0 then 0 else 1) normalize"
	using urel64_normalize[OF ] mod_ring_normalize unfolding mod_ring_rel64_def[OF ] rel_fun_def by blast

	lemma mod_ring_mod64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x y. if y = 0 then x else 0) (mod)"
	using urel64_mod[OF ] mod_ring_mod unfolding mod_ring_rel64_def[OF ] rel_fun_def by blast

	lemma mod_ring_unit_factor64: "(mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x. x) unit_factor"
	using mod_ring_unit_factor unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

	lemma mod_ring_inverse64: "(mod_ring_rel64 ===> mod_ring_rel64) (inverse_p64 pp) inverse"
	using urel64_inverse[OF ] mod_ring_inverse unfolding mod_ring_rel64_def[OF ] rel_fun_def by blast

	lemma mod_ring_divide64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (divide_p64 pp) (/)"
	using mod_ring_inverse64 mod_ring_mult64[OF *]
	unfolding divide_p64_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
	rel_fun_def by blast

	lemma finite_field_ops64: "field_ops (finite_field_ops64 pp) mod_ring_rel64"
	by (unfold_locales, insert ring_finite_field_ops64[OF *], auto simp:
	ring_ops_def
	finite_field_ops64_def
	mod_ring_divide64
	mod_ring_inverse64
	mod_ring_mod64
	mod_ring_normalize64)
	end
	end

	(* and a final implementation via integer *)
	context
	fixes p :: integer
	begin
	definition plus_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
	"plus_p_integer x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

	definition minus_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
	"minus_p_integer x y \<equiv> if y \<le> x then x - y else (x + p) - y"

	definition uminus_p_integer :: "integer \<Rightarrow> integer" where
	"uminus_p_integer x = (if x = 0 then 0 else p - x)"

	definition mult_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
	"mult_p_integer x y = (x * y mod p)"

	lemma int_of_integer_0_iff: "int_of_integer n = 0 \<longleftrightarrow> n = 0"
	using integer_eqI by auto

	lemma int_of_integer_0: "int_of_integer 0 = 0" unfolding int_of_integer_0_iff by simp

	lemma int_of_integer_plus: "int_of_integer (x + y) = (int_of_integer x + int_of_integer y)"
	by simp

	lemma int_of_integer_minus: "int_of_integer (x - y) = (int_of_integer x - int_of_integer y)"
	by simp

	lemma int_of_integer_mult: "int_of_integer (x * y) = (int_of_integer x * int_of_integer y)"
	by simp

	lemma int_of_integer_mod: "int_of_integer (x mod y) = (int_of_integer x mod int_of_integer y)"
	by simp

	lemma int_of_integer_inv: "int_of_integer (integer_of_int x) = x" by simp

	lemma int_of_integer_shift: "int_of_integer (drop_bit k n) = (int_of_integer n) div (2 ^ k)"
	by transfer (simp add: int_of_integer_pow shiftr_integer_conv_div_pow2)

	context
	includes bit_operations_syntax
	begin

	function power_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
	"power_p_integer x n = (if n \<le> 0 then 1 else
	let rec = power_p_integer (mult_p_integer x x) (drop_bit 1 n) in
	if n AND 1 = 0 then rec else mult_p_integer rec x)"
	by pat_completeness auto

	termination
	proof -
	{
	fix n :: integer
	assume "\<not> (n \<le> 0)"
	hence "n > 0" by auto
	hence "int_of_integer n > 0"
	by (simp add: less_integer.rep_eq)
	hence "0 < int_of_integer n" "int_of_integer n div 2 < int_of_integer n" by auto
	} note * = this
	show ?thesis
	by (relation "measure (\<lambda> (x,n). nat (int_of_integer n))", auto simp: * int_of_integer_shift)
	qed

	end

	text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
	it turned out that taking the below implementation of inverse via exponentiation
	is faster than the one based on the extended Euclidean algorithm.\<close>

	definition inverse_p_integer :: "integer \<Rightarrow> integer" where
	"inverse_p_integer x = (if x = 0 then 0 else power_p_integer x (p - 2))"

	definition divide_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
	"divide_p_integer x y = mult_p_integer x (inverse_p_integer y)"

	definition finite_field_ops_integer :: "integer arith_ops_record" where
	"finite_field_ops_integer \<equiv> Arith_Ops_Record
	0
	1
	plus_p_integer
	mult_p_integer
	minus_p_integer
	uminus_p_integer
	divide_p_integer
	inverse_p_integer
	(\<lambda> x y . if y = 0 then x else 0)
	(\<lambda> x . if x = 0 then 0 else 1)
	(\<lambda> x . x)
	integer_of_int
	int_of_integer
	(\<lambda> x. 0 \<le> x \<and> x < p)"
	end

	lemma shiftr_integer_code [code_unfold]: "drop_bit 1 x = (integer_shiftr x 1)"
	unfolding shiftr_integer_code using integer_of_nat_1 by auto

	text \<open>For soundness of the integer implementation, we mainly prove that this implementation
	implements the int-based implementation of GF(p).\<close>
	context mod_ring_locale
	begin

	context fixes pp :: "integer"
	assumes ppp: "p = int_of_integer pp"
	begin

	lemmas integer_simps =
	int_of_integer_0
	int_of_integer_plus
	int_of_integer_minus
	int_of_integer_mult


	definition urel_integer :: "integer \<Rightarrow> int \<Rightarrow> bool" where "urel_integer x y = (y = int_of_integer x \<and> y \<ge> 0 \<and> y < p)"

	definition mod_ring_rel_integer :: "integer \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
	"mod_ring_rel_integer x y = (\<exists> z. urel_integer x z \<and> mod_ring_rel z y)"

	lemma urel_integer_0: "urel_integer 0 0" unfolding urel_integer_def using p2 by simp

	lemma urel_integer_1: "urel_integer 1 1" unfolding urel_integer_def using p2 by simp

	lemma le_int_of_integer: "(x \<le> y) = (int_of_integer x \<le> int_of_integer y)"
	by (rule less_eq_integer.rep_eq)

	lemma urel_integer_plus: assumes "urel_integer x y" "urel_integer x' y'"
	shows "urel_integer (plus_p_integer pp x x') (plus_p p y y')"
	proof -
	let ?x = "int_of_integer x"
	let ?x' = "int_of_integer x'"
	let ?p = "int_of_integer pp"
	from assms have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' \<le> p" unfolding urel_integer_def by auto
	have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_integer
	using rel by auto
	show ?thesis
	proof (cases "?p \<le> ?x + ?x'")
	case True
	hence True: "(?p \<le> ?x + ?x') = True" by simp
	show ?thesis unfolding id
	using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def
	unfolding ppp le True if_True
	using True by auto
	next
	case False
	hence False: "(?p \<le> ?x + ?x') = False" by simp
	show ?thesis unfolding id
	using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def
	unfolding ppp le False if_False
	using False by auto
	qed
	qed

	lemma urel_integer_minus: assumes "urel_integer x y" "urel_integer x' y'"
	shows "urel_integer (minus_p_integer pp x x') (minus_p p y y')"
	proof -
	let ?x = "int_of_integer x"
	let ?x' = "int_of_integer x'"
	from assms have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' \<le> p" unfolding urel_integer_def by auto
	have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_integer
	using rel by auto
	show ?thesis
	proof (cases "?x' \<le> ?x")
	case True
	hence True: "(?x' \<le> ?x) = True" by simp
	show ?thesis unfolding id
	using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def
	unfolding ppp le True if_True
	using True by auto
	next
	case False
	hence False: "(?x' \<le> ?x) = False" by simp
	show ?thesis unfolding id
	using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def
	unfolding ppp le False if_False
	using False by auto
	qed
	qed

	lemma urel_integer_uminus: assumes "urel_integer x y"
	shows "urel_integer (uminus_p_integer pp x) (uminus_p p y)"
	proof -
	let ?x = "int_of_integer x"
	from assms have id: "y = ?x"
	and rel: "0 \<le> ?x" "?x < p"
	unfolding urel_integer_def by auto
	have le: "(x = 0) = (?x = 0)" unfolding int_of_integer_0_iff
	using rel by auto
	show ?thesis
	proof (cases "?x = 0")
	case True
	hence True: "(?x = 0) = True" by simp
	show ?thesis unfolding id
	using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def
	unfolding ppp le True if_True
	using True by auto
	next
	case False
	hence False: "(?x = 0) = False" by simp
	show ?thesis unfolding id
	using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def
	unfolding ppp le False if_False
	using False by auto
	qed
	qed

	lemma pp_pos: "int_of_integer pp > 0"
	using ppp nontriv[where 'a = 'a] unfolding p
	by (simp add: less_integer.rep_eq)

	lemma urel_integer_mult: assumes "urel_integer x y" "urel_integer x' y'"
	shows "urel_integer (mult_p_integer pp x x') (mult_p p y y')"
	proof -
	let ?x = "int_of_integer x"
	let ?x' = "int_of_integer x'"
	from assms have id: "y = ?x" "y' = ?x'"
	and rel: "0 \<le> ?x" "?x < p"
	"0 \<le> ?x'" "?x' < p" unfolding urel_integer_def by auto
	from rel(1,3) have xx: "0 \<le> ?x * ?x'" by simp
	show ?thesis unfolding id
	using rel unfolding mult_p_integer_def mult_p_def Let_def urel_integer_def
	unfolding ppp mod_nonneg_pos_int[OF xx pp_pos] using xx pp_pos by simp
	qed

	lemma urel_integer_eq: assumes "urel_integer x y" "urel_integer x' y'"
	shows "(x = x') = (y = y')"
	proof -
	let ?x = "int_of_integer x"
	let ?x' = "int_of_integer x'"
	from assms have id: "y = ?x" "y' = ?x'"
	unfolding urel_integer_def by auto
	show ?thesis unfolding id integer_eq_iff ..
	qed

	lemma urel_integer_normalize:
	assumes x: "urel_integer x y"
	shows "urel_integer (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
	unfolding urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_1 by auto

	lemma urel_integer_mod:
	assumes x: "urel_integer x x'" and y: "urel_integer y y'"
	shows "urel_integer (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
	unfolding urel_integer_eq[OF y urel_integer_0] using urel_integer_0 x by auto

	lemma urel_integer_power: "urel_integer x x' \<Longrightarrow> urel_integer y (int y') \<Longrightarrow> urel_integer (power_p_integer pp x y) (power_p p x' y')"
	including bit_operations_syntax proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
	case (1 x' y' x y)
	note x = 1(2) note y = 1(3)
	show ?case
	proof (cases "y' \<le> 0")
	case True
	hence y: "y = 0" "y' = 0" using urel_integer_eq[OF y urel_integer_0] by auto
	show ?thesis unfolding y True by (simp add: power_p.simps urel_integer_1)
	next
	case False
	hence id: "(y \<le> 0) = False" "(y' = 0) = False" using False y
	by (auto simp add: urel_integer_def not_le) (metis of_int_integer_of of_int_of_nat_eq of_nat_0_less_iff)
	obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
	from divmod_nat_def[of y' 2, unfolded dr']
	have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
	have aux: "\<And> y'. int (y' mod 2) = int y' mod 2" by presburger
	have "urel_integer (y AND 1) r'" unfolding r' using y unfolding urel_integer_def
	unfolding ppp
	apply (auto simp add: and_one_eq)
	apply (simp add: of_nat_mod)
	done
	from urel_integer_eq[OF this urel_integer_0]
	have rem: "(y AND 1 = 0) = (r' = 0)" by simp
	have div: "urel_integer (drop_bit 1 y) (int d')" unfolding d' using y unfolding urel_integer_def
	unfolding ppp shiftr_integer_conv_div_pow2 by auto
	from id have "y' \<noteq> 0" by auto
	note IH = 1(1)[OF this refl dr'[symmetric] urel_integer_mult[OF x x] div]
	show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p_integer.simps[of _ _ y] dr' id if_False rem
	using IH urel_integer_mult[OF IH x] by (auto simp: Let_def)
	qed
	qed


	lemma urel_integer_inverse: assumes x: "urel_integer x x'"
	shows "urel_integer (inverse_p_integer pp x) (inverse_p p x')"
	proof -
	have p: "urel_integer (pp - 2) (int (nat (p - 2)))" using p2 unfolding urel_integer_def unfolding ppp
	by auto
	show ?thesis
	unfolding inverse_p_integer_def inverse_p_def urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_power[OF x p]
	by auto
	qed

	lemma mod_ring_0__integer: "mod_ring_rel_integer 0 0"
	using urel_integer_0 mod_ring_0 unfolding mod_ring_rel_integer_def by blast

	lemma mod_ring_1__integer: "mod_ring_rel_integer 1 1"
	using urel_integer_1 mod_ring_1 unfolding mod_ring_rel_integer_def by blast

	lemma mod_ring_uminus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (uminus_p_integer pp) uminus"
	using urel_integer_uminus mod_ring_uminus unfolding mod_ring_rel_integer_def rel_fun_def by blast

	lemma mod_ring_plus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (plus_p_integer pp) (+)"
	using urel_integer_plus mod_ring_plus unfolding mod_ring_rel_integer_def rel_fun_def by blast

	lemma mod_ring_minus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (minus_p_integer pp) (-)"
	using urel_integer_minus mod_ring_minus unfolding mod_ring_rel_integer_def rel_fun_def by blast

	lemma mod_ring_mult_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (mult_p_integer pp) ((*))"
	using urel_integer_mult mod_ring_mult unfolding mod_ring_rel_integer_def rel_fun_def by blast

	lemma mod_ring_eq_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> (=)) (=) (=)"
	using urel_integer_eq mod_ring_eq unfolding mod_ring_rel_integer_def rel_fun_def by blast

	lemma urel_integer_inj: "urel_integer x y \<Longrightarrow> urel_integer x z \<Longrightarrow> y = z"
	using urel_integer_eq[of x y x z] by auto

	lemma urel_integer_inj': "urel_integer x z \<Longrightarrow> urel_integer y z \<Longrightarrow> x = y"
	using urel_integer_eq[of x z y z] by auto

	lemma bi_unique_mod_ring_rel_integer:
	"bi_unique mod_ring_rel_integer" "left_unique mod_ring_rel_integer" "right_unique mod_ring_rel_integer"
	using bi_unique_mod_ring_rel urel_integer_inj'
	unfolding mod_ring_rel_integer_def bi_unique_def left_unique_def right_unique_def
	by (auto simp: urel_integer_def)

	lemma right_total_mod_ring_rel_integer: "right_total mod_ring_rel_integer"
	unfolding mod_ring_rel_integer_def right_total_def
	proof
	fix y :: "'a mod_ring"
	from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
	obtain z where zy: "mod_ring_rel z y" by auto
	hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
	hence "urel_integer (integer_of_int z) z" unfolding urel_integer_def unfolding ppp
	by auto
	with zy show "\<exists> x z. urel_integer x z \<and> mod_ring_rel z y" by blast
	qed

	lemma Domainp_mod_ring_rel_integer: "Domainp mod_ring_rel_integer = (\<lambda>x. 0 \<le> x \<and> x < pp)"
	proof
	fix x
	show "Domainp mod_ring_rel_integer x = (0 \<le> x \<and> x < pp)"
	unfolding Domainp.simps
	unfolding mod_ring_rel_integer_def
	proof
	let ?i = "int_of_integer"
	assume *: "0 \<le> x \<and> x < pp"
	hence "0 \<le> ?i x \<and> ?i x < p" unfolding ppp
	by (simp add: le_int_of_integer less_integer.rep_eq)
	hence "?i x \<in> {0 ..< p}" by auto
	with Domainp_mod_ring_rel
	have "Domainp mod_ring_rel (?i x)" by auto
	from this[unfolded Domainp.simps]
	obtain b where b: "mod_ring_rel (?i x) b" by auto
	show "\<exists>a b. x = a \<and> (\<exists>z. urel_integer a z \<and> mod_ring_rel z b)"
	proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
	show "urel_integer x (?i x)" unfolding urel_integer_def using * unfolding ppp
	by (simp add: le_int_of_integer less_integer.rep_eq)
	qed
	next
	assume "\<exists>a b. x = a \<and> (\<exists>z. urel_integer a z \<and> mod_ring_rel z b)"
	then obtain b z where xz: "urel_integer x z" and zb: "mod_ring_rel z b" by auto
	hence "Domainp mod_ring_rel z" by auto
	with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
	with xz show "0 \<le> x \<and> x < pp" unfolding urel_integer_def unfolding ppp
	by (simp add: le_int_of_integer less_integer.rep_eq)
	qed
	qed

	lemma ring_finite_field_ops_integer: "ring_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
	by (unfold_locales, auto simp:
	finite_field_ops_integer_def
	bi_unique_mod_ring_rel_integer
	right_total_mod_ring_rel_integer
	mod_ring_plus_integer
	mod_ring_minus_integer
	mod_ring_uminus_integer
	mod_ring_mult_integer
	mod_ring_eq_integer
	mod_ring_0__integer
	mod_ring_1__integer
	Domainp_mod_ring_rel_integer)
	end
	end

	context prime_field
	begin
	context fixes pp :: "integer"
	assumes *: "p = int_of_integer pp"
	begin

	lemma mod_ring_normalize_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x. if x = 0 then 0 else 1) normalize"
	using urel_integer_normalize[OF ] mod_ring_normalize unfolding mod_ring_rel_integer_def[OF ] rel_fun_def by blast

	lemma mod_ring_mod_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x y. if y = 0 then x else 0) (mod)"
	using urel_integer_mod[OF ] mod_ring_mod unfolding mod_ring_rel_integer_def[OF ] rel_fun_def by blast

	lemma mod_ring_unit_factor_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x. x) unit_factor"
	using mod_ring_unit_factor unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

	lemma mod_ring_inverse_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (inverse_p_integer pp) inverse"
	using urel_integer_inverse[OF ] mod_ring_inverse unfolding mod_ring_rel_integer_def[OF ] rel_fun_def by blast

	lemma mod_ring_divide_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (divide_p_integer pp) (/)"
	using mod_ring_inverse_integer mod_ring_mult_integer[OF *]
	unfolding divide_p_integer_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
	rel_fun_def by blast

	lemma finite_field_ops_integer: "field_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
	by (unfold_locales, insert ring_finite_field_ops_integer[OF *], auto simp:
	ring_ops_def
	finite_field_ops_integer_def
	mod_ring_divide_integer
	mod_ring_inverse_integer
	mod_ring_mod_integer
	mod_ring_normalize_integer)
	end
	end

	context prime_field
	begin
	(* four implementations of modular integer arithmetic for finite fields *)
	thm
	finite_field_ops64
	finite_field_ops32
	finite_field_ops_integer
	finite_field_ops_int
	end

	context mod_ring_locale
	begin
	(* four implementations of modular integer arithmetic for finite rings *)
	thm
	ring_finite_field_ops64
	ring_finite_field_ops32
	ring_finite_field_ops_integer
	ring_finite_field_ops_int
	end

	end
	diff --git a/thys/Buildings/Algebra.thy b/thys/Buildings/Algebra.thy
	--- a/thys/Buildings/Algebra.thy
	+++ b/thys/Buildings/Algebra.thy
	@@ -1,3095 +1,3094 @@
	section \<open>Algebra\<close>

	text \<open>
	In this section, we develop the necessary algebra for developing the theory of Coxeter systems,
	including groups, quotient groups, free groups, group presentations, and words in a group over a
	set of generators.
	\<close>

	theory Algebra
	imports Prelim

	begin

	subsection \<open>Miscellaneous algebra facts\<close>

	lemma times2_conv_add: "(j::nat) + j = 2*j"
	by (induct j) auto

	lemma (in comm_semiring_1) odd_n0: "odd m \<Longrightarrow> m\<noteq>0"
	using dvd_0_right by fast

	lemma (in semigroup_add) add_assoc4: "a + b + c + d = a + (b + c + d)"
	using add.assoc by simp

	lemmas (in monoid_add) sum_list_map_cong =
	arg_cong[OF map_cong, OF refl, of _ _ _ sum_list]

	context group_add
	begin

	lemma map_uminus_order2:
	"\<forall>s\<in>set ss. s+s=0 \<Longrightarrow> map (uminus) ss = ss"
	by (induct ss) (auto simp add: minus_unique)

	lemma uminus_sum_list: "- sum_list as = sum_list (map uminus (rev as))"
	by (induct as) (auto simp add: minus_add)

	lemma uminus_sum_list_order2:
	"\<forall>s\<in>set ss. s+s=0 \<Longrightarrow> - sum_list ss = sum_list (rev ss)"
	using uminus_sum_list map_uminus_order2 by simp

	end (* context group_add *)

	subsection \<open>The type of permutations of a type\<close>

	text \<open>
	Here we construct a type consisting of all bijective functions on a type. This is the
	prototypical example of a group, where the group operation is composition, and every group can
	be embedded into such a type. It is for this purpose that we construct this type, so that we may
	confer upon suitable subsets of types that are not of class @{class group_add} the properties of
	that class, via a suitable injective correspondence to this permutation type.
	\<close>

	typedef 'a permutation = "{f::'a\<Rightarrow>'a. bij f}"
	morphisms permutation Abs_permutation
	by fast

	setup_lifting type_definition_permutation

	abbreviation permutation_apply :: "'a permutation \<Rightarrow> 'a \<Rightarrow> 'a " (infixr "\<rightarrow>" 90)
	where "p \<rightarrow> a \<equiv> permutation p a"
	abbreviation permutation_image :: "'a permutation \<Rightarrow> 'a set \<Rightarrow> 'a set"
	(infixr "`\<rightarrow>" 90)
	where "p `\<rightarrow> A \<equiv> permutation p ` A"

	lemma permutation_eq_image: "a `\<rightarrow> A = a `\<rightarrow> B \<Longrightarrow> A=B"
	using permutation[of a] inj_eq_image[OF bij_is_inj] by auto

	instantiation permutation :: (type) zero
	begin
	lift_definition zero_permutation :: "'a permutation" is "id::'a\<Rightarrow>'a" by simp
	instance ..
	end

	instantiation permutation :: (type) plus
	begin
	lift_definition plus_permutation :: "'a permutation \<Rightarrow> 'a permutation \<Rightarrow> 'a permutation"
	is "comp"
	using bij_comp
	by fast
	instance ..
	end

	lemma plus_permutation_abs_eq:
	"bij f \<Longrightarrow> bij g \<Longrightarrow>
	Abs_permutation f + Abs_permutation g = Abs_permutation (f\<circ>g)"
	by (simp add: plus_permutation.abs_eq eq_onp_same_args)

	instance permutation :: (type) semigroup_add
	proof
	fix a b c :: "'a permutation" show "a + b + c = a + (b + c)"
	using comp_assoc[of "permutation a" "permutation b" "permutation c"]
	by transfer simp
	qed

	instance permutation :: (type) monoid_add
	proof
	fix a :: "'a permutation"
	show "0 + a = a" by transfer simp
	show "a + 0 = a" by transfer simp
	qed

	instantiation permutation :: (type) uminus
	begin
	lift_definition uminus_permutation :: "'a permutation \<Rightarrow> 'a permutation"
	is "\<lambda>f. the_inv f"
	using bij_betw_the_inv_into
	by fast
	instance ..
	end

	instantiation permutation :: (type) minus
	begin
	lift_definition minus_permutation :: "'a permutation \<Rightarrow> 'a permutation \<Rightarrow> 'a permutation"
	is "\<lambda>f g. f \<circ> (the_inv g)"
	using bij_betw_the_inv_into bij_comp
	by fast
	instance ..
	end

	lemma minus_permutation_abs_eq:
	"bij f \<Longrightarrow> bij g \<Longrightarrow>
	Abs_permutation f - Abs_permutation g = Abs_permutation (f \<circ> the_inv g)"
	by (simp add: minus_permutation.abs_eq eq_onp_same_args)

	instance permutation :: (type) group_add
	proof
	fix a b :: "'a permutation"
	show "- a + a = 0" using the_inv_leftinv[of "permutation a"] by transfer simp
	show "a + - b = a - b" by transfer simp
	qed


	subsection \<open>Natural action of @{typ nat} on types of class @{class monoid_add}\<close>

	subsubsection \<open>Translation from class @{class power}.\<close>

	text \<open>
	Here we translate the @{class power} class to apply to types of class @{class monoid_add}.
	\<close>

	context monoid_add
	begin

	sublocale nataction: power 0 plus .
	sublocale add_mult_translate: monoid_mult 0 plus
	by unfold_locales (auto simp add: add.assoc)

	abbreviation nataction :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infix "+^" 80)
	where "a+^n \<equiv> nataction.power a n"

	lemmas nataction_2 = add_mult_translate.power2_eq_square
	lemmas nataction_Suc2 = add_mult_translate.power_Suc2

	lemma alternating_sum_list_conv_nataction:
	"sum_list (alternating_list (2*n) s t) = (s+t)+^n"
	by (induct n) (auto simp add: nataction_Suc2[THEN sym])

	lemma nataction_add_flip: "(a+b)+^(Suc n) = a + (b+a)+^n + b"
	using nataction_Suc2 add.assoc by (induct n arbitrary: a b) auto

	end (* context monoid_add *)

	lemma (in group_add) nataction_add_eq0_flip:
	assumes "(a+b)+^n = 0"
	shows "(b+a)+^n = 0"
	proof (cases n)
	case (Suc k) with assms show ?thesis
	using nataction_add_flip add.assoc[of "-a" "a+b" "(a+b)+^k"] by simp
	qed simp

	subsubsection \<open>Additive order of an element\<close>

	context monoid_add
	begin

	definition add_order :: "'a \<Rightarrow> nat"
	where "add_order a \<equiv> if (\<exists>n>0. a+^n = 0) then
	(LEAST n. n>0 \<and> a+^n = 0) else 0"

	lemma add_order: "a+^(add_order a) = 0"
	using LeastI_ex[of "\<lambda>n. n>0 \<and> a+^n = 0"] add_order_def by simp

	lemma add_order_least: "n>0 \<Longrightarrow> a+^n = 0 \<Longrightarrow> add_order a \<le> n"
	using Least_le[of "\<lambda>n. n>0 \<and> a+^n = 0"] add_order_def by simp

	lemma add_order_equality:
	"\<lbrakk> n>0; a+^n = 0; (\<And>m. m>0 \<Longrightarrow> a+^m = 0 \<Longrightarrow> n\<le>m) \<rbrakk> \<Longrightarrow>
	add_order a = n"
	using Least_equality[of "\<lambda>n. n>0 \<and> a+^n = 0"] add_order_def by auto

	lemma add_order0: "add_order 0 = 1"
	using add_order_equality by simp

	lemma add_order_gt0: "(add_order a > 0) = (\<exists>n>0. a+^n = 0)"
	using LeastI_ex[of "\<lambda>n. n>0 \<and> a+^n = 0"] add_order_def by simp

	lemma add_order_eq0: "add_order a = 0 \<Longrightarrow> n>0 \<Longrightarrow> a+^n \<noteq> 0"
	using add_order_gt0 by force

	lemma less_add_order_eq_0:
	assumes "a+^k = 0" "k < add_order a"
	shows "k = 0"
	proof (cases "k=0")
	case False
	moreover with assms(1) have "\<exists>n>0. a+^n = 0" by fast
	ultimately show ?thesis
	using assms add_order_def not_less_Least[of k "\<lambda>n. n>0 \<and> a+^n = 0"]
	by auto
	qed simp

	lemma less_add_order_eq_0_contra: "k>0 \<Longrightarrow> k < add_order a \<Longrightarrow> a+^k \<noteq> 0"
	using less_add_order_eq_0 by fast

	lemma add_order_relator: "add_order (a+^(add_order a)) = 1"
	using add_order by (auto intro: add_order_equality)

	abbreviation pair_relator_list :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list"
	where "pair_relator_list s t \<equiv> alternating_list (2*add_order (s+t)) s t"
	abbreviation pair_relator_halflist :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list"
	where "pair_relator_halflist s t \<equiv> alternating_list (add_order (s+t)) s t"
	abbreviation pair_relator_halflist2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list"
	where "pair_relator_halflist2 s t \<equiv>
	(if even (add_order (s+t)) then pair_relator_halflist s t else
	pair_relator_halflist t s)"

	lemma sum_list_pair_relator_list: "sum_list (pair_relator_list s t) = 0"
	by (auto simp add: add_order alternating_sum_list_conv_nataction)

	end (* context monoid_add *)

	context group_add
	begin

	lemma add_order_add_eq1: "add_order (s+t) = 1 \<Longrightarrow> t = -s"
	using add_order[of "s+t"] by (simp add: minus_unique)

	lemma add_order_add_sym: "add_order (t+s) = add_order (s+t)"
	proof (cases "add_order (t+s) = 0" "add_order (s+t) = 0" rule: two_cases)
	case one thus ?thesis
	using add_order nataction_add_eq0_flip[of s t] add_order_eq0 by auto
	next
	case other thus ?thesis
	using add_order nataction_add_eq0_flip[of t s] add_order_eq0 by auto
	next
	case neither thus ?thesis
	using add_order[of "s+t"] add_order[of "t+s"]
	nataction_add_eq0_flip[of s t] nataction_add_eq0_flip[of t s]
	add_order_least[of "add_order (s+t)"] add_order_least[of "add_order (t+s)"]
	by fastforce
	qed simp

	lemma pair_relator_halflist_append:
	"pair_relator_halflist s t @ pair_relator_halflist2 s t = pair_relator_list s t"
	using alternating_list_split[of "add_order (s+t)" "add_order (s+t)" s t]
	by (auto simp add: times2_conv_add add_order_add_sym)

	lemma rev_pair_relator_list: "rev (pair_relator_list s t) = pair_relator_list t s"
	by (simp add:rev_alternating_list add_order_add_sym)

	lemma pair_relator_halflist2_conv_rev_pair_relator_halflist:
	"pair_relator_halflist2 s t = rev (pair_relator_halflist t s)"
	by (auto simp add: add_order_add_sym rev_alternating_list)

	end (* context group_add *)

	subsection \<open>Partial sums of a list\<close>

	text \<open>
	Here we construct a list that collects the results of adding the elements of a given list
	together one-by-one.
	\<close>

	context monoid_add
	begin

	primrec sums :: "'a list \<Rightarrow> 'a list"
	where
	"sums [] = [0]"
	\| "sums (x#xs) = 0 # map ((+) x) (sums xs)"

	lemma length_sums: "length (sums xs) = Suc (length xs)"
	by (induct xs) auto

	lemma sums_snoc: "sums (xs@[x]) = sums xs @ [sum_list (xs@[x])]"
	by (induct xs) (auto simp add: add.assoc)

	lemma sums_append2:
	"sums (xs@ys) = butlast (sums xs) @ map ((+) (sum_list xs)) (sums ys)"
	proof (induct ys rule: rev_induct)
	case Nil show ?case by (cases xs rule: rev_cases) (auto simp add: sums_snoc)
	next
	case (snoc y ys) thus ?case using sums_snoc[of "xs@ys"] by (simp add: sums_snoc)
	qed

	lemma sums_Cons_conv_append_tl:
	"sums (x#xs) = 0 # x # map ((+) x) (tl (sums xs))"
	by (cases xs) auto

	lemma pullback_sums_map_middle2:
	"map F (sums xs) = ds@[d,e]@es \<Longrightarrow>
	\<exists>as a bs. xs = as@[a]@bs \<and> map F (sums as) = ds@[d] \<and>
	d = F (sum_list as) \<and> e = F (sum_list (as@[a]))"
	proof (induct xs es rule: list_induct2_snoc)
	case (Nil2 xs)
	show ?case
	proof (cases xs rule: rev_cases)
	case Nil with Nil2 show ?thesis by simp
	next
	case (snoc ys y) have ys: "xs = ys@[y]" by fact
	with Nil2(1) have y: "map F (sums ys) = ds@[d]" "e = F (sum_list (ys@[y]))"
	by (auto simp add: sums_snoc)
	show ?thesis
	proof (cases ys rule: rev_cases)
	case Nil
	with ys y have
	"xs = []@[y]@[]" "map F (sums []) = ds@[d]"
	"d = F (sum_list [])" "e = F (sum_list ([]@[y]))"
	by auto
	thus ?thesis by fast
	next
	case (snoc zs z)
	with y(1) have z: "map F (sums zs) = ds" "d = F (sum_list (zs@[z]))"
	by (auto simp add: sums_snoc)
	from z(1) ys y snoc have
	"xs = (zs@[z])@[y]@[]" "map F (sums (zs@[z])) = ds@[d]"
	"e = F (sum_list ((zs@[z])@[y]))"
	by auto
	with z(2) show ?thesis by fast
	qed
	qed
	next
	case snoc thus ?case by (fastforce simp add: sums_snoc)
	qed simp

	lemma pullback_sums_map_middle3:
	"map F (sums xs) = ds@[d,e,f]@fs \<Longrightarrow>
	\<exists>as a b bs. xs = as@[a,b]@bs \<and> d = F (sum_list as) \<and>
	e = F (sum_list (as@[a])) \<and> f = F (sum_list (as@[a,b]))"
	proof (induct xs fs rule: list_induct2_snoc)
	case (Nil2 xs)
	show ?case
	proof (cases xs rule: rev_cases)
	case Nil with Nil2 show ?thesis by simp
	next
	case (snoc ys y)
	with Nil2 have y: "map F (sums ys) = ds@[d,e]" "f = F (sum_list (ys@[y]))"
	by (auto simp add: sums_snoc)
	from y(1) obtain as a bs where asabs:
	"ys = as@[a]@bs" "map F (sums as) = ds@[d]"
	"d = F (sum_list as)" "e = F (sum_list (as@[a]))"
	using pullback_sums_map_middle2[of F ys ds]
	by fastforce
	have "bs = []"
	proof-
	from y(1) asabs(1,2) have "Suc (length bs) = Suc 0"
	by (auto simp add: sums_append2 map_butlast length_sums[THEN sym])
	thus ?thesis by fast
	qed
	with snoc asabs(1) y(2) have "xs = as@[a,y]@[]" "f = F (sum_list (as@[a,y]))"
	by auto
	with asabs(3,4) show ?thesis by fast
	qed
	next
	case snoc thus ?case by (fastforce simp add: sums_snoc)
	qed simp

	lemma pullback_sums_map_double_middle2:
	assumes "map F (sums xs) = ds@[d,e]@es@[f,g]@gs"
	shows "\<exists>as a bs b cs. xs = as@[a]@bs@[b]@cs \<and> d = F (sum_list as) \<and>
	e = F (sum_list (as@[a])) \<and> f = F (sum_list (as@[a]@bs)) \<and>
	g = F (sum_list (as@[a]@bs@[b]))"
	proof-
	from assms obtain As b cs where Asbcs:
	"xs = As@[b]@cs" "map F (sums As) = ds@[d,e]@es@[f]"
	"f = F (sum_list As)" "g = F (sum_list (As@[b]))"
	using pullback_sums_map_middle2[of F xs "ds@[d,e]@es"]
	by fastforce
	from Asbcs show ?thesis
	using pullback_sums_map_middle2[of F As ds d e "es@[f]"] by fastforce
	qed

	end (* context monoid_add *)

	subsection \<open>Sums of alternating lists\<close>

	lemma (in group_add) uminus_sum_list_alternating_order2:
	"s+s=0 \<Longrightarrow> t+t=0 \<Longrightarrow> - sum_list (alternating_list n s t) =
	sum_list (if even n then alternating_list n t s else alternating_list n s t)"
	using uminus_sum_list_order2 set_alternating_list[of n] rev_alternating_list[of n s]
	by fastforce

	context monoid_add
	begin

	lemma alternating_order2_cancel_1left:
	"s+s=0 \<Longrightarrow>
	sum_list (s # (alternating_list (Suc n) s t)) = sum_list (alternating_list n t s)"
	using add.assoc[of s s] alternating_list_Suc_Cons[of n s] by simp

	lemma alternating_order2_cancel_2left:
	"s+s=0 \<Longrightarrow> t+t=0 \<Longrightarrow>
	sum_list (t # s # (alternating_list (Suc (Suc n)) s t)) =
	sum_list (alternating_list n s t)"
	using alternating_order2_cancel_1left[of s "Suc n"]
	alternating_order2_cancel_1left[of t n]
	by simp

	lemma alternating_order2_even_cancel_right:
	assumes st : "s+s=0" "t+t=0"
	and even_n: "even n"
	shows "m \<le> n \<Longrightarrow> sum_list (alternating_list n s t @ alternating_list m t s) =
	sum_list (alternating_list (n-m) s t)"
	proof (induct n arbitrary: m rule: nat_even_induct, rule even_n)
	case (SucSuc k) with st show ?case
	using alternating_order2_cancel_2left[of t s]
	by (cases m rule: nat_cases_2Suc) auto
	qed simp

	end (* context monoid_add *)

	subsection \<open>Conjugation in @{class group_add}\<close>

	subsubsection \<open>Abbreviations and basic facts\<close>

	context group_add
	begin

	abbreviation lconjby :: "'a\<Rightarrow>'a\<Rightarrow>'a"
	where "lconjby x y \<equiv> x+y-x"

	abbreviation rconjby :: "'a\<Rightarrow>'a\<Rightarrow>'a"
	where "rconjby x y \<equiv> -x+y+x"

	lemma lconjby_add: "lconjby (x+y) z = lconjby x (lconjby y z)"
	by (auto simp add: algebra_simps)

	lemma rconjby_add: "rconjby (x+y) z = rconjby y (rconjby x z)"
	by (simp add: minus_add add.assoc[THEN sym])

	lemma add_rconjby: "rconjby x y + rconjby x z = rconjby x (y+z)"
	by (simp add: add.assoc)

	lemma lconjby_uminus: "lconjby x (-y) = - lconjby x y"
	using minus_unique[of "lconjby x y", THEN sym] by (simp add: algebra_simps)

	lemma rconjby_uminus: "rconjby x (-y) = - rconjby x y"
	using minus_unique[of "rconjby x y"] add_assoc4[of "rconjby x y" "-x" "-y" x] by simp

	lemma lconjby_rconjby: "lconjby x (rconjby x y) = y"
	by (simp add: algebra_simps)

	lemma rconjby_lconjby: "rconjby x (lconjby x y) = y"
	by (simp add: algebra_simps)

	lemma lconjby_inj: "inj (lconjby x)"
	using rconjby_lconjby by (fast intro: inj_on_inverseI)

	lemma rconjby_inj: "inj (rconjby x)"
	using lconjby_rconjby by (fast intro: inj_on_inverseI)

	lemma lconjby_surj: "surj (lconjby x)"
	using lconjby_rconjby surjI[of "lconjby x"] by fast

	lemma lconjby_bij: "bij (lconjby x)"
	unfolding bij_def using lconjby_inj lconjby_surj by fast

	lemma the_inv_lconjby: "the_inv (lconjby x) = (rconjby x)"
	using bij_betw_f_the_inv_into_f[OF lconjby_bij, of _ x] lconjby_rconjby
	by (force intro: inj_onD[OF lconjby_inj, of x])

	lemma lconjby_eq_conv_rconjby_eq: "w = lconjby x y \<Longrightarrow> y = rconjby x w"
	using the_inv_lconjby the_inv_into_f_f[OF lconjby_inj] by force

	lemma rconjby_order2: "s+s = 0 \<Longrightarrow> rconjby x s + rconjby x s = 0"
	by (simp add: add_rconjby)

	lemma rconjby_order2_eq_lconjby:
	assumes "s+s=0"
	shows "rconjby s = lconjby s"
	proof-
	have "rconjby s = lconjby (-s)" by simp
	with assms show ?thesis using minus_unique by simp
	qed

	lemma lconjby_alternating_list_order2:
	assumes "s+s=0" "t+t=0"
	shows "lconjby (sum_list (alternating_list k s t)) (if even k then s else t) =
	sum_list (alternating_list (Suc (2*k)) s t)"
	proof (induct k rule: nat_induct_step2)
	case (SucSuc m)
	have "lconjby (sum_list (alternating_list (Suc (Suc m)) s t))
	(if even (Suc (Suc m)) then s else t) = s + t +
	lconjby (sum_list (alternating_list m s t)) (if even m then s else t) - t - s"
	using alternating_list_SucSuc_ConsCons[of m s t]
	by (simp add: algebra_simps)
	also from assms SucSuc
	have "\<dots> = sum_list (alternating_list (Suc (2*Suc (Suc m))) s t)"
	using alternating_list_SucSuc_ConsCons[of "Suc (2*m)" s t]
	sum_list.append[of "alternating_list (Suc (2*Suc m)) s t" "[t]"]
	by (simp add: algebra_simps)
	finally show ?case by fast
	qed (auto simp add: assms(1) algebra_simps)

	end (* context group_add *)

	subsubsection \<open>The conjugation sequence\<close>

	text \<open>
	Given a list in @{class group_add}, we create a new list by conjugating each term by all the
	previous terms. This sequence arises in Coxeter systems.
	\<close>

	context group_add
	begin

	primrec lconjseq :: "'a list \<Rightarrow> 'a list"
	where
	"lconjseq [] = []"
	\| "lconjseq (x#xs) = x # (map (lconjby x) (lconjseq xs))"

	lemma length_lconjseq: "length (lconjseq xs) = length xs"
	by (induct xs) auto

	lemma lconjseq_snoc: "lconjseq (xs@[x]) = lconjseq xs @ [lconjby (sum_list xs) x]"
	by (induct xs) (auto simp add: lconjby_add)

	lemma lconjseq_append:
	"lconjseq (xs@ys) = lconjseq xs @ (map (lconjby (sum_list xs)) (lconjseq ys))"
	proof (induct ys rule: rev_induct)
	case (snoc y ys) thus ?case
	using lconjseq_snoc[of "xs@ys"] lconjseq_snoc[of ys] by (simp add: lconjby_add)
	qed simp

	lemma lconjseq_alternating_order2_repeats':
	fixes s t :: 'a
	defines altst: "altst \<equiv> \<lambda>n. alternating_list n s t"
	and altts: "altts \<equiv> \<lambda>n. alternating_list n t s"
	assumes st : "s+s=0" "t+t=0" "(s+t)+^k = 0"
	shows "map (lconjby (sum_list (altst k)))
	(lconjseq (if even k then altst m else altts m)) = lconjseq (altst m)"
	proof (induct m)
	case (Suc j)
	with altst altts
	have "map (lconjby (sum_list (altst k)))
	(lconjseq (if even k then altst (Suc j) else altts (Suc j))) =
	lconjseq (altst j) @
	[lconjby (sum_list (altst k @ (if even k then altst j else altts j)))
	(if even k then (if even j then s else t) else (if even j then t else s))]"
	by (auto simp add: lconjseq_snoc lconjby_add)
	also from altst altts st(1,2)
	have "\<dots> = lconjseq (altst j) @ [sum_list (altst (Suc (2*(k+j))))]"
	using lconjby_alternating_list_order2[of s t "k+j"]
	by (cases "even k")
	(auto simp add: alternating_list_append[of k])
	finally show ?case using altst st
	by (auto simp add:
	alternating_list_append(1)[THEN sym]
	alternating_sum_list_conv_nataction
	lconjby_alternating_list_order2 lconjseq_snoc
	)
	qed (simp add: altst altts)

	lemma lconjseq_alternating_order2_repeats:
	fixes s t :: 'a and k :: nat
	defines altst: "altst \<equiv> \<lambda>n. alternating_list n s t"
	and altts: "altts \<equiv> \<lambda>n. alternating_list n t s"
	assumes st: "s+s=0" "t+t=0" "(s+t)+^k = 0"
	shows "lconjseq (altst (2*k)) = lconjseq (altst k) @ lconjseq (altst k)"
	proof-
	from altst altts
	have "lconjseq (altst (2*k)) = lconjseq (altst k) @
	map (lconjby (sum_list (altst k)))
	(lconjseq (if even k then altst k else altts k))"
	using alternating_list_append[THEN sym, of k k s t]
	by (auto simp add: times2_conv_add lconjseq_append)
	with altst altts st show ?thesis
	using lconjseq_alternating_order2_repeats'[of s t k k] by auto
	qed

	lemma even_count_lconjseq_alternating_order2:
	fixes s t :: 'a
	assumes "s+s=0" "t+t=0" "(s+t)+^k = 0"
	shows "even (count_list (lconjseq (alternating_list (2*k) s t)) x)"
	proof-
	define xs where xs: "xs \<equiv> lconjseq (alternating_list (2*k) s t)"
	with assms obtain as where "xs = as@as"
	using lconjseq_alternating_order2_repeats by fast
	hence "count_list xs x = 2 * (count_list as x)"
	- by (simp add: count_list_append times2_conv_add)
	+ by (simp add: times2_conv_add)
	with xs show ?thesis by simp
	qed

	lemma order2_hd_in_lconjseq_deletion:
	shows "s+s=0 \<Longrightarrow> s \<in> set (lconjseq ss)
	\<Longrightarrow> \<exists>as b bs. ss = as@[b]@bs \<and> sum_list (s#ss) = sum_list (as@bs)"
	proof (induct ss arbitrary: s rule: rev_induct)
	case (snoc t ts) show ?case
	proof (cases "s \<in> set (lconjseq ts)")
	case True
	with snoc(1,2) obtain as b bs
	where asbbs: "ts = as @[b]@bs" "sum_list (s#ts) = sum_list (as@bs)"
	by fastforce
	from asbbs(2) have "sum_list (s#ts@[t]) = sum_list (as@(bs@[t]))"
	using sum_list.append[of "s#ts" "[t]"] sum_list.append[of "as@bs" "[t]"] by simp
	with asbbs(1) show ?thesis by fastforce
	next
	case False
	with snoc(3) have s: "s = lconjby (sum_list ts) t" by (simp add: lconjseq_snoc)
	with snoc(2) have "t+t=0"
	using lconjby_eq_conv_rconjby_eq[of s "sum_list ts" t]
	rconjby_order2[of s "sum_list ts"]
	by simp
	moreover from s have "sum_list (s#ts@[t]) = sum_list ts + t + t"
	using add.assoc[of "sum_list ts + t - sum_list ts" "sum_list ts"]
	by (simp add: algebra_simps)
	ultimately have "sum_list (s#ts@[t]) = sum_list (ts@[])"
	by (simp add: algebra_simps)
	thus ?thesis by fast
	qed
	qed simp

	end (* context group_add *)

	subsubsection \<open>The action on signed @{class group_add} elements\<close>

	text \<open>
	Here we construct an action of a group on itself by conjugation, where group elements are
	endowed with an auxiliary sign by pairing with a boolean element. In multiple applications of
	this action, the auxiliary sign helps keep track of how many times the elements conjugating and
	being conjugated are the same. This action arises in exploring reduced expressions of group
	elements as words in a set of generators of order two (in particular, in a Coxeter group).
	\<close>

	type_synonym 'a signed = "'a\<times>bool"

	definition signed_funaction :: "('a\<Rightarrow>'a\<Rightarrow>'a) \<Rightarrow> 'a \<Rightarrow> 'a signed \<Rightarrow> 'a signed"
	where "signed_funaction f s x \<equiv> map_prod (f s) (\<lambda>b. b \<noteq> (fst x = s)) x"
	\<comment> \<open>so the sign of @{term x} is flipped precisely when its first component is equal to
	@{term s}\<close>

	context group_add
	begin

	abbreviation "signed_lconjaction \<equiv> signed_funaction lconjby"
	abbreviation "signed_rconjaction \<equiv> signed_funaction rconjby"

	lemmas signed_lconjactionD = signed_funaction_def[of lconjby]
	lemmas signed_rconjactionD = signed_funaction_def[of rconjby]

	abbreviation signed_lconjpermutation :: "'a \<Rightarrow> 'a signed permutation"
	where "signed_lconjpermutation s \<equiv> Abs_permutation (signed_lconjaction s)"

	abbreviation signed_list_lconjaction :: "'a list \<Rightarrow> 'a signed \<Rightarrow> 'a signed"
	where "signed_list_lconjaction ss \<equiv> foldr signed_lconjaction ss"

	lemma signed_lconjaction_fst: "fst (signed_lconjaction s x) = lconjby s (fst x)"
	using signed_lconjactionD by simp

	lemma signed_lconjaction_rconjaction:
	"signed_lconjaction s (signed_rconjaction s x) = x"
	proof-
	obtain a::'a and b::bool where "x = (a,b)" by fastforce
	thus ?thesis
	using signed_lconjactionD signed_rconjactionD injD[OF rconjby_inj, of s a]
	lconjby_rconjby[of s a]
	by auto
	qed

	lemma signed_rconjaction_by_order2_eq_lconjaction:
	"s+s=0 \<Longrightarrow> signed_rconjaction s = signed_lconjaction s"
	using signed_funaction_def[of lconjby s] signed_funaction_def[of rconjby s]
	rconjby_order2_eq_lconjby[of s]
	by auto

	lemma inj_signed_lconjaction: "inj (signed_lconjaction s)"
	proof (rule injI)
	fix x y assume 1: "signed_lconjaction s x = signed_lconjaction s y"
	moreover obtain a1 a2 :: 'a and b1 b2 :: bool
	where xy: "x = (a1,b1)" "y = (a2,b2)"
	by fastforce
	ultimately show "x=y"
	using injD[OF lconjby_inj, of s a1 a2] signed_lconjactionD
	by (cases "a1=s" "a2=s" rule: two_cases) auto
	qed

	lemma surj_signed_lconjaction: "surj (signed_lconjaction s)"
	using signed_lconjaction_rconjaction[THEN sym] by fast

	lemma bij_signed_lconjaction: "bij (signed_lconjaction s)"
	using inj_signed_lconjaction surj_signed_lconjaction by (fast intro: bijI)

	lemma the_inv_signed_lconjaction:
	"the_inv (signed_lconjaction s) = signed_rconjaction s"
	proof
	fix x
	show "the_inv (signed_lconjaction s) x = signed_rconjaction s x"
	proof (rule the_inv_into_f_eq, rule inj_signed_lconjaction)
	show "signed_lconjaction s (signed_rconjaction s x) = x"
	using signed_lconjaction_rconjaction by fast
	qed (simp add: surj_signed_lconjaction)
	qed

	lemma the_inv_signed_lconjaction_by_order2:
	"s+s=0 \<Longrightarrow> the_inv (signed_lconjaction s) = signed_lconjaction s"
	using the_inv_signed_lconjaction signed_rconjaction_by_order2_eq_lconjaction
	by simp

	lemma signed_list_lconjaction_fst:
	"fst (signed_list_lconjaction ss x) = lconjby (sum_list ss) (fst x)"
	using signed_lconjaction_fst lconjby_add by (induct ss) auto

	lemma signed_list_lconjaction_snd:
	shows "\<forall>s\<in>set ss. s+s=0 \<Longrightarrow> snd (signed_list_lconjaction ss x)
	= (if even (count_list (lconjseq (rev ss)) (fst x)) then snd x else \<not>snd x)"
	proof (induct ss)
	case (Cons s ss) hence prevcase:
	"snd (signed_list_lconjaction ss x) =
	(if even (count_list (lconjseq (rev ss)) (fst x)) then snd x else \<not> snd x)"
	by simp
	have 1: "snd (signed_list_lconjaction (s # ss) x) =
	snd (signed_lconjaction s (signed_list_lconjaction ss x))"
	by simp
	show ?case
	proof (cases "fst (signed_list_lconjaction ss x) = s")
	case True
	with 1 prevcase
	have "snd (signed_list_lconjaction (s # ss) x) =
	(if even (count_list (lconjseq (rev ss)) (fst x)) then \<not> snd x else snd x)"
	by (simp add: signed_lconjactionD)
	- with True Cons(2) show ?thesis
	- by (simp add:
	- signed_list_lconjaction_fst lconjby_eq_conv_rconjby_eq
	- uminus_sum_list_order2[THEN sym] lconjseq_snoc count_list_snoc
	+ with True Cons(2) rconjby_lconjby show ?thesis
	+ by (auto simp add: signed_list_lconjaction_fst lconjseq_snoc
	+ simp flip: uminus_sum_list_order2
	)
	next
	case False
	hence "rconjby (sum_list ss) (lconjby (sum_list ss) (fst x)) \<noteq>
	rconjby (sum_list ss) s"
	by (simp add: signed_list_lconjaction_fst)
	with Cons(2)
	have "count_list (lconjseq (rev (s#ss))) (fst x) =
	count_list (lconjseq (rev ss)) (fst x)"
	by (simp add:
	rconjby_lconjby uminus_sum_list_order2[THEN sym]
	- lconjseq_snoc count_list_snoc
	+ lconjseq_snoc
	)
	moreover from False 1 prevcase
	have "snd (signed_list_lconjaction (s # ss) x) =
	(if even (count_list (lconjseq (rev ss)) (fst x)) then snd x else \<not> snd x)"
	by (simp add: signed_lconjactionD)
	ultimately show ?thesis by simp
	qed
	qed simp

	end (* context group_add *)

	subsection \<open>Cosets\<close>

	subsubsection \<open>Basic facts\<close>

	lemma set_zero_plus' [simp]: "(0::'a::monoid_add) +o C = C"
	\<comment> \<open>lemma @{text "Set_Algebras.set_zero_plus"} is restricted to types of class
	@{class comm_monoid_add}; here is a version in @{class monoid_add}.\<close>
	by (auto simp add: elt_set_plus_def)

	lemma lcoset_0: "(w::'a::monoid_add) +o 0 = {w}"
	using elt_set_plus_def[of w] by simp

	lemma lcoset_refl: "(0::'a::monoid_add) \<in> A \<Longrightarrow> a \<in> a +o A"
	using elt_set_plus_def by force

	lemma lcoset_eq_reps_subset:
	"(a::'a::group_add) +o A \<subseteq> a +o B \<Longrightarrow> A \<subseteq> B"
	using elt_set_plus_def[of a] by auto

	lemma lcoset_eq_reps: "(a::'a::group_add) +o A = a +o B \<Longrightarrow> A = B"
	using lcoset_eq_reps_subset[of a A B] lcoset_eq_reps_subset[of a B A] by auto

	lemma lcoset_inj_on: "inj ((+o) (a::'a::group_add))"
	using lcoset_eq_reps inj_onI[of UNIV "(+o) a"] by auto

	lemma lcoset_conv_set: "(a::'g::group_add) \<in> b +o A \<Longrightarrow> -b + a \<in> A"
	by (auto simp add: elt_set_plus_def)

	subsubsection \<open>The supset order on cosets\<close>

	lemma supset_lbound_lcoset_shift:
	"supset_lbound_of X Y B \<Longrightarrow>
	ordering.lbound_of (\<supseteq>) (a +o X) (a +o Y) (a +o B)"
	using ordering.lbound_of_def[OF supset_poset, of X Y B]
	by (fast intro: ordering.lbound_ofI supset_poset)

	lemma supset_glbound_in_of_lcoset_shift:
	fixes P :: "'a::group_add set set"
	assumes "supset_glbound_in_of P X Y B"
	shows "supset_glbound_in_of ((+o) a ` P) (a +o X) (a +o Y) (a +o B)"
	using ordering.glbound_in_ofD_in[OF supset_poset, OF assms]
	ordering.glbound_in_ofD_lbound[OF supset_poset, OF assms]
	supset_lbound_lcoset_shift[of X Y B a]
	supset_lbound_lcoset_shift[of "a +o X" "a +o Y" _ "-a"]
	ordering.glbound_in_ofD_glbound[OF supset_poset, OF assms]
	ordering.glbound_in_ofI[
	OF supset_poset, of "a +o B" "(+o) a ` P" "a +o X" "a +o Y"
	]
	by (fastforce simp add: set_plus_rearrange2)

	subsubsection \<open>The afforded partition\<close>

	definition lcoset_rel :: "'a::{uminus,plus} set \<Rightarrow> ('a\<times>'a) set"
	where "lcoset_rel A \<equiv> {(x,y). -x + y \<in> A}"

	lemma lcoset_relI: "-x+y \<in> A \<Longrightarrow> (x,y) \<in> lcoset_rel A"
	using lcoset_rel_def by fast


	subsection \<open>Groups\<close>

	text \<open>We consider groups as closed sets in a type of class @{class group_add}.\<close>

	subsubsection \<open>Locale definition and basic facts\<close>

	locale Group =
	fixes G :: "'g::group_add set"
	assumes nonempty : "G \<noteq> {}"
	and diff_closed: "\<And>g h. g \<in> G \<Longrightarrow> h \<in> G \<Longrightarrow> g - h \<in> G"
	begin

	abbreviation Subgroup :: "'g set \<Rightarrow> bool"
	where "Subgroup H \<equiv> Group H \<and> H \<subseteq> G"

	lemma SubgroupD1: "Subgroup H \<Longrightarrow> Group H" by fast

	lemma zero_closed : "0 \<in> G"
	proof-
	from nonempty obtain g where "g \<in> G" by fast
	hence "g - g \<in> G" using diff_closed by fast
	thus ?thesis by simp
	qed

	lemma uminus_closed: "g\<in>G \<Longrightarrow> -g\<in>G"
	using zero_closed diff_closed[of 0 g] by simp

	lemma add_closed: "g\<in>G \<Longrightarrow> h\<in>G \<Longrightarrow> g+h \<in> G"
	using uminus_closed[of h] diff_closed[of g "-h"] by simp

	lemma uminus_add_closed: "g \<in> G \<Longrightarrow> h \<in> G \<Longrightarrow> -g + h \<in> G"
	using uminus_closed add_closed by fast

	lemma lconjby_closed: "g\<in>G \<Longrightarrow> x\<in>G \<Longrightarrow> lconjby g x \<in> G"
	using add_closed diff_closed by fast

	lemma lconjby_set_closed: "g\<in>G \<Longrightarrow> A\<subseteq>G \<Longrightarrow> lconjby g ` A \<subseteq> G"
	using lconjby_closed by fast

	lemma set_lconjby_subset_closed:
	"H\<subseteq>G \<Longrightarrow> A\<subseteq>G \<Longrightarrow> (\<Union>h\<in>H. lconjby h ` A) \<subseteq> G"
	using lconjby_set_closed[of _ A] by fast

	lemma sum_list_map_closed: "set (map f as) \<subseteq> G \<Longrightarrow> (\<Sum>a\<leftarrow>as. f a) \<in> G"
	using zero_closed add_closed by (induct as) auto

	lemma sum_list_closed: "set as \<subseteq> G \<Longrightarrow> sum_list as \<in> G"
	using sum_list_map_closed by force

	end (* context Group *)

	subsubsection \<open>Sets with a suitable binary operation\<close>

	text \<open>
	We have chosen to only consider groups in types of class @{class group_add} so that we can take
	advantage of all the algebra lemmas already proven in @{theory HOL.Groups}, as well as
	constructs like @{const sum_list}. The following locale builds a bridge between this restricted
	view of groups and the usual notion of a binary operation on a set satisfying the group axioms,
	by constructing an injective map into type @{type permutation} (which is of class
	@{class group_add} with respect to the composition operation) that respects the group operation.
	This bridge will be necessary to define quotient groups, in particular.
	\<close>

	locale BinOpSetGroup =
	fixes G :: "'a set"
	and binop :: "'a\<Rightarrow>'a\<Rightarrow>'a"
	and e :: "'a"
	assumes closed : "g\<in>G \<Longrightarrow> h\<in>G \<Longrightarrow> binop g h \<in> G"
	and assoc :
	"\<lbrakk> g\<in>G; h\<in>G; k\<in>G \<rbrakk> \<Longrightarrow> binop (binop g h) k = binop g (binop h k)"
	and identity: "e\<in>G" "g\<in>G \<Longrightarrow> binop g e = g" "g\<in>G \<Longrightarrow> binop e g = g"
	and inverses: "g\<in>G \<Longrightarrow> \<exists>h\<in>G. binop g h = e \<and> binop h g = e"
	begin

	lemma unique_identity1: "g\<in>G \<Longrightarrow> \<forall>x\<in>G. binop g x = x \<Longrightarrow> g = e"
	using identity(1,2) by auto

	lemma unique_inverse:
	assumes "g\<in>G"
	shows "\<exists>!h. h\<in>G \<and> binop g h = e \<and> binop h g = e"
	proof (rule ex_ex1I)
	from assms show "\<exists>h. h \<in> G \<and> binop g h = e \<and> binop h g = e"
	using inverses by fast
	next
	fix h k
	assume "h\<in>G \<and> binop g h = e \<and> binop h g = e" "k\<in>G \<and>
	binop g k = e \<and> binop k g = e"
	hence h: "h\<in>G" "binop g h = e" "binop h g = e"
	and k: "k\<in>G" "binop g k = e" "binop k g = e"
	by auto
	from assms h(1,3) k(1,2) show "h=k" using identity(2,3) assoc by force
	qed

	abbreviation "G_perm g \<equiv> restrict1 (binop g) G"

	definition Abs_G_perm :: "'a \<Rightarrow> 'a permutation"
	where "Abs_G_perm g \<equiv> Abs_permutation (G_perm g)"

	abbreviation "\<pp> \<equiv> Abs_G_perm" \<comment> \<open>the injection into type @{type permutation}\<close>
	abbreviation "\<ii>\<pp> \<equiv> the_inv_into G \<pp>" \<comment> \<open>the reverse correspondence\<close>
	abbreviation "pG \<equiv> \<pp>`G" \<comment> \<open>the resulting @{const Group} of type @{type permutation}\<close>

	lemma G_perm_comp:
	"g\<in>G \<Longrightarrow> h\<in>G \<Longrightarrow> G_perm g \<circ> G_perm h = G_perm (binop g h)"
	using closed by (auto simp add: assoc)

	definition the_inverse :: "'a \<Rightarrow> 'a"
	where "the_inverse g \<equiv> (THE h. h\<in>G \<and> binop g h = e \<and> binop h g = e)"

	abbreviation "\<ii> \<equiv> the_inverse"

	lemma the_inverseD:
	assumes "g\<in>G"
	shows "\<ii> g \<in> G" "binop g (\<ii> g) = e" "binop (\<ii> g) g = e"
	using assms theI'[OF unique_inverse]
	unfolding the_inverse_def
	by auto

	lemma binop_G_comp_binop_\<ii>G: "g\<in>G \<Longrightarrow> x\<in>G \<Longrightarrow> binop g (binop (\<ii> g) x) = x"
	using the_inverseD(1) assoc[of g "\<ii> g" x] by (simp add: identity(3) the_inverseD(2))

	lemma bij_betw_binop_G:
	assumes "g\<in>G"
	shows "bij_betw (binop g) G G"
	unfolding bij_betw_def
	proof
	show "inj_on (binop g) G"
	proof (rule inj_onI)
	fix h k assume hk: "h\<in>G" "k\<in>G" "binop g h = binop g k"
	with assms have "binop (binop (\<ii> g) g) h = binop (binop (\<ii> g) g) k"
	using the_inverseD(1) by (simp add: assoc)
	with assms hk(1,2) show "h=k" using the_inverseD(3) identity by simp
	qed
	show "binop g ` G = G"
	proof
	from assms show "binop g ` G \<subseteq> G" using closed by fast
	from assms show "binop g ` G \<supseteq> G"
	using binop_G_comp_binop_\<ii>G[THEN sym] the_inverseD(1) closed by fast
	qed
	qed

	lemma the_inv_into_G_binop_G:
	assumes "g\<in>G" "x\<in>G"
	shows "the_inv_into G (binop g) x = binop (\<ii> g) x"
	proof (rule the_inv_into_f_eq)
	from assms(1) show "inj_on (binop g) G"
	using bij_betw_imp_inj_on[OF bij_betw_binop_G] by fast
	from assms show "binop g (binop (\<ii> g) x) = x"
	using binop_G_comp_binop_\<ii>G by fast
	from assms show "binop (\<ii> g) x \<in> G" using closed the_inverseD(1) by fast
	qed

	lemma restrict1_the_inv_into_G_binop_G:
	"g\<in>G \<Longrightarrow> restrict1 (the_inv_into G (binop g)) G = G_perm (\<ii> g)"
	using the_inv_into_G_binop_G by auto

	lemma bij_G_perm: "g\<in>G \<Longrightarrow> bij (G_perm g)"
	using set_permutation_bij_restrict1 bij_betw_binop_G by fast

	lemma G_perm_apply: "g\<in>G \<Longrightarrow> x\<in>G \<Longrightarrow> \<pp> g \<rightarrow> x = binop g x"
	using Abs_G_perm_def Abs_permutation_inverse bij_G_perm by fastforce

	lemma G_perm_apply_identity: "g\<in>G \<Longrightarrow> \<pp> g \<rightarrow> e = g"
	using G_perm_apply identity(1,2) by simp

	lemma the_inv_G_perm:
	"g\<in>G \<Longrightarrow> the_inv (G_perm g) = G_perm (\<ii> g)"
	using set_permutation_the_inv_restrict1 bij_betw_binop_G
	restrict1_the_inv_into_G_binop_G
	by fastforce

	lemma Abs_G_perm_diff:
	"g\<in>G \<Longrightarrow> h\<in>G \<Longrightarrow> \<pp> g - \<pp> h = \<pp> (binop g (\<ii> h))"
	using Abs_G_perm_def minus_permutation_abs_eq[OF bij_G_perm bij_G_perm]
	the_inv_G_perm G_perm_comp the_inverseD(1)
	by simp

	lemma Group: "Group pG"
	using identity(1) Abs_G_perm_diff the_inverseD(1) closed by unfold_locales auto

	lemma inj_on_\<pp>_G: "inj_on \<pp> G"
	proof (rule inj_onI)
	fix x y assume xy: "x\<in>G" "y\<in>G" "\<pp> x = \<pp> y"
	hence "Abs_permutation (G_perm (binop x (\<ii> y))) = Abs_permutation id"
	using Abs_G_perm_diff Abs_G_perm_def
	by (fastforce simp add: zero_permutation.abs_eq)
	moreover from xy(1,2) have 1: "binop x (\<ii> y) \<in> G"
	using bij_id closed the_inverseD(1) by fast
	ultimately have 2: "G_perm (binop x (\<ii> y)) = id"
	using Abs_permutation_inject[of "G_perm (binop x (\<ii> y))"] bij_G_perm bij_id
	by simp
	have "\<forall>z\<in>G. binop (binop x (\<ii> y)) z = z"
	proof
	fix z assume "z\<in>G"
	thus "binop (binop x (\<ii> y)) z = z" using fun_cong[OF 2, of z] by simp
	qed
	with xy(1,2) have "binop x (binop (\<ii> y) y) = y"
	using unique_identity1[OF 1] the_inverseD(1) by (simp add: assoc)
	with xy(1,2) show "x = y" using the_inverseD(3) identity(2) by simp
	qed

	lemma homs:
	"\<And>g h. g\<in>G \<Longrightarrow> h\<in>G \<Longrightarrow> \<pp> (binop g h) = \<pp> g + \<pp> h"
	"\<And>x y. x\<in>pG \<Longrightarrow> y\<in>pG \<Longrightarrow> binop (\<ii>\<pp> x) (\<ii>\<pp> y) = \<ii>\<pp> (x+y)"
	proof-
	show 1: "\<And>g h. g\<in>G \<Longrightarrow> h\<in>G \<Longrightarrow> \<pp> (binop g h) = \<pp> g + \<pp> h"
	using Abs_G_perm_def G_perm_comp
	plus_permutation_abs_eq[OF bij_G_perm bij_G_perm]
	by simp
	show "\<And>x y. x\<in>pG \<Longrightarrow> y\<in>pG \<Longrightarrow> binop (\<ii>\<pp> x) (\<ii>\<pp> y) = \<ii>\<pp> (x+y)"
	proof-
	fix x y assume "x\<in>pG" "y\<in>pG"
	moreover hence "\<ii>\<pp> (\<pp> (binop (\<ii>\<pp> x) (\<ii>\<pp> y))) = \<ii>\<pp> (x + y)"
	using 1 the_inv_into_into[OF inj_on_\<pp>_G] f_the_inv_into_f[OF inj_on_\<pp>_G]
	by simp
	ultimately show "binop (\<ii>\<pp> x) (\<ii>\<pp> y) = \<ii>\<pp> (x+y)"
	using the_inv_into_into[OF inj_on_\<pp>_G] closed the_inv_into_f_f[OF inj_on_\<pp>_G]
	by simp
	qed
	qed

	lemmas inv_correspondence_into =
	the_inv_into_into[OF inj_on_\<pp>_G, of _ G, simplified]

	lemma inv_correspondence_conv_apply: "x \<in> pG \<Longrightarrow> \<ii>\<pp> x = x\<rightarrow>e"
	using G_perm_apply_identity inj_on_\<pp>_G by (auto intro: the_inv_into_f_eq)

	end (* context BinOpSetGroup *)


	subsubsection \<open>Cosets of a @{const Group}\<close>

	context Group
	begin

	lemma lcoset_refl: "a \<in> a +o G"
	using lcoset_refl zero_closed by fast

	lemma lcoset_el_reduce:
	assumes "a \<in> G"
	shows "a +o G = G"
	proof (rule seteqI)
	fix x assume "x \<in> a +o G"
	from this obtain g where "g\<in>G" "x = a+g" using elt_set_plus_def[of a] by auto
	with assms show "x\<in>G" by (simp add: add_closed)
	next
	fix x assume "x\<in>G"
	with assms have "-a + x \<in> G" by (simp add: uminus_add_closed)
	thus "x \<in> a +o G" using elt_set_plus_def by force
	qed

	lemma lcoset_el_reduce0: "0 \<in> a +o G \<Longrightarrow> a +o G = G"
	using elt_set_plus_def[of a G] minus_unique uminus_closed[of "-a"]
	lcoset_el_reduce
	by fastforce

	lemma lcoset_subgroup_imp_eq_reps:
	"Group H \<Longrightarrow> w +o H \<subseteq> w' +o G \<Longrightarrow> w' +o G = w +o G"
	using Group.lcoset_refl[of H w] lcoset_conv_set[of w] lcoset_el_reduce
	set_plus_rearrange2[of w' "-w'+w" G]
	by force

	lemma lcoset_closed: "a\<in>G \<Longrightarrow> A\<subseteq>G \<Longrightarrow> a +o A \<subseteq> G"
	using elt_set_plus_def[of a] add_closed by auto

	lemma lcoset_rel_sym: "sym (lcoset_rel G)"
	proof (rule symI)
	fix a b show "(a,b) \<in> lcoset_rel G \<Longrightarrow> (b,a) \<in> lcoset_rel G"
	using uminus_closed minus_add[of "-a" b] lcoset_rel_def[of G] by fastforce
	qed

	lemma lcoset_rel_trans: "trans (lcoset_rel G)"
	proof (rule transI)
	fix x y z assume xy: "(x,y) \<in> lcoset_rel G" and yz: "(y,z) \<in> lcoset_rel G"
	from this obtain g g' where "g\<in>G" "-x+y = g" "g'\<in>G" "-y+z = g'"
	using lcoset_rel_def[of G] by fast
	thus "(x, z) \<in> lcoset_rel G"
	using add.assoc[of g "-y" z] add_closed lcoset_rel_def[of G] by auto
	qed

	abbreviation LCoset_rel :: "'g set \<Rightarrow> ('g\<times>'g) set"
	where "LCoset_rel H \<equiv> lcoset_rel H \<inter> (G\<times>G)"

	lemma refl_on_LCoset_rel: "0\<in>H \<Longrightarrow> refl_on G (LCoset_rel H)"
	using lcoset_rel_def by (fastforce intro: refl_onI)

	lemmas subgroup_refl_on_LCoset_rel =
	refl_on_LCoset_rel[OF Group.zero_closed, OF SubgroupD1]
	lemmas LCoset_rel_quotientI = quotientI[of _ G "LCoset_rel _"]
	lemmas LCoset_rel_quotientE = quotientE[of _ G "LCoset_rel _"]

	lemma lcoset_subgroup_rel_equiv:
	"Subgroup H \<Longrightarrow> equiv G (LCoset_rel H)"
	using Group.lcoset_rel_sym sym_sym sym_Int Group.lcoset_rel_trans trans_sym
	trans_Int subgroup_refl_on_LCoset_rel
	by (blast intro: equivI)

	lemma trivial_LCoset: "H\<subseteq>G \<Longrightarrow> H = LCoset_rel H `` {0}"
	using zero_closed unfolding lcoset_rel_def by auto

	end (* context Group *)

	subsubsection \<open>The @{const Group} generated by a set\<close>

	inductive_set genby :: "'a::group_add set \<Rightarrow> 'a set" ("\<langle>_\<rangle>")
	for S :: "'a set"
	where
	genby_0_closed : "0\<in>\<langle>S\<rangle>" \<comment> \<open>just in case @{term S} is empty\<close>
	\| genby_genset_closed: "s\<in>S \<Longrightarrow> s\<in>\<langle>S\<rangle>"
	\| genby_diff_closed : "w\<in>\<langle>S\<rangle> \<Longrightarrow> w'\<in>\<langle>S\<rangle> \<Longrightarrow> w - w' \<in> \<langle>S\<rangle>"

	lemma genby_Group: "Group \<langle>S\<rangle>"
	using genby_0_closed genby_diff_closed by unfold_locales fast

	lemmas genby_uminus_closed = Group.uminus_closed [OF genby_Group]
	lemmas genby_add_closed = Group.add_closed [OF genby_Group]
	lemmas genby_uminus_add_closed = Group.uminus_add_closed [OF genby_Group]
	lemmas genby_lcoset_refl = Group.lcoset_refl [OF genby_Group]
	lemmas genby_lcoset_el_reduce = Group.lcoset_el_reduce [OF genby_Group]
	lemmas genby_lcoset_el_reduce0 = Group.lcoset_el_reduce0 [OF genby_Group]
	lemmas genby_lcoset_closed = Group.lcoset_closed [OF genby_Group]

	lemmas genby_lcoset_subgroup_imp_eq_reps =
	Group.lcoset_subgroup_imp_eq_reps[OF genby_Group, OF genby_Group]

	lemma genby_genset_subset: "S \<subseteq> \<langle>S\<rangle>"
	using genby_genset_closed by fast

	lemma genby_uminus_genset_subset: "uminus ` S \<subseteq> \<langle>S\<rangle>"
	using genby_genset_subset genby_uminus_closed by auto

	lemma genby_in_sum_list_lists:
	fixes S
	defines S_sum_lists: "S_sum_lists \<equiv> (\<Union>ss\<in>lists (S \<union> uminus ` S). {sum_list ss})"
	shows "w \<in> \<langle>S\<rangle> \<Longrightarrow> w \<in> S_sum_lists"
	proof (erule genby.induct)
	have "0 = sum_list []" by simp
	with S_sum_lists show "0 \<in> S_sum_lists" by blast
	next
	fix s assume "s\<in>S"
	hence "[s] \<in> lists (S \<union> uminus ` S)" by simp
	moreover have "s = sum_list [s]" by simp
	ultimately show "s \<in> S_sum_lists" using S_sum_lists by blast
	next
	fix w w' assume ww': "w \<in> S_sum_lists" "w' \<in> S_sum_lists"
	with S_sum_lists obtain ss ts
	where ss: "ss \<in> lists (S \<union> uminus ` S)" "w = sum_list ss"
	and ts: "ts \<in> lists (S \<union> uminus ` S)" "w' = sum_list ts"
	by fastforce
	from ss(2) ts(2) have "w-w' = sum_list (ss @ map uminus (rev ts))"
	by (simp add: diff_conv_add_uminus uminus_sum_list)
	moreover from ss(1) ts(1)
	have "ss @ map uminus (rev ts) \<in> lists (S \<union> uminus ` S)"
	by fastforce
	ultimately show "w - w' \<in> S_sum_lists" using S_sum_lists by fast
	qed

	lemma sum_list_lists_in_genby: "ss \<in> lists (S \<union> uminus ` S) \<Longrightarrow> sum_list ss \<in> \<langle>S\<rangle>"
	proof (induct ss)
	case Nil show ?case using genby_0_closed by simp
	next
	case (Cons s ss) thus ?case
	using genby_genset_subset[of S] genby_uminus_genset_subset
	genby_add_closed[of s S "sum_list ss"]
	by auto
	qed

	lemma sum_list_lists_in_genby_sym:
	"uminus ` S \<subseteq> S \<Longrightarrow> ss \<in> lists S \<Longrightarrow> sum_list ss \<in> \<langle>S\<rangle>"
	using sum_list_lists_in_genby by fast

	lemma genby_eq_sum_lists: "\<langle>S\<rangle> = (\<Union>ss\<in>lists (S \<union> uminus ` S). {sum_list ss})"
	using genby_in_sum_list_lists sum_list_lists_in_genby by fast

	lemma genby_mono: "T \<subseteq> S \<Longrightarrow> \<langle>T\<rangle> \<subseteq> \<langle>S\<rangle>"
	using genby_eq_sum_lists[of T] genby_eq_sum_lists[of S] by force

	lemma (in Group) genby_closed:
	assumes "S \<subseteq> G"
	shows "\<langle>S\<rangle> \<subseteq> G"
	proof
	fix x show "x \<in> \<langle>S\<rangle> \<Longrightarrow> x \<in> G"
	proof (erule genby.induct, rule zero_closed)
	from assms show "\<And>s. s\<in>S \<Longrightarrow> s\<in>G" by fast
	show "\<And>w w'. w\<in>G \<Longrightarrow> w'\<in>G \<Longrightarrow> w-w' \<in> G" using diff_closed by fast
	qed
	qed

	lemma (in Group) genby_subgroup: "S \<subseteq> G \<Longrightarrow> Subgroup \<langle>S\<rangle>"
	using genby_closed genby_Group by simp

	lemma genby_sym_eq_sum_lists:
	"uminus ` S \<subseteq> S \<Longrightarrow> \<langle>S\<rangle> = (\<Union>ss\<in>lists S. {sum_list ss})"
	using lists_mono genby_eq_sum_lists[of S] by force

	lemma genby_empty': "w \<in> \<langle>{}\<rangle> \<Longrightarrow> w = 0"
	proof (erule genby.induct) qed auto

	lemma genby_order2':
	assumes "s+s=0"
	shows "w \<in> \<langle>{s}\<rangle> \<Longrightarrow> w = 0 \<or> w = s"
	proof (erule genby.induct)
	fix w w' assume "w = 0 \<or> w = s" "w' = 0 \<or> w' = s"
	with assms show "w - w' = 0 \<or> w - w' = s"
	by (cases "w'=0") (auto simp add: minus_unique)
	qed auto

	lemma genby_order2: "s+s=0 \<Longrightarrow> \<langle>{s}\<rangle> = {0,s}"
	using genby_order2'[of s] genby_0_closed genby_genset_closed by auto

	lemma genby_empty: "\<langle>{}\<rangle> = 0"
	using genby_empty' genby_0_closed by auto

	lemma genby_lcoset_order2: "s+s=0 \<Longrightarrow> w +o \<langle>{s}\<rangle> = {w,w+s}"
	using elt_set_plus_def[of w] by (auto simp add: genby_order2)

	lemma genby_lcoset_empty: "(w::'a::group_add) +o \<langle>{}\<rangle> = {w}"
	proof-
	have "\<langle>{}::'a set\<rangle> = (0::'a set)" using genby_empty by fast
	thus ?thesis using lcoset_0 by simp
	qed

	lemma (in Group) genby_set_lconjby_set_lconjby_closed:
	fixes A :: "'g set"
	defines "S \<equiv> (\<Union>g\<in>G. lconjby g ` A)"
	assumes "g\<in>G"
	shows "x \<in> \<langle>S\<rangle> \<Longrightarrow> lconjby g x \<in> \<langle>S\<rangle>"
	proof (erule genby.induct)
	show "lconjby g 0 \<in> \<langle>S\<rangle>" using genby_0_closed by simp
	from assms show "\<And>s. s \<in> S \<Longrightarrow> lconjby g s \<in> \<langle>S\<rangle>"
	using add_closed genby_genset_closed[of _ S] by (force simp add: lconjby_add)
	next
	fix w w'
	assume ww': "lconjby g w \<in> \<langle>S\<rangle>" "lconjby g w' \<in> \<langle>S\<rangle>"
	have "lconjby g (w - w') = lconjby g w + lconjby g (-w')"
	by (simp add: algebra_simps)
	with ww' show "lconjby g (w - w') \<in> \<langle>S\<rangle>"
	using lconjby_uminus[of g] diff_conv_add_uminus[of _ "lconjby g w'"]
	genby_diff_closed
	by fastforce
	qed

	lemma (in Group) genby_set_lconjby_set_rconjby_closed:
	fixes A :: "'g set"
	defines "S \<equiv> (\<Union>g\<in>G. lconjby g ` A)"
	assumes "g\<in>G" "x \<in> \<langle>S\<rangle>"
	shows "rconjby g x \<in> \<langle>S\<rangle>"
	using assms uminus_closed genby_set_lconjby_set_lconjby_closed
	by fastforce

	subsubsection \<open>Homomorphisms and isomorphisms\<close>

	locale GroupHom = Group G
	for G :: "'g::group_add set"
	+ fixes T :: "'g \<Rightarrow> 'h::group_add"
	assumes hom : "g \<in> G \<Longrightarrow> g' \<in> G \<Longrightarrow> T (g + g') = T g + T g'"
	and supp: "supp T \<subseteq> G"
	begin

	lemma im_zero: "T 0 = 0"
	using zero_closed hom[of 0 0] add_diff_cancel[of "T 0" "T 0"] by simp

	lemma im_uminus: "T (- g) = - T g"
	using im_zero hom[of g "- g"] uminus_closed[of g] minus_unique[of "T g"]
	uminus_closed[of "-g"] supp suppI_contra[of g T]
	suppI_contra[of "-g" T]
	by fastforce

	lemma im_uminus_add: "g \<in> G \<Longrightarrow> g' \<in> G \<Longrightarrow> T (-g + g') = - T g + T g'"
	by (simp add: uminus_closed hom im_uminus)

	lemma im_diff: "g \<in> G \<Longrightarrow> g' \<in> G \<Longrightarrow> T (g - g') = T g - T g'"
	using hom uminus_closed hom[of g "-g'"] im_uminus by simp

	lemma im_lconjby: "x \<in> G \<Longrightarrow> g \<in> G \<Longrightarrow> T (lconjby x g) = lconjby (T x) (T g)"
	using add_closed by (simp add: im_diff hom)

	lemma im_sum_list_map:
	"set (map f as) \<subseteq> G \<Longrightarrow> T (\<Sum>a\<leftarrow>as. f a) = (\<Sum>a\<leftarrow>as. T (f a))"
	using hom im_zero sum_list_closed by (induct as) auto

	lemma comp:
	assumes "GroupHom H S" "T`G \<subseteq> H"
	shows "GroupHom G (S \<circ> T)"
	proof
	fix g g' assume "g \<in> G" "g' \<in> G"
	with hom assms(2) show "(S \<circ> T) (g + g') = (S \<circ> T) g + (S \<circ> T) g'"
	using GroupHom.hom[OF assms(1)] by fastforce
	next
	from supp have "\<And>g. g \<notin> G \<Longrightarrow> (S \<circ> T) g = 0"
	using suppI_contra GroupHom.im_zero[OF assms(1)] by fastforce
	thus "supp (S \<circ> T) \<subseteq> G" using suppD_contra by fast
	qed

	end (* context GroupHom *)


	definition ker :: "('a\<Rightarrow>'b::zero) \<Rightarrow> 'a set"
	where "ker f = {a. f a = 0}"

	lemma ker_subset_ker_restrict0: "ker f \<subseteq> ker (restrict0 f A)"
	unfolding ker_def by auto

	context GroupHom
	begin

	abbreviation "Ker \<equiv> ker T \<inter> G"

	lemma uminus_add_in_Ker_eq_eq_im:
	"g\<in>G \<Longrightarrow> h\<in>G \<Longrightarrow> (-g + h \<in> Ker) = (T g = T h)"
	using neg_equal_iff_equal
	by (simp add: uminus_add_closed ker_def im_uminus_add eq_neg_iff_add_eq_0)

	end (* context GroupHom *)

	locale UGroupHom = GroupHom UNIV T
	for T :: "'g::group_add \<Rightarrow> 'h::group_add"
	begin

	lemmas im_zero = im_zero
	lemmas im_uminus = im_uminus

	lemma hom: "T (g+g') = T g + T g'"
	using hom by simp

	lemma im_diff: "T (g - g') = T g - T g'"
	using im_diff by simp

	lemma im_lconjby: "T (lconjby x g) = lconjby (T x) (T g)"
	using im_lconjby by simp

	lemma restrict0:
	assumes "Group G"
	shows "GroupHom G (restrict0 T G)"
	proof (intro_locales, rule assms, unfold_locales)
	from hom
	show "\<And>g g'. g \<in> G \<Longrightarrow> g' \<in> G \<Longrightarrow>
	restrict0 T G (g + g') = restrict0 T G g + restrict0 T G g'"
	using Group.add_closed[OF assms]
	by auto
	show "supp (restrict0 T G) \<subseteq> G" using supp_restrict0[of G T] by fast
	qed

	end (* context UGroupHom *)

	lemma UGroupHomI:
	assumes "\<And>g g'. T (g + g') = T g + T g'"
	shows "UGroupHom T"
	using assms
	by unfold_locales auto

	locale GroupIso = GroupHom G T
	for G :: "'g::group_add set"
	and T :: "'g \<Rightarrow> 'h::group_add"
	+ assumes inj_on: "inj_on T G"

	lemma (in GroupHom) isoI:
	assumes "\<And>k. k\<in>G \<Longrightarrow> T k = 0 \<Longrightarrow> k=0"
	shows "GroupIso G T"
	proof (unfold_locales, rule inj_onI)
	fix x y from assms show "\<lbrakk> x\<in>G; y\<in>G; T x = T y \<rbrakk> \<Longrightarrow> x = y"
	using im_diff diff_closed by force
	qed

	text \<open>
	In a @{const BinOpSetGroup}, any map from the set into a type of class @{class group_add} that respects the
	binary operation induces a @{const GroupHom}.
	\<close>

	abbreviation (in BinOpSetGroup) "lift_hom T \<equiv> restrict0 (T \<circ> \<ii>\<pp>) pG"

	lemma (in BinOpSetGroup) lift_hom:
	fixes T :: "'a \<Rightarrow> 'b::group_add"
	assumes "\<forall>g\<in>G. \<forall>h\<in>G. T (binop g h) = T g + T h"
	shows "GroupHom pG (lift_hom T)"
	proof (intro_locales, rule Group, unfold_locales)
	from assms
	show "\<And>x y. x\<in>pG \<Longrightarrow> y\<in>pG \<Longrightarrow>
	lift_hom T (x+y) = lift_hom T x + lift_hom T y"
	using Group.add_closed[OF Group] inv_correspondence_into
	by (simp add: homs(2)[THEN sym])
	qed (rule supp_restrict0)




	subsubsection \<open>Normal subgroups\<close>

	definition rcoset_rel :: "'a::{minus,plus} set \<Rightarrow> ('a\<times>'a) set"
	where "rcoset_rel A \<equiv> {(x,y). x-y \<in> A}"

	context Group
	begin

	lemma rcoset_rel_conv_lcoset_rel:
	"rcoset_rel G = map_prod uminus uminus ` (lcoset_rel G)"
	proof (rule set_eqI)
	fix x :: "'g\<times>'g"
	obtain a b where ab: "x=(a,b)" by fastforce
	hence "(x \<in> rcoset_rel G) = (a-b \<in> G)" using rcoset_rel_def by auto
	also have "\<dots> = ( (-b,-a) \<in> lcoset_rel G )"
	using uminus_closed lcoset_rel_def by fastforce
	finally
	show "(x \<in> rcoset_rel G) = (x \<in> map_prod uminus uminus ` (lcoset_rel G))"
	using ab symD[OF lcoset_rel_sym] map_prod_def
	by force
	qed

	lemma rcoset_rel_sym: "sym (rcoset_rel G)"
	using rcoset_rel_conv_lcoset_rel map_prod_sym lcoset_rel_sym by simp

	abbreviation RCoset_rel :: "'g set \<Rightarrow> ('g\<times>'g) set"
	where "RCoset_rel H \<equiv> rcoset_rel H \<inter> (G\<times>G)"

	definition normal :: "'g set \<Rightarrow> bool"
	where "normal H \<equiv> (\<forall>g\<in>G. LCoset_rel H `` {g} = RCoset_rel H `` {g})"

	lemma normalI:
	assumes "Group H" "\<forall>g\<in>G. \<forall>h\<in>H. \<exists>h'\<in>H. g+h = h'+g"
	"\<forall>g\<in>G. \<forall>h\<in>H. \<exists>h'\<in>H. h+g = g+h'"
	shows "normal H"
	unfolding normal_def
	proof
	fix g assume g: "g\<in>G"
	show "LCoset_rel H `` {g} = RCoset_rel H `` {g}"
	proof (rule seteqI)
	fix x assume "x \<in> LCoset_rel H `` {g}"
	with g have x: "x\<in>G" "-g+x \<in> H" unfolding lcoset_rel_def by auto
	from g x(2) assms(2) obtain h where h: "h\<in>H" "g-x = -h"
	by (fastforce simp add: algebra_simps)
	with assms(1) g x(1) show "x \<in> RCoset_rel H `` {g}"
	using Group.uminus_closed unfolding rcoset_rel_def by simp
	next
	fix x assume "x \<in> RCoset_rel H `` {g}"
	with g have x: "x\<in>G" "g-x \<in> H" unfolding rcoset_rel_def by auto
	with assms(3) obtain h where h: "h\<in>H" "-g+x = -h"
	by (fastforce simp add: algebra_simps minus_add)
	with assms(1) g x(1) show "x \<in> LCoset_rel H `` {g}"
	using Group.uminus_closed unfolding lcoset_rel_def by simp
	qed
	qed

	lemma normal_lconjby_closed:
	"\<lbrakk> Subgroup H; normal H; g\<in>G; h\<in>H \<rbrakk> \<Longrightarrow> lconjby g h \<in> H"
	using lcoset_relI[of g "g+h" H] add_closed[of g h] normal_def[of H]
	symD[OF Group.rcoset_rel_sym, of H g "g+h"] rcoset_rel_def[of H]
	by auto

	lemma normal_rconjby_closed:
	"\<lbrakk> Subgroup H; normal H; g\<in>G; h\<in>H \<rbrakk> \<Longrightarrow> rconjby g h \<in> H"
	using normal_lconjby_closed[of H "-g" h] uminus_closed[of g] by auto

	abbreviation "normal_closure A \<equiv> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>"

	lemma (in Group) normal_closure:
	assumes "A\<subseteq>G"
	shows "normal (normal_closure A)"
	proof (rule normalI, rule genby_Group)
	show "\<forall>x\<in>G. \<forall>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>.
	\<exists>h'\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. x + h = h' + x"
	proof
	fix x assume x: "x\<in>G"
	show "\<forall>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>.
	\<exists>h'\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. x + h = h' + x"
	proof (rule ballI, erule genby.induct)
	show "\<exists>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. x + 0 = h + x"
	using genby_0_closed by force
	next
	fix s assume "s \<in> (\<Union>g\<in>G. lconjby g ` A)"
	from this obtain g a where ga: "g\<in>G" "a\<in>A" "s = lconjby g a" by fast
	from ga(3) have "x + s = lconjby x (lconjby g a) + x"
	by (simp add: algebra_simps)
	hence "x + s = lconjby (x+g) a + x" by (simp add: lconjby_add)
	with x ga(1,2) show "\<exists>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. x + s = h + x"
	using add_closed by (blast intro: genby_genset_closed)
	next
	fix w w'
	assume w : "w \<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>"
	"\<exists>h \<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. x + w = h + x"
	and w': "w'\<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>"
	"\<exists>h'\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. x + w' = h'+ x"
	from w(2) w'(2) obtain h h'
	where h : "h \<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>" "x + w = h + x"
	and h': "h'\<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>" "x + w' = h'+ x"
	by fast
	have "x + (w - w') = x + w - (-x + (x + w'))"
	by (simp add: algebra_simps)
	also from h(2) h'(2) have "\<dots> = h + x + (-(h' + x) + x)"
	by (simp add: algebra_simps)
	also have "\<dots> = h + x + (-x + -h') + x"
	by (simp add: minus_add add.assoc)
	finally have "x + (w-w') = h - h' + x"
	using add.assoc[of "h+x" "-x" "-h'"] by simp
	with h(1) h'(1)
	show "\<exists>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. x + (w - w') = h + x"
	using genby_diff_closed
	by fast
	qed
	qed
	show "\<forall>x\<in>G. \<forall>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>.
	\<exists>h'\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. h + x = x + h'"
	proof
	fix x assume x: "x\<in>G"
	show "\<forall>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>.
	\<exists>h'\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. h + x = x + h'"
	proof (rule ballI, erule genby.induct)
	show "\<exists>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. 0 + x = x + h"
	using genby_0_closed by force
	next
	fix s assume "s \<in> (\<Union>g\<in>G. lconjby g ` A)"
	from this obtain g a where ga: "g\<in>G" "a\<in>A" "s = lconjby g a" by fast
	from ga(3) have "s + x = x + (((-x + g) + a) + -g) + x"
	by (simp add: algebra_simps)
	also have "\<dots> = x + (-x + g + a + -g + x)" by (simp add: add.assoc)
	finally have "s + x = x + lconjby (-x+g) a"
	by (simp add: algebra_simps lconjby_add)
	with x ga(1,2) show "\<exists>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. s + x = x + h"
	using uminus_add_closed by (blast intro: genby_genset_closed)
	next
	fix w w'
	assume w : "w \<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>"
	"\<exists>h \<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. w + x = x + h"
	and w': "w'\<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>"
	"\<exists>h'\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. w' + x = x + h'"
	from w(2) w'(2) obtain h h'
	where h : "h \<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>" "w + x = x + h"
	and h': "h'\<in> \<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>" "w' + x = x + h'"
	by fast
	have "w - w' + x = w + x + (-x + -w') + x" by (simp add: algebra_simps)
	also from h(2) h'(2) have "\<dots> = x + h + (-h'+-x) + x"
	using minus_add[of w' x] minus_add[of x h'] by simp
	finally have "w - w' + x = x + (h - h')" by (simp add: algebra_simps)
	with h(1) h'(1) show "\<exists>h\<in>\<langle>\<Union>g\<in>G. lconjby g ` A\<rangle>. w - w' + x = x + h"
	using genby_diff_closed by fast
	qed
	qed
	qed

	end (* context Group *)

	subsubsection \<open>Quotient groups\<close>

	text \<open>
	Here we use the bridge built by @{const BinOpSetGroup} to make the quotient of a @{const Group}
	by a normal subgroup into a @{const Group} itself.
	\<close>

	context Group
	begin

	lemma normal_quotient_add_well_defined:
	assumes "Subgroup H" "normal H" "g\<in>G" "g'\<in>G"
	shows "LCoset_rel H `` {g} + LCoset_rel H `` {g'} = LCoset_rel H `` {g+g'}"
	proof (rule seteqI)
	fix x assume "x \<in> LCoset_rel H `` {g} + LCoset_rel H `` {g'}"
	from this obtain y z
	where "y \<in> LCoset_rel H `` {g}" "z \<in> LCoset_rel H `` {g'}" "x = y+z"
	unfolding set_plus_def
	by fast
	with assms show "x \<in> LCoset_rel H `` {g + g'}"
	using lcoset_rel_def[of H] normal_lconjby_closed[of H g' "-g'+z"]
	Group.add_closed
	normal_rconjby_closed[of H g' "-g + y + (z - g')"]
	add.assoc[of "-g'" "-g"]
	add_closed lcoset_relI[of "g+g'" "y+z"]
	by (fastforce simp add: add.assoc minus_add)
	next
	fix x assume "x \<in> LCoset_rel H `` {g + g'}"
	moreover define h where "h \<equiv> -(g+g') + x"
	moreover hence "x = g + (g' + h)"
	using add.assoc[of "-g'" "-g" x] by (simp add: add.assoc minus_add)
	ultimately show "x \<in> LCoset_rel H `` {g} + LCoset_rel H `` {g'}"
	using assms(1,3,4) lcoset_rel_def[of H] add_closed
	refl_onD[OF subgroup_refl_on_LCoset_rel, of H]
	by force
	qed

	abbreviation "quotient_set H \<equiv> G // LCoset_rel H"

	lemma BinOpSetGroup_normal_quotient:
	assumes "Subgroup H" "normal H"
	shows "BinOpSetGroup (quotient_set H) (+) H"
	proof
	from assms(1) have H0: "H = LCoset_rel H `` {0}"
	using trivial_LCoset by auto

	from assms(1) show "H \<in> quotient_set H"
	using H0 zero_closed LCoset_rel_quotientI[of 0 H] by simp

	fix x assume "x \<in> quotient_set H"
	from this obtain gx where gx: "gx\<in>G" "x = LCoset_rel H `` {gx}"
	by (fast elim: LCoset_rel_quotientE)
	with assms(1,2) show "x+H = x" "H+x = x"
	using normal_quotient_add_well_defined[of H gx 0]
	normal_quotient_add_well_defined[of H 0 gx]
	H0 zero_closed
	by auto

	from gx(1) have "LCoset_rel H `` {-gx} \<in> quotient_set H"
	using uminus_closed by (fast intro: LCoset_rel_quotientI)
	moreover from assms(1,2) gx
	have "x + LCoset_rel H `` {-gx} = H" "LCoset_rel H `` {-gx} + x = H"
	using H0 uminus_closed normal_quotient_add_well_defined
	by auto
	ultimately show "\<exists>x'\<in>quotient_set H. x + x' = H \<and> x' + x = H" by fast

	fix y assume "y \<in> quotient_set H"
	from this obtain gy where gy: "gy\<in>G" "y = LCoset_rel H `` {gy}"
	by (fast elim: LCoset_rel_quotientE)
	with assms gx show "x+y \<in> quotient_set H"
	using add_closed normal_quotient_add_well_defined
	by (auto intro: LCoset_rel_quotientI)

	qed (rule add.assoc)

	abbreviation "abs_lcoset_perm H \<equiv>
	BinOpSetGroup.Abs_G_perm (quotient_set H) (+)"
	abbreviation "abs_lcoset_perm_lift H g \<equiv> abs_lcoset_perm H (LCoset_rel H `` {g})"
	abbreviation "abs_lcoset_perm_lift_arg_permutation g H \<equiv> abs_lcoset_perm_lift H g"

	notation abs_lcoset_perm_lift_arg_permutation ("\<lceil>_\|_\<rceil>" [51,51] 50)

	end (* context Group *)

	abbreviation "Group_abs_lcoset_perm_lift_arg_permutation G' g H \<equiv>
	Group.abs_lcoset_perm_lift_arg_permutation G' g H"
	notation Group_abs_lcoset_perm_lift_arg_permutation ("\<lceil>_\|_\|_\<rceil>" [51,51,51] 50)

	context Group
	begin

	lemmas lcoset_perm_def =
	BinOpSetGroup.Abs_G_perm_def[OF BinOpSetGroup_normal_quotient]
	lemmas lcoset_perm_comp =
	BinOpSetGroup.G_perm_comp[OF BinOpSetGroup_normal_quotient]
	lemmas bij_lcoset_perm =
	BinOpSetGroup.bij_G_perm[OF BinOpSetGroup_normal_quotient]

	lemma trivial_lcoset_perm:
	assumes "Subgroup H" "normal H" "h\<in>H"
	shows "restrict1 ((+) (LCoset_rel H `` {h})) (quotient_set H) = id"
	proof (rule ext, simp, rule impI)
	fix x assume x: "x \<in> quotient_set H"
	then obtain k where k: "k\<in>G" "x = LCoset_rel H `` {k}"
	by (blast elim: LCoset_rel_quotientE)
	with x have "LCoset_rel H `` {h} + x = LCoset_rel H `` {h+k}"
	using assms normal_quotient_add_well_defined by auto
	with assms k show "LCoset_rel H `` {h} + x = x"
	using add_closed[of h k] lcoset_relI[of k "h+k" H]
	normal_rconjby_closed[of H k h]
	eq_equiv_class_iff[OF lcoset_subgroup_rel_equiv, of H]
	by (auto simp add: add.assoc)
	qed

	definition quotient_group :: "'g set \<Rightarrow> 'g set permutation set" where
	"quotient_group H \<equiv> BinOpSetGroup.pG (quotient_set H) (+)"

	abbreviation "natural_quotient_hom H \<equiv> restrict0 (\<lambda>g. \<lceil>g\|H\<rceil>) G"

	theorem quotient_group:
	"Subgroup H \<Longrightarrow> normal H \<Longrightarrow> Group (quotient_group H)"
	unfolding quotient_group_def
	using BinOpSetGroup.Group[OF BinOpSetGroup_normal_quotient]
	by auto

	lemma natural_quotient_hom:
	"Subgroup H \<Longrightarrow> normal H \<Longrightarrow> GroupHom G (natural_quotient_hom H)"
	using add_closed bij_lcoset_perm lcoset_perm_def supp_restrict0
	normal_quotient_add_well_defined[THEN sym]
	LCoset_rel_quotientI[of _ H]
	by unfold_locales
	(force simp add: lcoset_perm_comp plus_permutation_abs_eq)

	lemma natural_quotient_hom_image:
	"natural_quotient_hom H ` G = quotient_group H"
	unfolding quotient_group_def
	by (force elim: LCoset_rel_quotientE intro: LCoset_rel_quotientI)

	lemma quotient_group_UN: "quotient_group H = (\<lambda>g. \<lceil>g\|H\<rceil>) ` G"
	using natural_quotient_hom_image by auto

	lemma quotient_identity_rule: "\<lbrakk> Subgroup H; normal H; h\<in>H \<rbrakk> \<Longrightarrow> \<lceil>h\|H\<rceil> = 0"
	using lcoset_perm_def
	by (simp add: trivial_lcoset_perm zero_permutation.abs_eq)

	lemma quotient_group_lift_to_quotient_set:
	"\<lbrakk> Subgroup H; normal H; g\<in>G \<rbrakk> \<Longrightarrow> (\<lceil>g\|H\<rceil>) \<rightarrow> H = LCoset_rel H `` {g}"
	using LCoset_rel_quotientI
	BinOpSetGroup.G_perm_apply_identity[
	OF BinOpSetGroup_normal_quotient
	]
	by simp

	end (* context Group *)

	subsubsection \<open>The induced homomorphism on a quotient group\<close>

	text \<open>
	A normal subgroup contained in the kernel of a homomorphism gives rise to a homomorphism on the
	quotient group by that subgroup. When the subgroup is the kernel itself (which is always normal),
	we obtain an isomorphism on the quotient.
	\<close>

	context GroupHom
	begin

	lemma respects_Ker_lcosets: "H \<subseteq> Ker \<Longrightarrow> T respects (LCoset_rel H)"
	using uminus_add_in_Ker_eq_eq_im
	unfolding lcoset_rel_def
	by (blast intro: congruentI)

	abbreviation "quotient_hom H \<equiv>
	BinOpSetGroup.lift_hom (quotient_set H) (+) (quotientfun T)"

	lemmas normal_subgroup_quotientfun_classrep_equality =
	quotientfun_classrep_equality[
	OF subgroup_refl_on_LCoset_rel, OF _ respects_Ker_lcosets
	]

	lemma quotient_hom_im:
	"\<lbrakk> Subgroup H; normal H; H \<subseteq> Ker; g\<in>G \<rbrakk> \<Longrightarrow> quotient_hom H (\<lceil>g\|H\<rceil>) = T g"
	using quotient_group_def quotient_group_UN quotient_group_lift_to_quotient_set
	BinOpSetGroup.inv_correspondence_conv_apply[
	OF BinOpSetGroup_normal_quotient
	]
	normal_subgroup_quotientfun_classrep_equality
	by auto

	lemma quotient_hom:
	assumes "Subgroup H" "normal H" "H \<subseteq> Ker"
	shows "GroupHom (quotient_group H) (quotient_hom H)"
	unfolding quotient_group_def
	proof (
	rule BinOpSetGroup.lift_hom, rule BinOpSetGroup_normal_quotient, rule assms(1),
	rule assms(2)
	)
	from assms
	show "\<forall>x \<in> quotient_set H. \<forall>y \<in> quotient_set H.
	quotientfun T (x + y) = quotientfun T x + quotientfun T y"
	using normal_quotient_add_well_defined normal_subgroup_quotientfun_classrep_equality
	add_closed hom
	by (fastforce elim: LCoset_rel_quotientE)
	qed

	end (* context GroupHom *)


	subsection \<open>Free groups\<close>

	subsubsection \<open>Words in letters of @{type signed} type\<close>

	paragraph \<open>Definitions and basic fact\<close>

	text \<open>
	We pair elements of some type with type @{typ bool}, where the @{typ bool} part of the pair
	indicates inversion.
	\<close>

	abbreviation "pairtrue \<equiv> \<lambda>s. (s,True)"
	abbreviation "pairfalse \<equiv> \<lambda>s. (s,False)"

	abbreviation flip_signed :: "'a signed \<Rightarrow> 'a signed"
	where "flip_signed \<equiv> apsnd (\<lambda>b. \<not>b)"

	abbreviation nflipped_signed :: "'a signed \<Rightarrow> 'a signed \<Rightarrow> bool"
	where "nflipped_signed x y \<equiv> y \<noteq> flip_signed x"

	lemma flip_signed_order2: "flip_signed (flip_signed x) = x"
	using apsnd_conv[of "\<lambda>b. \<not>b" "fst x" "snd x"] by simp

	abbreviation charpair :: "'a::uminus set \<Rightarrow> 'a \<Rightarrow> 'a signed"
	where "charpair S s \<equiv> if s\<in>S then (s,True) else (-s,False)"

	lemma map_charpair_uniform:
	"ss\<in>lists S \<Longrightarrow> map (charpair S) ss = map pairtrue ss"
	by (induct ss) auto

	lemma fst_set_map_charpair_un_uminus:
	fixes ss :: "'a::group_add list"
	shows "ss\<in>lists (S \<union> uminus ` S) \<Longrightarrow> fst ` set (map (charpair S) ss) \<subseteq> S"
	by (induct ss) auto

	abbreviation apply_sign :: "('a\<Rightarrow>'b::uminus) \<Rightarrow> 'a signed \<Rightarrow> 'b"
	where "apply_sign f x \<equiv> (if snd x then f (fst x) else - f (fst x))"

	text \<open>
	A word in such pairs will be considered proper if it does not contain consecutive letters that
	have opposite signs (and so are considered inverse), since such consecutive letters would be
	cancelled in a group.
	\<close>

	abbreviation proper_signed_list :: "'a signed list \<Rightarrow> bool"
	where "proper_signed_list \<equiv> binrelchain nflipped_signed"

	lemma proper_map_flip_signed:
	"proper_signed_list xs \<Longrightarrow> proper_signed_list (map flip_signed xs)"
	by (induct xs rule: list_induct_CCons) auto

	lemma proper_rev_map_flip_signed:
	"proper_signed_list xs \<Longrightarrow> proper_signed_list (rev (map flip_signed xs))"
	using proper_map_flip_signed binrelchain_sym_rev[of nflipped_signed] by fastforce

	lemma uniform_snd_imp_proper_signed_list:
	"snd ` set xs \<subseteq> {b} \<Longrightarrow> proper_signed_list xs"
	proof (induct xs rule: list_induct_CCons)
	case CCons thus ?case by force
	qed auto

	lemma proper_signed_list_map_uniform_snd:
	"proper_signed_list (map (\<lambda>s. (s,b)) as)"
	using uniform_snd_imp_proper_signed_list[of _ b] by force

	paragraph \<open>Algebra\<close>

	text \<open>
	Addition is performed by appending words and recursively removing any newly created adjacent
	pairs of inverse letters. Since we will only ever be adding proper words, we only need to care
	about newly created adjacent inverse pairs in the middle.
	\<close>

	function prappend_signed_list :: "'a signed list \<Rightarrow> 'a signed list \<Rightarrow> 'a signed list"
	where "prappend_signed_list xs [] = xs"
	\| "prappend_signed_list [] ys = ys"
	\| "prappend_signed_list (xs@[x]) (y#ys) = (
	if y = flip_signed x then prappend_signed_list xs ys else xs @ x # y # ys
	)"
	by (auto) (rule two_prod_lists_cases_snoc_Cons)
	termination by (relation "measure (\<lambda>(xs,ys). length xs + length ys)") auto

	lemma proper_prappend_signed_list:
	"proper_signed_list xs \<Longrightarrow> proper_signed_list ys
	\<Longrightarrow> proper_signed_list (prappend_signed_list xs ys)"
	proof (induct xs ys rule: list_induct2_snoc_Cons)
	case (snoc_Cons xs x y ys)
	show ?case
	proof (cases "y = flip_signed x")
	case True with snoc_Cons show ?thesis
	using binrelchain_append_reduce1[of nflipped_signed]
	binrelchain_Cons_reduce[of nflipped_signed y]
	by auto
	next
	case False with snoc_Cons(2,3) show ?thesis
	using binrelchain_join[of nflipped_signed] by simp
	qed
	qed auto

	lemma fully_prappend_signed_list:
	"prappend_signed_list (rev (map flip_signed xs)) xs = []"
	by (induct xs) auto

	lemma prappend_signed_list_single_Cons:
	"prappend_signed_list [x] (y#ys) = (if y = flip_signed x then ys else x#y#ys)"
	using prappend_signed_list.simps(3)[of "[]" x] by simp

	lemma prappend_signed_list_map_uniform_snd:
	"prappend_signed_list (map (\<lambda>s. (s,b)) xs) (map (\<lambda>s. (s,b)) ys) =
	map (\<lambda>s. (s,b)) xs @ map (\<lambda>s. (s,b)) ys"
	by (cases xs ys rule: two_lists_cases_snoc_Cons) auto

	lemma prappend_signed_list_assoc_conv_snoc2Cons:
	assumes "proper_signed_list (xs@[y])" "proper_signed_list (y#ys)"
	shows "prappend_signed_list (xs@[y]) ys = prappend_signed_list xs (y#ys)"
	proof (cases xs ys rule: two_lists_cases_snoc_Cons')
	case Nil1 with assms(2) show ?thesis
	by (simp add: prappend_signed_list_single_Cons)
	next
	case Nil2 with assms(1) show ?thesis
	using binrelchain_append_reduce2 by force
	next
	case (snoc_Cons as a b bs)
	with assms show ?thesis
	using prappend_signed_list.simps(3)[of "as@[a]"]
	binrelchain_append_reduce2[of nflipped_signed as "[a,y]"]
	by simp
	qed simp

	lemma prappend_signed_list_assoc:
	"\<lbrakk> proper_signed_list xs; proper_signed_list ys; proper_signed_list zs \<rbrakk> \<Longrightarrow>
	prappend_signed_list (prappend_signed_list xs ys) zs =
	prappend_signed_list xs (prappend_signed_list ys zs)"
	proof (induct xs ys zs rule: list_induct3_snoc_Conssnoc_Cons_pairwise)
	case (snoc_single_Cons xs x y z zs)
	thus ?case
	using prappend_signed_list.simps(3)[of "[]" y]
	prappend_signed_list.simps(3)[of "xs@[x]"]
	by (cases "y = flip_signed x" "z = flip_signed y" rule: two_cases)
	(auto simp add:
	flip_signed_order2 prappend_signed_list_assoc_conv_snoc2Cons
	)
	next
	case (snoc_Conssnoc_Cons xs x y ys w z zs)
	thus ?case
	using binrelchain_Cons_reduce[of nflipped_signed y "ys@[w]"]
	binrelchain_Cons_reduce[of nflipped_signed z zs]
	binrelchain_append_reduce1[of nflipped_signed xs]
	binrelchain_append_reduce1[of nflipped_signed "y#ys"]
	binrelchain_Conssnoc_reduce[of nflipped_signed y ys]
	prappend_signed_list.simps(3)[of "y#ys"]
	prappend_signed_list.simps(3)[of "xs@x#y#ys"]
	by (cases "y = flip_signed x" "z = flip_signed w" rule: two_cases) auto
	qed auto

	lemma fst_set_prappend_signed_list:
	"fst ` set (prappend_signed_list xs ys) \<subseteq> fst ` (set xs \<union> set ys)"
	by (induct xs ys rule: list_induct2_snoc_Cons) auto

	lemma collapse_flipped_signed:
	"prappend_signed_list [(s,b)] [(s,\<not>b)] = []"
	using prappend_signed_list.simps(3)[of "[]" "(s,b)"] by simp



	subsubsection \<open>The collection of proper signed lists as a type\<close>

	text \<open>
	Here we create a type out of the collection of proper signed lists. This type will be of class
	@{class group_add}, with the empty list as zero, the modified append operation
	@{const prappend_signed_list} as addition, and inversion performed by flipping the signs of the
	elements in the list and then reversing the order.
	\<close>

	paragraph \<open>Type definition, instantiations, and instances\<close>

	text \<open>Here we define the type and instantiate it with respect to various type classes.\<close>

	typedef 'a freeword = "{as::'a signed list. proper_signed_list as}"
	morphisms freeword Abs_freeword
	using binrelchain.simps(1) by fast

	text \<open>
	These two functions act as the natural injections of letters and words in the letter type into
	the @{type freeword} type.
	\<close>

	abbreviation Abs_freeletter :: "'a \<Rightarrow> 'a freeword"
	where "Abs_freeletter s \<equiv> Abs_freeword [pairtrue s]"

	abbreviation Abs_freelist :: "'a list \<Rightarrow> 'a freeword"
	where "Abs_freelist as \<equiv> Abs_freeword (map pairtrue as)"

	abbreviation Abs_freelistfst :: "'a signed list \<Rightarrow> 'a freeword"
	where "Abs_freelistfst xs \<equiv> Abs_freelist (map fst xs)"

	setup_lifting type_definition_freeword

	instantiation freeword :: (type) zero
	begin
	lift_definition zero_freeword :: "'a freeword" is "[]::'a signed list" by simp
	instance ..
	end

	instantiation freeword :: (type) plus
	begin
	lift_definition plus_freeword :: "'a freeword \<Rightarrow> 'a freeword \<Rightarrow> 'a freeword"
	is "prappend_signed_list"
	using proper_prappend_signed_list
	by fast
	instance ..
	end

	instantiation freeword :: (type) uminus
	begin
	lift_definition uminus_freeword :: "'a freeword \<Rightarrow> 'a freeword"
	is "\<lambda>xs. rev (map flip_signed xs)"
	by (rule proper_rev_map_flip_signed)
	instance ..
	end

	instantiation freeword :: (type) minus
	begin
	lift_definition minus_freeword :: "'a freeword \<Rightarrow> 'a freeword \<Rightarrow> 'a freeword"
	is "\<lambda>xs ys. prappend_signed_list xs (rev (map flip_signed ys))"
	using proper_rev_map_flip_signed proper_prappend_signed_list by fast
	instance ..
	end

	instance freeword :: (type) semigroup_add
	proof
	fix a b c :: "'a freeword" show "a + b + c = a + (b + c)"
	using prappend_signed_list_assoc[of "freeword a" "freeword b" "freeword c"]
	by transfer simp
	qed

	instance freeword :: (type) monoid_add
	proof
	fix a b c :: "'a freeword"
	show "0 + a = a" by transfer simp
	show "a + 0 = a" by transfer simp
	qed

	instance freeword :: (type) group_add
	proof
	fix a b :: "'a freeword"
	show "- a + a = 0"
	using fully_prappend_signed_list[of "freeword a"] by transfer simp
	show "a + - b = a - b" by transfer simp
	qed

	paragraph \<open>Basic algebra and transfer facts in the @{type freeword} type\<close>

	text \<open>
	Here we record basic algebraic manipulations for the @{type freeword} type as well as various
	transfer facts for dealing with representations of elements of @{type freeword} type as lists of
	signed letters.
	\<close>

	abbreviation Abs_freeletter_add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a freeword" (infixl "[+]" 65)
	where "s [+] t \<equiv> Abs_freeletter s + Abs_freeletter t"

	lemma Abs_freeword_Cons:
	assumes "proper_signed_list (x#xs)"
	shows "Abs_freeword (x#xs) = Abs_freeword [x] + Abs_freeword xs"
	proof (cases xs)
	case Nil thus ?thesis
	using add_0_right[of "Abs_freeword [x]"] by (simp add: zero_freeword.abs_eq)
	next
	case (Cons y ys)
	with assms
	have "freeword (Abs_freeword (x#xs)) =
	freeword (Abs_freeword [x] + Abs_freeword xs)"
	by (simp add:
	plus_freeword.rep_eq Abs_freeword_inverse
	prappend_signed_list_single_Cons
	)
	thus ?thesis using freeword_inject by fast
	qed

	lemma Abs_freelist_Cons: "Abs_freelist (x#xs) = Abs_freeletter x + Abs_freelist xs"
	using proper_signed_list_map_uniform_snd[of True "x#xs"] Abs_freeword_Cons
	by simp

	lemma plus_freeword_abs_eq:
	"proper_signed_list xs \<Longrightarrow> proper_signed_list ys \<Longrightarrow>
	Abs_freeword xs + Abs_freeword ys = Abs_freeword (prappend_signed_list xs ys)"
	using plus_freeword.abs_eq unfolding eq_onp_def by simp

	lemma Abs_freeletter_add: "s [+] t = Abs_freelist [s,t]"
	using Abs_freelist_Cons[of s "[t]"] by simp

	lemma uminus_freeword_Abs_eq:
	"proper_signed_list xs \<Longrightarrow>
	- Abs_freeword xs = Abs_freeword (rev (map flip_signed xs))"
	using uminus_freeword.abs_eq unfolding eq_onp_def by simp

	lemma uminus_Abs_freeword_singleton:
	"- Abs_freeword [(s,b)] = Abs_freeword [(s,\<not> b)]"
	using uminus_freeword_Abs_eq[of "[(s,b)]"] by simp

	lemma Abs_freeword_append_uniform_snd:
	"Abs_freeword (map (\<lambda>s. (s,b)) (xs@ys)) =
	Abs_freeword (map (\<lambda>s. (s,b)) xs) + Abs_freeword (map (\<lambda>s. (s,b)) ys)"
	using proper_signed_list_map_uniform_snd[of b xs]
	proper_signed_list_map_uniform_snd[of b ys]
	plus_freeword_abs_eq prappend_signed_list_map_uniform_snd[of b xs ys]
	by force

	lemmas Abs_freelist_append = Abs_freeword_append_uniform_snd[of True]

	lemma Abs_freelist_append_append:
	"Abs_freelist (xs@ys@zs) = Abs_freelist xs + Abs_freelist ys + Abs_freelist zs"
	using Abs_freelist_append[of "xs@ys"] Abs_freelist_append by simp

	lemma Abs_freelist_inverse: "freeword (Abs_freelist as) = map pairtrue as"
	using proper_signed_list_map_uniform_snd Abs_freeword_inverse by fast

	lemma Abs_freeword_singleton_conv_apply_sign_freeletter:
	"Abs_freeword [x] = apply_sign Abs_freeletter x"
	by (cases x) (auto simp add: uminus_Abs_freeword_singleton)

	lemma Abs_freeword_conv_freeletter_sum_list:
	"proper_signed_list xs \<Longrightarrow>
	Abs_freeword xs = (\<Sum>x\<leftarrow>xs. apply_sign Abs_freeletter x)"
	proof (induct xs)
	case (Cons x xs) thus ?case
	using Abs_freeword_Cons[of x] binrelchain_Cons_reduce[of _ x]
	by (simp add: Abs_freeword_singleton_conv_apply_sign_freeletter)
	qed (simp add: zero_freeword.abs_eq)

	lemma freeword_conv_freeletter_sum_list:
	"x = (\<Sum>s\<leftarrow>freeword x. apply_sign Abs_freeletter s)"
	using Abs_freeword_conv_freeletter_sum_list[of "freeword x"] freeword
	by (auto simp add: freeword_inverse)

	lemma Abs_freeletter_prod_conv_Abs_freeword:
	"snd x \<Longrightarrow> Abs_freeletter (fst x) = Abs_freeword [x]"
	using prod_eqI[of x "pairtrue (fst x)"] by simp


	subsubsection \<open>Lifts of functions on the letter type\<close>

	text \<open>
	Here we lift functions on the letter type to type @{type freeword}. In particular, we are
	interested in the case where the function being lifted has codomain of class @{class group_add}.
	\<close>

	paragraph \<open>The universal property\<close>

	text \<open>
	The universal property for free groups says that every function from the letter type to some
	@{class group_add} type gives rise to a unique homomorphism.
	\<close>

	lemma extend_map_to_freeword_hom':
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	defines h: "h::'a signed \<Rightarrow> 'b \<equiv> \<lambda>(s,b). if b then f s else - (f s)"
	defines g: "g::'a signed list \<Rightarrow> 'b \<equiv> \<lambda>xs. sum_list (map h xs)"
	shows "g (prappend_signed_list xs ys) = g xs + g ys"
	proof (induct xs ys rule: list_induct2_snoc_Cons)
	case (snoc_Cons xs x y ys)
	show ?case
	proof (cases "y = flip_signed x")
	case True
	with h have "h y = - h x"
	using split_beta'[of "\<lambda>s b. if b then f s else - (f s)"] by simp
	with g have "g (xs @ [x]) + g (y # ys) = g xs + g ys"
	by (simp add: algebra_simps)
	with True snoc_Cons show ?thesis by simp
	next
	case False with g show ?thesis
	using sum_list.append[of "map h (xs@[x])" "map h (y#ys)"] by simp
	qed
	qed (auto simp add: h g)

	lemma extend_map_to_freeword_hom1:
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	defines "h::'a signed \<Rightarrow> 'b \<equiv> \<lambda>(s,b). if b then f s else - (f s)"
	defines "g::'a freeword \<Rightarrow> 'b \<equiv> \<lambda>x. sum_list (map h (freeword x))"
	shows "g (Abs_freeletter s) = f s"
	using assms
	by (simp add: Abs_freeword_inverse)

	lemma extend_map_to_freeword_hom2:
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	defines "h::'a signed \<Rightarrow> 'b \<equiv> \<lambda>(s,b). if b then f s else - (f s)"
	defines "g::'a freeword \<Rightarrow> 'b \<equiv> \<lambda>x. sum_list (map h (freeword x))"
	shows "UGroupHom g"
	using assms
	by (
	auto intro: UGroupHomI
	simp add: plus_freeword.rep_eq extend_map_to_freeword_hom'
	)

	lemma uniqueness_of_extended_map_to_freeword_hom':
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	defines h: "h::'a signed \<Rightarrow> 'b \<equiv> \<lambda>(s,b). if b then f s else - (f s)"
	defines g: "g::'a signed list \<Rightarrow> 'b \<equiv> \<lambda>xs. sum_list (map h xs)"
	assumes singles: "\<And>s. k [(s,True)] = f s"
	and adds : "\<And>xs ys. proper_signed_list xs \<Longrightarrow> proper_signed_list ys
	\<Longrightarrow> k (prappend_signed_list xs ys) = k xs + k ys"
	shows "proper_signed_list xs \<Longrightarrow> k xs = g xs"
	proof-
	have knil: "k [] = 0" using adds[of "[]" "[]"] add.assoc[of "k []" "k []" "- k []"] by simp
	have ksingle: "\<And>x. k [x] = g [x]"
	proof-
	fix x :: "'a signed"
	obtain s b where x: "x = (s,b)" by fastforce
	show "k [x] = g [x]"
	proof (cases b)
	case False
	from adds x singles
	have "k (prappend_signed_list [x] [(s,True)]) = k [x] + f s"
	by simp
	moreover have "prappend_signed_list [(s,False)] [(s,True)] = []"
	using collapse_flipped_signed[of s False] by simp
	ultimately have "- f s = k [x] + f s + - f s" using x False knil by simp
	with x False g h show "k [x] = g [x]" by (simp add: algebra_simps)
	qed (simp add: x g h singles)
	qed
	show "proper_signed_list xs \<Longrightarrow> k xs = g xs"
	proof (induct xs rule: list_induct_CCons)
	case (CCons x y xs)
	with g h show ?case
	using adds[of "[x]" "y#xs"]
	by (simp add:
	prappend_signed_list_single_Cons
	ksingle extend_map_to_freeword_hom'
	)
	qed (auto simp add: g h knil ksingle)
	qed

	lemma uniqueness_of_extended_map_to_freeword_hom:
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	defines "h::'a signed \<Rightarrow> 'b \<equiv> \<lambda>(s,b). if b then f s else - (f s)"
	defines "g::'a freeword \<Rightarrow> 'b \<equiv> \<lambda>x. sum_list (map h (freeword x))"
	assumes k: "k \<circ> Abs_freeletter = f" "UGroupHom k"
	shows "k = g"
	proof
	fix x::"'a freeword"
	define k' where k': "k' \<equiv> k \<circ> Abs_freeword"
	have "k' (freeword x) = g x" unfolding h_def g_def
	proof (rule uniqueness_of_extended_map_to_freeword_hom')
	from k' k(1) show "\<And>s. k' [pairtrue s] = f s" by auto
	show "\<And>xs ys. proper_signed_list xs \<Longrightarrow> proper_signed_list ys
	\<Longrightarrow> k' (prappend_signed_list xs ys) = k' xs + k' ys"
	proof-
	fix xs ys :: "'a signed list"
	assume xsys: "proper_signed_list xs" "proper_signed_list ys"
	with k'
	show "k' (prappend_signed_list xs ys) = k' xs + k' ys"
	using UGroupHom.hom[OF k(2), of "Abs_freeword xs" "Abs_freeword ys"]
	by (simp add: plus_freeword_abs_eq)
	qed
	show "proper_signed_list (freeword x)" using freeword by fast
	qed
	with k' show "k x = g x" using freeword_inverse[of x] by simp
	qed

	theorem universal_property:
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	shows "\<exists>!g::'a freeword\<Rightarrow>'b. g \<circ> Abs_freeletter = f \<and> UGroupHom g"
	proof
	define h where h: "h \<equiv> \<lambda>(s,b). if b then f s else - (f s)"
	define g where g: "g \<equiv> \<lambda>x. sum_list (map h (freeword x))"
	from g h show "g \<circ> Abs_freeletter = f \<and> UGroupHom g"
	using extend_map_to_freeword_hom1[of f] extend_map_to_freeword_hom2
	by auto
	from g h show "\<And>k. k \<circ> Abs_freeletter = f \<and> UGroupHom k \<Longrightarrow> k = g"
	using uniqueness_of_extended_map_to_freeword_hom by auto
	qed

	paragraph \<open>Properties of homomorphisms afforded by the universal property\<close>

	text \<open>
	The lift of a function on the letter set is the unique additive function on @{type freeword}
	that agrees with the original function on letters.
	\<close>

	definition freeword_funlift :: "('a \<Rightarrow> 'b::group_add) \<Rightarrow> ('a freeword\<Rightarrow>'b::group_add)"
	where "freeword_funlift f \<equiv> (THE g. g \<circ> Abs_freeletter = f \<and> UGroupHom g)"

	lemma additive_freeword_funlift: "UGroupHom (freeword_funlift f)"
	using theI'[OF universal_property, of f] unfolding freeword_funlift_def by simp

	lemma freeword_funlift_Abs_freeletter: "freeword_funlift f (Abs_freeletter s) = f s"
	using theI'[OF universal_property, of f]
	comp_apply[of "freeword_funlift f" Abs_freeletter]
	unfolding freeword_funlift_def
	by fastforce

	lemmas freeword_funlift_add = UGroupHom.hom [OF additive_freeword_funlift]
	lemmas freeword_funlift_0 = UGroupHom.im_zero [OF additive_freeword_funlift]
	lemmas freeword_funlift_uminus = UGroupHom.im_uminus [OF additive_freeword_funlift]
	lemmas freeword_funlift_diff = UGroupHom.im_diff [OF additive_freeword_funlift]
	lemmas freeword_funlift_lconjby = UGroupHom.im_lconjby [OF additive_freeword_funlift]

	lemma freeword_funlift_uminus_Abs_freeletter:
	"freeword_funlift f (Abs_freeword [(s,False)]) = - f s"
	using freeword_funlift_uminus[of f "Abs_freeword [(s,False)]"]
	uminus_freeword_Abs_eq[of "[(s,False)]"]
	freeword_funlift_Abs_freeletter[of f]
	by simp

	lemma freeword_funlift_Abs_freeword_singleton:
	"freeword_funlift f (Abs_freeword [x]) = apply_sign f x"
	proof-
	obtain s b where x: "x = (s,b)" by fastforce
	thus ?thesis
	using freeword_funlift_Abs_freeletter freeword_funlift_uminus_Abs_freeletter
	by (cases b) auto
	qed

	lemma freeword_funlift_Abs_freeword_Cons:
	assumes "proper_signed_list (x#xs)"
	shows "freeword_funlift f (Abs_freeword (x#xs)) =
	apply_sign f x + freeword_funlift f (Abs_freeword xs)"
	proof-
	from assms
	have "freeword_funlift f (Abs_freeword (x#xs)) =
	freeword_funlift f (Abs_freeword [x]) +
	freeword_funlift f (Abs_freeword xs)"
	using Abs_freeword_Cons[of x xs] freeword_funlift_add by simp
	thus ?thesis
	using freeword_funlift_Abs_freeword_singleton[of f x] by simp
	qed

	lemma freeword_funlift_Abs_freeword:
	"proper_signed_list xs \<Longrightarrow> freeword_funlift f (Abs_freeword xs) =
	(\<Sum>x\<leftarrow>xs. apply_sign f x)"
	proof (induct xs)
	case (Cons x xs) thus ?case
	using freeword_funlift_Abs_freeword_Cons[of _ _ f]
	binrelchain_Cons_reduce[of _ x xs]
	by simp
	qed (simp add: zero_freeword.abs_eq[THEN sym] freeword_funlift_0)

	lemma freeword_funlift_Abs_freelist:
	"freeword_funlift f (Abs_freelist xs) = (\<Sum>x\<leftarrow>xs. f x)"
	proof (induct xs)
	case (Cons x xs) thus ?case
	using Abs_freelist_Cons[of x xs]
	by (simp add: freeword_funlift_add freeword_funlift_Abs_freeletter)
	qed (simp add: zero_freeword.abs_eq[THEN sym] freeword_funlift_0)

	lemma freeword_funlift_im':
	"proper_signed_list xs \<Longrightarrow> fst ` set xs \<subseteq> S \<Longrightarrow>
	freeword_funlift f (Abs_freeword xs) \<in> \<langle>f`S\<rangle>"
	proof (induct xs)
	case Nil
	have "Abs_freeword ([]::'a signed list) = (0::'a freeword)"
	using zero_freeword.abs_eq[THEN sym] by simp
	thus "freeword_funlift f (Abs_freeword ([]::'a signed list)) \<in> \<langle>f`S\<rangle>"
	using freeword_funlift_0[of f] genby_0_closed by simp
	next
	case (Cons x xs)
	define y where y: "y \<equiv> apply_sign f x"
	define z where z: "z \<equiv> freeword_funlift f (Abs_freeword xs)"
	from Cons(3) have "fst ` set xs \<subseteq> S" by simp
	with z Cons(1,2) have "z \<in> \<langle>f`S\<rangle>" using binrelchain_Cons_reduce by fast
	with y Cons(3) have "y + z \<in> \<langle>f`S\<rangle>"
	using genby_genset_closed[of _ "f`S"]
	genby_uminus_closed genby_add_closed[of y]
	by fastforce
	with Cons(2) y z show ?case
	using freeword_funlift_Abs_freeword_Cons
	subst[
	OF sym,
	of "freeword_funlift f (Abs_freeword (x#xs))" "y+z"
	"\<lambda>b. b\<in>\<langle>f`S\<rangle>"
	]
	by fast
	qed


	subsubsection \<open>Free groups on a set\<close>

	text \<open>
	We now take the free group on a set to be the set in the @{type freeword} type with letters
	restricted to the given set.
	\<close>

	paragraph \<open>Definition and basic facts\<close>

	text \<open>
	Here we define the set of elements of the free group over a set of letters, and record basic
	facts about that set.
	\<close>

	definition FreeGroup :: "'a set \<Rightarrow> 'a freeword set"
	where "FreeGroup S \<equiv> {x. fst ` set (freeword x) \<subseteq> S}"

	lemma FreeGroupI_transfer:
	"proper_signed_list xs \<Longrightarrow> fst ` set xs \<subseteq> S \<Longrightarrow> Abs_freeword xs \<in> FreeGroup S"
	using Abs_freeword_inverse unfolding FreeGroup_def by fastforce

	lemma FreeGroupD: "x \<in> FreeGroup S \<Longrightarrow> fst ` set (freeword x) \<subseteq> S"
	using FreeGroup_def by fast

	lemma FreeGroupD_transfer:
	"proper_signed_list xs \<Longrightarrow> Abs_freeword xs \<in> FreeGroup S \<Longrightarrow> fst ` set xs \<subseteq> S"
	using Abs_freeword_inverse unfolding FreeGroup_def by fastforce

	lemma FreeGroupD_transfer':
	"Abs_freelist xs \<in> FreeGroup S \<Longrightarrow> xs \<in> lists S"
	using proper_signed_list_map_uniform_snd FreeGroupD_transfer by fastforce

	lemma FreeGroup_0_closed: "0 \<in> FreeGroup S"
	proof-
	have "(0::'a freeword) = Abs_freeword []" using zero_freeword.abs_eq by fast
	moreover have "Abs_freeword [] \<in> FreeGroup S"
	using FreeGroupI_transfer[of "[]"] by simp
	ultimately show ?thesis by simp
	qed

	lemma FreeGroup_diff_closed:
	assumes "x \<in> FreeGroup S" "y \<in> FreeGroup S"
	shows "x-y \<in> FreeGroup S"
	proof-
	define xs where xs: "xs \<equiv> freeword x"
	define ys where ys: "ys \<equiv> freeword y"
	have "freeword (x-y) =
	prappend_signed_list (freeword x) (rev (map flip_signed (freeword y)))"
	by transfer simp
	hence "fst ` set (freeword (x-y)) \<subseteq> fst ` (set (freeword x) \<union> set (freeword y))"
	using fst_set_prappend_signed_list by force
	with assms show ?thesis unfolding FreeGroup_def by fast
	qed

	lemma FreeGroup_Group: "Group (FreeGroup S)"
	using FreeGroup_0_closed FreeGroup_diff_closed by unfold_locales fast

	lemmas FreeGroup_add_closed = Group.add_closed [OF FreeGroup_Group]
	lemmas FreeGroup_uminus_closed = Group.uminus_closed [OF FreeGroup_Group]

	lemmas FreeGroup_genby_set_lconjby_set_rconjby_closed =
	Group.genby_set_lconjby_set_rconjby_closed[OF FreeGroup_Group]

	lemma Abs_freelist_in_FreeGroup: "ss \<in> lists S \<Longrightarrow> Abs_freelist ss \<in> FreeGroup S"
	using proper_signed_list_map_uniform_snd by (fastforce intro: FreeGroupI_transfer)

	lemma Abs_freeletter_in_FreeGroup_iff: "(Abs_freeletter s \<in> FreeGroup S) = (s\<in>S)"
	using Abs_freeword_inverse[of "[pairtrue s]"] unfolding FreeGroup_def by simp

	paragraph \<open>Lifts of functions from the letter set to some type of class @{class group_add}\<close>

	text \<open>
	We again obtain a universal property for functions from the (restricted) letter set to some type
	of class @{class group_add}.
	\<close>

	abbreviation "res_freeword_funlift f S \<equiv>
	restrict0 (freeword_funlift f) (FreeGroup S)"

	lemma freeword_funlift_im: "x \<in> FreeGroup S \<Longrightarrow> freeword_funlift f x \<in> \<langle>f ` S\<rangle>"
	using freeword[of x] freeword_funlift_im'[of "freeword x"]
	freeword_inverse[of x]
	unfolding FreeGroup_def
	by auto

	lemma freeword_funlift_surj':
	"ys \<in> lists (f`S \<union> uminus`f`S) \<Longrightarrow> sum_list ys \<in> freeword_funlift f ` FreeGroup S"
	proof (induct ys)
	case Nil thus ?case using FreeGroup_0_closed freeword_funlift_0 by fastforce
	next
	case (Cons y ys)
	from this obtain x
	where x: "x \<in> FreeGroup S" "sum_list ys = freeword_funlift f x"
	by auto
	show "sum_list (y#ys) \<in> freeword_funlift f ` FreeGroup S"
	proof (cases "y \<in> f`S")
	case True
	from this obtain s where s: "s\<in>S" "y = f s" by fast
	from s(1) x(1) have "Abs_freeletter s + x \<in> FreeGroup S"
	using FreeGroupI_transfer[of _ S] FreeGroup_add_closed[of _ S] by force
	moreover from s(2) x(2)
	have "freeword_funlift f (Abs_freeletter s + x) = sum_list (y#ys)"
	using freeword_funlift_add[of f] freeword_funlift_Abs_freeletter
	by simp
	ultimately show ?thesis by force
	next
	case False
	with Cons(2) obtain s where s: "s\<in>S" "y = - f s" by auto
	from s(1) x(1) have "Abs_freeword [(s,False)] + x \<in> FreeGroup S"
	using FreeGroupI_transfer[of _ S] FreeGroup_add_closed[of _ S] by force
	moreover from s(2) x(2)
	have "freeword_funlift f (Abs_freeword [(s,False)] + x) = sum_list (y#ys)"
	using freeword_funlift_add[of f] freeword_funlift_uminus_Abs_freeletter
	by simp
	ultimately show ?thesis by force
	qed
	qed

	lemma freeword_funlift_surj:
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	shows "freeword_funlift f ` FreeGroup S = \<langle>f`S\<rangle>"
	proof (rule seteqI)
	show "\<And>a. a \<in> freeword_funlift f ` FreeGroup S \<Longrightarrow> a \<in> \<langle>f`S\<rangle>"
	using freeword_funlift_im by auto
	next
	fix w assume "w\<in>\<langle>f`S\<rangle>"
	from this obtain ys where ys: "ys \<in> lists (f`S \<union> uminus`f`S)" "w = sum_list ys"
	using genby_eq_sum_lists[of "f`S"] by auto
	thus "w \<in> freeword_funlift f ` FreeGroup S" using freeword_funlift_surj' by simp
	qed

	lemma hom_restrict0_freeword_funlift:
	"GroupHom (FreeGroup S) (res_freeword_funlift f S)"
	using UGroupHom.restrict0 additive_freeword_funlift FreeGroup_Group
	by auto

	lemma uniqueness_of_restricted_lift:
	assumes "GroupHom (FreeGroup S) T" "\<forall>s\<in>S. T (Abs_freeletter s) = f s"
	shows "T = res_freeword_funlift f S"
	proof
	fix x
	define F where "F \<equiv> res_freeword_funlift f S"
	define u_Abs where "u_Abs \<equiv> \<lambda>a::'a signed. apply_sign Abs_freeletter a"
	show "T x = F x"
	proof (cases "x \<in> FreeGroup S")
	case True
	have 1: "set (map u_Abs (freeword x)) \<subseteq> FreeGroup S"
	using u_Abs_def FreeGroupD[OF True]
	Abs_freeletter_in_FreeGroup_iff[of _ S]
	FreeGroup_uminus_closed
	by auto
	moreover from u_Abs_def have "x = (\<Sum>a\<leftarrow>freeword x. u_Abs a)"
	using freeword_conv_freeletter_sum_list by fast
	ultimately
	have "T x = (\<Sum>a\<leftarrow>freeword x. T (u_Abs a))"
	"F x = (\<Sum>a\<leftarrow>freeword x. F (u_Abs a))"
	using F_def
	GroupHom.im_sum_list_map[OF assms(1), of u_Abs "freeword x"]
	GroupHom.im_sum_list_map[
	OF hom_restrict0_freeword_funlift,
	of u_Abs "freeword x" S f
	]
	by auto
	moreover have "\<forall>a\<in>set (freeword x). T (u_Abs a) = F (u_Abs a)"
	proof
	fix a assume "a \<in> set (freeword x)"
	moreover define b where "b \<equiv> Abs_freeletter (fst a)"
	ultimately show "T (u_Abs a) = F (u_Abs a)"
	using F_def u_Abs_def True assms(2) FreeGroupD[of x S]
	GroupHom.im_uminus[OF assms(1)]
	Abs_freeletter_in_FreeGroup_iff[of "fst a" S]
	GroupHom.im_uminus[OF hom_restrict0_freeword_funlift, of b S f]
	freeword_funlift_Abs_freeletter[of f]
	by auto
	qed
	ultimately show ?thesis
	using F_def
	sum_list_map_cong[of "freeword x" "\<lambda>s. T (u_Abs s)" "\<lambda>s. F (u_Abs s)"]
	by simp
	next
	case False
	with assms(1) F_def show ?thesis
	using hom_restrict0_freeword_funlift GroupHom.supp suppI_contra[of x T]
	suppI_contra[of x F]
	by fastforce
	qed
	qed

	theorem FreeGroup_universal_property:
	fixes f :: "'a \<Rightarrow> 'b::group_add"
	shows "\<exists>!T::'a freeword\<Rightarrow>'b. (\<forall>s\<in>S. T (Abs_freeletter s) = f s) \<and>
	GroupHom (FreeGroup S) T"
	proof (rule ex1I, rule conjI)
	show "\<forall>s\<in>S. res_freeword_funlift f S (Abs_freeletter s) = f s"
	using Abs_freeletter_in_FreeGroup_iff[of _ S] freeword_funlift_Abs_freeletter
	by auto
	show "\<And>T. (\<forall>s\<in>S. T (Abs_freeletter s) = f s) \<and>
	GroupHom (FreeGroup S) T \<Longrightarrow>
	T = restrict0 (freeword_funlift f) (FreeGroup S)"
	using uniqueness_of_restricted_lift by auto
	qed (rule hom_restrict0_freeword_funlift)


	subsubsection \<open>Group presentations\<close>

	text \<open>
	We now define a group presentation to be the quotient of a free group by the subgroup generated by
	all conjugates of a set of relators. We are most concerned with lifting functions on the letter
	set to the free group and with the associated induced homomorphisms on the quotient.
	\<close>

	paragraph \<open>A first group presentation locale and basic facts\<close>

	text \<open>
	Here we define a locale that provides a way to construct a group by providing sets of generators
	and relator words.
	\<close>

	locale GroupByPresentation =
	fixes S :: "'a set" \<comment> \<open>the set of generators\<close>
	and P :: "'a signed list set" \<comment> \<open>the set of relator words\<close>
	assumes P_S: "ps\<in>P \<Longrightarrow> fst ` set ps \<subseteq> S"
	and proper_P: "ps\<in>P \<Longrightarrow> proper_signed_list ps"
	begin

	abbreviation "P' \<equiv> Abs_freeword ` P" \<comment> \<open>the set of relators\<close>
	abbreviation "Q \<equiv> Group.normal_closure (FreeGroup S) P'"
	\<comment> \<open>the normal subgroup generated by relators inside the free group\<close>
	abbreviation "G \<equiv> Group.quotient_group (FreeGroup S) Q"

	lemmas G_UN = Group.quotient_group_UN[OF FreeGroup_Group, of S Q]

	lemma P'_FreeS: "P' \<subseteq> FreeGroup S"
	using P_S proper_P by (blast intro: FreeGroupI_transfer)

	lemma relators: "P' \<subseteq> Q"
	using FreeGroup_0_closed genby_genset_subset by fastforce

	lemmas lconjby_P'_FreeS =
	Group.set_lconjby_subset_closed[
	OF FreeGroup_Group _ P'_FreeS, OF basic_monos(1)
	]

	lemmas Q_FreeS =
	Group.genby_closed[OF FreeGroup_Group lconjby_P'_FreeS]

	lemmas Q_subgroup_FreeS =
	Group.genby_subgroup[OF FreeGroup_Group lconjby_P'_FreeS]

	lemmas normal_Q = Group.normal_closure[OF FreeGroup_Group, OF P'_FreeS]

	lemmas natural_hom =
	Group.natural_quotient_hom[
	OF FreeGroup_Group Q_subgroup_FreeS normal_Q
	]

	lemmas natural_hom_image =
	Group.natural_quotient_hom_image[OF FreeGroup_Group, of S Q]

	end (* context GroupByPresentation *)

	paragraph \<open>Functions on the quotient induced from lifted functions\<close>

	text \<open>
	A function on the generator set into a type of class @{class group_add} lifts to a unique
	homomorphism on the free group. If this lift is trivial on relators, then it factors to a
	homomorphism of the group described by the generators and relators.
	\<close>

	locale GroupByPresentationInducedFun = GroupByPresentation S P
	for S :: "'a set"
	and P :: "'a signed list set" \<comment> \<open>the set of relator words\<close>
	+ fixes f :: "'a \<Rightarrow> 'b::group_add"
	assumes lift_f_trivial_P:
	"ps\<in>P \<Longrightarrow> freeword_funlift f (Abs_freeword ps) = 0"
	begin

	abbreviation "lift_f \<equiv> freeword_funlift f"

	definition induced_hom :: "'a freeword set permutation \<Rightarrow> 'b"
	where "induced_hom \<equiv> GroupHom.quotient_hom (FreeGroup S)
	(restrict0 lift_f (FreeGroup S)) Q"
	\<comment> \<open>the @{const restrict0} operation is really only necessary to make
	@{const GroupByPresentationInducedFun.induced_hom} a @{const GroupHom}\<close>
	abbreviation "F \<equiv> induced_hom"

	lemma lift_f_trivial_P': "p\<in>P' \<Longrightarrow> lift_f p = 0"
	using lift_f_trivial_P by fast

	lemma lift_f_trivial_lconjby_P': "p\<in>P' \<Longrightarrow> lift_f (lconjby w p) = 0"
	using freeword_funlift_lconjby[of f] lift_f_trivial_P' by simp

	lemma lift_f_trivial_Q: "q\<in>Q \<Longrightarrow> lift_f q = 0"
	proof (erule genby.induct, rule freeword_funlift_0)
	show "\<And>s. s \<in> (\<Union>w \<in> FreeGroup S. lconjby w ` P') \<Longrightarrow> lift_f s = 0"
	using lift_f_trivial_lconjby_P' by fast
	next
	fix w w' :: "'a freeword" assume ww': "lift_f w = 0" "lift_f w' = 0"
	have "lift_f (w - w') = lift_f w - lift_f w'"
	using freeword_funlift_diff[of f w] by simp
	with ww' show "lift_f (w-w') = 0" by simp
	qed

	lemma lift_f_ker_Q: "Q \<subseteq> ker lift_f"
	using lift_f_trivial_Q unfolding ker_def by auto

	lemma lift_f_Ker_Q: "Q \<subseteq> GroupHom.Ker (FreeGroup S) lift_f"
	using lift_f_ker_Q Q_FreeS by fast

	lemma restrict0_lift_f_Ker_Q:
	"Q \<subseteq> GroupHom.Ker (FreeGroup S) (restrict0 lift_f (FreeGroup S))"
	using lift_f_Ker_Q ker_subset_ker_restrict0 by fast

	lemma induced_hom_equality:
	"w \<in> FreeGroup S \<Longrightarrow> F (\<lceil>FreeGroup S\|w\|Q\<rceil>) = lift_f w"
	\<comment> \<open>algebraic properties of the induced homomorphism could be proved using its properties as a group
	homomorphism, but it's generally easier to prove them using the algebraic properties of the lift
	via this lemma\<close>
	unfolding induced_hom_def
	using GroupHom.quotient_hom_im hom_restrict0_freeword_funlift
	Q_subgroup_FreeS normal_Q restrict0_lift_f_Ker_Q
	by fastforce

	lemma hom_induced_hom: "GroupHom G F"
	unfolding induced_hom_def
	using GroupHom.quotient_hom hom_restrict0_freeword_funlift
	Q_subgroup_FreeS normal_Q restrict0_lift_f_Ker_Q
	by fast

	lemma induced_hom_Abs_freeletter_equality:
	"s\<in>S \<Longrightarrow> F (\<lceil>FreeGroup S\|Abs_freeletter s\|Q\<rceil>) = f s"
	using Abs_freeletter_in_FreeGroup_iff[of s S]
	by (simp add: induced_hom_equality freeword_funlift_Abs_freeletter)

	lemma uniqueness_of_induced_hom':
	defines "q \<equiv> Group.natural_quotient_hom (FreeGroup S) Q"
	assumes "GroupHom G T" "\<forall>s\<in>S. T (\<lceil>FreeGroup S\|Abs_freeletter s\|Q\<rceil>) = f s"
	shows "T \<circ> q = F \<circ> q"
	proof-
	from assms have "T\<circ>q = res_freeword_funlift f S"
	using natural_hom natural_hom_image Abs_freeletter_in_FreeGroup_iff[of _ S]
	by (force intro: uniqueness_of_restricted_lift GroupHom.comp)
	moreover from q_def have "F \<circ> q = res_freeword_funlift f S"
	using induced_hom_equality GroupHom.im_zero[OF hom_induced_hom]
	by auto
	ultimately show ?thesis by simp
	qed

	lemma uniqueness_of_induced_hom:
	assumes "GroupHom G T" "\<forall>s\<in>S. T (\<lceil>FreeGroup S\|Abs_freeletter s\|Q\<rceil>) = f s"
	shows "T = F"
	proof
	fix x
	show "T x = F x"
	proof (cases "x\<in>G")
	case True
	define q where "q \<equiv> Group.natural_quotient_hom (FreeGroup S) Q"
	from True obtain w where "w \<in> FreeGroup S" "x = (\<lceil>FreeGroup S\|w\|Q\<rceil>)"
	using G_UN by fast
	with q_def have "T x = (T\<circ>q) w" "F x = (F\<circ>q) w" by auto
	with assms q_def show ?thesis using uniqueness_of_induced_hom' by simp
	next
	case False
	with assms(1) show ?thesis
	using hom_induced_hom GroupHom.supp suppI_contra[of x T]
	suppI_contra[of x F]
	by fastforce
	qed
	qed

	theorem induced_hom_universal_property:
	"\<exists>!F. GroupHom G F \<and> (\<forall>s\<in>S. F (\<lceil>FreeGroup S\|Abs_freeletter s\|Q\<rceil>) = f s)"
	using hom_induced_hom induced_hom_Abs_freeletter_equality
	uniqueness_of_induced_hom
	by blast

	lemma induced_hom_Abs_freelist_conv_sum_list:
	"ss\<in>lists S \<Longrightarrow> F (\<lceil>FreeGroup S\|Abs_freelist ss\|Q\<rceil>) = (\<Sum>s\<leftarrow>ss. f s)"
	by (simp add:
	Abs_freelist_in_FreeGroup induced_hom_equality freeword_funlift_Abs_freelist
	)

	lemma induced_hom_surj: "F`G = \<langle>f`S\<rangle>"
	proof (rule seteqI)
	show "\<And>x. x\<in>F`G \<Longrightarrow> x\<in>\<langle>f`S\<rangle>"
	using G_UN induced_hom_equality freeword_funlift_surj[of f S] by auto
	next
	fix x assume "x\<in>\<langle>f`S\<rangle>"
	hence "x \<in> lift_f ` FreeGroup S" using freeword_funlift_surj[of f S] by fast
	thus "x \<in> F`G" using induced_hom_equality G_UN by force
	qed

	end (* context GroupByPresentationInducedFun *)

	paragraph \<open>Groups affording a presentation\<close>

	text \<open>
	The locale @{const GroupByPresentation} allows the construction of a @{const Group} out of any
	type from a set of generating letters and a set of relator words in (signed) letters. The
	following locale concerns the question of when the @{const Group} generated by a set in class
	@{class group_add} is isomorphic to a group presentation.
	\<close>

	locale GroupWithGeneratorsRelators =
	fixes S :: "'g::group_add set" \<comment> \<open>the set of generators\<close>
	and R :: "'g list set" \<comment> \<open>the set of relator words\<close>
	assumes relators: "rs\<in>R \<Longrightarrow> rs \<in> lists (S \<union> uminus ` S)"
	"rs\<in>R \<Longrightarrow> sum_list rs = 0"
	"rs\<in>R \<Longrightarrow> proper_signed_list (map (charpair S) rs)"
	begin

	abbreviation "P \<equiv> map (charpair S) ` R"
	abbreviation "P' \<equiv> GroupByPresentation.P' P"
	abbreviation "Q \<equiv> GroupByPresentation.Q S P"
	abbreviation "G \<equiv> GroupByPresentation.G S P"
	abbreviation "relator_freeword rs \<equiv> Abs_freeword (map (charpair S) rs)"
	\<comment> \<open>this maps R onto P'\<close>

	abbreviation "freeliftid \<equiv> freeword_funlift id"

	abbreviation induced_id :: "'g freeword set permutation \<Rightarrow> 'g"
	where "induced_id \<equiv> GroupByPresentationInducedFun.induced_hom S P id"

	lemma GroupByPresentation_S_P: "GroupByPresentation S P"
	proof
	show "\<And>ps. ps \<in> P \<Longrightarrow> fst ` set ps \<subseteq> S"
	using fst_set_map_charpair_un_uminus relators(1) by fast
	show "\<And>ps. ps \<in> P \<Longrightarrow> proper_signed_list ps" using relators(3) by fast
	qed

	lemmas G_UN = GroupByPresentation.G_UN[OF GroupByPresentation_S_P]
	lemmas P'_FreeS = GroupByPresentation.P'_FreeS[OF GroupByPresentation_S_P]

	lemma freeliftid_trivial_relator_freeword_R:
	"rs\<in>R \<Longrightarrow> freeliftid (relator_freeword rs) = 0"
	using relators(2,3) freeword_funlift_Abs_freeword[of "map (charpair S) rs" id]
	sum_list_map_cong[of rs "(apply_sign id) \<circ> (charpair S)" id]
	by simp

	lemma freeliftid_trivial_P: "ps\<in>P \<Longrightarrow> freeliftid (Abs_freeword ps) = 0"
	using freeliftid_trivial_relator_freeword_R by fast

	lemma GroupByPresentationInducedFun_S_P_id:
	"GroupByPresentationInducedFun S P id"
	by (
	intro_locales, rule GroupByPresentation_S_P,
	unfold_locales, rule freeliftid_trivial_P
	)

	lemma induced_id_Abs_freelist_conv_sum_list:
	"ss\<in>lists S \<Longrightarrow> induced_id (\<lceil>FreeGroup S\|Abs_freelist ss\|Q\<rceil>) = sum_list ss"
	by (simp add:
	GroupByPresentationInducedFun.induced_hom_Abs_freelist_conv_sum_list[
	OF GroupByPresentationInducedFun_S_P_id
	]
	)

	lemma lconj_relator_freeword_R:
	"\<lbrakk> rs\<in>R; proper_signed_list xs; fst ` set xs \<subseteq> S \<rbrakk> \<Longrightarrow>
	lconjby (Abs_freeword xs) (relator_freeword rs) \<in> Q"
	by (blast intro: genby_genset_closed FreeGroupI_transfer)

	lemma rconj_relator_freeword:
	assumes "rs\<in>R" "proper_signed_list xs" "fst ` set xs \<subseteq> S"
	shows "rconjby (Abs_freeword xs) (relator_freeword rs) \<in> Q"
	proof (rule genby_genset_closed, rule UN_I)
	show "- Abs_freeword xs \<in> FreeGroup S"
	using FreeGroupI_transfer[OF assms(2,3)] FreeGroup_uminus_closed by fast
	from assms(1)
	show "rconjby (Abs_freeword xs) (relator_freeword rs) \<in>
	lconjby (- Abs_freeword xs) ` Abs_freeword ` P"
	by simp
	qed

	lemma lconjby_Abs_freelist_relator_freeword:
	"\<lbrakk> rs\<in>R; xs\<in>lists S \<rbrakk> \<Longrightarrow> lconjby (Abs_freelist xs) (relator_freeword rs) \<in> Q"
	using proper_signed_list_map_uniform_snd by (force intro: lconj_relator_freeword_R)

	text \<open>
	Here we record that the lift of the identity map to the free group on @{term S} induces a
	homomorphic surjection onto the group generated by @{term S} from the group presentation on
	@{term S}, subject to the same relations as the elements of @{term S}.
	\<close>

	theorem induced_id_hom_surj: "GroupHom G induced_id" "induced_id ` G = \<langle>S\<rangle>"
	using GroupByPresentationInducedFun.hom_induced_hom[
	OF GroupByPresentationInducedFun_S_P_id
	]
	GroupByPresentationInducedFun.induced_hom_surj[
	OF GroupByPresentationInducedFun_S_P_id
	]
	by auto

	end (* context GroupWithGeneratorsRelators *)

	locale GroupPresentation = GroupWithGeneratorsRelators S R
	for S :: "'g::group_add set" \<comment> \<open>the set of generators\<close>
	and R :: "'g list set" \<comment> \<open>the set of relator words\<close>
	+ assumes induced_id_inj: "inj_on induced_id G"
	begin

	abbreviation "inv_induced_id \<equiv> the_inv_into G induced_id"

	lemma inv_induced_id_sum_list_S:
	"ss \<in> lists S \<Longrightarrow> inv_induced_id (sum_list ss) = (\<lceil>FreeGroup S\|Abs_freelist ss\|Q\<rceil>)"
	using G_UN induced_id_inj induced_id_Abs_freelist_conv_sum_list
	Abs_freelist_in_FreeGroup
	by (blast intro: the_inv_into_f_eq)

	end (* GroupPresentation *)

	subsection \<open>Words over a generating set\<close>

	text \<open>
	Here we gather the necessary constructions and facts for studying a group generated by some set
	in terms of words in the generators.
	\<close>

	context monoid_add
	begin

	abbreviation "word_for A a as \<equiv> as \<in> lists A \<and> sum_list as = a"

	definition reduced_word_for :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool"
	where "reduced_word_for A a as \<equiv> is_arg_min length (word_for A a) as"

	abbreviation "reduced_word A as \<equiv> reduced_word_for A (sum_list as) as"
	abbreviation "reduced_words_for A a \<equiv> Collect (reduced_word_for A a)"

	abbreviation reduced_letter_set :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a set"
	where "reduced_letter_set A a \<equiv> \<Union>( set ` (reduced_words_for A a) )"
	\<comment> \<open>will be empty if @{term a} is not in the set generated by @{term A}\<close>

	definition word_length :: "'a set \<Rightarrow> 'a \<Rightarrow> nat"
	where "word_length A a \<equiv> length (arg_min length (word_for A a))"

	lemma reduced_word_forI:
	assumes "as \<in> lists A" "sum_list as = a"
	"\<And>bs. bs \<in> lists A \<Longrightarrow> sum_list bs = a \<Longrightarrow> length as \<le> length bs"
	shows "reduced_word_for A a as"
	using assms
	unfolding reduced_word_for_def
	by (force intro: is_arg_minI)

	lemma reduced_word_forI_compare:
	"\<lbrakk> reduced_word_for A a as; bs \<in> lists A; sum_list bs = a; length bs = length as \<rbrakk>
	\<Longrightarrow> reduced_word_for A a bs"
	using reduced_word_for_def is_arg_min_eq[of length] by fast

	lemma reduced_word_for_lists: "reduced_word_for A a as \<Longrightarrow> as \<in> lists A"
	using reduced_word_for_def is_arg_minD1 by fast

	lemma reduced_word_for_sum_list: "reduced_word_for A a as \<Longrightarrow> sum_list as = a"
	using reduced_word_for_def is_arg_minD1 by fast

	lemma reduced_word_for_minimal:
	"\<lbrakk> reduced_word_for A a as; bs \<in> lists A; sum_list bs = a \<rbrakk> \<Longrightarrow>
	length as \<le> length bs"
	using reduced_word_for_def is_arg_minD2[of length]
	by fastforce

	lemma reduced_word_for_length:
	"reduced_word_for A a as \<Longrightarrow> length as = word_length A a"
	unfolding word_length_def reduced_word_for_def is_arg_min_def
	by (fastforce intro: arg_min_equality[THEN sym])

	lemma reduced_word_for_eq_length:
	"reduced_word_for A a as \<Longrightarrow> reduced_word_for A a bs \<Longrightarrow> length as = length bs"
	using reduced_word_for_length by simp

	lemma reduced_word_for_arg_min:
	"as \<in> lists A \<Longrightarrow> sum_list as = a \<Longrightarrow>
	reduced_word_for A a (arg_min length (word_for A a))"
	using is_arg_min_arg_min_nat[of "word_for A a"]
	unfolding reduced_word_for_def
	by fast

	lemma nil_reduced_word_for_0: "reduced_word_for A 0 []"
	by (auto intro: reduced_word_forI)

	lemma reduced_word_for_0_imp_nil: "reduced_word_for A 0 as \<Longrightarrow> as = []"
	using nil_reduced_word_for_0[of A] reduced_word_for_minimal[of A 0 as]
	unfolding reduced_word_for_def is_arg_min_def
	by (metis (mono_tags, opaque_lifting) length_0_conv length_greater_0_conv)

	lemma not_reduced_word_for:
	"\<lbrakk> bs \<in> lists A; sum_list bs = a; length bs < length as \<rbrakk> \<Longrightarrow>
	\<not> reduced_word_for A a as"
	using reduced_word_for_minimal by fastforce

	lemma reduced_word_for_imp_reduced_word:
	"reduced_word_for A a as \<Longrightarrow> reduced_word A as"
	unfolding reduced_word_for_def is_arg_min_def
	by (fast intro: reduced_word_forI)

	lemma sum_list_zero_nreduced:
	"as \<noteq> [] \<Longrightarrow> sum_list as = 0 \<Longrightarrow> \<not> reduced_word A as"
	using not_reduced_word_for[of "[]"] by simp

	lemma order2_nreduced: "a+a=0 \<Longrightarrow> \<not> reduced_word A [a,a]"
	using sum_list_zero_nreduced by simp

	lemma reduced_word_append_reduce_contra1:
	assumes "\<not> reduced_word A as"
	shows "\<not> reduced_word A (as@bs)"
	proof (cases "as \<in> lists A" "bs \<in> lists A" rule: two_cases)
	case both
	define cs where cs: "cs \<equiv> ARG_MIN length cs. cs \<in> lists A \<and> sum_list cs = sum_list as"
	with both(1) have "reduced_word_for A (sum_list as) cs"
	using reduced_word_for_def is_arg_min_arg_min_nat[of "word_for A (sum_list as)"]
	by auto
	with assms both show ?thesis
	using reduced_word_for_lists reduced_word_for_sum_list
	reduced_word_for_minimal[of A "sum_list as" cs as]
	reduced_word_forI_compare[of A "sum_list as" cs as]
	not_reduced_word_for[of "cs@bs" A "sum_list (as@bs)"]
	by fastforce
	next
	case one thus ?thesis using reduced_word_for_lists by fastforce
	next
	case other thus ?thesis using reduced_word_for_lists by fastforce
	next
	case neither thus ?thesis using reduced_word_for_lists by fastforce
	qed

	lemma reduced_word_append_reduce_contra2:
	assumes "\<not> reduced_word A bs"
	shows "\<not> reduced_word A (as@bs)"
	proof (cases "as \<in> lists A" "bs \<in> lists A" rule: two_cases)
	case both
	define cs where cs: "cs \<equiv> ARG_MIN length cs. cs \<in> lists A \<and> sum_list cs = sum_list bs"
	with both(2) have "reduced_word_for A (sum_list bs) cs"
	using reduced_word_for_def is_arg_min_arg_min_nat[of "word_for A (sum_list bs)" ]
	by auto
	with assms both show ?thesis
	using reduced_word_for_lists reduced_word_for_sum_list
	reduced_word_for_minimal[of A "sum_list bs" cs bs]
	reduced_word_forI_compare[of A "sum_list bs" cs bs]
	not_reduced_word_for[of "as@cs" A "sum_list (as@bs)"]
	by fastforce
	next
	case one thus ?thesis using reduced_word_for_lists by fastforce
	next
	case other thus ?thesis using reduced_word_for_lists by fastforce
	next
	case neither thus ?thesis using reduced_word_for_lists by fastforce
	qed

	lemma contains_nreduced_imp_nreduced:
	"\<not> reduced_word A bs \<Longrightarrow> \<not> reduced_word A (as@bs@cs)"
	using reduced_word_append_reduce_contra1 reduced_word_append_reduce_contra2
	by fast

	lemma contains_order2_nreduced: "a+a=0 \<Longrightarrow> \<not> reduced_word A (as@[a,a]@bs)"
	using order2_nreduced contains_nreduced_imp_nreduced by fast

	lemma reduced_word_Cons_reduce_contra:
	"\<not> reduced_word A as \<Longrightarrow> \<not> reduced_word A (a#as)"
	using reduced_word_append_reduce_contra2[of A as "[a]"] by simp

	lemma reduced_word_Cons_reduce: "reduced_word A (a#as) \<Longrightarrow> reduced_word A as"
	using reduced_word_Cons_reduce_contra by fast

	lemma reduced_word_singleton:
	assumes "a\<in>A" "a\<noteq>0"
	shows "reduced_word A [a]"
	proof (rule reduced_word_forI)
	from assms(1) show "[a] \<in> lists A" by simp
	next
	fix bs assume bs: "bs \<in> lists A" "sum_list bs = sum_list [a]"
	with assms(2) show "length [a] \<le> length bs" by (cases bs) auto
	qed simp

	lemma el_reduced:
	assumes "0 \<notin> A" "as \<in> lists A" "sum_list as \<in> A" "reduced_word A as"
	shows "length as = 1"
	proof-
	define n where n: "n \<equiv> length as"
	from assms(3) obtain a where "[a]\<in>lists A" "sum_list as = sum_list [a]" by auto
	with n assms(1,3,4) have "n\<le>1" "n>0"
	using reduced_word_for_minimal[of A _ as "[a]"] by auto
	hence "n = 1" by simp
	with n show ?thesis by fast
	qed

	lemma reduced_letter_set_0: "reduced_letter_set A 0 = {}"
	using reduced_word_for_0_imp_nil by simp

	lemma reduced_letter_set_subset: "reduced_letter_set A a \<subseteq> A"
	using reduced_word_for_lists by fast

	lemma reduced_word_forI_length:
	"\<lbrakk> as \<in> lists A; sum_list as = a; length as = word_length A a \<rbrakk> \<Longrightarrow>
	reduced_word_for A a as"
	using reduced_word_for_arg_min reduced_word_for_length
	reduced_word_forI_compare[of A a _ as]
	by fastforce

	lemma word_length_le:
	"as \<in> lists A \<Longrightarrow> sum_list as = a \<Longrightarrow> word_length A a \<le> length as"
	using reduced_word_for_arg_min reduced_word_for_length
	reduced_word_for_minimal[of A]
	by fastforce

	lemma reduced_word_forI_length':
	"\<lbrakk> as \<in> lists A; sum_list as = a; length as \<le> word_length A a \<rbrakk> \<Longrightarrow>
	reduced_word_for A a as"
	using word_length_le[of as A] reduced_word_forI_length[of as A] by fastforce

	lemma word_length_lt:
	"as \<in> lists A \<Longrightarrow> sum_list as = a \<Longrightarrow> \<not> reduced_word_for A a as \<Longrightarrow>
	word_length A a < length as"
	using reduced_word_forI_length' by fastforce

	end (* context monoid_add *)

	lemma in_genby_reduced_letter_set:
	assumes "as \<in> lists A" "sum_list as = a"
	shows "a \<in> \<langle>reduced_letter_set A a\<rangle>"
	proof-
	define xs where xs: "xs \<equiv> arg_min length (word_for A a)"
	with assms have "xs \<in> lists (reduced_letter_set A a)" "sum_list xs = a"
	using reduced_word_for_arg_min[of as A] reduced_word_for_sum_list by auto
	thus ?thesis using genby_eq_sum_lists by force
	qed

	lemma reduced_word_for_genby_arg_min:
	fixes A :: "'a::group_add set"
	defines "B \<equiv> A \<union> uminus ` A"
	assumes "a\<in>\<langle>A\<rangle>"
	shows "reduced_word_for B a (arg_min length (word_for B a))"
	using assms genby_eq_sum_lists[of A] reduced_word_for_arg_min[of _ B a]
	by auto

	lemma reduced_word_for_genby_sym_arg_min:
	assumes "uminus ` A \<subseteq> A" "a\<in>\<langle>A\<rangle>"
	shows "reduced_word_for A a (arg_min length (word_for A a))"
	proof-
	from assms(1) have "A = A \<union> uminus ` A" by auto
	with assms(2) show ?thesis
	using reduced_word_for_genby_arg_min[of a A] by simp
	qed

	lemma in_genby_imp_in_reduced_letter_set:
	fixes A :: "'a::group_add set"
	defines "B \<equiv> A \<union> uminus ` A"
	assumes "a \<in> \<langle>A\<rangle>"
	shows "a \<in> \<langle>reduced_letter_set B a\<rangle>"
	using assms genby_eq_sum_lists[of A] in_genby_reduced_letter_set[of _ B]
	by auto

	lemma in_genby_sym_imp_in_reduced_letter_set:
	"uminus ` A \<subseteq> A \<Longrightarrow> a \<in> \<langle>A\<rangle> \<Longrightarrow> a \<in> \<langle>reduced_letter_set A a\<rangle>"
	using in_genby_imp_in_reduced_letter_set by (fastforce simp add: Un_absorb2)

	end (* theory *)
	diff --git a/thys/Buildings/Coxeter.thy b/thys/Buildings/Coxeter.thy
	--- a/thys/Buildings/Coxeter.thy
	+++ b/thys/Buildings/Coxeter.thy
	@@ -1,2928 +1,2927 @@
	section \<open>Coxeter systems and complexes\<close>

	text \<open>
	A Coxeter system is a group that affords a presentation, where each generator is of order two,
	and each relator is an alternating word of even length in two generators.
	\<close>

	theory Coxeter
	imports Chamber

	begin

	subsection \<open>Coxeter-like systems\<close>

	text \<open>First we work in a group generated by elements of order two.\<close>

	subsubsection \<open>Locale definition and basic facts\<close>

	locale PreCoxeterSystem =
	fixes S :: "'w::group_add set"
	assumes genset_order2: "s\<in>S \<Longrightarrow> add_order s = 2"
	begin

	abbreviation "W \<equiv> \<langle>S\<rangle>"
	abbreviation "S_length \<equiv> word_length S"
	abbreviation "S_reduced_for \<equiv> reduced_word_for S"
	abbreviation "S_reduced \<equiv> reduced_word S"
	abbreviation "relfun \<equiv> \<lambda>s t. add_order (s+t)"

	lemma no_zero_genset: "0\<notin>S"
	proof
	assume "0\<in>S"
	moreover have "add_order (0::'w) = 1" using add_order0 by fast
	ultimately show False using genset_order2 by simp
	qed

	lemma genset_order2_add: "s\<in>S \<Longrightarrow> s + s = 0"
	using add_order[of s] by (simp add: genset_order2 nataction_2)

	lemmas genset_uminus = minus_unique[OF genset_order2_add]

	lemma relfun_S: "s\<in>S \<Longrightarrow> relfun s s = 1"
	using add_order_relator[of s] by (auto simp add: genset_order2 nataction_2)

	lemma relfun_eq1: "\<lbrakk> s\<in>S; relfun s t = 1 \<rbrakk> \<Longrightarrow> t=s"
	using add_order_add_eq1 genset_uminus by fastforce

	lemma S_relator_list: "s\<in>S \<Longrightarrow> pair_relator_list s s = [s,s]"
	using relfun_S alternating_list2 by simp

	lemma S_sym: "T \<subseteq> S \<Longrightarrow> uminus ` T \<subseteq> T"
	using genset_uminus by auto

	lemmas special_subgroup_eq_sum_list =
	genby_sym_eq_sum_lists[OF S_sym]
	lemmas genby_S_reduced_word_for_arg_min =
	reduced_word_for_genby_sym_arg_min[OF S_sym]
	lemmas in_genby_S_reduced_letter_set =
	in_genby_sym_imp_in_reduced_letter_set[OF S_sym]

	end (* context PreCoxeterSystem *)


	subsubsection \<open>Special cosets\<close>

	text \<open>
	From a Coxeter system we will eventually construct an associated chamber complex. To do so, we
	will consider the collection of special cosets: left cosets of subgroups generated by subsets of
	the generating set @{term S}. This collection forms a poset under the supset relation that, under
	a certain extra assumption, can be used to form a simplicial complex whose poset of simplices
	is isomorphic to this poset of special cosets. In the literature, groups generated by subsets of
	@{term S} are often referred to as parabolic subgroups of @{term W}, and their cosets as parabolic
	cosets, but following Garrett \cite{Garrett:Buildings} we have opted for the names special
	subgroups and special cosets.
	\<close>

	context PreCoxeterSystem
	begin

	definition special_cosets :: "'w set set"
	where "special_cosets \<equiv> (\<Union>T\<in>Pow S. (\<Union>w\<in>W. { w +o \<langle>T\<rangle> }))"
	abbreviation "\<P> \<equiv> special_cosets"

	lemma special_cosetsI: "T\<in>Pow S \<Longrightarrow> w\<in>W \<Longrightarrow> w +o \<langle>T\<rangle> \<in> \<P>"
	using special_cosets_def by auto

	lemma special_coset_singleton: "w\<in>W \<Longrightarrow> {w}\<in>\<P>"
	using special_cosetsI genby_lcoset_empty[of w] by fastforce

	lemma special_coset_nempty: "X\<in>\<P> \<Longrightarrow> X \<noteq> {}"
	using special_cosets_def genby_lcoset_refl by fastforce

	lemma special_subgroup_special_coset: "T\<in>Pow S \<Longrightarrow> \<langle>T\<rangle> \<in> \<P>"
	using genby_0_closed special_cosetsI[of T] by fastforce

	lemma special_cosets_lcoset_closed: "w\<in>W \<Longrightarrow> X\<in>\<P> \<Longrightarrow> w +o X \<in> \<P>"
	using genby_add_closed unfolding special_cosets_def
	by (fastforce simp add: set_plus_rearrange2)

	lemma special_cosets_lcoset_shift: "w\<in>W \<Longrightarrow> ((+o) w) ` \<P> = \<P>"
	using special_cosets_lcoset_closed genby_uminus_closed
	by (force simp add: set_plus_rearrange2)

	lemma special_cosets_has_bottom: "supset_has_bottom \<P>"
	proof (rule ordering.has_bottomI, rule supset_poset)
	show "W\<in>\<P>" using special_subgroup_special_coset by fast
	next
	fix X assume X: "X\<in>\<P>"
	from this obtain w T where wT: "w\<in>W" "T\<in>Pow S" "X = w +o \<langle>T\<rangle>"
	using special_cosets_def by auto
	thus "X \<subseteq> W" using genby_mono[of T] genby_lcoset_closed[of w] by auto
	qed

	lemma special_cosets_bottom: "supset_bottom \<P> = W"
	proof (rule supset_bottomI[THEN sym])
	fix X assume "X\<in>\<P>"
	from this obtain w T where "w\<in>W" "T\<in>Pow S" "X = w +o \<langle>T\<rangle>"
	using special_cosets_def by auto
	thus "X\<subseteq>W"
	using genby_mono[of T S] set_plus_mono[of "\<langle>T\<rangle>" W] genby_lcoset_el_reduce
	by force
	qed (auto simp add: special_subgroup_special_coset)

	end (* context PreCoxeterSystem *)

	subsubsection \<open>Transfer from the free group over generators\<close>

	text \<open>
	We form a set of relators and show that it and @{term S} form a
	@{const GroupWithGeneratorsRelators}. The associated quotient group @{term G} maps surjectively
	onto @{term W}. In the \<open>CoxeterSystem\<close> locale below, this correspondence will be assumed
	to be injective as well.
	\<close>

	context PreCoxeterSystem
	begin

	abbreviation R :: "'w list set" where "R \<equiv> (\<Union>s\<in>S. \<Union>t\<in>S. {pair_relator_list s t})"
	abbreviation "P \<equiv> map (charpair S) ` R"
	abbreviation "P' \<equiv> GroupWithGeneratorsRelators.P' S R"
	abbreviation "Q \<equiv> GroupWithGeneratorsRelators.Q S R"
	abbreviation "G \<equiv> GroupWithGeneratorsRelators.G S R"
	abbreviation "relator_freeword \<equiv>
	GroupWithGeneratorsRelators.relator_freeword S"
	abbreviation pair_relator_freeword :: "'w \<Rightarrow> 'w \<Rightarrow> 'w freeword"
	where "pair_relator_freeword s t \<equiv> Abs_freelist (pair_relator_list s t)"

	abbreviation "freeliftid \<equiv> freeword_funlift id"

	abbreviation induced_id :: "'w freeword set permutation \<Rightarrow> 'w"
	where "induced_id \<equiv> GroupWithGeneratorsRelators.induced_id S R"

	lemma S_relator_freeword: "s\<in>S \<Longrightarrow> pair_relator_freeword s s = s[+]s"
	by (simp add: S_relator_list Abs_freeletter_add)

	lemma map_charpair_map_pairtrue_R:
	"s\<in>S \<Longrightarrow> t\<in>S \<Longrightarrow>
	map (charpair S) (pair_relator_list s t) = map pairtrue (pair_relator_list s t)"
	using set_alternating_list map_charpair_uniform by fastforce

	lemma relator_freeword:
	"s\<in>S \<Longrightarrow> t\<in>S \<Longrightarrow>
	pair_relator_freeword s t = relator_freeword (pair_relator_list s t)"
	using set_alternating_list
	arg_cong[OF map_charpair_map_pairtrue_R, of s t Abs_freeword]
	by fastforce

	lemma relator_freewords: "Abs_freelist ` R = P'"
	using relator_freeword by force

	lemma GroupWithGeneratorsRelators_S_R: "GroupWithGeneratorsRelators S R"
	proof
	fix rs assume rs: "rs\<in>R"
	hence rs': "rs \<in> lists S" using set_alternating_list by fast
	from rs' show "rs \<in> lists (S \<union> uminus ` S)" by fast
	from rs show "sum_list rs = 0" using sum_list_pair_relator_list by fast
	from rs' show "proper_signed_list (map (charpair S) rs)"
	using proper_signed_list_map_uniform_snd
	arg_cong[of "map (charpair S) rs" "map pairtrue rs" proper_signed_list]
	by fastforce
	qed

	lemmas GroupByPresentation_S_P =
	GroupWithGeneratorsRelators.GroupByPresentation_S_P[
	OF GroupWithGeneratorsRelators_S_R
	]

	lemmas Q_FreeS = GroupByPresentation.Q_FreeS[OF GroupByPresentation_S_P]

	lemma relator_freeword_Q: "s\<in>S \<Longrightarrow> t\<in>S \<Longrightarrow> pair_relator_freeword s t \<in> Q"
	using relator_freeword
	GroupByPresentation.relators[OF GroupByPresentation_S_P]
	by fastforce

	lemmas P'_FreeS =
	GroupWithGeneratorsRelators.P'_FreeS[
	OF GroupWithGeneratorsRelators_S_R
	]

	lemmas GroupByPresentationInducedFun_S_P_id =
	GroupWithGeneratorsRelators.GroupByPresentationInducedFun_S_P_id[
	OF GroupWithGeneratorsRelators_S_R
	]

	lemma rconj_relator_freeword:
	"\<lbrakk> s\<in>S; t\<in>S; proper_signed_list xs; fst ` set xs \<subseteq> S \<rbrakk> \<Longrightarrow>
	rconjby (Abs_freeword xs) (pair_relator_freeword s t) \<in> Q"
	using GroupWithGeneratorsRelators.rconj_relator_freeword[
	OF GroupWithGeneratorsRelators_S_R
	]
	relator_freeword
	by force

	lemma lconjby_Abs_freelist_relator_freeword:
	"\<lbrakk> s\<in>S; t\<in>S; xs\<in>lists S \<rbrakk> \<Longrightarrow>
	lconjby (Abs_freelist xs) (pair_relator_freeword s t) \<in> Q"
	using GroupWithGeneratorsRelators.lconjby_Abs_freelist_relator_freeword[
	OF GroupWithGeneratorsRelators_S_R
	]
	relator_freeword
	by force

	lemma Abs_freelist_rev_append_alternating_list_in_Q:
	assumes "s\<in>S" "t\<in>S"
	shows "Abs_freelist (rev (alternating_list n s t) @ alternating_list n s t) \<in> Q"
	proof (induct n)
	case (Suc m)
	define u where "u = (if even m then s else t)"
	define x where "x = Abs_freelist (rev (alternating_list m s t) @ alternating_list m s t)"
	from u_def x_def assms have
	"Abs_freelist (rev (alternating_list (Suc m) s t) @
	alternating_list (Suc m) s t) =
	(pair_relator_freeword u u) + rconjby (Abs_freeletter u) x"
	using Abs_freelist_append[of
	"u # rev (alternating_list m s t) @ alternating_list m s t"
	"[u]"
	]
	Abs_freelist_Cons[of
	u
	"rev (alternating_list m s t) @ alternating_list m s t"
	]
	by (simp add: add.assoc[THEN sym] S_relator_freeword)
	moreover from Suc assms u_def x_def have "rconjby (Abs_freeletter u) x \<in> Q"
	using Abs_freeletter_in_FreeGroup_iff[of _ S]
	FreeGroup_genby_set_lconjby_set_rconjby_closed
	by fastforce
	ultimately show ?case
	using u_def assms relator_freeword_Q genby_add_closed by fastforce
	qed (simp add: zero_freeword.abs_eq[THEN sym] genby_0_closed)

	lemma Abs_freeword_freelist_uminus_add_in_Q:
	"proper_signed_list xs \<Longrightarrow> fst ` set xs \<subseteq> S \<Longrightarrow>
	- Abs_freelistfst xs + Abs_freeword xs \<in> Q"
	proof (induct xs)
	case (Cons x xs)
	from Cons(2) have 1:
	"- Abs_freelistfst (x#xs) + Abs_freeword (x#xs) =
	-Abs_freelistfst xs + -Abs_freeletter (fst x)
	+ Abs_freeword [x] + Abs_freeword xs"
	using Abs_freelist_Cons[of "fst x" "map fst xs"]
	by (simp add: Abs_freeword_Cons[THEN sym] add.assoc minus_add)
	show ?case
	proof (cases "snd x")
	case True
	with Cons show ?thesis
	using 1
	by (simp add:
	Abs_freeletter_prod_conv_Abs_freeword
	binrelchain_Cons_reduce
	)
	next
	case False
	define s where "s = fst x"
	with Cons(3) have s_S: "s\<in>S" by simp
	define q where "q = rconjby (Abs_freelistfst xs) (pair_relator_freeword s s)"
	from s_def False Cons(3) have
	"- Abs_freelistfst (x#xs) + Abs_freeword (x#xs) =
	-Abs_freelistfst xs + -pair_relator_freeword s s + Abs_freeword xs"
	using 1 surjective_pairing[of x] S_relator_freeword[of s]
	uminus_Abs_freeword_singleton[of s False, THEN sym]
	by (simp add: add.assoc)
	with q_def have 2:
	"- Abs_freelistfst (x#xs) + Abs_freeword (x#xs) =
	-q + (-Abs_freelistfst xs + Abs_freeword xs)"
	by (simp add: rconjby_uminus[THEN sym] add.assoc[THEN sym])
	moreover from q_def s_def Cons(3) have "-q\<in>Q"
	using proper_signed_list_map_uniform_snd[of True "map fst xs"]
	rconj_relator_freeword genby_uminus_closed
	by fastforce
	moreover from Cons have "-Abs_freelistfst xs + Abs_freeword xs \<in> Q"
	by (simp add: binrelchain_Cons_reduce)
	ultimately show ?thesis using genby_add_closed by simp
	qed
	qed (simp add: zero_freeword.abs_eq[THEN sym] genby_0_closed)

	lemma Q_freelist_freeword':
	"\<lbrakk> proper_signed_list xs; fst ` set xs \<subseteq> S; Abs_freelistfst xs \<in> Q \<rbrakk> \<Longrightarrow>
	Abs_freeword xs \<in> Q"
	using Abs_freeword_freelist_uminus_add_in_Q genby_add_closed
	by fastforce

	lemma Q_freelist_freeword:
	"c \<in> FreeGroup S \<Longrightarrow> Abs_freelist (map fst (freeword c)) \<in> Q \<Longrightarrow> c \<in> Q"
	using freeword FreeGroupD Q_freelist_freeword' freeword_inverse[of c]
	by fastforce

	text \<open>
	Here we show that the lift of the identity map to the free group on @{term S} is really just
	summation.
	\<close>

	lemma freeliftid_Abs_freeword_conv_sum_list:
	"proper_signed_list xs \<Longrightarrow> fst ` set xs \<subseteq> S \<Longrightarrow>
	freeliftid (Abs_freeword xs) = sum_list (map fst xs)"
	using freeword_funlift_Abs_freeword[of xs id] genset_uminus
	sum_list_map_cong[of xs "apply_sign id" fst]
	by fastforce

	end (* context PreCoxeterSystem *)


	subsubsection \<open>Words in generators containing alternating subwords\<close>

	text \<open>
	Besides cancelling subwords equal to relators, the primary algebraic manipulation in seeking to
	reduce a word in generators in a Coxeter system is to reverse the order of alternating subwords
	of half the length of the associated relator, in order to create adjacent repeated letters that
	can be cancelled. Here we detail the mechanics of such manipulations.
	\<close>

	context PreCoxeterSystem
	begin

	lemma sum_list_pair_relator_halflist_flip:
	"s\<in>S \<Longrightarrow> t\<in>S \<Longrightarrow>
	sum_list (pair_relator_halflist s t) = sum_list (pair_relator_halflist t s)"
	using add_order[of "s+t"] genset_order2_add
	alternating_order2_even_cancel_right[of s t "2*(relfun s t)"]
	by (simp add: alternating_sum_list_conv_nataction add_order_add_sym)

	definition flip_altsublist_adjacent :: "'w list \<Rightarrow> 'w list \<Rightarrow> bool"
	where "flip_altsublist_adjacent ss ts
	\<equiv> \<exists>s t as bs. ss = as @ (pair_relator_halflist s t) @ bs \<and>
	ts = as @ (pair_relator_halflist t s) @ bs"
	abbreviation "flip_altsublist_chain \<equiv> binrelchain flip_altsublist_adjacent"

	lemma flip_altsublist_adjacentI:
	"ss = as @ (pair_relator_halflist s t) @ bs \<Longrightarrow>
	ts = as @ (pair_relator_halflist t s) @ bs \<Longrightarrow>
	flip_altsublist_adjacent ss ts"
	using flip_altsublist_adjacent_def by fast

	lemma flip_altsublist_adjacent_Cons_grow:
	assumes "flip_altsublist_adjacent ss ts"
	shows "flip_altsublist_adjacent (a#ss) (a#ts)"
	proof-
	from assms obtain s t as bs
	where ssts: "ss = as @ (pair_relator_halflist s t) @ bs"
	"ts = as @ (pair_relator_halflist t s) @ bs"
	using flip_altsublist_adjacent_def
	by auto
	from ssts have
	"a#ss = (a#as) @ (pair_relator_halflist s t) @ bs"
	"a#ts = (a#as) @ (pair_relator_halflist t s) @ bs"
	by auto
	thus ?thesis by (fast intro: flip_altsublist_adjacentI)
	qed

	lemma flip_altsublist_chain_map_Cons_grow:
	"flip_altsublist_chain tss \<Longrightarrow> flip_altsublist_chain (map ((#) t) tss)"
	by (induct tss rule: list_induct_CCons)
	(auto simp add:
	binrelchain_Cons_reduce[of flip_altsublist_adjacent]
	flip_altsublist_adjacent_Cons_grow
	)

	lemma flip_altsublist_adjacent_refl:
	"ss \<noteq> [] \<Longrightarrow> ss\<in>lists S \<Longrightarrow> flip_altsublist_adjacent ss ss"
	proof (induct ss rule: list_nonempty_induct)
	case (single s)
	hence "[s] = [] @ pair_relator_halflist s s @ []"
	using relfun_S by simp
	thus ?case by (fast intro: flip_altsublist_adjacentI)
	next
	case cons thus ?case using flip_altsublist_adjacent_Cons_grow by simp
	qed

	lemma flip_altsublist_adjacent_sym:
	"flip_altsublist_adjacent ss ts \<Longrightarrow> flip_altsublist_adjacent ts ss"
	using flip_altsublist_adjacent_def flip_altsublist_adjacentI by auto

	lemma rev_flip_altsublist_chain:
	"flip_altsublist_chain xss \<Longrightarrow> flip_altsublist_chain (rev xss)"
	using flip_altsublist_adjacent_sym binrelchain_snoc[of flip_altsublist_adjacent]
	by (induct xss rule: list_induct_CCons) auto

	lemma flip_altsublist_adjacent_set:
	assumes "ss\<in>lists S" "flip_altsublist_adjacent ss ts"
	shows "set ts = set ss"
	proof-
	from assms obtain s t as bs where ssts:
	"ss = as @ (pair_relator_halflist s t) @ bs"
	"ts = as @ (pair_relator_halflist t s) @ bs"
	using flip_altsublist_adjacent_def
	by auto
	with assms(1) show ?thesis
	using set_alternating_list2[of "relfun s t" s t]
	set_alternating_list2[of "relfun t s" t s]
	add_order_add_sym[of t s] relfun_eq1
	by (cases "relfun s t" rule: nat_cases_2Suc) auto
	qed

	lemma flip_altsublist_adjacent_set_ball:
	"\<forall>ss\<in>lists S. \<forall>ts. flip_altsublist_adjacent ss ts \<longrightarrow> set ts = set ss"
	using flip_altsublist_adjacent_set by fast

	lemma flip_altsublist_adjacent_lists:
	"ss \<in> lists S \<Longrightarrow> flip_altsublist_adjacent ss ts \<Longrightarrow> ts \<in> lists S"
	using flip_altsublist_adjacent_set by fast

	lemma flip_altsublist_adjacent_lists_ball:
	"\<forall>ss\<in>lists S. \<forall>ts. flip_altsublist_adjacent ss ts \<longrightarrow> ts \<in> lists S"
	using flip_altsublist_adjacent_lists by fast

	lemma flip_altsublist_chain_lists:
	"ss \<in> lists S \<Longrightarrow> flip_altsublist_chain (ss#xss@[ts]) \<Longrightarrow> ts \<in> lists S"
	using flip_altsublist_adjacent_lists
	binrelchain_propcong_Cons_snoc[of
	"\<lambda>ss. ss\<in>lists S" flip_altsublist_adjacent ss xss ts
	]
	by fast

	lemmas flip_altsublist_chain_funcong_Cons_snoc =
	binrelchain_setfuncong_Cons_snoc[OF flip_altsublist_adjacent_lists_ball]

	lemmas flip_altsublist_chain_set =
	flip_altsublist_chain_funcong_Cons_snoc[
	OF flip_altsublist_adjacent_set_ball
	]

	lemma flip_altsublist_adjacent_length:
	"flip_altsublist_adjacent ss ts \<Longrightarrow> length ts = length ss"
	unfolding flip_altsublist_adjacent_def
	by (auto simp add: add_order_add_sym length_alternating_list)

	lemmas flip_altsublist_chain_length =
	binrelchain_funcong_Cons_snoc[
	of flip_altsublist_adjacent length, OF flip_altsublist_adjacent_length, simplified
	]

	lemma flip_altsublist_adjacent_sum_list:
	assumes "ss \<in> lists S" "flip_altsublist_adjacent ss ts"
	shows "sum_list ts = sum_list ss"
	proof-
	from assms(2) obtain s t as bs where stasbs:
	"ss = as @ (pair_relator_halflist s t) @ bs"
	"ts = as @ (pair_relator_halflist t s) @ bs"
	using flip_altsublist_adjacent_def
	by auto
	show ?thesis
	proof (cases "relfun s t")
	case 0 thus ?thesis using stasbs by (simp add: add_order_add_sym)
	next
	case Suc
	with assms stasbs have "s\<in>S" "t\<in>S"
	using set_alternating_list1[of "add_order (s+t)" s t]
	set_alternating_list1[of "add_order (t+s)" t s]
	add_order_add_sym[of t]
	flip_altsublist_adjacent_lists[of ss ts]
	by auto
	with stasbs show ?thesis
	using sum_list_pair_relator_halflist_flip by simp
	qed
	qed

	lemma flip_altsublist_adjacent_sum_list_ball:
	"\<forall>ss\<in>lists S. \<forall>ts. flip_altsublist_adjacent ss ts \<longrightarrow> sum_list ts = sum_list ss"
	using flip_altsublist_adjacent_sum_list by fast

	lemma S_reduced_forI_flip_altsublist_adjacent:
	"S_reduced_for w ss \<Longrightarrow> flip_altsublist_adjacent ss ts \<Longrightarrow> S_reduced_for w ts"
	using reduced_word_for_lists[of S] reduced_word_for_sum_list
	flip_altsublist_adjacent_lists flip_altsublist_adjacent_sum_list
	flip_altsublist_adjacent_length
	by (fastforce intro: reduced_word_forI_compare)

	lemma flip_altsublist_adjacent_in_Q':
	fixes as bs s t
	defines xs: "xs \<equiv> as @ pair_relator_halflist s t @ bs"
	and ys: "ys \<equiv> as @ pair_relator_halflist t s @ bs"
	assumes Axs: "Abs_freelist xs \<in> Q"
	shows "Abs_freelist ys \<in> Q"
	proof-
	define X Y A B half_st half2_st half_ts
	where "X = Abs_freelist xs"
	and "Y = Abs_freelist ys"
	and "A = Abs_freelist as"
	and "B = Abs_freelist bs"
	and "half_st = Abs_freelist (pair_relator_halflist s t)"
	and "half2_st = Abs_freelist (pair_relator_halflist2 s t)"
	and "half_ts = Abs_freelist (pair_relator_halflist t s)"
	define z where "z = -half2_st + B"
	define w1 w2 where "w1 = rconjby z (pair_relator_freeword s t)"
	and "w2 = Abs_freelist (rev (pair_relator_halflist t s) @ pair_relator_halflist t s)"
	define w3 where "w3 = rconjby B w2"

	from w1_def z_def
	have w1': "w1 = rconjby B (lconjby half2_st (pair_relator_freeword s t))"
	by (simp add: rconjby_add)
	hence "-w1 = rconjby B (lconjby half2_st (-pair_relator_freeword s t))"
	using lconjby_uminus[of "half2_st"] by (simp add: rconjby_uminus[THEN sym])
	moreover from X_def xs A_def half_st_def B_def have "X = A + B + rconjby B half_st"
	by (simp add:
	Abs_freelist_append_append[THEN sym] add.assoc[THEN sym]
	)
	ultimately have
	"X + -w1 = A + B +
	( rconjby B (half_st + (half2_st + -pair_relator_freeword s t - half2_st)) )"
	by (simp add: add.assoc add_rconjby)
	moreover from w2_def half2_st_def half_ts_def have "w2 = half2_st + half_ts"
	by (simp add:
	Abs_freelist_append[THEN sym]
	pair_relator_halflist2_conv_rev_pair_relator_halflist
	)
	ultimately have
	"X + -w1 + w3 = A + B + (rconjby B (-half2_st + (half2_st + half_ts)))"
	using half_st_def half2_st_def w3_def add_assoc4[
	of half_st half2_st "-pair_relator_freeword s t" "-half2_st"
	]
	by (simp add:
	Abs_freelist_append[THEN sym] pair_relator_halflist_append
	add.assoc add_rconjby
	)
	hence Y': "Y = X - w1 + w3"
	using A_def half_ts_def B_def ys Y_def
	by (simp add:
	add.assoc[THEN sym]
	Abs_freelist_append_append[THEN sym]
	)

	from Axs have xs_S: "xs \<in> lists S" using Q_FreeS FreeGroupD_transfer' by fast
	have "w1\<in>Q \<and> w3\<in>Q"
	proof (cases "relfun s t")
	case 0 with w1_def w2_def w3_def show ?thesis using genby_0_closed
	by (auto simp add:
	zero_freeword.abs_eq[THEN sym]
	add_order_add_sym
	)
	next
	case (Suc m) have m: "add_order (s+t) = Suc m" by fact
	have st: "{s,t} \<subseteq> S"
	proof (cases m)
	case 0 with m xs xs_S show ?thesis
	using set_alternating_list1 relfun_eq1 by force
	next
	case Suc with m xs xs_S show ?thesis
	using set_alternating_list2[of "add_order (s+t)" s t] by fastforce
	qed
	from xs xs_S B_def have B_S: "B \<in> FreeGroup S"
	using Abs_freelist_in_FreeGroup[of bs S] by simp
	moreover from w2_def have "w2\<in>Q"
	using st Abs_freelist_rev_append_alternating_list_in_Q[of t s "add_order (t+s)"]
	by fast
	ultimately have "w3 \<in> Q"
	using w3_def FreeGroup_genby_set_lconjby_set_rconjby_closed by fast
	moreover from half2_st_def have "w1 \<in> Q"
	using w1' st B_S alternating_list_in_lists[of s S] alternating_list_in_lists[of t S]
	lconjby_Abs_freelist_relator_freeword[of s t]
	by (force intro: FreeGroup_genby_set_lconjby_set_rconjby_closed)
	ultimately show ?thesis by fast
	qed
	with X_def Y_def Axs show ?thesis
	using Y' genby_diff_closed[of X] genby_add_closed[of "X-w1" _ w3] by simp

	qed

	lemma flip_altsublist_adjacent_in_Q:
	"Abs_freelist ss \<in> Q \<Longrightarrow> flip_altsublist_adjacent ss ts \<Longrightarrow> Abs_freelist ts \<in> Q"
	using flip_altsublist_adjacent_def flip_altsublist_adjacent_in_Q' by auto

	lemma flip_altsublist_chain_G_in_Q:
	"\<lbrakk> Abs_freelist ss \<in> Q; flip_altsublist_chain (ss#xss@[ts]) \<rbrakk> \<Longrightarrow> Abs_freelist ts \<in> Q"
	using flip_altsublist_adjacent_in_Q
	binrelchain_propcong_Cons_snoc[of
	"\<lambda>ss. Abs_freelist ss \<in> Q"
	flip_altsublist_adjacent
	]
	by fast

	lemma alternating_S_no_flip:
	assumes "s\<in>S" "t\<in>S" "n > 0" "n < relfun s t \<or> relfun s t = 0"
	shows "sum_list (alternating_list n s t) \<noteq> sum_list (alternating_list n t s)"
	proof
	assume "sum_list (alternating_list n s t) = sum_list (alternating_list n t s)"
	hence "sum_list (alternating_list n s t) + - sum_list (alternating_list n t s) = 0"
	by simp
	with assms(1,2) have "sum_list (alternating_list (2*n) s t) = 0"
	by (cases "even n")
	(auto simp add:
	genset_order2_add uminus_sum_list_alternating_order2
	sum_list.append[THEN sym]
	alternating_list_append mult_2
	)
	with assms(3,4) less_add_order_eq_0_contra add_order_eq0 show False
	by (auto simp add: alternating_sum_list_conv_nataction)
	qed

	lemma exchange_alternating_not_in_alternating:
	assumes "n \<ge> 2" "n < relfun s t \<or> relfun s t = 0"
	"S_reduced_for w (alternating_list n s t @ cs)"
	"alternating_list n s t @ cs = xs@[x]@ys" "S_reduced_for w (t#xs@ys)"
	shows "length xs \<ge> n"
	proof-
	from assms(1) obtain m k where n: "n = Suc m" and m: "m = Suc k"
	using gr0_implies_Suc by fastforce
	define altnst altnts altmts altkst
	where "altnst = alternating_list n s t"
	and "altnts = alternating_list n t s"
	and "altmts = alternating_list m t s"
	and "altkst = alternating_list k s t"
	from altnst_def altmts_def n have altnmst: "altnst = s # altmts"
	using alternating_list_Suc_Cons[of m] by fastforce
	with assms(3) altnst_def have s_S: "s\<in>S" using reduced_word_for_lists by fastforce
	from assms(5) have t_S: "t\<in>S" using reduced_word_for_lists by fastforce
	from m altnmst altmts_def altkst_def have altnkst: "altnst = s # t # altkst"
	using alternating_list_Suc_Cons by fastforce
	have "\<not> length xs < n"
	proof (cases "Suc (length xs) = n")
	case True
	with assms(4,5) n altnts_def have flip: "S_reduced_for w (altnts @ cs)"
	using length_alternating_list[of n s t]
	- same_length_eq_append[of altnts "xs@[x]" cs ys]
	alternating_list_Suc_Cons[of m t s]
	by auto
	from altnst_def have "sum_list altnst = sum_list altnts"
	using reduced_word_for_sum_list[OF assms(3)]
	reduced_word_for_sum_list[OF flip]
	by auto
	with n assms(2) altnst_def altnts_def show ?thesis
	using alternating_S_no_flip[OF s_S t_S] by fast
	next
	case False show ?thesis
	proof (cases xs ys rule: two_lists_cases_snoc_Cons)
	case Nil1
	from Nil1(1) assms(4) altnkst altnst_def have "ys = t # altkst @ cs" by auto
	with Nil1(1) assms(5) show ?thesis
	using t_S genset_order2_add[of t]
	contains_order2_nreduced[of t S "[]" "altkst@cs"]
	reduced_word_for_imp_reduced_word
	by force
	next
	case Nil2 with assms(4) altnst_def False show ?thesis
	using length_append[of altnst cs]
	by (fastforce simp add: length_alternating_list)
	next
	case (snoc_Cons us u z zs)
	with assms(4,5) altnst_def
	have 1: "altnst @ cs = us@[u,x,z]@zs" "S_reduced_for w (t#us@[u,z]@zs)"
	by auto
	from 1(1) snoc_Cons(1) False altnst_def show ?thesis
	using take_append[of n altnst cs] take_append[of n "us@[u,x,z]" zs]
	set_alternating_list[of n s t]
	alternating_list_alternates[of n s t us u]
	reduced_word_for_imp_reduced_word[OF 1(2)]
	s_S t_S genset_order2_add
	contains_order2_nreduced[of u S "t#us"]
	by (force simp add: length_alternating_list)
	qed
	qed
	thus ?thesis by fastforce
	qed

	end (* context PreCoxeterSystem *)

	subsubsection \<open>Preliminary facts on the word problem\<close>

	text \<open>
	The word problem seeks criteria for determining whether two words over the generator set represent
	the same element in @{term W}. Here we establish one direction of the word problem, as well as a
	preliminary step toward the other direction.
	\<close>

	context PreCoxeterSystem
	begin

	lemmas flip_altsublist_chain_sum_list =
	flip_altsublist_chain_funcong_Cons_snoc[OF flip_altsublist_adjacent_sum_list_ball]
	\<comment> \<open>This lemma represents one direction in the word problem: if a word in generators can be
	transformed into another by a sequence of manipulations, each of which consists of replacing a
	half-relator subword by its reversal, then the two words sum to the same element of @{term W}.\<close>

	lemma reduced_word_problem_eq_hd_step:
	assumes step: "\<And>y ss ts. \<lbrakk>
	S_length y < S_length w; y\<noteq>0; S_reduced_for y ss; S_reduced_for y ts
	\<rbrakk> \<Longrightarrow> \<exists>xss. flip_altsublist_chain (ss # xss @ [ts])"
	and set_up: "S_reduced_for w (a#ss)" "S_reduced_for w (a#ts)"
	shows "\<exists>xss. flip_altsublist_chain ((a#ss) # xss @ [a#ts])"
	proof (cases "ss=ts")
	case True
	with set_up(1) have "flip_altsublist_chain ((a#ss) # [] @ [a#ts])"
	using reduced_word_for_lists flip_altsublist_adjacent_refl by fastforce
	thus ?thesis by fast
	next
	case False
	define y where "y = sum_list ss"
	with set_up(1) have ss: "S_reduced_for y ss"
	using reduced_word_for_imp_reduced_word reduced_word_Cons_reduce by fast
	moreover from y_def ss have ts: "S_reduced_for y ts"
	using reduced_word_for_sum_list[OF set_up(1)]
	reduced_word_for_sum_list[OF set_up(2)]
	reduced_word_for_eq_length[OF set_up(1) set_up(2)]
	reduced_word_for_lists[OF set_up(2)]
	by (auto intro: reduced_word_forI_compare)
	moreover from ss set_up(1) have "S_length y < S_length w"
	using reduced_word_for_length reduced_word_for_length by fastforce
	moreover from False have "y \<noteq> 0"
	using ss ts reduced_word_for_0_imp_nil reduced_word_for_0_imp_nil by fastforce
	ultimately show ?thesis
	using step flip_altsublist_chain_map_Cons_grow by fastforce
	qed

	end (* context PreCoxeterSystem *)

	subsubsection \<open>Preliminary facts related to the deletion condition\<close>

	text \<open>
	The deletion condition states that in a Coxeter system, every non-reduced word in the generating
	set can be shortened to an equivalent word by deleting some particular pair of letters. This
	condition is both necessary and sufficient for a group generated by elements of order two to be a
	Coxeter system. Here we establish some facts related to the deletion condition that are true in
	any group generated by elements of order two.
	\<close>

	context PreCoxeterSystem
	begin

	abbreviation "\<H> \<equiv> (\<Union>w\<in>W. lconjby w ` S)" \<comment> \<open>the set of reflections\<close>

	abbreviation "lift_signed_lconjperm \<equiv> freeword_funlift signed_lconjpermutation"

	lemma lconjseq_reflections: "ss\<in>lists S \<Longrightarrow> set (lconjseq ss) \<subseteq> \<H>"
	using special_subgroup_eq_sum_list[of S]
	by (induct ss rule: rev_induct) (auto simp add: lconjseq_snoc)

	lemma deletion':
	"ss \<in> lists S \<Longrightarrow> \<not> distinct (lconjseq ss) \<Longrightarrow>
	\<exists>a b as bs cs. ss = as @ [a] @ bs @ [b] @ cs \<and>
	sum_list ss = sum_list (as@bs@cs)"
	proof (induct ss)
	case (Cons s ss)
	show ?case
	proof (cases "distinct (lconjseq ss)")
	case True with Cons(2,3) show ?thesis
	using subset_inj_on[OF lconjby_inj, of "set (lconjseq ss)" s]
	distinct_map[of "lconjby s"]
	genset_order2_add order2_hd_in_lconjseq_deletion[of s ss]
	by (force simp add: algebra_simps)
	next
	case False
	with Cons(1,2) obtain a b as bs cs where
	"s#ss = (s#as) @ [a] @ bs @ [b] @ cs"
	"sum_list (s#ss) = sum_list ((s#as) @ bs @ cs)"
	by auto
	thus ?thesis by fast
	qed
	qed simp

	lemma S_reduced_imp_distinct_lconjseq':
	assumes "ss \<in> lists S" "\<not> distinct (lconjseq ss)"
	shows "\<not> S_reduced ss"
	proof
	assume ss: "S_reduced ss"
	from assms obtain as a bs b cs
	where decomp: "ss = as @ [a] @ bs @ [b] @ cs"
	"sum_list ss = sum_list (as@bs@cs)"
	using deletion'[of ss]
	by fast
	from ss decomp assms(1) show False
	using reduced_word_for_minimal[of S _ ss "as@bs@cs"] by auto
	qed

	lemma S_reduced_imp_distinct_lconjseq: "S_reduced ss \<Longrightarrow> distinct (lconjseq ss)"
	using reduced_word_for_lists S_reduced_imp_distinct_lconjseq' by fast

	lemma permutation_lift_signed_lconjperm_eq_signed_list_lconjaction':
	"proper_signed_list xs \<Longrightarrow> fst ` set xs \<subseteq> S \<Longrightarrow>
	permutation (lift_signed_lconjperm (Abs_freeword xs)) =
	signed_list_lconjaction (map fst xs)"
	proof (induct xs)
	case Nil
	have "Abs_freeword ([]::'w signed list) = (0::'w freeword)"
	using zero_freeword.abs_eq by simp
	thus ?case by (simp add: zero_permutation.rep_eq freeword_funlift_0)
	next
	case (Cons x xs)
	obtain s b where x: "x=(s,b)" by fastforce
	with Cons show ?case
	using Abs_freeword_Cons[of x xs]
	binrelchain_Cons_reduce[of nflipped_signed x xs]
	bij_signed_lconjaction[of s] genset_order2_add[of s]
	by (cases b)
	(auto simp add:
	plus_permutation.rep_eq freeword_funlift_add
	freeword_funlift_Abs_freeletter
	Abs_permutation_inverse uminus_permutation.rep_eq
	the_inv_signed_lconjaction_by_order2
	freeword_funlift_uminus_Abs_freeletter
	)
	qed

	lemma permutation_lift_signed_lconjperm_eq_signed_list_lconjaction:
	"x \<in> FreeGroup S \<Longrightarrow>
	permutation (lift_signed_lconjperm x) =
	signed_list_lconjaction (map fst (freeword x))"
	using freeword FreeGroup_def[of S] freeword_inverse[of x]
	permutation_lift_signed_lconjperm_eq_signed_list_lconjaction'
	by force

	lemma even_count_lconjseq_rev_relator:
	"s\<in>S \<Longrightarrow> t\<in>S \<Longrightarrow> even (count_list (lconjseq (rev (pair_relator_list s t))) x)"
	using even_count_lconjseq_alternating_order2[of t]
	by (simp add: genset_order2_add add_order rev_pair_relator_list)

	lemma GroupByPresentationInducedFun_S_R_signed_lconjaction:
	"GroupByPresentationInducedFun S P signed_lconjpermutation"
	proof (intro_locales, rule GroupByPresentation_S_P, unfold_locales)
	fix ps assume ps: "ps\<in>P"
	define r where "r = Abs_freeword ps"
	with ps have r: "r\<in>P'" by fast
	then obtain s t where st: "s\<in>S" "t\<in>S" "r = pair_relator_freeword s t"
	using relator_freewords by fast
	from r st(3)
	have 1: "permutation (lift_signed_lconjperm r) =
	signed_list_lconjaction (pair_relator_list s t)"
	using P'_FreeS
	permutation_lift_signed_lconjperm_eq_signed_list_lconjaction
	Abs_freelist_inverse[of "pair_relator_list s t"]
	map_fst_map_const_snd[of True "pair_relator_list s t"]
	by force
	have "permutation (lift_signed_lconjperm r) = id"
	proof
	fix x
	show "lift_signed_lconjperm r \<rightarrow> x = id x"
	proof
	show "snd (freeword_funlift signed_lconjpermutation r \<rightarrow> x) = snd (id x)"
	using 1 st(1,2) even_count_lconjseq_rev_relator genset_order2_add
	set_alternating_list[of "2*relfun s t" s t]
	signed_list_lconjaction_snd[of "pair_relator_list s t" x]
	by fastforce
	qed (simp add: 1 signed_list_lconjaction_fst sum_list_pair_relator_list)
	qed
	moreover
	have "permutation (0::'w signed permutation) = (id::'w signed \<Rightarrow> 'w signed)"
	using zero_permutation.rep_eq
	by fast
	ultimately show "lift_signed_lconjperm r = 0"
	using permutation_inject by fastforce
	qed

	end (* context PreCoxeterSystem *)


	subsection \<open>Coxeter-like systems with deletion\<close>

	text \<open>
	Here we add the so-called deletion condition as an assumption, and explore its consequences.
	\<close>

	subsubsection \<open>Locale definition\<close>

	locale PreCoxeterSystemWithDeletion = PreCoxeterSystem S
	for S :: "'w::group_add set"
	+ assumes deletion:
	"ss \<in> lists S \<Longrightarrow> \<not> reduced_word S ss \<Longrightarrow>
	\<exists>a b as bs cs. ss = as @ [a] @ bs @ [b] @ cs \<and>
	sum_list ss = sum_list (as@bs@cs)"

	subsubsection \<open>Consequences of the deletion condition\<close>

	context PreCoxeterSystemWithDeletion
	begin

	lemma deletion_reduce:
	"ss \<in> lists S \<Longrightarrow> \<exists>ts. ts \<in> ssubseqs ss \<inter> reduced_words_for S (sum_list ss)"
	proof (cases "S_reduced ss")
	case True
	thus "ss \<in> lists S \<Longrightarrow>
	\<exists>ts. ts \<in> ssubseqs ss \<inter> reduced_words_for S (sum_list ss)"
	by (force simp add: ssubseqs_refl)
	next
	case False
	have "ss \<in> lists S \<Longrightarrow> \<not> S_reduced ss \<Longrightarrow>
	\<exists>ts. ts \<in> ssubseqs ss \<inter> reduced_words_for S (sum_list ss)"
	proof (induct ss rule: length_induct)
	fix xs::"'w list"
	assume xs:
	"\<forall>ys. length ys < length xs \<longrightarrow> ys \<in> lists S \<longrightarrow> \<not> S_reduced ys
	\<longrightarrow> (\<exists>ts. ts \<in> ssubseqs ys \<inter> reduced_words_for S (sum_list ys))"
	"xs \<in> lists S" "\<not> S_reduced xs"
	from xs(2,3) obtain as a bs b cs
	where asbscs: "xs = as@[a]@bs@[b]@cs" "sum_list xs = sum_list (as@bs@cs)"
	using deletion[of xs]
	by fast
	show "\<exists>ts. ts \<in> ssubseqs xs \<inter> reduced_words_for S (sum_list xs)"
	proof (cases "S_reduced (as@bs@cs)")
	case True with asbscs xs(2) show ?thesis
	using delete2_ssubseqs by fastforce
	next
	case False
	moreover from asbscs(1) xs(2)
	have "length (as@bs@cs) < length xs" "as@bs@cs \<in> lists S"
	by auto
	ultimately obtain ts
	where ts: "ts \<in> ssubseqs (as@bs@cs) \<inter>
	reduced_words_for S (sum_list (as@bs@cs))"
	using xs(1,2) asbscs(1)
	by fast
	with asbscs show ?thesis
	using delete2_ssubseqs[of as bs cs a b] ssubseqs_subset by auto
	qed
	qed
	with False
	show "ss \<in> lists S \<Longrightarrow>
	\<exists>ts. ts \<in> ssubseqs ss \<inter> reduced_words_for S (sum_list ss)"
	by fast
	qed

	lemma deletion_reduce':
	"ss \<in> lists S \<Longrightarrow> \<exists>ts\<in>reduced_words_for S (sum_list ss). set ts \<subseteq> set ss"
	using deletion_reduce[of ss] subseqs_powset[of ss] by auto

	end (* context PreCoxeterSystemWithDeletion *)

	subsubsection \<open>The exchange condition\<close>

	text \<open>
	The exchange condition states that, given a reduced word in the generators, if prepending a
	letter to the word does not remain reduced, then the new word can be shortened to a word
	equivalent to the original one by deleting some letter other than the prepended one. Thus, one
	able to exchange some letter for the addition of a desired letter at the beginning of a word,
	without changing the elemented represented.
	\<close>

	context PreCoxeterSystemWithDeletion
	begin

	lemma exchange:
	assumes "s\<in>S" "S_reduced_for w ss" "\<not> S_reduced (s#ss)"
	shows "\<exists>t as bs. ss = as@t#bs \<and> reduced_word_for S w (s#as@bs)"
	proof-
	from assms(2) have ss_lists: "ss \<in> lists S" using reduced_word_for_lists by fast
	with assms(1) have "s#ss \<in> lists S" by simp
	with assms(3) obtain a b as bs cs
	where del: "s#ss = as @ [a] @ bs @ [b] @ cs"
	"sum_list (s#ss) = sum_list (as@bs@cs)"
	using deletion[of "s#ss"]
	by fastforce
	show ?thesis
	proof (cases as)
	case Nil with assms(1,2) del show ?thesis
	using reduced_word_for_sum_list add.assoc[of s s w] genset_order2_add ss_lists
	by (fastforce intro: reduced_word_forI_compare)
	next
	case (Cons d ds) with del assms(2) show ?thesis
	using ss_lists reduced_word_for_imp_reduced_word
	reduced_word_for_minimal[of S "sum_list ss" ss "ds@bs@cs"]
	by fastforce
	qed
	qed

	lemma reduced_head_imp_exchange:
	assumes "reduced_word_for S w (s#as)" "reduced_word_for S w cs"
	shows "\<exists>a ds es. cs = ds@[a]@es \<and> reduced_word_for S w (s#ds@es)"
	proof-
	from assms(1) have s_S: "s\<in>S" using reduced_word_for_lists by fastforce
	moreover have "\<not> S_reduced (s#cs)"
	proof (rule not_reduced_word_for)
	show "as \<in> lists S" using reduced_word_for_lists[OF assms(1)] by simp
	from assms(1,2) show "sum_list as = sum_list (s#cs)"
	using s_S reduced_word_for_sum_list[of S w] add.assoc[of s s] genset_order2_add
	by fastforce
	from assms(1,2) show "length as < length (s#cs)"
	using reduced_word_for_length[of S w] by fastforce
	qed
	ultimately obtain a ds es
	where "cs = ds@[a]@es" "reduced_word_for S w (s#ds@es)"
	using assms(2) exchange[of s w cs]
	by auto
	thus ?thesis by fast
	qed

	end (* context PreCoxeterSystemWithDeletion *)

	subsubsection \<open>More on words in generators containing alternating subwords\<close>

	text \<open>
	Here we explore more of the mechanics of manipulating words over @{term S} that contain
	alternating subwords, in preparation of the word problem.
	\<close>

	context PreCoxeterSystemWithDeletion
	begin

	lemma two_reduced_heads_imp_reduced_alt_step:
	assumes "s\<noteq>t" "reduced_word_for S w (t#bs)" "n < relfun s t \<or> relfun s t = 0"
	"reduced_word_for S w (alternating_list n s t @ cs)"
	shows "\<exists>ds. reduced_word_for S w (alternating_list (Suc n) t s @ ds)"
	proof-
	define altnst where "altnst = alternating_list n s t"
	with assms(2,4) obtain x xs ys
	where xxsys: "altnst @ cs = xs@[x]@ys" "reduced_word_for S w (t#xs@ys)"
	using reduced_head_imp_exchange
	by fast
	show ?thesis
	proof (cases n rule: nat_cases_2Suc)
	case 0 with xxsys(2) show ?thesis by auto
	next
	case 1 with assms(1,4) xxsys altnst_def show ?thesis
	using reduced_word_for_sum_list[of S w "s#cs"]
	reduced_word_for_sum_list[of S w "t#cs"]
	by (cases xs) auto
	next
	case (SucSuc k)
	with assms(3,4) xxsys altnst_def have "length xs \<ge> n"
	using exchange_alternating_not_in_alternating by simp
	moreover define ds where "ds = take (length xs - n) cs"
	ultimately have "t#xs@ys = alternating_list (Suc n) t s @ ds @ ys"
	using xxsys(1) altnst_def take_append[of "length xs" altnst cs]
	alternating_list_Suc_Cons[of n t]
	by (fastforce simp add: length_alternating_list)
	with xxsys(2) show ?thesis by auto
	qed
	qed

	lemma two_reduced_heads_imp_reduced_alt':
	assumes "s\<noteq>t" "reduced_word_for S w (s#as)" "reduced_word_for S w (t#bs)"
	shows "n \<le> relfun s t \<or> relfun s t = 0 \<Longrightarrow> (\<exists>cs.
	reduced_word_for S w (alternating_list n s t @ cs) \<or>
	reduced_word_for S w (alternating_list n t s @ cs)
	)"
	proof (induct n)
	case 0 from assms(2) show ?case by auto
	next
	case (Suc m) thus ?case
	using add_order_add_sym[of s t]
	two_reduced_heads_imp_reduced_alt_step[
	OF assms(1)[THEN not_sym] assms(2), of m
	]
	two_reduced_heads_imp_reduced_alt_step[OF assms(1,3), of m]
	by fastforce
	qed

	lemma two_reduced_heads_imp_reduced_alt:
	assumes "s\<noteq>t" "reduced_word_for S w (s#as)" "reduced_word_for S w (t#bs)"
	shows "\<exists>cs. reduced_word_for S w (pair_relator_halflist s t @ cs)"
	proof-
	define altst altts
	where "altst = pair_relator_halflist s t"
	and "altts = pair_relator_halflist t s"
	then obtain cs
	where cs: "reduced_word_for S w (altst @ cs) \<or>
	reduced_word_for S w (altts @ cs)"
	using add_order_add_sym[of t] two_reduced_heads_imp_reduced_alt'[OF assms]
	by auto
	moreover from altst_def altts_def
	have "reduced_word_for S w (altts @ cs) \<Longrightarrow> reduced_word_for S w (altst @ cs)"
	using reduced_word_for_lists[OF assms(2)] reduced_word_for_lists[OF assms(3)]
	flip_altsublist_adjacent_def
	by (force intro: S_reduced_forI_flip_altsublist_adjacent
	simp add: add_order_add_sym)
	ultimately show "\<exists>cs. reduced_word_for S w (altst @ cs)" by fast
	qed

	lemma two_reduced_heads_imp_nzero_relfun:
	assumes "s\<noteq>t" "reduced_word_for S w (s#as)" "reduced_word_for S w (t#bs)"
	shows "relfun s t \<noteq> 0"
	proof
	assume 1: "relfun s t = 0"
	define altst altts
	where "altst = alternating_list (Suc (S_length w)) s t"
	and "altts = alternating_list (Suc (S_length w)) t s"
	with 1 obtain cs
	where "reduced_word_for S w (altst @ cs) \<or>
	reduced_word_for S w (altts @ cs)"
	using two_reduced_heads_imp_reduced_alt'[OF assms]
	by fast
	moreover from altst_def altts_def
	have "length (altst @ cs) > S_length w"
	"length (altts @ cs) > S_length w"
	using length_alternating_list[of _ s] length_alternating_list[of _ t]
	by auto
	ultimately show False using reduced_word_for_length by fastforce
	qed

	end (* context PreCoxeterSystemWithDeletion *)

	subsubsection \<open>The word problem\<close>

	text \<open>Here we establish the other direction of the word problem for reduced words.\<close>

	context PreCoxeterSystemWithDeletion
	begin

	lemma reduced_word_problem_ConsCons_step:
	assumes "\<And>y ss ts. \<lbrakk> S_length y < S_length w; y\<noteq>0; reduced_word_for S y ss;
	reduced_word_for S y ts \<rbrakk> \<Longrightarrow> \<exists>xss. flip_altsublist_chain (ss # xss @ [ts])"
	"reduced_word_for S w (a#as)" "reduced_word_for S w (b#bs)" "a\<noteq>b"
	shows "\<exists>xss. flip_altsublist_chain ((a#as)#xss@[b#bs])"
	proof-
	from assms(2-4) obtain cs
	where cs: "reduced_word_for S w (pair_relator_halflist a b @ cs)"
	using two_reduced_heads_imp_reduced_alt
	by fast
	define rs us where "rs = pair_relator_halflist a b @ cs"
	and "us = pair_relator_halflist b a @ cs"
	from assms(2,3) have a_S: "a\<in>S" and b_S: "b\<in>S"
	using reduced_word_for_lists[of S _ "a#as"] reduced_word_for_lists[of S _ "b#bs"]
	by auto
	with rs_def us_def have midlink: "flip_altsublist_adjacent rs us"
	using add_order_add_sym[of b a] flip_altsublist_adjacent_def by fastforce
	from assms(2-4) have "relfun a b \<noteq> 0"
	using two_reduced_heads_imp_nzero_relfun by fast
	from this obtain k where k: "relfun a b = Suc k"
	using not0_implies_Suc by auto
	define qs vs
	where "qs = alternating_list k b a @ cs"
	and "vs = alternating_list k a b @ cs"
	with k rs_def us_def have rs': "rs = a # qs" and us': "us = b # vs"
	using add_order_add_sym[of b a] alternating_list_Suc_Cons[of k] by auto
	from assms(1,2) cs rs_def rs'
	have startlink: "as \<noteq> qs \<Longrightarrow> \<exists>xss. flip_altsublist_chain ((a#as) # xss @ [rs])"
	using reduced_word_problem_eq_hd_step
	by fastforce
	from assms(1,3) rs_def cs us'
	have endlink: "bs \<noteq> vs \<Longrightarrow> \<exists>xss. flip_altsublist_chain (us # xss @ [b#bs])"
	using midlink flip_altsublist_adjacent_sym
	S_reduced_forI_flip_altsublist_adjacent[of w rs]
	reduced_word_problem_eq_hd_step[of w]
	by auto
	show ?thesis
	proof (cases "as = qs" "bs = vs" rule: two_cases)
	case both
	with rs' us' have "flip_altsublist_chain ((a#as) # [] @ [b#bs])"
	using midlink by simp
	thus ?thesis by fast
	next
	case one
	with rs' obtain xss
	where "flip_altsublist_chain ((a#as) # (us # xss) @ [b#bs])"
	using endlink midlink
	by auto
	thus ?thesis by fast
	next
	case other
	from other(1) obtain xss where "flip_altsublist_chain ((a#as) # xss @ [rs])"
	using startlink by fast
	with other(2) us' startlink
	have "flip_altsublist_chain ((a#as) # (xss@[rs]) @ [b#bs])"
	using midlink binrelchain_snoc[of flip_altsublist_adjacent "(a#as)#xss"]
	by simp
	thus ?thesis by fast
	next
	case neither
	from neither(1) obtain xss
	where "flip_altsublist_chain ((a#as) # xss @ [rs])"
	using startlink
	by fast
	with neither(2) obtain yss
	where "flip_altsublist_chain ((a#as) # (xss @ [rs,us] @ yss) @ [b#bs])"
	using startlink midlink endlink
	binrelchain_join[of flip_altsublist_adjacent "(a#as)#xss"]
	by auto
	thus ?thesis by fast
	qed
	qed

	lemma reduced_word_problem:
	"\<lbrakk> w\<noteq>0; reduced_word_for S w ss; reduced_word_for S w ts \<rbrakk> \<Longrightarrow>
	\<exists>xss. flip_altsublist_chain (ss#xss@[ts])"
	proof (induct w arbitrary: ss ts rule: measure_induct_rule[of "S_length"])
	case (less w)
	show ?case
	proof (cases ss ts rule: two_lists_cases_Cons_Cons)
	case Nil1 from Nil1(1) less(2,3) show ?thesis
	using reduced_word_for_sum_list by fastforce
	next
	case Nil2 from Nil2(2) less(2,4) show ?thesis
	using reduced_word_for_sum_list by fastforce
	next
	case (ConsCons a as b bs)
	show ?thesis
	proof (cases "a=b")
	case True with less ConsCons show ?thesis
	using reduced_word_problem_eq_hd_step[of w] by auto
	next
	case False with less ConsCons show ?thesis
	using reduced_word_problem_ConsCons_step[of w] by simp
	qed
	qed
	qed

	lemma reduced_word_letter_set:
	assumes "S_reduced_for w ss"
	shows "reduced_letter_set S w = set ss"
	proof (cases "w=0")
	case True with assms show ?thesis
	using reduced_word_for_0_imp_nil[of S ss] reduced_letter_set_0 by simp
	next
	case False
	show ?thesis
	proof
	from assms show "set ss \<subseteq> reduced_letter_set S w" by fast
	show "reduced_letter_set S w \<subseteq> set ss"
	proof
	fix x assume "x \<in> reduced_letter_set S w"
	from this obtain ts where "reduced_word_for S w ts" "x \<in> set ts" by fast
	with False assms show "x \<in> set ss"
	using reduced_word_for_lists[of S _ ss] reduced_word_problem[of w ss]
	flip_altsublist_chain_set
	by force
	qed
	qed
	qed

	end (* context PreCoxeterSystemWithDeletion *)

	subsubsection \<open>Special subgroups and cosets\<close>

	text \<open>
	Recall that special subgroups are those generated by subsets of the generating set @{term S}.
	Here we show that the presence of the deletion condition guarantees that the collection of
	special subgroups and their left cosets forms a poset under reverse inclusion that satisfies the
	necessary properties to ensure that the poset of simplices in the associated simplicial complex
	is isomorphic to this poset of special cosets.
	\<close>

	context PreCoxeterSystemWithDeletion
	begin

	lemma special_subgroup_int_S:
	assumes "T \<in> Pow S"
	shows "\<langle>T\<rangle> \<inter> S = T"
	proof
	show "\<langle>T\<rangle> \<inter> S \<subseteq> T"
	proof
	fix t assume t: "t \<in> \<langle>T\<rangle> \<inter> S"
	with assms obtain ts where ts: "ts \<in> lists T" "t = sum_list ts"
	using special_subgroup_eq_sum_list[of T] by fast
	with assms obtain us
	where us: "reduced_word_for S (sum_list ts) us" "set us \<subseteq> set ts"
	using deletion_reduce'[of ts]
	by auto
	with no_zero_genset ts(2) t have "length us = 1"
	using reduced_word_for_lists[of S _ us] reduced_word_for_sum_list[of S _ us]
	reduced_word_for_imp_reduced_word[of S _ us] el_reduced[of S]
	by auto
	with us ts show "t\<in>T"
	using reduced_word_for_sum_list[of S _ us] by (cases us) auto
	qed
	from assms show "T \<subseteq> \<langle>T\<rangle> \<inter> S" using genby_genset_subset by fast
	qed

	lemma special_subgroup_inj: "inj_on genby (Pow S)"
	using special_subgroup_int_S inj_on_inverseI[of _ "\<lambda>W. W\<inter>S"] by fastforce

	lemma special_subgroup_genby_subset_ordering_iso:
	"subset_ordering_iso (Pow S) genby"
	proof (unfold_locales, rule genby_mono, simp, rule special_subgroup_inj)
	fix X Y assume XY: "X \<in> genby ` Pow S" "Y \<in> genby ` Pow S" "X\<subseteq>Y"
	from XY(1,2) obtain TX TY
	where "TX\<in>Pow S" "X = \<langle>TX\<rangle>" "TY\<in>Pow S" "Y = \<langle>TY\<rangle>"
	by auto
	hence "the_inv_into (Pow S) genby X = X\<inter>S"
	"the_inv_into (Pow S) genby Y = Y\<inter>S"
	using the_inv_into_f_f[OF special_subgroup_inj] special_subgroup_int_S
	by auto
	with XY(3)
	show "the_inv_into (Pow S) genby X \<subseteq> the_inv_into (Pow S) genby Y"
	by auto
	qed

	lemmas special_subgroup_genby_rev_mono
	= OrderingSetIso.rev_ordsetmap[OF special_subgroup_genby_subset_ordering_iso]

	lemma special_subgroup_word_length:
	assumes "T\<in>Pow S" "w\<in>\<langle>T\<rangle>"
	shows "word_length T w = S_length w"
	proof-
	from assms obtain ts where ts: "ts \<in> lists T" "w = sum_list ts"
	using special_subgroup_eq_sum_list by auto
	with assms(1) obtain us where "us \<in> ssubseqs ts" "S_reduced_for w us"
	using deletion_reduce[of ts] by fast
	with assms(1) ts(1) show ?thesis
	using ssubseqs_lists[of ts] reduced_word_for_sum_list
	is_arg_min_size_subprop[of length "word_for S w" us "word_for T w"]
	unfolding reduced_word_for_def word_length_def
	by fast
	qed

	lemma S_subset_reduced_imp_S_reduced:
	"T\<in>Pow S \<Longrightarrow> reduced_word T ts \<Longrightarrow> S_reduced ts"
	using reduced_word_for_lists reduced_word_for_lists[of T _ ts]
	reduced_word_for_length[of T "sum_list ts" ts] special_subgroup_eq_sum_list[of T]
	special_subgroup_word_length[of T "sum_list ts"]
	by (fastforce intro: reduced_word_forI_length)

	lemma smallest_genby: "T\<in>Pow S \<Longrightarrow> w\<in>\<langle>T\<rangle> \<Longrightarrow> reduced_letter_set S w \<subseteq> T"
	using genby_S_reduced_word_for_arg_min[of T]
	reduced_word_for_imp_reduced_word[of T w]
	S_subset_reduced_imp_S_reduced[of T "arg_min length (word_for T w)"]
	reduced_word_for_sum_list[of T] reduced_word_for_lists reduced_word_letter_set
	by fastforce

	lemma special_cosets_below_in:
	assumes "w\<in>W" "T \<in> Pow S"
	shows "\<P>.\<supseteq>(w +o \<langle>T\<rangle>) = (\<Union>R\<in>(Pow S).\<supseteq>T. {w +o \<langle>R\<rangle>})"
	proof (rule seteqI)
	fix A assume "A \<in> \<P>.\<supseteq>(w +o \<langle>T\<rangle>)"
	hence A: "A\<in>\<P>" "A \<supseteq> (w +o \<langle>T\<rangle>)" by auto
	from A(1) obtain R w' where "R\<in>Pow S" "A = w' +o \<langle>R\<rangle>"
	using special_cosets_def by auto
	with A(2) assms(2) show "A \<in> (\<Union>R\<in>(Pow S).\<supseteq>T. {w +o \<langle>R\<rangle>})"
	using genby_lcoset_subgroup_imp_eq_reps[of w T w' R]
	lcoset_eq_reps_subset[of w "\<langle>T\<rangle>"]
	special_subgroup_genby_rev_mono[of T R]
	by auto
	next
	fix B assume "B \<in> (\<Union>R\<in>(Pow S).\<supseteq>T. {w +o \<langle>R\<rangle>})"
	from this obtain R where R: " R \<in> (Pow S).\<supseteq>T" "B = w +o \<langle>R\<rangle>" by auto
	moreover hence "B \<supseteq> w +o \<langle>T\<rangle>"
	using genby_mono elt_set_plus_def[of w] by auto
	ultimately show "B \<in> special_cosets .\<supseteq> (w +o \<langle>T\<rangle>)"
	using assms(1) special_cosetsI by auto
	qed

	lemmas special_coset_inj
	= comp_inj_on[OF special_subgroup_inj, OF inj_inj_on, OF lcoset_inj_on]

	lemma special_coset_eq_imp_eq_gensets:
	"\<lbrakk> T1\<in>Pow S; T2\<in>Pow S; w1 +o \<langle>T1\<rangle> = w2 +o \<langle>T2\<rangle> \<rbrakk> \<Longrightarrow> T1=T2"
	using set_plus_rearrange2[of "-w1" w1 "\<langle>T1\<rangle>"]
	set_plus_rearrange2[of "-w1" w2 "\<langle>T2\<rangle>"]
	genby_lcoset_subgroup_imp_eq_reps[of 0 T1 "-w1+w2" T2]
	inj_onD[OF special_subgroup_inj]
	by force

	lemma special_subgroup_special_coset_subset_ordering_iso:
	"subset_ordering_iso (genby ` Pow S) ((+o) w)"
	proof
	show "\<And>a b. a \<subseteq> b \<Longrightarrow> w +o a \<subseteq> w +o b" using elt_set_plus_def by auto
	show 2: "inj_on ((+o) w) (genby ` Pow S)"
	using lcoset_inj_on inj_inj_on by fast
	show "\<And>a b. a \<in> (+o) w ` genby ` Pow S \<Longrightarrow>
	b \<in> (+o) w ` genby ` Pow S \<Longrightarrow>
	a \<subseteq> b \<Longrightarrow>
	the_inv_into (genby ` Pow S) ((+o) w) a \<subseteq>
	the_inv_into (genby ` Pow S) ((+o) w) b"
	proof-
	fix a b
	assume ab : "a \<in> (+o) w ` genby ` Pow S" "b \<in> (+o) w ` genby ` Pow S"
	and a_b: "a\<subseteq>b"
	from ab obtain Ta Tb
	where "Ta\<in>Pow S" "a = w +o \<langle>Ta\<rangle>" "Tb\<in>Pow S" "b = w +o \<langle>Tb\<rangle>"
	by auto
	with a_b
	show "the_inv_into (genby ` Pow S) ((+o) w) a \<subseteq>
	the_inv_into (genby ` Pow S) ((+o) w) b"
	using the_inv_into_f_eq[OF 2] lcoset_eq_reps_subset[of w "\<langle>Ta\<rangle>" "\<langle>Tb\<rangle>"]
	by simp
	qed
	qed

	lemma special_coset_subset_ordering_iso:
	"subset_ordering_iso (Pow S) ((+o) w \<circ> genby)"
	using special_subgroup_genby_subset_ordering_iso
	special_subgroup_special_coset_subset_ordering_iso
	by (fast intro: OrderingSetIso.iso_comp)

	lemmas special_coset_subset_rev_mono =
	OrderingSetIso.rev_ordsetmap[OF special_coset_subset_ordering_iso]

	lemma special_coset_below_in_subset_ordering_iso:
	"subset_ordering_iso ((Pow S).\<supseteq>T) ((+o) w \<circ> genby)"
	using special_coset_subset_ordering_iso by (auto intro: OrderingSetIso.iso_subset)

	lemma special_coset_below_in_supset_ordering_iso:
	"OrderingSetIso (\<supseteq>) (\<supset>) (\<supseteq>) (\<supset>) ((Pow S).\<supseteq>T) ((+o) w \<circ> genby)"
	using special_coset_below_in_subset_ordering_iso OrderingSetIso.iso_dual by fast

	lemma special_coset_pseudominimals:
	assumes "supset_pseudominimal_in \<P> X"
	shows "\<exists>w s. w\<in>W \<and> s\<in>S \<and> X = w +o \<langle>S-{s}\<rangle>"
	proof-
	from assms have "X\<in>\<P>" using supset_pseudominimal_inD1 by fast
	from this obtain w T where wT: "w\<in>W" "T\<in>Pow S" "X = w +o \<langle>T\<rangle>"
	using special_cosets_def by auto
	show ?thesis
	proof (cases "T=S")
	case True with wT(1,3) assms show ?thesis
	using genby_lcoset_el_reduce supset_pseudominimal_ne_bottom
	special_cosets_bottom
	by fast
	next
	case False
	with wT(2) obtain s where s: "s\<in>S" "T \<subseteq> S-{s}" by fast
	from s(2) wT(1,3) assms have "X \<subseteq> w +o \<langle>S-{s}\<rangle>"
	using genby_mono by auto
	moreover from assms wT(1) s(1) have "\<not> X \<subset> w +o \<langle>S-{s}\<rangle>"
	using special_cosetsI[of _ w]
	supset_pseudominimal_inD2[of \<P> X "w +o \<langle>S-{s}\<rangle>"]
	lcoset_eq_reps[of w _ "\<langle>S\<rangle>"]
	inj_onD[OF special_subgroup_inj, of "S-{s}" S]
	by (auto simp add: special_cosets_bottom genby_lcoset_el_reduce)
	ultimately show ?thesis using wT(1) s(1) by fast
	qed
	qed

	lemma special_coset_pseudominimal_in_below_in:
	assumes "w\<in>W" "T\<in>Pow S" "supset_pseudominimal_in (\<P>.\<supseteq>(w +o \<langle>T\<rangle>)) X"
	shows "\<exists>s\<in>S-T. X = w +o \<langle>S-{s}\<rangle>"
	proof-
	from assms obtain v s where vs: "v\<in>W" "s\<in>S" "X = v +o \<langle>S-{s}\<rangle>"
	using special_cosets_has_bottom special_cosetsI[of T w]
	supset_has_bottom_pseudominimal_in_below_in
	special_coset_pseudominimals
	by force
	from assms(3) have X: "X \<supseteq> w +o \<langle>T\<rangle>"
	using supset_pseudominimal_inD1 by fast
	with vs(3) have 1: "X = w +o \<langle>S-{s}\<rangle>"
	using genby_lcoset_subgroup_imp_eq_reps[of w T v "S-{s}"] by fast
	with X assms have "T \<subseteq> S-{s}"
	using special_cosetsI special_coset_subset_rev_mono[of T "S-{s}"]
	by fastforce
	with vs(2) show ?thesis using 1 by fast
	qed

	lemma exclude_one_is_pseudominimal:
	assumes "w\<in>W" "t\<in>S"
	shows "supset_pseudominimal_in \<P> (w +o \<langle>S-{t}\<rangle>)"
	proof (rule supset_pseudominimal_inI, rule special_cosetsI)
	show "w \<in> W" by fact
	from assms have "w +o \<langle>S - {t}\<rangle> \<noteq> W"
	using genby_lcoset_el_reduce[of w] lcoset_eq_reps[of w _ W]
	inj_onD[OF special_subgroup_inj, of "S-{t}" S]
	by auto
	thus "w +o \<langle>S - {t}\<rangle> \<noteq> supset_bottom \<P>"
	using special_cosets_bottom by fast
	next
	fix X assume X: "X\<in>\<P>" "w +o \<langle>S - {t}\<rangle> \<subset> X"
	with assms(1) have "X \<in> (\<Union>R\<in>(Pow S).\<supseteq>(S-{t}). {w +o \<langle>R\<rangle>})"
	using subst[OF special_cosets_below_in, of w "S-{t}" "\<lambda>A. X\<in>A"] by fast
	from this obtain R where R: "R \<in> (Pow S).\<supseteq>(S-{t})" "X = w +o \<langle>R\<rangle>" by auto
	from R(2) X(2) have "R \<noteq> S-{t}" by fast
	with R(1) have "R=S" by auto
	with assms(1) R(2) show "X = supset_bottom \<P>"
	using genby_lcoset_el_reduce special_cosets_bottom by fast
	qed fast

	lemma exclude_one_is_pseudominimal_in_below_in:
	"\<lbrakk> w\<in>W; T\<in>Pow S; s\<in>S-T \<rbrakk> \<Longrightarrow>
	supset_pseudominimal_in (\<P>.\<supseteq>(w +o \<langle>T\<rangle>)) (w +o \<langle>S-{s}\<rangle>)"
	using special_cosets_has_bottom special_cosetsI
	exclude_one_is_pseudominimal[of w s]
	genby_mono[of T "S-{s}"]
	supset_has_bottom_pseudominimal_in_below_inI[
	of \<P> "w +o \<langle>T\<rangle>" "w +o \<langle>S-{s}\<rangle>"
	]
	by auto

	lemma glb_special_subset_coset:
	assumes wTT': "w\<in> W" "T \<in> Pow S" "T' \<in> Pow S"
	defines U: "U \<equiv> T \<union> T' \<union> reduced_letter_set S w"
	shows "supset_glbound_in_of \<P> \<langle>T\<rangle> (w +o \<langle>T'\<rangle>) \<langle>U\<rangle>"
	proof (rule supset_glbound_in_ofI)

	from wTT'(2,3) U show "\<langle>U\<rangle> \<in> \<P>"
	using reduced_letter_set_subset[of S] special_subgroup_special_coset by simp

	show "supset_lbound_of \<langle>T\<rangle> (w +o \<langle>T'\<rangle>) \<langle>U\<rangle>"
	proof (rule supset_lbound_ofI)
	from U show "\<langle>T\<rangle> \<subseteq> \<langle>U\<rangle>" using genby_mono[of T U] by fast
	show "w +o \<langle>T'\<rangle> \<subseteq> \<langle>U\<rangle>"
	proof
	fix x assume "x \<in> w +o \<langle>T'\<rangle>"
	with wTT'(3) obtain y where y: "y \<in> \<langle>T'\<rangle>" "x = w + y"
	using elt_set_plus_def[of w] by auto
	with wTT'(1) U show "x \<in> \<langle>U\<rangle>"
	using in_genby_S_reduced_letter_set genby_mono[of _ U]
	genby_mono[of T' U] genby_add_closed[of w U y]
	by auto
	qed
	qed

	next

	fix X assume X: "X\<in>\<P>" "supset_lbound_of \<langle>T\<rangle> (w +o \<langle>T'\<rangle>) X"
	from X(1) obtain v R where vR: "R\<in>Pow S" "X = v +o \<langle>R\<rangle>"
	using special_cosets_def by auto
	from X(2) have X': "X \<supseteq> \<langle>T\<rangle>" "X \<supseteq> w +o \<langle>T'\<rangle>"
	using supset_lbound_of_def[of _ _ X] by auto
	from X'(1) vR(2) have R: "X = \<langle>R\<rangle>"
	using genby_0_closed genby_lcoset_el_reduce0 by fast
	with X'(2) have w: "w\<in>\<langle>R\<rangle>" using genby_0_closed lcoset_refl by fast
	have "T' \<subseteq> R"
	proof (
	rule special_subgroup_genby_rev_mono, rule wTT'(3), rule vR(1), rule subsetI
	)
	fix x assume "x \<in> \<langle>T'\<rangle>"
	with X'(2) R show "x \<in> \<langle>R\<rangle>"
	using elt_set_plus_def[of w "\<langle>T'\<rangle>"] w genby_uminus_add_closed[of "w" R "w+x"]
	by auto
	qed
	with X'(1) wTT'(2) vR(1) show "\<langle>U\<rangle>\<subseteq>X"
	using special_subgroup_genby_rev_mono[of T R] w smallest_genby U R
	genby_mono[of _ R]
	by simp

	qed

	lemma glb_special_subset_coset_ex:
	assumes "w\<in> W" "T \<in> Pow S" "T' \<in> Pow S"
	shows "\<exists>B. supset_glbound_in_of \<P> \<langle>T\<rangle> (w +o \<langle>T'\<rangle>) B"
	using glb_special_subset_coset[OF assms]
	by fast

	lemma special_cosets_have_glbs:
	assumes "X\<in>\<P>" "Y\<in>\<P>"
	shows "\<exists>B. supset_glbound_in_of \<P> X Y B"
	proof-
	from assms obtain wx Tx wy Ty
	where X: "wx \<in> W" "Tx \<in> Pow S" "X = wx +o \<langle>Tx\<rangle>"
	and Y: "wy \<in> W" "Ty \<in> Pow S" "Y = wy +o \<langle>Ty\<rangle>"
	using special_cosets_def
	by auto
	from X(1,2) Y(1,2) obtain A
	where A: "supset_glbound_in_of \<P> \<langle>Tx\<rangle> ((-wx+wy) +o \<langle>Ty\<rangle>) A"
	using genby_uminus_add_closed[of wx] glb_special_subset_coset_ex by fastforce
	from X(1,3) Y(3) have "supset_glbound_in_of \<P> X Y (wx +o A)"
	using supset_glbound_in_of_lcoset_shift[OF A, of wx]
	by (auto simp add: set_plus_rearrange2 special_cosets_lcoset_shift)
	thus ?thesis by fast
	qed

	end (* context PreCoxeterSystemWithDeletion *)

	subsection \<open>Coxeter systems\<close>

	subsubsection \<open>Locale definition and transfer from the associated free group\<close>

	text \<open>
	Now we consider groups generated by elements of order two with an additional assumption to ensure
	that the natural correspondence between the group @{term W} and the group presentation on the
	generating set @{term S} and its relations is bijective. Below, such groups will be shown to
	satisfy the deletion condition.
	\<close>

	locale CoxeterSystem = PreCoxeterSystem S
	for S :: "'w::group_add set"
	+ assumes induced_id_inj: "inj_on induced_id G"

	lemma (in PreCoxeterSystem) CoxeterSystemI:
	assumes "\<And>g. g\<in>G \<Longrightarrow> induced_id g = 0 \<Longrightarrow> g=0"
	shows "CoxeterSystem S"
	proof
	from assms have "GroupIso G induced_id"
	using GroupWithGeneratorsRelators_S_R
	GroupWithGeneratorsRelators.induced_id_hom_surj(1)
	by (fast intro: GroupHom.isoI)
	thus "inj_on induced_id G" using GroupIso.inj_on by fast
	qed

	context CoxeterSystem
	begin

	abbreviation "inv_induced_id \<equiv> GroupPresentation.inv_induced_id S R"

	lemma GroupPresentation_S_R: "GroupPresentation S R"
	by (
	intro_locales, rule GroupWithGeneratorsRelators_S_R,
	unfold_locales, rule induced_id_inj
	)

	lemmas inv_induced_id_sum_list =
	GroupPresentation.inv_induced_id_sum_list_S[OF GroupPresentation_S_R]

	end (* context CoxeterSystem *)

	subsubsection \<open>The deletion condition is necessary\<close>

	text \<open>
	Call an element of @{term W} a reflection if it is a conjugate of a generating element (and so
	is also of order two). Here we use the action of words over @{term S} on such reflections to show
	that Coxeter systems satisfy the deletion condition.
	\<close>

	context CoxeterSystem
	begin

	abbreviation "induced_signed_lconjperm \<equiv>
	GroupByPresentationInducedFun.induced_hom S P signed_lconjpermutation"

	definition flipped_reflections :: "'w \<Rightarrow> 'w set"
	where "flipped_reflections w \<equiv>
	{t\<in>\<H>. induced_signed_lconjperm (inv_induced_id (-w)) \<rightarrow>
	(t,True) = (rconjby w t, False)}"

	lemma induced_signed_lconjperm_inv_induced_id_sum_list:
	"ss \<in> lists S \<Longrightarrow> induced_signed_lconjperm (inv_induced_id (sum_list ss)) =
	sum_list (map signed_lconjpermutation ss)"
	by (simp add:
	inv_induced_id_sum_list Abs_freelist_in_FreeGroup
	GroupByPresentationInducedFun.induced_hom_Abs_freelist_conv_sum_list[
	OF GroupByPresentationInducedFun_S_R_signed_lconjaction
	]
	)

	lemma induced_signed_eq_lconjpermutation:
	"ss \<in> lists S \<Longrightarrow>
	permutation (induced_signed_lconjperm (inv_induced_id (sum_list ss))) =
	signed_list_lconjaction ss"
	proof (induct ss)
	case Nil
	have "permutation (induced_signed_lconjperm (inv_induced_id (sum_list []))) = id"
	using induced_signed_lconjperm_inv_induced_id_sum_list[of "[]"]
	zero_permutation.rep_eq
	by simp
	thus ?case by fastforce
	next
	case (Cons s ss)
	from Cons(2)
	have "induced_signed_lconjperm (inv_induced_id (sum_list (s#ss))) =
	signed_lconjpermutation s + sum_list (map signed_lconjpermutation ss)"
	using induced_signed_lconjperm_inv_induced_id_sum_list[of "s#ss"]
	by simp
	with Cons(2) have
	"permutation (induced_signed_lconjperm (inv_induced_id (sum_list (s#ss)))) =
	permutation (signed_lconjpermutation s) \<circ>
	permutation (induced_signed_lconjperm (inv_induced_id (sum_list ss)))"
	using plus_permutation.rep_eq induced_signed_lconjperm_inv_induced_id_sum_list
	by simp
	with Cons show ?case
	using bij_signed_lconjaction[of s] Abs_permutation_inverse by fastforce
	qed

	lemma flipped_reflections_odd_lconjseq:
	assumes "ss\<in>lists S"
	shows "flipped_reflections (sum_list ss) = {t\<in>\<H>. odd (count_list (lconjseq ss) t)}"
	proof (rule seteqI)
	fix t assume "t \<in> flipped_reflections (sum_list ss)"
	moreover with assms
	have "snd (signed_list_lconjaction (rev ss) (t,True)) = False"
	using flipped_reflections_def genset_order2_add uminus_sum_list_order2
	induced_signed_eq_lconjpermutation[of "rev ss"]
	by force
	ultimately show "t \<in> {t\<in>\<H>. odd (count_list (lconjseq ss) t)}"
	using assms flipped_reflections_def genset_order2_add
	signed_list_lconjaction_snd[of "rev ss"]
	by auto
	next
	fix t assume t: "t \<in> {t\<in>\<H>. odd (count_list (lconjseq ss) t)}"
	with assms
	have "signed_list_lconjaction (rev ss) (t,True) =
	(rconjby (sum_list ss) t, False)"
	using genset_order2_add signed_list_lconjaction_snd[of "rev ss"]
	signed_list_lconjaction_fst[of "rev ss"]
	uminus_sum_list_order2[of ss, THEN sym]
	by (auto intro: prod_eqI)
	with t assms show "t \<in> flipped_reflections (sum_list ss)"
	using induced_signed_eq_lconjpermutation[of "rev ss"] genset_order2_add
	uminus_sum_list_order2 flipped_reflections_def
	by fastforce
	qed

	lemma flipped_reflections_in_lconjseq:
	"ss\<in>lists S \<Longrightarrow> flipped_reflections (sum_list ss) \<subseteq> set (lconjseq ss)"
	using flipped_reflections_odd_lconjseq odd_n0 count_notin[of _ "lconjseq ss"]
	by fastforce

	lemma flipped_reflections_distinct_lconjseq_eq_lconjseq:
	assumes "ss\<in>lists S" "distinct (lconjseq ss)"
	shows "flipped_reflections (sum_list ss) = set (lconjseq ss)"
	proof
	from assms(1) show "flipped_reflections (sum_list ss) \<subseteq> set (lconjseq ss)"
	using flipped_reflections_in_lconjseq by fast
	show "flipped_reflections (sum_list ss) \<supseteq> set (lconjseq ss)"
	proof
	fix t assume "t \<in> set (lconjseq ss)"
	moreover with assms(2) have "count_list (lconjseq ss) t = 1"
	by (simp add: distinct_count_list)
	ultimately show "t \<in> flipped_reflections (sum_list ss)"
	using assms(1) flipped_reflections_odd_lconjseq lconjseq_reflections
	by fastforce
	qed
	qed

	lemma flipped_reflections_reduced_eq_lconjseq:
	"S_reduced ss \<Longrightarrow> flipped_reflections (sum_list ss) = set (lconjseq ss)"
	using reduced_word_for_lists[of S] S_reduced_imp_distinct_lconjseq
	flipped_reflections_distinct_lconjseq_eq_lconjseq
	by fast

	lemma card_flipped_reflections:
	assumes "w\<in>W"
	shows "card (flipped_reflections w) = S_length w"
	proof-
	define ss where "ss = arg_min length (word_for S w)"
	with assms have "S_reduced_for w ss"
	using genby_S_reduced_word_for_arg_min by simp
	thus ?thesis
	using reduced_word_for_sum_list flipped_reflections_reduced_eq_lconjseq
	S_reduced_imp_distinct_lconjseq distinct_card length_lconjseq[of ss]
	reduced_word_for_length
	by fastforce
	qed

	end (* context CoxeterSystem *)

	sublocale CoxeterSystem < PreCoxeterSystemWithDeletion
	proof
	fix ss assume ss: "ss \<in> lists S" "\<not> S_reduced ss"
	define w where "w = sum_list ss"
	with ss(1)
	have "distinct (lconjseq ss) \<Longrightarrow> card (flipped_reflections w) = length ss"
	by (simp add:
	flipped_reflections_distinct_lconjseq_eq_lconjseq distinct_card
	length_lconjseq)
	moreover from w_def ss have "length ss > S_length w" using word_length_lt by fast
	moreover from w_def ss(1) have "card (flipped_reflections w) = S_length w"
	using special_subgroup_eq_sum_list card_flipped_reflections by fast
	ultimately have "\<not> distinct (lconjseq ss)" by auto
	with w_def ss
	show "\<exists>a b as bs cs. ss = as @ [a] @ bs @ [b] @ cs \<and>
	sum_list ss = sum_list (as @ bs @ cs)"
	using deletion'
	by fast
	qed


	subsubsection \<open>The deletion condition is sufficient\<close>

	text \<open>
	Now we come full circle and show that a pair consisting of a group and a generating set of
	order-two elements that satisfies the deletion condition affords a presentation that makes it a
	Coxeter system.
	\<close>

	context PreCoxeterSystemWithDeletion
	begin

	lemma reducible_by_flipping:
	"ss \<in> lists S \<Longrightarrow> \<not> S_reduced ss \<Longrightarrow>
	\<exists>xss as t bs. flip_altsublist_chain (ss # xss @ [as@[t,t]@bs])"
	proof (induct ss)
	case (Cons s ss)
	show ?case
	proof (cases "S_reduced ss")
	case True
	define w where "w = sum_list ss"
	with True have ss_red_w: "reduced_word_for S w ss" by fast
	moreover from Cons(2) have "s\<in>S" by simp
	ultimately obtain as bs where asbs: "reduced_word_for S w (s#as@bs)"
	using Cons(3) exchange by fast
	show ?thesis
	proof (cases "w=0")
	case True with asbs show ?thesis
	using reduced_word_for_0_imp_nil by fast
	next
	case False
	from this obtain xss where "flip_altsublist_chain (ss # xss @ [s#as@bs])"
	using ss_red_w asbs reduced_word_problem by fast
	hence "flip_altsublist_chain (
	(s#ss) # map ((#) s) xss @ [[]@[s,s]@(as@bs)]
	)"
	using flip_altsublist_chain_map_Cons_grow by fastforce
	thus ?thesis by fast
	qed
	next
	case False
	with Cons(1,2) obtain xss as t bs
	where "flip_altsublist_chain (
	(s#ss) # map ((#) s) xss @ [(s#as)@[t,t]@bs]
	)"
	using flip_altsublist_chain_map_Cons_grow
	by fastforce
	thus ?thesis by fast
	qed
	qed (simp add: nil_reduced_word_for_0)

	lemma freeliftid_kernel':
	"ss \<in> lists S \<Longrightarrow> sum_list ss = 0 \<Longrightarrow> Abs_freelist ss \<in> Q"
	proof (induct ss rule: length_induct)
	fix ss
	assume step: "\<forall>ts. length ts < length ss \<longrightarrow> ts \<in> lists S \<longrightarrow>
	sum_list ts = 0 \<longrightarrow> Abs_freelist ts \<in> Q"
	and set_up: "ss \<in> lists S" "sum_list ss = 0"
	show "Abs_freelist ss \<in> Q"
	proof (cases "ss=[]")
	case True thus ?thesis
	using genby_0_closed[of "\<Union>w\<in>FreeGroup S. lconjby w ` P'"]
	by (auto simp add: zero_freeword.abs_eq)
	next
	case False
	with set_up obtain xss as t bs
	where xss: "flip_altsublist_chain (ss # xss @ [as@[t,t]@bs])"
	using sum_list_zero_nreduced reducible_by_flipping[of ss]
	by fast
	with set_up
	have astbs: "length (as@[t,t]@bs) = length ss"
	"as@[t,t]@bs \<in> lists S"
	"sum_list (as@[t,t]@bs) = 0"
	using flip_altsublist_chain_length[of ss xss "as@[t,t]@bs"]
	flip_altsublist_chain_sum_list[of ss xss "as@[t,t]@bs"]
	flip_altsublist_chain_lists[of ss xss "as@[t,t]@bs"]
	by auto
	have listsS: "as \<in> lists S" "t\<in>S" "bs\<in>lists S" using astbs(2) by auto
	have "sum_list as + (t + t + sum_list bs) = 0"
	using astbs(3) by (simp add: add.assoc)
	hence "sum_list (as@bs) = 0"
	using listsS(2) by (simp add: genset_order2_add)
	moreover have "length (as@bs) < length ss" using astbs(1) by simp
	moreover have "as@bs \<in> lists S" using listsS(1,3) by simp
	ultimately have "Abs_freelist (as@bs) \<in> Q" using step by fast
	hence "Abs_freelist as + pair_relator_freeword t t +
	(- Abs_freelist as + (Abs_freelist as + Abs_freelist bs)) \<in> Q"
	using listsS(1,2) lconjby_Abs_freelist_relator_freeword[of t t as]
	genby_add_closed
	by (simp add: Abs_freelist_append[THEN sym] add.assoc[THEN sym])
	hence "Abs_freelist as + Abs_freelist [t,t] + Abs_freelist bs \<in> Q"
	using listsS(2) by (simp add: S_relator_freeword Abs_freeletter_add)
	thus ?thesis
	using Abs_freelist_append_append[of as "[t,t]" bs]
	rev_flip_altsublist_chain[OF xss]
	flip_altsublist_chain_G_in_Q[of "as@[t,t]@bs" "rev xss" ss]
	by simp
	qed
	qed

	lemma freeliftid_kernel:
	assumes "c \<in> FreeGroup S" "freeliftid c = 0"
	shows "c\<in>Q"
	proof-
	from assms(2) have "freeliftid (Abs_freeword (freeword c)) = 0"
	by (simp add: freeword_inverse)
	with assms(1) have "sum_list (map fst (freeword c)) = 0"
	using FreeGroup_def freeword freeliftid_Abs_freeword_conv_sum_list by fastforce
	with assms(1) show ?thesis
	using FreeGroup_def freeliftid_kernel'[of "map fst (freeword c)"]
	Q_freelist_freeword
	by fastforce
	qed

	lemma induced_id_kernel:
	"c \<in> FreeGroup S \<Longrightarrow> induced_id (\<lceil>FreeGroup S\|c\|Q\<rceil>) = 0 \<Longrightarrow> c\<in>Q"
	by (simp add:
	freeliftid_kernel
	GroupByPresentationInducedFun.induced_hom_equality[
	OF GroupByPresentationInducedFun_S_P_id
	]
	)

	theorem CoxeterSystem: "CoxeterSystem S"
	proof (rule CoxeterSystemI)
	fix x assume x: "x\<in>G" "induced_id x = 0"
	from x(1) obtain c where "c \<in> FreeGroup S" "x = (\<lceil>FreeGroup S\|c\|Q\<rceil>)"
	using Group.quotient_group_UN FreeGroup_Group by fast
	with x(2) show "x=0"
	using induced_id_kernel
	Group.quotient_identity_rule[OF FreeGroup_Group]
	GroupByPresentation.Q_subgroup_FreeS[OF GroupByPresentation_S_P]
	GroupByPresentation.normal_Q[OF GroupByPresentation_S_P]
	by auto
	qed

	end (* context PreCoxeterSystemWithDeletion *)

	subsubsection \<open>The Coxeter system associated to a thin chamber complex with many foldings\<close>

	text \<open>
	We now show that the fundamental automorphisms in a thin chamber complex with many foldings
	satisfy the deletion condition, and hence form a Coxeter system.
	\<close>

	context ThinChamberComplexManyFoldings
	begin

	lemma not_reduced_word_not_min_gallery:
	assumes "ss \<in> lists S" "\<not> reduced_word S ss"
	shows "\<not> min_gallery (map (\<lambda>w. w`\<rightarrow>C0) (sums ss))"
	proof (cases ss rule: list_cases_Cons_snoc)
	case Nil with assms(2) show ?thesis using nil_reduced_word_for_0 by auto
	next
	case (Single s) with assms show ?thesis
	using zero_notin_S reduced_word_singleton[of s S] by fastforce
	next
	case (Cons_snoc s ts t) have ss: "ss = s#ts@[t]" by fact
	define Ms where "Ms = map (\<lambda>w. w`\<rightarrow>C0) (map ((+) s) (sums ts))"
	with ss
	have C0_ms_ss_C0: "map (\<lambda>w. w`\<rightarrow>C0) (sums ss) =
	C0 # Ms @ [sum_list ss `\<rightarrow> C0]"
	by (simp add: sums_snoc zero_permutation.rep_eq)
	define rs where "rs = arg_min length (word_for S (sum_list ss))"
	with assms(1) have rs: "rs \<in> lists S" "sum_list rs = sum_list ss"
	using arg_min_natI[of "\<lambda>rs. word_for S (sum_list ss) rs" ss length] by auto
	show ?thesis
	proof (cases rs rule: list_cases_Cons_snoc)
	case Nil
	hence "sum_list ss `\<rightarrow> C0 = C0"
	using rs(2) by (fastforce simp add: zero_permutation.rep_eq)
	with C0_ms_ss_C0 show ?thesis by simp
	next
	case (Single r)
	from Single have "min_gallery [C0,r`\<rightarrow>C0]"
	using rs(1) fundchamber fundchamber_S_chamber fundchamber_S_adjacent
	fundchamber_S_image_neq_fundchamber
	by (fastforce intro: min_gallery_adj)
	with Single C0_ms_ss_C0 Ms_def show ?thesis
	using rs(2) min_galleryD_min_betw[of C0 Ms "sum_list ss `\<rightarrow> C0" "[]"]
	min_galleryD_gallery
	by (fastforce simp add: length_sums)
	next
	case (Cons_snoc p qs q)
	define Ns where "Ns = map (\<lambda>w. w`\<rightarrow>C0) (map ((+) p) (sums qs))"
	from assms rs_def have "length rs < length ss"
	using word_length_lt[of ss S]
	reduced_word_for_length reduced_word_for_arg_min[of ss S]
	by force
	with Cons_snoc ss Ms_def Ns_def have "length Ns < length Ms"
	by (simp add: length_sums)
	moreover from Ns_def Cons_snoc
	have "gallery (C0 # Ns @ [sum_list ss `\<rightarrow> C0])"
	using rs S_list_image_gallery[of rs]
	by (auto simp add: sums_snoc zero_permutation.rep_eq)
	ultimately show ?thesis using C0_ms_ss_C0 not_min_galleryI_betw by auto
	qed
	qed

	lemma S_list_not_min_gallery_double_split:
	assumes "ss \<in> lists S" "ss\<noteq>[]" "\<not> min_gallery (map (\<lambda>w. w`\<rightarrow>C0) (sums ss))"
	shows
	"\<exists>f g as s bs t cs.
	(f,g)\<in>foldpairs \<and>
	sum_list as `\<rightarrow> C0 \<in> f\<turnstile>\<C> \<and>
	sum_list (as@[s]) `\<rightarrow> C0 \<in> g\<turnstile>\<C> \<and>
	sum_list (as@[s]@bs) `\<rightarrow> C0 \<in> g\<turnstile>\<C> \<and>
	sum_list (as@[s]@bs@[t]) `\<rightarrow> C0 \<in> f\<turnstile>\<C> \<and>
	ss = as@[s]@bs@[t]@cs"
	proof-
	define Cs where "Cs = map (\<lambda>w. w`\<rightarrow>C0) (sums ss)"
	moreover from assms(1) Cs_def have "gallery Cs"
	using S_list_image_gallery by fastforce
	moreover from assms(1) Cs_def have "{} \<notin> set (wall_crossings Cs)"
	using S_list_image_crosses_walls by fastforce
	ultimately obtain f g As A B Bs E F Fs
	where fg : "(f,g)\<in>foldpairs"
	and sep : "A\<in>f\<turnstile>\<C>" "B\<in>g\<turnstile>\<C>" "E\<in>g\<turnstile>\<C>" "F\<in>f\<turnstile>\<C>"
	and decomp_cases:
	"Cs = As@[A,B,F]@Fs \<or> Cs = As@[A,B]@Bs@[E,F]@Fs"
	using assms(3) not_min_gallery_double_split[of Cs]
	by blast
	show ?thesis
	proof (cases "Cs = As@[A,B,F]@Fs")
	case True
	define bs :: "'a permutation list" where "bs = []"
	from True Cs_def obtain as s t cs where
	"ss = as@[s,t]@cs" "A = sum_list as `\<rightarrow> C0" "B = sum_list (as@[s]) `\<rightarrow> C0"
	"F = sum_list (as@[s,t]) `\<rightarrow> C0"
	using pullback_sums_map_middle3[of "\<lambda>w. w`\<rightarrow>C0" ss As A B F Fs]
	by auto
	with sep(1,2,4) bs_def have
	"sum_list as `\<rightarrow> C0 \<in> f\<turnstile>\<C>" "sum_list (as@[s]) `\<rightarrow> C0 \<in> g\<turnstile>\<C>"
	"sum_list (as@[s]@bs) `\<rightarrow> C0 \<in> g\<turnstile>\<C>" "sum_list (as@[s]@bs@[t]) `\<rightarrow> C0 \<in> f\<turnstile>\<C>"
	"ss = as@[s]@bs@[t]@cs"
	by auto
	with fg show ?thesis by blast
	next
	case False
	with Cs_def decomp_cases obtain as s bs t cs where
	"ss = as@[s]@bs@[t]@cs" "A = sum_list as `\<rightarrow> C0" "B = sum_list (as@[s]) `\<rightarrow> C0"
	"E = sum_list (as@[s]@bs) `\<rightarrow> C0" "F = sum_list (as@[s]@bs@[t]) `\<rightarrow> C0"
	using pullback_sums_map_double_middle2[
	of "\<lambda>w. w`\<rightarrow>C0" ss As A B Bs E F Fs
	]
	by auto
	with sep have
	"sum_list as `\<rightarrow> C0 \<in> f\<turnstile>\<C>" "sum_list (as@[s]) `\<rightarrow> C0 \<in> g\<turnstile>\<C>"
	"sum_list (as@[s]@bs) `\<rightarrow> C0 \<in> g\<turnstile>\<C>" "sum_list (as@[s]@bs@[t]) `\<rightarrow> C0 \<in> f\<turnstile>\<C>"
	"ss = as@[s]@bs@[t]@cs"
	by auto
	with fg show ?thesis by blast
	qed
	qed

	lemma fold_end_sum_chain_fg:
	fixes f g :: "'a\<Rightarrow>'a"
	defines \<s> : "\<s> \<equiv> induced_automorph f g"
	assumes fg : "(f,g) \<in> foldpairs"
	and as : "as \<in> lists S"
	and s : "s\<in>S"
	and sep: "sum_list as `\<rightarrow> C0 \<in> f\<turnstile>\<C>" "sum_list (as@[s]) `\<rightarrow> C0 \<in> g\<turnstile>\<C>"
	shows "bs \<in>lists S \<Longrightarrow>
	\<s> ` sum_list (as@[s]@bs) `\<rightarrow> C0 = sum_list (as@bs) `\<rightarrow> C0"
	proof-
	from fg obtain C where C: "OpposedThinChamberComplexFoldings X f g C"
	using foldpairs_def by fast
	show "bs \<in>lists S \<Longrightarrow> \<s> ` sum_list (as@[s]@bs) `\<rightarrow> C0 = sum_list (as@bs) `\<rightarrow> C0"
	proof (induct bs rule: rev_induct)
	case Nil
	from \<s> as s sep C show ?case
	using sum_list_S_in_W[of as] sum_list_append[of as "[s]"]
	fundchamber_WS_image_adjacent
	by (auto simp add:
	OpposedThinChamberComplexFoldings.indaut_adj_halfchsys_im_fg
	)
	next
	case (snoc b bs)
	define bC0 B where "bC0 = b`\<rightarrow>C0" and "B = sum_list (as@bs) `\<rightarrow> C0"
	define y where "y = C0\<inter>bC0"
	define z z'
	where "z = \<s> ` sum_list (as@[s]@bs) `\<rightarrow> y"
	and "z' = sum_list (as@bs) `\<rightarrow> y"

	from snoc B_def have B': "\<s> ` sum_list (as@[s]@bs) `\<rightarrow> C0 = B" by simp

	obtain \<phi> where \<phi>: "label_wrt C0 \<phi>" using ex_label_map by fast
	from bC0_def y_def snoc(2) obtain u where u: "bC0 = insert u y"
	using fundchamber_S_adjacent[of b] adjacent_sym
	fundchamber_S_image_neq_fundchamber
	adjacent_int_decomp[of bC0 C0]
	by (auto simp add: Int_commute)
	define v v'
	where "v = \<s> (sum_list (as@[s]@bs) \<rightarrow> u)"
	and "v' = sum_list (as@bs) \<rightarrow> u"

	from bC0_def u v_def z_def v'_def z'_def
	have ins_vz : "\<s> ` sum_list (as@[s]@bs@[b]) `\<rightarrow> C0 = insert v z"
	and ins_vz': "sum_list (as@bs@[b]) `\<rightarrow> C0 = insert v' z'"
	using image_insert[of "permutation (sum_list (as@[s]@bs))" u y, THEN sym]
	image_insert[
	of \<s> "sum_list (as@[s]@bs)\<rightarrow>u" "sum_list (as@[s]@bs)`\<rightarrow>y",
	THEN sym]
	image_insert[of "permutation (sum_list (as@bs))" u y, THEN sym]
	by (auto simp add: plus_permutation.rep_eq image_comp)

	from as s snoc(2) have sums:
	"sum_list (as@[s]@bs) \<in> W" "sum_list (as@bs) \<in> W"
	"sum_list (as@[s]@bs@[b]) \<in> W" "sum_list (as@bs@[b]) \<in> W"
	using sum_list_S_in_W[of "as@[s]@bs"] sum_list_S_in_W[of "as@bs"]
	sum_list_S_in_W[of "as@[s]@bs@[b]"] sum_list_S_in_W[of "as@bs@[b]"]
	by auto
	from u bC0_def snoc(2) have u: "u\<in>\<Union>X"
	using fundchamber_S_chamber[of b] chamberD_simplex[of bC0] by auto
	moreover from as s snoc(2) u have "sum_list (as@[s]@bs) \<rightarrow> u \<in> \<Union>X"
	using sums(1)
	ChamberComplexEndomorphism.vertex_map[OF W_endomorphism]
	by fastforce
	ultimately have "\<phi> v = \<phi> v'"
	using \<s> v_def v'_def sums(1,2) W_respects_labels[OF \<phi>, of "sum_list (as@[s]@bs)" u]
	W_respects_labels[OF \<phi>, of "sum_list (as@bs)" u]
	OpposedThinChamberComplexFoldings.indaut_resplabels[
	OF C \<phi>
	]
	by simp

	moreover from \<s> have "chamber (insert v z)" "chamber (insert v' z')"
	using sums(3,4)
	fundchamber_W_image_chamber[of "sum_list (as@[s]@bs@[b])"]
	OpposedThinChamberComplexFoldings.indaut_chmap[
	OF C
	]
	fundchamber_W_image_chamber[of "sum_list (as@bs@[b])"]
	by (auto simp add: ins_vz[THEN sym] ins_vz'[THEN sym])

	moreover from y_def z_def z'_def bC0_def B_def snoc(2) \<s> have "z\<lhd>B" "z'\<lhd>B"
	using B' sums(1,2) fundchamber_S_adjacent[of b]
	fundchamber_S_image_neq_fundchamber[of b]
	adjacent_int_facet1[of C0]
	W_endomorphism[of "sum_list (as@bs)"]
	W_endomorphism[of "sum_list (as@[s]@bs)"]
	fundchamber fundchamber_W_image_chamber[of "sum_list (as@[s]@bs)"]
	ChamberComplexEndomorphism.facet_map[of X]
	OpposedThinChamberComplexFoldings.indaut_morph[
	OF C
	]
	ChamberComplexEndomorphism.facet_map[
	of X \<s> "sum_list (as@[s]@bs) `\<rightarrow> C0"
	]
	by auto

	moreover from snoc(2) B_def \<s> have "insert v z \<noteq> B" "insert v' z' \<noteq> B"
	using sum_list_append[of "as@[s]@bs" "[b]"] sum_list_append[of "as@bs" "[b]"]
	fundchamber_next_WS_image_neq[of b "sum_list (as@[s]@bs)"]
	fundchamber_next_WS_image_neq[of b "sum_list (as@bs)"]
	OpposedThinChamberComplexFoldings.indaut_aut[
	OF C
	]
	ChamberComplexAutomorphism.bij bij_is_inj B'
	inj_eq_image[
	of \<s> "sum_list (as@[s]@bs@[b]) `\<rightarrow> C0" "sum_list (as@[s]@bs) `\<rightarrow> C0"
	]
	by (auto simp add: ins_vz[THEN sym] ins_vz'[THEN sym])

	ultimately show ?case
	using B_def sums(2) fundchamber_W_image_chamber[of "sum_list (as@bs)"]
	label_wrt_eq_on_adjacent_vertex[OF \<phi>, of v v' B z z']
	by (auto simp add: ins_vz[THEN sym] ins_vz'[THEN sym])
	qed
	qed

	lemma fold_end_sum_chain_gf:
	fixes f g :: "'a\<Rightarrow>'a"
	defines "\<s> \<equiv> induced_automorph f g"
	assumes fg : "(f,g) \<in> foldpairs"
	and "as \<in> lists S" "s\<in>S" "bs \<in>lists S"
	"sum_list as `\<rightarrow> C0 \<in> g\<turnstile>\<C>"
	"sum_list (as@[s]) `\<rightarrow> C0 \<in> f\<turnstile>\<C>"
	shows "\<s> ` sum_list (as@[s]@bs) `\<rightarrow> C0 = sum_list (as@bs) `\<rightarrow> C0"
	proof-
	from fg obtain C where C: "OpposedThinChamberComplexFoldings X f g C"
	using foldpairs_def by fast
	from assms show ?thesis
	using foldpairs_sym fold_end_sum_chain_fg[of g f as s bs]
	OpposedThinChamberComplexFoldings.induced_automorphism_sym[OF C]
	by simp
	qed

	lemma fold_middle_sum_chain:
	assumes fg : "(f,g) \<in> foldpairs"
	and S : "as \<in> lists S" "s\<in>S" "bs \<in> lists S" "t\<in>S" "cs \<in>lists S"
	and sep: "sum_list as `\<rightarrow> C0 \<in> f\<turnstile>\<C>"
	"sum_list (as@[s]) `\<rightarrow> C0 \<in> g\<turnstile>\<C>"
	"sum_list (as@[s]@bs) `\<rightarrow> C0 \<in> g\<turnstile>\<C>" "sum_list (as@[s]@bs@[t]) `\<rightarrow> C0 \<in> f\<turnstile>\<C>"
	shows "sum_list (as@[s]@bs@[t]@cs) `\<rightarrow> C0 = sum_list (as@bs@cs) `\<rightarrow> C0"
	proof-
	define \<s> where "\<s> = induced_automorph f g"
	from fg obtain C
	where "OpposedThinChamberComplexFoldings X f g C"
	using foldpairs_def
	by fast
	then have "id ` sum_list (as@[s]@bs@[t]@cs) `\<rightarrow> C0 = sum_list (as@bs@cs) `\<rightarrow> C0"
	using \<s>_def fg S sep fold_end_sum_chain_gf[of f g "as@[s]@bs" t cs]
	fold_end_sum_chain_fg[of f g as s "bs@cs"]
	by (simp add:
	image_comp[THEN sym]
	OpposedThinChamberComplexFoldings.indaut_order2[
	THEN sym]
	)
	thus ?thesis by simp
	qed

	lemma S_list_not_min_gallery_deletion:
	fixes ss :: "'a permutation list"
	defines w : "w \<equiv> sum_list ss"
	assumes ss: "ss\<in>lists S" "ss\<noteq>[]" "\<not> min_gallery (map (\<lambda>w. w`\<rightarrow>C0) (sums ss))"
	shows "\<exists>a b as bs cs. ss = as@[a]@bs@[b]@cs \<and> w = sum_list (as@bs@cs)"
	proof-
	from w ss(1) have w_W: "w\<in>W" using sum_list_S_in_W by fast

	define Cs where "Cs = map (\<lambda>w. w`\<rightarrow>C0) (sums ss)"
	from ss obtain f g as s bs t cs
	where fg : "(f,g)\<in>foldpairs"
	and sep : "sum_list as `\<rightarrow> C0 \<in> f\<turnstile>\<C>"
	"sum_list (as@[s]) `\<rightarrow> C0 \<in> g\<turnstile>\<C>"
	"sum_list (as@[s]@bs) `\<rightarrow> C0 \<in> g\<turnstile>\<C>"
	"sum_list (as@[s]@bs@[t]) `\<rightarrow> C0 \<in> f\<turnstile>\<C>"
	and decomp: "ss = as@[s]@bs@[t]@cs"
	using S_list_not_min_gallery_double_split[of ss]
	by blast
	from fg sep decomp w ss(1)
	have "w`\<rightarrow>C0 = sum_list (as@bs@cs) `\<rightarrow> C0"
	using fold_middle_sum_chain
	by auto
	with ss(1) decomp have "w = sum_list (as@bs@cs)"
	using w_W sum_list_S_in_W[of "as@bs@cs"]
	by (auto intro: inj_onD fundchamber_W_image_inj_on)
	with decomp show ?thesis by fast
	qed

	lemma deletion:
	"ss \<in> lists S \<Longrightarrow> \<not> reduced_word S ss \<Longrightarrow>
	\<exists>a b as bs cs. ss = as@[a]@bs@[b]@cs \<and> sum_list ss = sum_list (as@bs@cs)"
	using nil_reduced_word_for_0[of S] not_reduced_word_not_min_gallery
	S_list_not_min_gallery_deletion
	by fastforce

	lemma PreCoxeterSystemWithDeletion: "PreCoxeterSystemWithDeletion S"
	using S_add_order2 deletion by unfold_locales simp

	lemma CoxeterSystem: "CoxeterSystem S"
	using PreCoxeterSystemWithDeletion
	PreCoxeterSystemWithDeletion.CoxeterSystem
	by fast

	end (* context ThinChamberComplexManyFoldings *)


	subsection \<open>Coxeter complexes\<close>

	subsubsection \<open>Locale and complex definitions\<close>

	text \<open>
	Now we add in the assumption that the generating set is finite, and construct the associated
	Coxeter complex from the poset of special cosets.
	\<close>

	locale CoxeterComplex = CoxeterSystem S
	for S :: "'w::group_add set"
	+ assumes finite_genset: "finite S"
	begin

	definition TheComplex :: "'w set set set"
	where "TheComplex \<equiv> ordering.PosetComplex (\<supseteq>) (\<supset>) \<P>"
	abbreviation "\<Sigma> \<equiv> TheComplex"

	end (* context CoxeterComplex *)

	subsubsection \<open>As a simplicial complex\<close>

	text \<open>
	Here we record the fact that the Coxeter complex associated to a Coxeter system is a simplicial
	complex, and note that the poset of special cosets is complex-like. This last fact allows us to
	reason about the complex by reasoning about the poset, via the poset isomorphism
	@{const ComplexLikePoset.smap}.
	\<close>

	context CoxeterComplex
	begin

	lemma simplex_like_special_cosets:
	assumes "X\<in>\<P>"
	shows "supset_simplex_like (\<P>.\<supseteq>X)"
	proof-
	have image_eq_UN: "\<And>f A. f ` A = (\<Union>x\<in>A. {f x})" by blast

	from assms obtain w T where "w\<in>W" "T \<in> Pow S" "X = w +o \<langle>T\<rangle>"
	using special_cosets_def by auto
	thus ?thesis
	using image_eq_UN[where f= "(+o) w \<circ> genby"]
	finite_genset simplex_like_pow_above_in
	OrderingSetIso.simplex_like_map[
	OF special_coset_below_in_supset_ordering_iso, of T w
	]
	special_cosets_below_in
	by force
	qed

	lemma SimplicialComplex_\<Sigma>: "SimplicialComplex \<Sigma>"
	unfolding TheComplex_def
	proof (rule ordering.poset_is_SimplicialComplex)
	show "ordering (\<supseteq>) (\<supset>)" ..
	show "\<forall>X\<in>\<P>. supset_simplex_like (\<P>.\<supseteq>X)"
	using simplex_like_special_cosets by fast
	qed

	lemma ComplexLikePoset_special_cosets: "ComplexLikePoset (\<supseteq>) (\<supset>) \<P>"
	using simplex_like_special_cosets special_cosets_has_bottom special_cosets_have_glbs
	by unfold_locales

	abbreviation "smap \<equiv> ordering.poset_simplex_map (\<supseteq>) (\<supset>) \<P>"

	lemmas smap_def = ordering.poset_simplex_map_def[OF supset_poset, of \<P>]

	lemma ordsetmap_smap: "\<lbrakk> X\<in>\<P>; Y\<in>\<P>; X\<supseteq>Y \<rbrakk> \<Longrightarrow> smap X \<subseteq> smap Y"
	using ComplexLikePoset.ordsetmap_smap[OF ComplexLikePoset_special_cosets]
	smap_def
	by simp

	lemma rev_ordsetmap_smap: "\<lbrakk> X\<in>\<P>; Y\<in>\<P>; smap X \<subseteq> smap Y \<rbrakk> \<Longrightarrow> X\<supseteq>Y"
	using ComplexLikePoset.rev_ordsetmap_smap[
	OF ComplexLikePoset_special_cosets
	]
	smap_def
	by simp

	lemma smap_onto_PosetComplex: "smap ` \<P> = \<Sigma>"
	using ComplexLikePoset.smap_onto_PosetComplex[
	OF ComplexLikePoset_special_cosets
	]
	smap_def TheComplex_def
	by simp

	lemmas simplices_conv_special_cosets = smap_onto_PosetComplex[THEN sym]

	lemma smap_into_PosetComplex: "X\<in>\<P> \<Longrightarrow> smap X \<in> \<Sigma>"
	using smap_onto_PosetComplex by fast

	lemma smap_pseudominimal:
	"w\<in>W \<Longrightarrow> s\<in>S \<Longrightarrow> smap (w +o \<langle>S-{s}\<rangle>) = {w +o \<langle>S-{s}\<rangle>}"
	using smap_def[of "w +o \<langle>S-{s}\<rangle>"]
	special_coset_pseudominimal_in_below_in[of w "S-{s}"]
	exclude_one_is_pseudominimal_in_below_in[of w "S-{s}"]
	by auto

	lemma exclude_one_notin_smap_singleton:
	"s\<in>S \<Longrightarrow> w +o \<langle>S-{s}\<rangle> \<notin> smap (w +o \<langle>{s}\<rangle>)"
	using smap_def[of "w +o \<langle>{s}\<rangle>"]
	supset_pseudominimal_inD1[of "\<P>.\<supseteq>(w +o \<langle>{s}\<rangle>)" "w +o \<langle>S-{s}\<rangle>"]
	special_coset_subset_rev_mono[of "{s}" "S-{s}"]
	by auto

	lemma maxsimp_vertices: "w\<in>W \<Longrightarrow> s\<in>S \<Longrightarrow> w +o \<langle>S-{s}\<rangle> \<in> smap {w}"
	using special_cosetsI[of "S-{s}"] special_coset_singleton
	ordsetmap_smap[of "w +o \<langle>S-{s}\<rangle>"] smap_pseudominimal
	by (simp add: genby_lcoset_refl)

	lemma maxsimp_singleton:
	assumes "w\<in>W"
	shows "SimplicialComplex.maxsimp \<Sigma> (smap {w})"
	proof (rule SimplicialComplex.maxsimpI, rule SimplicialComplex_\<Sigma>)
	from assms show "smap {w} \<in> \<Sigma>"
	using special_coset_singleton smap_into_PosetComplex by fast
	next
	fix z assume z: "z\<in>\<Sigma>" "smap {w} \<subseteq> z"
	from z(1) obtain X where X: "X\<in>\<P>" "z = smap X"
	using simplices_conv_special_cosets by auto
	with assms z(2) have "X = {w}"
	using special_coset_singleton rev_ordsetmap_smap special_coset_nempty by fast
	with X(2) show "z = smap {w}" by fast
	qed

	lemma maxsimp_is_singleton:
	assumes "SimplicialComplex.maxsimp \<Sigma> x"
	shows "\<exists>w\<in>W. smap {w} = x"
	proof-
	from assms obtain X where X: "X\<in>\<P>" "smap X = x"
	using SimplicialComplex.maxsimpD_simplex[OF SimplicialComplex_\<Sigma>]
	simplices_conv_special_cosets
	by auto
	from X(1) obtain w T where wT: "w\<in>W" "T\<in>Pow S" "X = w +o \<langle>T\<rangle>"
	using special_cosets_def by auto
	from wT(1) have "{w}\<in>\<P>" using special_coset_singleton by fast
	moreover with X wT(3) have "x \<subseteq> smap {w}"
	using genby_lcoset_refl ordsetmap_smap by fast
	ultimately show ?thesis
	using assms wT(1) smap_into_PosetComplex
	SimplicialComplex.maxsimpD_maximal[OF SimplicialComplex_\<Sigma>]
	by fast
	qed

	lemma maxsimp_vertex_conv_special_coset:
	"w\<in>W \<Longrightarrow> X \<in> smap {w} \<Longrightarrow> \<exists>s\<in>S. X = w +o \<langle>S-{s}\<rangle>"
	using smap_def special_coset_pseudominimal_in_below_in[of w "{}"]
	by (simp add: genby_lcoset_empty)

	lemma vertices: "w\<in>W \<Longrightarrow> s\<in>S \<Longrightarrow> w +o \<langle>S-{s}\<rangle> \<in> \<Union>\<Sigma>"
	using maxsimp_singleton SimplicialComplex.maxsimpD_simplex[OF SimplicialComplex_\<Sigma>]
	maxsimp_vertices
	by fast

	lemma smap0_conv_special_subgroups:
	"smap 0 = (\<lambda>s. \<langle>S - {s}\<rangle>) ` S"
	using genby_0_closed maxsimp_vertices maxsimp_vertex_conv_special_coset
	by force

	lemma S_bij_betw_chamber0: "bij_betw (\<lambda>s. \<langle>S-{s}\<rangle>) S (smap 0)"
	unfolding bij_betw_def
	proof
	show "inj_on (\<lambda>s. \<langle>S-{s}\<rangle>) S"
	proof (rule inj_onI)
	fix s t show "\<lbrakk> s\<in>S; t\<in>S; \<langle>S-{s}\<rangle> = \<langle>S-{t}\<rangle> \<rbrakk> \<Longrightarrow> s = t"
	using inj_onD[OF special_subgroup_inj, of "S-{s}" "S-{t}"] by fast
	qed
	qed (rule smap0_conv_special_subgroups[THEN sym])

	lemma smap_singleton_conv_W_image:
	"w\<in>W \<Longrightarrow> smap {w} = ((+o) w) ` (smap 0)"
	using genby_0_closed[of S] maxsimp_vertices[of 0] maxsimp_vertices[of w]
	maxsimp_vertex_conv_special_coset
	by force

	lemma W_lcoset_bij_betw_singletons:
	assumes "w\<in>W"
	shows "bij_betw ((+o) w) (smap 0) (smap {w})"
	unfolding bij_betw_def
	proof (rule conjI, rule inj_onI)
	fix X Y assume XY: "X \<in> smap 0" "Y \<in> smap 0" "w +o X = w +o Y"
	from XY(1,2) obtain sx sy where "X = \<langle>S-{sx}\<rangle>" "Y = \<langle>S-{sy}\<rangle>"
	using maxsimp_vertex_conv_special_coset[of 0 X]
	maxsimp_vertex_conv_special_coset[of 0 Y] genby_0_closed[of S]
	by auto
	with XY(3) show "X=Y"
	using inj_onD[OF special_coset_inj, of w "S-{sx}" "S-{sy}"] by force
	qed (rule smap_singleton_conv_W_image[THEN sym], rule assms)

	lemma facets:
	assumes "w\<in>W" "s\<in>S"
	shows "smap (w +o \<langle>{s}\<rangle>) \<lhd> smap {w}"
	proof (
	rule facetrelI, rule exclude_one_notin_smap_singleton, rule assms(2),
	rule order_antisym
	)

	show "smap {w} \<subseteq> insert (w +o \<langle>S - {s}\<rangle>) (smap (w +o \<langle>{s}\<rangle>))"
	proof
	fix X assume "X \<in> smap {w}"
	with assms(1) obtain t where "t\<in>S" "X = w +o \<langle>S-{t}\<rangle>"
	using maxsimp_vertex_conv_special_coset by fast
	with assms show "X\<in> insert (w +o \<langle>S - {s}\<rangle>) (smap (w +o \<langle>{s}\<rangle>))"
	using exclude_one_is_pseudominimal_in_below_in smap_def
	by (cases "t=s") auto
	qed

	from assms show "smap {w} \<supseteq> insert (w +o \<langle>S - {s}\<rangle>) (smap (w +o \<langle>{s}\<rangle>))"
	using genby_lcoset_refl special_cosetsI[of "{s}"] special_coset_singleton
	ordsetmap_smap maxsimp_vertices
	by fast

	qed

	lemma facets': "w\<in>W \<Longrightarrow> s\<in>S \<Longrightarrow> smap {w,w+s} \<lhd> smap {w}"
	using facets by (simp add: genset_order2_add genby_lcoset_order2)

	lemma adjacent: "w\<in>W \<Longrightarrow> s\<in>S \<Longrightarrow> smap {w+s} \<sim> smap {w}"
	using facets'[of w s] genby_genset_closed genby_add_closed[of w S]
	facets'[of "w+s" s]
	by (
	auto intro: adjacentI
	simp add: genset_order2_add add.assoc insert_commute
	)

	lemma singleton_adjacent_0: "s\<in>S \<Longrightarrow> smap {s} \<sim> smap 0"
	using genby_genset_closed genby_0_closed facets'[of 0] facets'[of s]
	by (fastforce intro: adjacentI simp add: genset_order2_add insert_commute)

	end (* context CoxeterComplex *)

	subsubsection \<open>As a chamber complex\<close>

	text \<open>Now we verify that a Coxeter complex is a chamber complex.\<close>

	context CoxeterComplex
	begin

	abbreviation "chamber \<equiv> SimplicialComplex.maxsimp \<Sigma>"
	abbreviation "gallery \<equiv> SimplicialComplex.maxsimpchain \<Sigma>"

	lemmas chamber_singleton = maxsimp_singleton
	lemmas chamber_vertex_conv_special_coset = maxsimp_vertex_conv_special_coset
	lemmas chamber_vertices = maxsimp_vertices
	lemmas chamber_is_singleton = maxsimp_is_singleton

	lemmas faces = SimplicialComplex.faces [OF SimplicialComplex_\<Sigma>]
	lemmas gallery_def = SimplicialComplex.maxsimpchain_def [OF SimplicialComplex_\<Sigma>]
	lemmas gallery_rev = SimplicialComplex.maxsimpchain_rev [OF SimplicialComplex_\<Sigma>]

	lemmas chamberD_simplex =
	SimplicialComplex.maxsimpD_simplex[OF SimplicialComplex_\<Sigma>]
	lemmas gallery_CConsI =
	SimplicialComplex.maxsimpchain_CConsI[OF SimplicialComplex_\<Sigma>]

	lemmas gallery_overlap_join =
	SimplicialComplex.maxsimpchain_overlap_join[OF SimplicialComplex_\<Sigma>]

	lemma word_gallery_to_0:
	"ss \<noteq> [] \<Longrightarrow> ss\<in> lists S \<Longrightarrow> \<exists>xs. gallery (smap {sum_list ss} # xs @ [smap 0])"
	proof (induct ss rule: rev_nonempty_induct)
	case (single s)
	hence "gallery (smap {sum_list [s]} # [] @ [smap 0])"
	using genby_genset_closed genby_0_closed chamber_singleton
	singleton_adjacent_0 gallery_def
	by auto
	thus ?case by fast
	next
	case (snoc s ss)
	from snoc(2,3) obtain xs where "gallery (smap {sum_list ss} # xs @ [smap 0])"
	by auto
	moreover from snoc(3) have "chamber (smap {sum_list (ss@[s])})"
	using special_subgroup_eq_sum_list chamber_singleton by fast
	ultimately
	have "gallery (smap {sum_list (ss@[s])} #
	(smap {sum_list ss} # xs) @ [smap 0])"
	using snoc(3) special_subgroup_eq_sum_list adjacent[of "sum_list ss" s]
	by (auto intro: gallery_CConsI)
	thus ?case by fast
	qed

	lemma gallery_to_0:
	assumes "w\<in>W" "w\<noteq>0"
	shows "\<exists>xs. gallery (smap {w} # xs @ [smap 0])"
	proof-
	from assms(1) obtain ss where ss: "ss\<in>lists S" "w = sum_list ss"
	using special_subgroup_eq_sum_list by auto
	with assms(2) show ?thesis using word_gallery_to_0[of ss] by fastforce
	qed

	lemma ChamberComplex_\<Sigma>: "ChamberComplex \<Sigma>"
	proof (intro_locales, rule SimplicialComplex_\<Sigma>, unfold_locales)
	fix y assume "y\<in>\<Sigma>"
	from this obtain X where X: "X\<in>\<P>" "y = smap X"
	using simplices_conv_special_cosets by auto
	from X(1) obtain w T where "w\<in>W" "X = w +o \<langle>T\<rangle>"
	using special_cosets_def by auto
	with X show "\<exists>x. chamber x \<and> y \<subseteq> x"
	using genby_lcoset_refl special_coset_singleton ordsetmap_smap
	chamber_singleton
	by fastforce
	next
	fix x y
	assume xy: "x\<noteq>y" "chamber x" "chamber y"
	from xy(2,3) obtain w w'
	where ww': "w\<in>W" "x = smap {w}" "w'\<in>W" "y = smap {w'}"
	using chamber_is_singleton
	by blast
	show "\<exists>zs. gallery (x # zs @ [y])"
	proof (cases "w=0" "w'=0" rule: two_cases)
	case both with xy(1) ww'(2,4) show ?thesis by fast
	next
	case one with ww'(2-4) show ?thesis
	using gallery_to_0 gallery_rev by fastforce
	next
	case other with ww'(1,2,4) show ?thesis using gallery_to_0 by auto
	next
	case neither
	from this ww' obtain xs ys
	where "gallery (x # xs @ [smap 0])" "gallery (smap 0 # ys @ [y])"
	using gallery_to_0 gallery_rev
	by force
	hence "gallery (x # (xs @ smap 0 # ys) @ [y])"
	using gallery_overlap_join[of "x#xs"] by simp
	thus ?thesis by fast
	qed
	qed

	lemma card_chamber: "chamber x \<Longrightarrow> card x = card S"
	using bij_betw_same_card[OF S_bij_betw_chamber0] chamber_singleton
	genby_0_closed[of S]
	ChamberComplex.chamber_card[OF ChamberComplex_\<Sigma>, of "smap 0"]
	by simp

	lemma vertex_conv_special_coset:
	"X\<in>\<Union>\<Sigma> \<Longrightarrow> \<exists>w s. w\<in>W \<and> s\<in>S \<and> X = w +o \<langle>S-{s}\<rangle>"
	using ChamberComplex.simplex_in_max[OF ChamberComplex_\<Sigma>] chamber_is_singleton
	chamber_vertex_conv_special_coset
	by fast

	end (* context CoxeterComplex *)

	subsubsection \<open>The Coxeter complex associated to a thin chamber complex with many foldings\<close>

	text \<open>
	Having previously verified that the fundamental automorphisms in a thin chamber complex with many
	foldings form a Coxeter system, we now record the existence of a chamber complex isomorphism onto
	the associated Coxeter complex.
	\<close>

	context ThinChamberComplexManyFoldings
	begin

	lemma CoxeterComplex: "CoxeterComplex S"
	by (
	rule CoxeterComplex.intro, rule CoxeterSystem, unfold_locales,
	rule finite_S
	)

	abbreviation "\<Sigma> \<equiv> CoxeterComplex.TheComplex S"

	lemma S_list_not_min_gallery_not_reduced:
	assumes "ss\<noteq>[]" "\<not> min_gallery (map (\<lambda>w. w`\<rightarrow>C0) (sums ss))"
	shows "\<not> reduced_word S ss"
	proof (cases "ss\<in>lists S")
	case True
	obtain a b as bs cs
	where "ss = as@[a]@bs@[b]@cs" "sum_list ss = sum_list (as@bs@cs)"
	using S_list_not_min_gallery_deletion [OF True assms]
	by blast
	with True show ?thesis using not_reduced_word_for[of "as@bs@cs"] by auto
	next
	case False thus ?thesis using reduced_word_for_lists by fast
	qed

	lemma reduced_S_list_min_gallery:
	"ss\<noteq>[] \<Longrightarrow> reduced_word S ss \<Longrightarrow> min_gallery (map (\<lambda>w. w`\<rightarrow>C0) (sums ss))"
	using S_list_not_min_gallery_not_reduced by fast

	lemma fundchamber_vertex_stabilizer1:
	fixes t
	defines v: "v \<equiv> fundantivertex t"
	assumes tw: "t\<in>S" "w\<in>W" "w\<rightarrow>v = v"
	shows "w \<in> \<langle>S-{t}\<rangle>"
	proof-
	from v tw(1) have v_C0: "v\<in>C0" using fundantivertex by simp
	define ss where "ss = arg_min length (word_for S w)"
	moreover
	have "reduced_word S ss \<Longrightarrow> sum_list ss \<rightarrow> v = v \<Longrightarrow> sum_list ss \<in> \<langle>S-{t}\<rangle>"
	proof (induct ss)
	case (Cons s ss)
	from Cons(2) have s_S: "s\<in>S" using reduced_word_for_lists by fastforce
	from this obtain f g
	where fg: "(f,g)\<in>fundfoldpairs" "s = Abs_induced_automorph f g"
	by auto
	from fg(1) have opp_fg: "OpposedThinChamberComplexFoldings X f g C0"
	using fundfoldpairs_def by auto
	define Cs where "Cs = map (\<lambda>w. w`\<rightarrow>C0) (sums (s#ss))"
	with Cons(2) have minCs: "min_gallery Cs"
	using reduced_S_list_min_gallery by fast
	have sv: "s\<rightarrow>v = v"
	proof (cases ss rule: rev_cases)
	case Nil with Cons(3) show ?thesis by simp
	next
	case (snoc ts t)
	define Ms Cn
	where "Ms = map (\<lambda>w. w`\<rightarrow>C0) (map ((+) s) (sums ts))"
	and "Cn = sum_list (s#ss) `\<rightarrow> C0"
	with snoc Cs_def have "Cs = C0 # Ms @ [Cn]"
	by (simp add: sums_snoc zero_permutation.rep_eq)
	with minCs Cs_def fg have "C0\<in>f\<turnstile>\<C>" "Cn\<in>g\<turnstile>\<C>"
	using sums_Cons_conv_append_tl[THEN sym, of s ss]
	wall_crossings_subset_walls_betw[of C0 Ms Cn] fundfoldpairs_def
	the_wall_betw_adj_fundchamber walls_betw_def
	OpposedThinChamberComplexFoldings.basech_halfchsys(1)[
	OF opp_fg
	]
	OpposedThinChamberComplexFoldings.separated_by_this_wall_fg[
	OF opp_fg, of C0 Cn
	]
	by (auto simp add: zero_permutation.rep_eq)
	moreover from Cons(3) Cn_def have "v\<in>Cn" using v_C0 by force
	ultimately show "s\<rightarrow>v = v"
	using v_C0 fg
	OpposedThinChamberComplexFoldings.indaut_wallvertex[
	OF opp_fg
	]
	by (simp add: permutation_conv_induced_automorph)
	qed
	moreover from Cons(3) have "0 \<rightarrow> sum_list ss \<rightarrow> v = s\<rightarrow>v"
	using s_S
	by (simp add: plus_permutation.rep_eq S_order2_add[THEN sym])
	ultimately have "sum_list ss \<rightarrow> v = v" by (simp add: zero_permutation.rep_eq)
	with Cons(1,2) have "sum_list ss \<in> \<langle>S-{t}\<rangle>"
	using reduced_word_Cons_reduce by auto
	moreover from tw(1) v have "s\<in>\<langle>S-{t}\<rangle>"
	using sv s_S genby_genset_closed[of s "S-{t}"] fundantivertex_unstable
	by fastforce
	ultimately show ?case using genby_add_closed by simp
	qed (simp add: genby_0_closed)
	ultimately show ?thesis
	using tw(2,3) reduced_word_for_genby_sym_arg_min[OF S_sym]
	reduced_word_for_sum_list
	by fastforce
	qed

	lemma fundchamber_vertex_stabilizer2:
	assumes s: "s\<in>S"
	defines v: "v \<equiv> fundantivertex s"
	shows "w \<in> \<langle>S-{s}\<rangle> \<Longrightarrow> w\<rightarrow>v = v"
	proof (erule genby.induct)
	show "0\<rightarrow>v = v" by (simp add: zero_permutation.rep_eq)
	next
	fix t assume "t\<in>S-{s}"
	moreover with s v have "v\<in>C0\<inter>t`\<rightarrow>C0"
	using inj_on_eq_iff[OF fundantivertex_inj_on] fundchamber_S_adjacent
	fundchamber_S_image_neq_fundchamber[THEN not_sym]
	not_the1[OF adj_antivertex, of C0 "t`\<rightarrow>C0" v] fundantivertex
	unfolding fundantivertex_def
	by auto
	ultimately show "t\<rightarrow>v = v"
	using S_fixespointwise_fundchamber_image_int fixespointwiseD by fastforce
	next
	fix w w' assume ww': "w\<rightarrow>v = v" "w'\<rightarrow>v = v"
	from ww'(2) have "(-w')\<rightarrow>v = id v"
	using plus_permutation.rep_eq[of "-w'" w']
	by (auto simp add: zero_permutation.rep_eq[THEN sym])
	with ww'(1) show "(w-w')\<rightarrow>v = v"
	using plus_permutation.rep_eq[of w "-w'"] by simp
	qed

	lemma label_wrt_special_coset1:
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0" "w0\<in>W" "s\<in>S"
	defines "v \<equiv> fundantivertex s"
	shows "{w\<in>W. w \<rightarrow> \<phi> (w0\<rightarrow>v) = w0\<rightarrow>v} = w0 +o \<langle>S-{s}\<rangle>"
	proof-
	from assms(4,5) have v_C0: "v\<in>C0" using fundantivertex[of s] by simp
	show ?thesis
	proof (rule seteqI)
	fix w assume "w\<in>{w\<in>W. w\<rightarrow>(\<phi> (w0\<rightarrow>v)) = w0\<rightarrow>v}"
	hence w: "w\<in>W" "w\<rightarrow>(\<phi> (w0\<rightarrow>v)) = w0\<rightarrow>v" by auto
	from assms(2,3) have "(-w0 + w) \<rightarrow> v = 0\<rightarrow>v"
	using w(2) v_C0 fundchamber chamberD_simplex
	W_respects_labels[OF assms(1)] plus_permutation.rep_eq[of "-w0" w0]
	by (fastforce simp add: plus_permutation.rep_eq fixespointwiseD)
	with assms(3-5) show "w \<in> w0 +o \<langle>S-{s}\<rangle>"
	using w(1) genby_uminus_add_closed[of w0 S w]
	fundchamber_vertex_stabilizer1
	by (force simp add: zero_permutation.rep_eq elt_set_plus_def)
	next
	fix w assume w: "w \<in> w0 +o \<langle>S-{s}\<rangle>"
	from this obtain w1 where w1: "w1 \<in> \<langle>S-{s}\<rangle>" "w = w0 + w1"
	using elt_set_plus_def by blast
	moreover with w assms(3) have w_W: "w\<in>W"
	using genby_mono[of "S-{s}" S] genby_add_closed by fastforce
	ultimately show "w\<in>{w\<in>W. w\<rightarrow>(\<phi> (w0\<rightarrow>v)) = w0\<rightarrow>v}"
	using assms(2-5) v_C0 fundchamber chamberD_simplex
	W_respects_labels[OF assms(1), of w0 v]
	fundchamber_vertex_stabilizer2[of s w1]
	by (fastforce simp add: fixespointwiseD plus_permutation.rep_eq)
	qed
	qed

	lemma label_wrt_special_coset1':
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0" "w0\<in>W" "v\<in>C0"
	defines "s \<equiv> fundantipermutation v"
	shows "{w\<in>W. w \<rightarrow> \<phi> (w0\<rightarrow>v) = w0\<rightarrow>v} = w0 +o \<langle>S-{s}\<rangle>"
	using assms fundantipermutation1 fundantivertex_bij_betw
	bij_betw_f_the_inv_into_f label_wrt_special_coset1[of \<phi> w0 s]
	by fastforce

	lemma label_wrt_special_coset2':
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0" "w0\<in>W" "v \<in> w0`\<rightarrow>C0"
	defines "s \<equiv> fundantipermutation (\<phi> v)"
	shows "{w\<in>W. w \<rightarrow> \<phi> v = v} = w0 +o \<langle>S-{s}\<rangle>"
	using assms fundchamber chamberD_simplex W_respects_labels
	label_wrt_special_coset1'[OF assms(1-3)]
	by (fastforce simp add: fixespointwiseD) (* slow *)

	lemma label_stab_map_W_fundchamber_image:
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0" "w0\<in>W"
	defines "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "\<psi>`(w0`\<rightarrow>C0) = CoxeterComplex.smap S {w0}"
	proof (rule seteqI)
	from assms
	show "\<And>x. x \<in> CoxeterComplex.smap S {w0} \<Longrightarrow> x \<in> \<psi>`(w0`\<rightarrow>C0)"
	using CoxeterComplex.chamber_vertex_conv_special_coset[
	OF CoxeterComplex, of w0
	]
	label_wrt_special_coset1 fundantivertex
	by fastforce
	next
	fix x assume "x\<in> \<psi>`(w0`\<rightarrow>C0)"
	from this obtain v where v: "v\<in>w0`\<rightarrow>C0" "x = \<psi> v" by fast
	with assms have "x = w0 +o \<langle>S-{fundantipermutation (\<phi> v)}\<rangle>"
	using label_wrt_special_coset2' by fast
	moreover from v(1) assms(3) have "v\<in>\<Union>X"
	using fundchamber chamberD_simplex W_endomorphism
	ChamberComplexEndomorphism.vertex_map
	by fastforce
	ultimately show "x \<in> CoxeterComplex.smap S {w0}"
	using assms(1,3) label_wrt_elt_image fundantipermutation1
	CoxeterComplex.chamber_vertices[OF CoxeterComplex]
	by fastforce
	qed

	lemma label_stab_map_chamber_map:
	assumes \<phi>: "label_wrt C0 \<phi>" "fixespointwise \<phi> C0"
	and C: "chamber C"
	defines \<psi>: "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "CoxeterComplex.chamber S (\<psi>`C)"
	proof-
	from C obtain w where w: "w\<in>W" "C = w`\<rightarrow>C0"
	using chamber_eq_W_image by fast
	with \<phi> \<psi> have "\<psi>`C = CoxeterComplex.smap S {w}"
	using label_stab_map_W_fundchamber_image by simp
	with w(1) show ?thesis
	using CoxeterComplex.chamber_singleton[OF CoxeterComplex] by simp
	qed

	lemma label_stab_map_inj_on_vertices:
	assumes \<phi>: "label_wrt C0 \<phi>" "fixespointwise \<phi> C0"
	defines \<psi>: "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "inj_on \<psi> (\<Union>X)"
	proof (rule inj_onI)
	fix v1 v2 assume v: "v1\<in>\<Union>X" "v2\<in>\<Union>X" "\<psi> v1 = \<psi> v2"
	from v(1,2) have \<phi>v: "\<phi> v1 \<in> C0" "\<phi> v2 \<in> C0"
	using label_wrt_elt_image[OF \<phi>(1)] by auto
	define s1 s2 where "s1 = fundantipermutation (\<phi> v1)" and "s2 = fundantipermutation (\<phi> v2)"
	from v(1,2) obtain w1 w2 where "w1\<in>W" "v1\<in>w1`\<rightarrow>C0" "w2\<in>W" "v2\<in>w2`\<rightarrow>C0"
	using simplex_in_max chamber_eq_W_image by blast
	with assms s1_def s2_def have \<psi>v: "\<psi> v1 = w1 +o \<langle>S-{s1}\<rangle>" "\<psi> v2 = w2 +o \<langle>S-{s2}\<rangle>"
	using label_wrt_special_coset2' by auto
	with v(3) have "w1 +o \<langle>S-{s1}\<rangle> = w2 +o \<langle>S-{s2}\<rangle>"
	using label_wrt_special_coset2' by auto
	with s1_def s2_def have "\<phi> v1 = \<phi> v2"
	using PreCoxeterSystemWithDeletion.special_coset_eq_imp_eq_gensets[
	OF PreCoxeterSystemWithDeletion, of "S-{s1}" "S-{s2}" w1 w2
	]
	\<phi>v fundantipermutation1[of "\<phi> v1"] fundantipermutation1[of "\<phi> v2"]
	bij_betw_f_the_inv_into_f[OF fundantivertex_bij_betw, of "\<phi> v1"]
	bij_betw_f_the_inv_into_f[OF fundantivertex_bij_betw, of "\<phi> v2"]
	by fastforce
	with v(3) \<psi> show "v1=v2"
	using \<psi>v(1) genby_0_closed[of "S-{s1}"] lcoset_refl[of "\<langle>S-{s1}\<rangle>" w1]
	by fastforce
	qed

	lemma label_stab_map_surj_on_vertices:
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0"
	defines "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "\<psi>`(\<Union>X) = \<Union>\<Sigma>"
	proof (rule seteqI)
	fix u assume "u \<in> \<psi>`(\<Union>X)"
	from this obtain v where v: "v\<in>\<Union>X" "u = \<psi> v" by fast
	from v(1) obtain w where "w\<in>W" "v\<in>w`\<rightarrow>C0"
	using simplex_in_max chamber_eq_W_image by blast
	with assms v show "u\<in>\<Union>\<Sigma>"
	using label_wrt_special_coset2' label_wrt_elt_image[OF assms(1)]
	fundantipermutation1 CoxeterComplex.vertices[OF CoxeterComplex]
	by auto
	next
	fix u assume "u\<in>\<Union>\<Sigma>"
	from this obtain w s where "w\<in>W" "s\<in>S" "u = w +o \<langle>S-{s}\<rangle>"
	using CoxeterComplex.vertex_conv_special_coset[OF CoxeterComplex] by blast
	with assms show "u \<in> \<psi>`(\<Union>X)"
	using label_wrt_special_coset1 fundantivertex fundchamber chamberD_simplex
	W_endomorphism ChamberComplexEndomorphism.vertex_map
	by fast
	qed

	lemma label_stab_map_bij_betw_vertices:
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0"
	defines "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "bij_betw \<psi> (\<Union>X) (\<Union>\<Sigma>)"
	unfolding bij_betw_def
	using assms label_stab_map_inj_on_vertices label_stab_map_surj_on_vertices
	by auto

	lemma label_stab_map_bij_betw_W_chambers:
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0" "w0\<in>W"
	defines "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "bij_betw \<psi> (w0`\<rightarrow>C0) (CoxeterComplex.smap S {w0})"
	unfolding bij_betw_def
	proof (rule conjI, rule inj_on_inverseI)
	define f1 f2
	where "f1 = the_inv_into (CoxeterComplex.smap S 0) ((+o) w0)"
	and "f2 = the_inv_into S (\<lambda>s. \<langle>S-{s}\<rangle>)"
	define g where "g = ((\<rightarrow>) w0) \<circ> fundantivertex \<circ> f2 \<circ> f1"

	from assms(3) have inj_opw0: "inj_on ((+o) w0) (CoxeterComplex.smap S 0)"
	using bij_betw_imp_inj_on[OF CoxeterComplex.W_lcoset_bij_betw_singletons]
	CoxeterComplex
	by fast
	have inj_genby_minus_s: "inj_on (\<lambda>s. \<langle>S-{s}\<rangle>) S"
	using bij_betw_imp_inj_on[OF CoxeterComplex.S_bij_betw_chamber0]
	CoxeterComplex
	by fast

	fix v assume v: "v\<in>w0`\<rightarrow>C0"
	from this obtain v0 where v0: "v0\<in>C0" "v = w0\<rightarrow>v0" by fast
	from v0(1) have fap_v0: "fundantipermutation v0 \<in> S"
	using fundantipermutation1 by auto
	with assms(3)
	have v0': "\<langle>S-{fundantipermutation v0}\<rangle> \<in> CoxeterComplex.smap S 0"
	using genby_0_closed[of S]
	CoxeterComplex.chamber_vertices[OF CoxeterComplex, of 0]
	by simp

	from v0 assms have "\<psi> v = w0 +o \<langle>S-{fundantipermutation v0}\<rangle>"
	using label_wrt_special_coset1' by simp
	with f1_def assms(3) f2_def v0 g_def show "g (\<psi> v) = v"
	using v0' fap_v0 the_inv_into_f_f[OF inj_opw0]
	the_inv_into_f_f[OF inj_genby_minus_s]
	bij_betw_f_the_inv_into_f[OF fundantivertex_bij_betw]
	by simp
	next
	from assms show "\<psi>`(w0`\<rightarrow>C0) = CoxeterComplex.smap S {w0}"
	using label_stab_map_W_fundchamber_image by simp
	qed

	lemma label_stab_map_surj_on_simplices:
	assumes \<phi>: "label_wrt C0 \<phi>" "fixespointwise \<phi> C0"
	defines \<psi>: "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "\<psi> \<turnstile> X = \<Sigma>"
	proof (rule seteqI)
	fix y assume "y \<in> \<psi> \<turnstile> X"
	from this obtain x where x: "x\<in>X" "y = \<psi> ` x" by fast
	from x(1) obtain C where "chamber C" "x\<subseteq>C" using simplex_in_max by fast
	with assms x(2) show "y \<in> \<Sigma>"
	using label_stab_map_chamber_map
	CoxeterComplex.chamberD_simplex[OF CoxeterComplex]
	CoxeterComplex.faces[OF CoxeterComplex, of "\<psi>`C" y]
	by auto
	next
	fix y assume "y \<in> \<Sigma>"
	from this obtain z where z: "CoxeterComplex.chamber S z" "y\<subseteq>z"
	using ChamberComplex.simplex_in_max[
	OF CoxeterComplex.ChamberComplex_\<Sigma>,
	OF CoxeterComplex
	]
	by fast
	from z(1) obtain w where w: "w\<in>W" "z = CoxeterComplex.smap S {w}"
	using CoxeterComplex.chamber_is_singleton[OF CoxeterComplex] by fast
	with assms have "bij_betw \<psi> (w`\<rightarrow>C0) z"
	using label_stab_map_bij_betw_W_chambers by fast
	hence 1: "bij_betw ((`) \<psi>) (Pow (w`\<rightarrow>C0)) (Pow z)"
	using bij_betw_imp_bij_betw_Pow by fast
	define x where x: "x \<equiv> the_inv_into (Pow (w`\<rightarrow>C0)) ((`) \<psi>) y"
	with z(2) have "x \<subseteq> w`\<rightarrow>C0" using bij_betw_the_inv_into_onto[OF 1] by auto
	with w(1) have "x\<in>X"
	using faces fundchamber_W_image_chamber chamberD_simplex
	by fastforce
	moreover from x z(2) have "y = \<psi> ` x"
	using bij_betw_f_the_inv_into_f[OF 1] by simp
	ultimately show "y \<in> \<psi> \<turnstile> X" by fast
	qed

	lemma label_stab_map_iso_to_coxeter_complex:
	assumes "label_wrt C0 \<phi>" "fixespointwise \<phi> C0"
	defines "\<psi> \<equiv> \<lambda>v. {w\<in>W. w\<rightarrow>(\<phi> v) = v}"
	shows "ChamberComplexIsomorphism X \<Sigma> \<psi>"
	proof (
	rule ChamberComplexIsomorphism.intro,
	rule ChamberComplexMorphism.intro
	)
	show "ChamberComplex X" ..
	show "ChamberComplex \<Sigma>"
	using CoxeterComplex CoxeterComplex.ChamberComplex_\<Sigma> by fast
	from assms show "ChamberComplexMorphism_axioms X \<Sigma> \<psi>"
	using label_stab_map_chamber_map
	CoxeterComplex.card_chamber[OF CoxeterComplex]
	card_S_chamber
	by unfold_locales auto
	from assms show "ChamberComplexIsomorphism_axioms X \<Sigma> \<psi>"
	using label_stab_map_bij_betw_vertices label_stab_map_surj_on_simplices
	by unfold_locales auto
	qed

	lemma ex_iso_to_coxeter_complex':
	"\<exists>\<psi>. ChamberComplexIsomorphism X (CoxeterComplex.TheComplex S) \<psi>"
	using CoxeterComplex ex_label_retraction label_stab_map_iso_to_coxeter_complex
	by force

	lemma ex_iso_to_coxeter_complex:
	"\<exists>S::'a permutation set. CoxeterComplex S \<and>
	(\<exists>\<psi>. ChamberComplexIsomorphism X (CoxeterComplex.TheComplex S) \<psi>)"
	using CoxeterComplex ex_iso_to_coxeter_complex' by fast

	end (* context ThinChamberComplexManyFoldings *)



	end (* theory *)
	diff --git a/thys/Buildings/Prelim.thy b/thys/Buildings/Prelim.thy
	--- a/thys/Buildings/Prelim.thy
	+++ b/thys/Buildings/Prelim.thy
	@@ -1,1725 +1,1713 @@
	section \<open>Preliminaries\<close>

	text \<open>
	In this section, we establish some basic facts about natural numbers, logic, sets, functions and
	relations, lists, and orderings and posets, that are either not available in the HOL library or
	are in a form not suitable for our purposes.
	\<close>

	theory Prelim
	imports Main "HOL-Library.Set_Algebras"
	begin

	declare image_cong_simp [cong del]

	subsection \<open>Natural numbers\<close>

	lemma nat_cases_2Suc [case_names 0 1 SucSuc]:
	assumes 0: "n = 0 \<Longrightarrow> P"
	and 1: "n = 1 \<Longrightarrow> P"
	and SucSuc: "\<And>m. n = Suc (Suc m) \<Longrightarrow> P"
	shows "P"
	proof (cases n)
	case (Suc m) with 1 SucSuc show ?thesis by (cases m) auto
	qed (simp add: 0)

	lemma nat_even_induct [case_names _ 0 SucSuc]:
	assumes even: "even n"
	and 0: "P 0"
	and SucSuc: "\<And>m. even m \<Longrightarrow> P m \<Longrightarrow> P (Suc (Suc m))"
	shows "P n"
	proof-
	from assms obtain k where "n = 2*k" using evenE by auto
	moreover from assms have "P (2*k)" by (induct k) auto
	ultimately show ?thesis by fast
	qed

	lemma nat_induct_step2 [case_names 0 1 SucSuc]:
	assumes 0: "P 0"
	and 1: "P 1"
	and SucSuc: "\<And>m. P m \<Longrightarrow> P (Suc (Suc m))"
	shows "P n"
	proof (cases "even n")
	case True
	from this obtain k where "n = 2*k" using evenE by auto
	moreover have "P (2*k)" using 0 SucSuc by (induct k) auto
	ultimately show ?thesis by fast
	next
	case False
	from this obtain k where "n = 2*k+1" using oddE by blast
	moreover have "P (2*k+1)" using 1 SucSuc by (induct k) auto
	ultimately show ?thesis by fast
	qed


	subsection \<open>Logic\<close>

	lemma ex1_unique: "\<exists>!x. P x \<Longrightarrow> P a \<Longrightarrow> P b \<Longrightarrow> a=b"
	by blast

	lemma not_the1:
	assumes "\<exists>!x. P x" "y \<noteq> (THE x. P x)"
	shows "\<not> P y"
	using assms(2) the1_equality[OF assms(1)]
	by auto

	lemma two_cases [case_names both one other neither]:
	assumes both : "P \<Longrightarrow> Q \<Longrightarrow> R"
	and one : "P \<Longrightarrow> \<not>Q \<Longrightarrow> R"
	and other : "\<not>P \<Longrightarrow> Q \<Longrightarrow> R"
	and neither: "\<not>P \<Longrightarrow> \<not>Q \<Longrightarrow> R"
	shows "R"
	using assms
	by fast


	subsection \<open>Sets\<close>

	lemma bex1_equality: "\<lbrakk> \<exists>!x\<in>A. P x; x\<in>A; P x; y\<in>A; P y \<rbrakk> \<Longrightarrow> x=y"
	by blast

	lemma prod_ballI: "(\<And>a b. (a,b)\<in>A \<Longrightarrow> P a b) \<Longrightarrow> \<forall>(a,b)\<in>A. P a b"
	by fast

	lemmas seteqI = set_eqI[OF iffI]

	lemma set_decomp_subset:
	"\<lbrakk> U = A\<union>B; A\<subseteq>X; B\<subseteq>Y; X\<subseteq>U; X\<inter>Y = {} \<rbrakk> \<Longrightarrow> A = X"
	by auto

	lemma insert_subset_equality: "\<lbrakk> a\<notin>A; a\<notin>B; insert a A = insert a B \<rbrakk> \<Longrightarrow> A=B"
	by auto

	lemma insert_compare_element: "a\<notin>A \<Longrightarrow> insert b A = insert a A \<Longrightarrow> b=a"
	by auto

	lemma card1:
	assumes "card A = 1"
	shows "\<exists>a. A = {a}"
	proof-
	from assms obtain a where a: "a \<in> A" by fastforce
	with assms show ?thesis using card_ge_0_finite[of A] card_subset_eq[of A "{a}"] by auto
	qed

	lemma singleton_pow: "a\<in>A \<Longrightarrow> {a}\<in>Pow A"
	using Pow_mono Pow_top by fast

	definition separated_by :: "'a set set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
	where "separated_by w x y \<equiv> \<exists>A B. w={A,B} \<and> x\<in>A \<and> y\<in>B"

	lemma separated_byI: "x\<in>A \<Longrightarrow> y\<in>B \<Longrightarrow> separated_by {A,B} x y"
	using separated_by_def by fastforce

	lemma separated_by_disjoint: "\<lbrakk> separated_by {A,B} x y; A\<inter>B={}; x\<in>A \<rbrakk> \<Longrightarrow> y\<in>B"
	unfolding separated_by_def by fast

	lemma separated_by_in_other: "separated_by {A,B} x y \<Longrightarrow> x\<notin>A \<Longrightarrow> x\<in>B \<and> y\<in>A"
	unfolding separated_by_def by auto

	lemma separated_by_not_empty: "separated_by w x y \<Longrightarrow> w\<noteq>{}"
	unfolding separated_by_def by fast

	lemma not_self_separated_by_disjoint: "A\<inter>B={} \<Longrightarrow> \<not> separated_by {A,B} x x"
	unfolding separated_by_def by auto

	subsection \<open>Functions and relations\<close>

	subsubsection \<open>Miscellaneous\<close>

	lemma cong_let: "(let x = y in f x) = f y" by simp

	lemma sym_sym: "sym (A\<times>A)" by (fast intro: symI)

	lemma trans_sym: "trans (A\<times>A)" by (fast intro: transI)

	lemma map_prod_sym: "sym A \<Longrightarrow> sym (map_prod f f ` A)"
	using symD[of A] map_prod_def by (fast intro: symI)

	abbreviation restrict1 :: "('a\<Rightarrow>'a) \<Rightarrow> 'a set \<Rightarrow> ('a\<Rightarrow>'a)"
	where "restrict1 f A \<equiv> (\<lambda>a. if a\<in>A then f a else a)"

	lemma restrict1_image: "B\<subseteq>A \<Longrightarrow> restrict1 f A ` B = f`B"
	by auto

	subsubsection \<open>Equality of functions restricted to a set\<close>

	definition "fun_eq_on f g A \<equiv> (\<forall>a\<in>A. f a = g a)"

	lemma fun_eq_onI: "(\<And>a. a\<in>A \<Longrightarrow> f a = g a) \<Longrightarrow> fun_eq_on f g A"
	using fun_eq_on_def by fast

	lemma fun_eq_onD: "fun_eq_on f g A \<Longrightarrow> a \<in> A \<Longrightarrow> f a = g a"
	using fun_eq_on_def by fast

	lemma fun_eq_on_UNIV: "(fun_eq_on f g UNIV) = (f=g)"
	unfolding fun_eq_on_def by fast

	lemma fun_eq_on_subset: "fun_eq_on f g A \<Longrightarrow> B\<subseteq>A \<Longrightarrow> fun_eq_on f g B"
	unfolding fun_eq_on_def by fast

	lemma fun_eq_on_sym: "fun_eq_on f g A \<Longrightarrow> fun_eq_on g f A"
	using fun_eq_onD by (fastforce intro: fun_eq_onI)

	lemma fun_eq_on_trans: "fun_eq_on f g A \<Longrightarrow> fun_eq_on g h A \<Longrightarrow> fun_eq_on f h A"
	using fun_eq_onD fun_eq_onD by (fastforce intro: fun_eq_onI)

	lemma fun_eq_on_cong: "fun_eq_on f h A \<Longrightarrow> fun_eq_on g h A \<Longrightarrow> fun_eq_on f g A"
	using fun_eq_on_trans fun_eq_on_sym by fastforce

	lemma fun_eq_on_im : "fun_eq_on f g A \<Longrightarrow> B\<subseteq>A \<Longrightarrow> f`B = g`B"
	using fun_eq_onD by force

	lemma fun_eq_on_subset_and_diff_imp_eq_on:
	assumes "A\<subseteq>B" "fun_eq_on f g A" "fun_eq_on f g (B-A)"
	shows "fun_eq_on f g B"
	proof (rule fun_eq_onI)
	fix x assume "x\<in>B" with assms(1) show "f x = g x"
	using fun_eq_onD[OF assms(2)] fun_eq_onD[OF assms(3)]
	by (cases "x\<in>A") auto
	qed

	lemma fun_eq_on_set_and_comp_imp_eq:
	"fun_eq_on f g A \<Longrightarrow> fun_eq_on f g (-A) \<Longrightarrow> f = g"
	using fun_eq_on_subset_and_diff_imp_eq_on[of A UNIV]
	by (simp add: Compl_eq_Diff_UNIV fun_eq_on_UNIV)

	lemma fun_eq_on_bij_betw: "fun_eq_on f g A \<Longrightarrow> bij_betw f A B = bij_betw g A B"
	using bij_betw_cong unfolding fun_eq_on_def by fast

	lemma fun_eq_on_restrict1: "fun_eq_on (restrict1 f A) f A"
	by (auto intro: fun_eq_onI)

	abbreviation "fixespointwise f A \<equiv> fun_eq_on f id A"

	lemmas fixespointwiseI = fun_eq_onI [of _ _ id]
	lemmas fixespointwiseD = fun_eq_onD [of _ id]
	lemmas fixespointwise_cong = fun_eq_on_trans [of _ _ _ id]
	lemmas fixespointwise_subset = fun_eq_on_subset [of _ id]
	lemmas fixespointwise2_imp_eq_on = fun_eq_on_cong [of _ id]

	lemmas fixespointwise_subset_and_diff_imp_eq_on =
	fun_eq_on_subset_and_diff_imp_eq_on[of _ _ _ id]

	lemma id_fixespointwise: "fixespointwise id A"
	using fun_eq_on_def by fast

	lemma fixespointwise_im: "fixespointwise f A \<Longrightarrow> B\<subseteq>A \<Longrightarrow> f`B = B"
	by (auto simp add: fun_eq_on_im)

	lemma fixespointwise_comp:
	"fixespointwise f A \<Longrightarrow> fixespointwise g A \<Longrightarrow> fixespointwise (g\<circ>f) A"
	unfolding fun_eq_on_def by simp

	lemma fixespointwise_insert:
	assumes "fixespointwise f A" "f ` (insert a A) = insert a A"
	shows "fixespointwise f (insert a A)"
	using assms(2) insert_compare_element[of a A "f a"]
	fixespointwiseD[OF assms(1)] fixespointwise_im[OF assms(1)]
	by (cases "a\<in>A") (auto intro: fixespointwiseI)

	lemma fixespointwise_restrict1:
	"fixespointwise f A \<Longrightarrow> fixespointwise (restrict1 f B) A"
	using fixespointwiseD[of f] by (auto intro: fixespointwiseI)

	lemma fold_fixespointwise:
	"\<forall>x\<in>set xs. fixespointwise (f x) A \<Longrightarrow> fixespointwise (fold f xs) A"
	proof (induct xs)
	case Nil show ?case using id_fixespointwise subst[of id] by fastforce
	next
	case (Cons x xs)
	hence "fixespointwise (fold f xs \<circ> f x) A"
	using fixespointwise_comp[of "f x" A "fold f xs"] by fastforce
	moreover have "fold f xs \<circ> f x = fold f (x#xs)" by simp
	ultimately show ?case using subst[of _ _ "\<lambda>f. fixespointwise f A"] by fast
	qed

	lemma funpower_fixespointwise:
	assumes "fixespointwise f A"
	shows "fixespointwise (f^^n) A"
	proof (induct n)
	case 0 show ?case using id_fixespointwise subst[of id] by fastforce
	next
	case (Suc m)
	with assms have "fixespointwise (f \<circ> (f^^m)) A"
	using fixespointwise_comp by fast
	moreover have "f \<circ> (f^^m) = f^^(Suc m)" by simp
	ultimately show ?case using subst[of _ _ "\<lambda>f. fixespointwise f A"] by fast
	qed

	subsubsection \<open>Injectivity, surjectivity, bijectivity, and inverses\<close>

	lemma inj_on_to_singleton:
	assumes "inj_on f A" "f`A = {b}"
	shows "\<exists>a. A = {a}"
	proof-
	from assms(2) obtain a where a: "a\<in>A" "f a = b" by force
	with assms have "A = {a}" using inj_onD[of f A] by blast
	thus ?thesis by fast
	qed

	lemmas inj_inj_on = subset_inj_on[of _ UNIV, OF _ subset_UNIV]

	lemma inj_on_eq_image': "\<lbrakk> inj_on f A; X\<subseteq>A; Y\<subseteq>A; f`X\<subseteq>f`Y \<rbrakk> \<Longrightarrow> X\<subseteq>Y"
	unfolding inj_on_def by fast

	lemma inj_on_eq_image: "\<lbrakk> inj_on f A; X\<subseteq>A; Y\<subseteq>A; f`X=f`Y \<rbrakk> \<Longrightarrow> X=Y"
	using inj_on_eq_image'[of f A X Y] inj_on_eq_image'[of f A Y X] by simp

	lemmas inj_eq_image = inj_on_eq_image[OF _ subset_UNIV subset_UNIV]

	lemma induced_pow_fun_inj_on:
	assumes "inj_on f A"
	shows "inj_on ((`) f) (Pow A)"
	using inj_onD[OF assms] inj_onI[of "Pow A" "(`) f"]
	by blast

	lemma inj_on_minus_set: "inj_on ((-) A) (Pow A)"
	by (fast intro: inj_onI)

	lemma induced_pow_fun_surj:
	"((`) f) ` (Pow A) = Pow (f`A)"
	proof (rule seteqI)
	fix X show "X \<in> ((`) f) ` (Pow A) \<Longrightarrow> X \<in> Pow (f`A)" by fast
	next
	fix Y assume Y: "Y \<in> Pow (f`A)"
	moreover hence "Y = f`{a\<in>A. f a \<in> Y}" by fast
	ultimately show "Y\<in> ((`) f) ` (Pow A)" by auto
	qed

	lemma bij_betw_f_the_inv_into_f:
	"bij_betw f A B \<Longrightarrow> y\<in>B \<Longrightarrow> f (the_inv_into A f y) = y"
	\<comment> \<open>an equivalent lemma appears in the HOL library, but this version avoids the double
	@{const bij_betw} premises\<close>
	unfolding bij_betw_def by (blast intro: f_the_inv_into_f)

	lemma bij_betw_the_inv_into_onto: "bij_betw f A B \<Longrightarrow> the_inv_into A f ` B = A"
	unfolding bij_betw_def by force

	lemma bij_betw_imp_bij_betw_Pow:
	assumes "bij_betw f A B"
	shows "bij_betw ((`) f) (Pow A) (Pow B)"
	unfolding bij_betw_def
	proof (rule conjI, rule inj_onI)
	show "\<And>x y. \<lbrakk> x\<in>Pow A; y\<in>Pow A; f`x = f`y \<rbrakk> \<Longrightarrow> x=y"
	using inj_onD[OF bij_betw_imp_inj_on, OF assms] by blast
	show "(`) f ` Pow A = Pow B"
	proof
	show "(`) f ` Pow A \<subseteq> Pow B" using bij_betw_imp_surj_on[OF assms] by fast
	show "(`) f ` Pow A \<supseteq> Pow B"
	proof
	fix y assume y: "y\<in>Pow B"
	with assms have "y = f ` the_inv_into A f ` y"
	using bij_betw_f_the_inv_into_f[THEN sym] by fastforce
	moreover from y assms have "the_inv_into A f ` y \<subseteq> A"
	using bij_betw_the_inv_into_onto by fastforce
	ultimately show "y \<in> (`) f ` Pow A" by auto
	qed
	qed
	qed

	lemma comps_fixpointwise_imp_bij_betw:
	assumes "f`X\<subseteq>Y" "g`Y\<subseteq>X" "fixespointwise (g\<circ>f) X" "fixespointwise (f\<circ>g) Y"
	shows "bij_betw f X Y"
	unfolding bij_betw_def
	proof
	show "inj_on f X"
	proof (rule inj_onI)
	fix x y show "\<lbrakk> x\<in>X; y\<in>X; f x = f y \<rbrakk> \<Longrightarrow> x=y"
	using fixespointwiseD[OF assms(3), of x] fixespointwiseD[OF assms(3), of y]
	by simp
	qed
	from assms(1,2) show "f`X = Y" using fixespointwiseD[OF assms(4)] by force
	qed

	lemma set_permutation_bij_restrict1:
	assumes "bij_betw f A A"
	shows "bij (restrict1 f A)"
	proof (rule bijI)
	have bij_f: "inj_on f A" "f`A = A" using iffD1[OF bij_betw_def, OF assms] by auto
	show "inj (restrict1 f A)"
	proof (rule injI)
	fix x y show "restrict1 f A x = restrict1 f A y \<Longrightarrow> x=y"
	using inj_onD bij_f by (cases "x\<in>A" "y\<in>A" rule: two_cases) auto
	qed
	show "surj (restrict1 f A)"
	proof (rule surjI)
	fix x
	define y where "y \<equiv> restrict1 (the_inv_into A f) A x"
	thus "restrict1 f A y = x"
	using the_inv_into_into[of f] bij_f f_the_inv_into_f[of f] by (cases "x\<in>A") auto
	qed
	qed

	lemma set_permutation_the_inv_restrict1:
	assumes "bij_betw f A A"
	shows "the_inv (restrict1 f A) = restrict1 (the_inv_into A f) A"
	proof (rule ext, rule the_inv_into_f_eq)
	from assms show "inj (restrict1 f A)"
	using bij_is_inj set_permutation_bij_restrict1 by fast
	next
	fix a from assms show "restrict1 f A (restrict1 (the_inv_into A f) A a) = a"
	using bij_betw_def[of f] by (simp add: the_inv_into_into f_the_inv_into_f)
	qed simp

	lemma the_inv_into_the_inv_into:
	"inj_on f A \<Longrightarrow> a\<in>A \<Longrightarrow> the_inv_into (f`A) (the_inv_into A f) a = f a"
	using inj_on_the_inv_into by (force intro: the_inv_into_f_eq imageI)

	lemma the_inv_into_f_im_f_im:
	assumes "inj_on f A" "x\<subseteq>A"
	shows "the_inv_into A f ` f ` x = x"
	using assms(2) the_inv_into_f_f[OF assms(1)]
	by force

	lemma f_im_the_inv_into_f_im:
	assumes "inj_on f A" "x\<subseteq>f`A"
	shows "f ` the_inv_into A f ` x = x"
	using assms(2) f_the_inv_into_f[OF assms(1)]
	by force

	lemma the_inv_leftinv: "bij f \<Longrightarrow> the_inv f \<circ> f = id"
	using bij_def[of f] the_inv_f_f by fastforce


	subsubsection \<open>Induced functions on sets of sets and lists of sets\<close>

	text \<open>
	Here we create convenience abbreviations for distributing a function over a set of sets and over
	a list of sets.
	\<close>

	abbreviation setsetmapim :: "('a\<Rightarrow>'b) \<Rightarrow> 'a set set \<Rightarrow> 'b set set" (infix "\<turnstile>" 70)
	where "f\<turnstile>X \<equiv> ((`) f) ` X"

	abbreviation setlistmapim :: "('a\<Rightarrow>'b) \<Rightarrow> 'a set list \<Rightarrow> 'b set list" (infix "\<Turnstile>" 70)
	where "f\<Turnstile>Xs \<equiv> map ((`) f) Xs"

	lemma setsetmapim_comp: "(f\<circ>g)\<turnstile>A = f\<turnstile>(g\<turnstile>A)"
	by (auto simp add: image_comp)

	lemma setlistmapim_comp: "(f\<circ>g)\<Turnstile>xs = f\<Turnstile>(g\<Turnstile>xs)"
	by auto

	lemma setsetmapim_cong_subset:
	assumes "fun_eq_on g f (\<Union>A)" "B\<subseteq>A"
	shows "g\<turnstile>B \<subseteq> f\<turnstile>B"
	proof
	fix y assume "y \<in> g\<turnstile>B"
	from this obtain x where "x\<in>B" "y = g`x" by fast
	with assms(2) show "y \<in> f\<turnstile>B" using fun_eq_on_im[OF assms(1), of x] by fast
	qed

	lemma setsetmapim_cong:
	assumes "fun_eq_on g f (\<Union>A)" "B\<subseteq>A"
	shows "g\<turnstile>B = f\<turnstile>B"
	using setsetmapim_cong_subset[OF assms]
	setsetmapim_cong_subset[OF fun_eq_on_sym, OF assms]
	by fast

	lemma setsetmapim_restrict1: "B\<subseteq>A \<Longrightarrow> restrict1 f (\<Union>A) \<turnstile> B = f\<turnstile>B"
	using setsetmapim_cong[of _ f] fun_eq_on_restrict1[of "\<Union>A" f] by simp

	lemma setsetmapim_the_inv_into:
	assumes "inj_on f (\<Union>A)"
	shows "(the_inv_into (\<Union>A) f) \<turnstile> (f\<turnstile>A) = A"
	proof (rule seteqI)
	fix x assume "x \<in> (the_inv_into (\<Union>A) f) \<turnstile> (f\<turnstile>A)"
	from this obtain y where y: "y \<in> f\<turnstile>A" "x = the_inv_into (\<Union>A) f ` y" by auto
	from y(1) obtain z where z: "z\<in>A" "y = f`z" by fast
	moreover from z(1) have "the_inv_into (\<Union>A) f ` f ` z = z"
	using the_inv_into_f_f[OF assms] by force
	ultimately show "x\<in>A" using y(2) the_inv_into_f_im_f_im[OF assms] by simp
	next
	fix x assume x: "x\<in>A"
	moreover hence "the_inv_into (\<Union>A) f ` f ` x = x"
	using the_inv_into_f_im_f_im[OF assms, of x] by fast
	ultimately show "x \<in> (the_inv_into (\<Union>A) f) \<turnstile> (f\<turnstile>A)" by auto
	qed


	subsubsection \<open>Induced functions on quotients\<close>

	text \<open>
	Here we construct the induced function on a quotient for an inducing function that respects the
	relation that defines the quotient.
	\<close>

	lemma respects_imp_unique_image_rel: "f respects r \<Longrightarrow> y\<in>f`r``{a} \<Longrightarrow> y = f a"
	using congruentD[of r f] by auto

	lemma ex1_class_image:
	assumes "refl_on A r" "f respects r" "X\<in>A//r"
	shows "\<exists>!b. b\<in>f`X"
	proof-
	from assms(3) obtain a where a: "a\<in>A" "X = r``{a}" by (auto intro: quotientE)
	thus ?thesis
	using refl_onD[OF assms(1)] ex1I[of _ "f a"]
	respects_imp_unique_image_rel[OF assms(2), of _ a]
	by force
	qed

	definition quotientfun :: "('a\<Rightarrow>'b) \<Rightarrow> 'a set \<Rightarrow> 'b"
	where "quotientfun f X = (THE b. b\<in>f`X)"

	lemma quotientfun_equality:
	assumes "refl_on A r" "f respects r" "X\<in>A//r" "b\<in>f`X"
	shows "quotientfun f X = b"
	unfolding quotientfun_def
	using assms(4) ex1_class_image[OF assms(1-3)]
	by (auto intro: the1_equality)

	lemma quotientfun_classrep_equality:
	"\<lbrakk> refl_on A r; f respects r; a\<in>A \<rbrakk> \<Longrightarrow> quotientfun f (r``{a}) = f a"
	using refl_onD by (fastforce intro: quotientfun_equality quotientI)


	subsubsection \<open>Support of a function\<close>

	definition supp :: "('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a set" where "supp f = {x. f x \<noteq> 0}"

	lemma suppI_contra: "x \<notin> supp f \<Longrightarrow> f x = 0"
	using supp_def by fast

	lemma suppD_contra: "f x = 0 \<Longrightarrow> x \<notin> supp f"
	using supp_def by fast

	abbreviation restrict0 :: "('a\<Rightarrow>'b::zero) \<Rightarrow> 'a set \<Rightarrow> ('a\<Rightarrow>'b)"
	where "restrict0 f A \<equiv> (\<lambda>a. if a \<in> A then f a else 0)"

	lemma supp_restrict0 : "supp (restrict0 f A) \<subseteq> A"
	proof-
	have "\<And>a. a \<notin> A \<Longrightarrow> a \<notin> supp (restrict0 f A)"
	using suppD_contra[of "restrict0 f A"] by simp
	thus ?thesis by fast
	qed


	subsection \<open>Lists\<close>


	subsubsection \<open>Miscellaneous facts\<close>

	lemma snoc_conv_cons: "\<exists>x xs. ys@[y] = x#xs"
	by (cases ys) auto

	lemma cons_conv_snoc: "\<exists>ys y. x#xs = ys@[y]"
	by (cases xs rule: rev_cases) auto

	-lemma same_length_eq_append:
	- "length as = length bs \<Longrightarrow> as@cs = bs@ds \<Longrightarrow> as = bs"
	- by (induct as bs rule: list_induct2) auto
	-
	-lemma count_list_append:
	- "count_list (xs@ys) a = count_list xs a + count_list ys a"
	- by (induct xs) auto
	-
	-lemma count_list_snoc:
	- "count_list (xs@[x]) y = (if y=x then Suc (count_list xs y) else count_list xs y)"
	- by (induct xs) auto
	-
	lemma distinct_count_list:
	"distinct xs \<Longrightarrow> count_list xs a = (if a \<in> set xs then 1 else 0)"
	by (induct xs) auto

	lemma map_fst_map_const_snd: "map fst (map (\<lambda>s. (s,b)) xs) = xs"
	by (induct xs) auto

	lemma inj_on_distinct_setlistmapim:
	assumes "inj_on f A"
	shows "\<forall>X\<in>set Xs. X \<subseteq> A \<Longrightarrow> distinct Xs \<Longrightarrow> distinct (f\<Turnstile>Xs)"
	proof (induct Xs)
	case (Cons X Xs)
	show ?case
	proof (cases "f`X \<in> set (f\<Turnstile>Xs)")
	case True
	from this obtain Y where Y: "Y\<in>set Xs" "f`X = f`Y" by auto
	with assms Y(1) Cons(2,3) show ?thesis
	using inj_on_eq_image[of f A X Y] by fastforce
	next
	case False with Cons show ?thesis by simp
	qed
	qed simp

	subsubsection \<open>Cases\<close>

	lemma list_cases_Cons_snoc [case_names Nil Single Cons_snoc]:
	assumes Nil: "xs = [] \<Longrightarrow> P"
	and Single: "\<And>x. xs = [x] \<Longrightarrow> P"
	and Cons_snoc: "\<And>x ys y. xs = x # ys @ [y] \<Longrightarrow> P"
	shows "P"
	proof (cases xs, rule Nil)
	case (Cons x xs) with Single Cons_snoc show ?thesis
	by (cases xs rule: rev_cases) auto
	qed

	lemma two_lists_cases_Cons_Cons [case_names Nil1 Nil2 ConsCons]:
	assumes Nil1: "\<And>ys. as = [] \<Longrightarrow> bs = ys \<Longrightarrow> P"
	and Nil2: "\<And>xs. as = xs \<Longrightarrow> bs = [] \<Longrightarrow> P"
	and ConsCons: "\<And>x xs y ys. as = x # xs \<Longrightarrow> bs = y # ys \<Longrightarrow> P"
	shows "P"
	proof (cases as)
	case Cons with assms(2,3) show ?thesis by (cases bs) auto
	qed (simp add: Nil1)

	lemma two_lists_cases_snoc_Cons [case_names Nil1 Nil2 snoc_Cons]:
	assumes Nil1: "\<And>ys. as = [] \<Longrightarrow> bs = ys \<Longrightarrow> P"
	and Nil2: "\<And>xs. as = xs \<Longrightarrow> bs = [] \<Longrightarrow> P"
	and snoc_Cons: "\<And>xs x y ys. as = xs @ [x] \<Longrightarrow> bs = y # ys \<Longrightarrow> P"
	shows "P"
	proof (cases as rule: rev_cases)
	case snoc with Nil2 snoc_Cons show ?thesis by (cases bs) auto
	qed (simp add: Nil1)

	lemma two_lists_cases_snoc_Cons' [case_names both_Nil Nil1 Nil2 snoc_Cons]:
	assumes both_Nil: "as = [] \<Longrightarrow> bs = [] \<Longrightarrow> P"
	and Nil1: "\<And>y ys. as = [] \<Longrightarrow> bs = y#ys \<Longrightarrow> P"
	and Nil2: "\<And>xs x. as = xs@[x] \<Longrightarrow> bs = [] \<Longrightarrow> P"
	and snoc_Cons: "\<And>xs x y ys. as = xs @ [x] \<Longrightarrow> bs = y # ys \<Longrightarrow> P"
	shows "P"
	proof (cases as bs rule: two_lists_cases_snoc_Cons)
	case (Nil1 ys) with assms(1,2) show "P" by (cases ys) auto
	next
	case (Nil2 xs) with assms(1,3) show "P" by (cases xs rule: rev_cases) auto
	qed (rule snoc_Cons)

	lemma two_prod_lists_cases_snoc_Cons:
	assumes "\<And>xs. as = xs \<Longrightarrow> bs = [] \<Longrightarrow> P" "\<And>ys. as = [] \<Longrightarrow> bs = ys \<Longrightarrow> P"
	"\<And>xs aa ba ab bb ys. as = xs @ [(aa, ba)] \<and> bs = (ab, bb) # ys \<Longrightarrow> P"
	shows "P"
	proof (rule two_lists_cases_snoc_Cons)
	from assms
	show "\<And>ys. as = [] \<Longrightarrow> bs = ys \<Longrightarrow> P" "\<And>xs. as = xs \<Longrightarrow> bs = [] \<Longrightarrow> P"
	by auto
	from assms(3) show "\<And>xs x y ys. as = xs @ [x] \<Longrightarrow> bs = y # ys \<Longrightarrow> P"
	by fast
	qed

	lemma three_lists_cases_snoc_mid_Cons
	[case_names Nil1 Nil2 Nil3 snoc_single_Cons snoc_mid_Cons]:
	assumes Nil1: "\<And>ys zs. as = [] \<Longrightarrow> bs = ys \<Longrightarrow> cs = zs \<Longrightarrow> P"
	and Nil2: "\<And>xs zs. as = xs \<Longrightarrow> bs = [] \<Longrightarrow> cs = zs \<Longrightarrow> P"
	and Nil3: "\<And>xs ys. as = xs \<Longrightarrow> bs = ys \<Longrightarrow> cs = [] \<Longrightarrow> P"
	and snoc_single_Cons:
	"\<And>xs x y z zs. as = xs @ [x] \<Longrightarrow> bs = [y] \<Longrightarrow> cs = z # zs \<Longrightarrow> P"
	and snoc_mid_Cons:
	"\<And>xs x w ys y z zs. as = xs @ [x] \<Longrightarrow> bs = w # ys @ [y] \<Longrightarrow>
	cs = z # zs \<Longrightarrow> P"
	shows "P"
	proof (cases as cs rule: two_lists_cases_snoc_Cons)
	case Nil1 with assms(1) show "P" by simp
	next
	case Nil2 with assms(3) show "P" by simp
	next
	case snoc_Cons
	with Nil2 snoc_single_Cons snoc_mid_Cons show "P"
	by (cases bs rule: list_cases_Cons_snoc) auto
	qed


	subsubsection \<open>Induction\<close>

	lemma list_induct_CCons [case_names Nil Single CCons]:
	assumes Nil : "P []"
	and Single: "\<And>x. P [x]"
	and CCons : "\<And>x y xs. P (y#xs) \<Longrightarrow> P (x # y # xs)"
	shows "P xs"
	proof (induct xs)
	case (Cons x xs) with Single CCons show ?case by (cases xs) auto
	qed (rule Nil)

	lemma list_induct_ssnoc [case_names Nil Single ssnoc]:
	assumes Nil : "P []"
	and Single: "\<And>x. P [x]"
	and ssnoc : "\<And>xs x y. P (xs@[x]) \<Longrightarrow> P (xs@[x,y])"
	shows "P xs"
	proof (induct xs rule: rev_induct)
	case (snoc x xs) with Single ssnoc show ?case by (cases xs rule: rev_cases) auto
	qed (rule Nil)

	lemma list_induct2_snoc [case_names Nil1 Nil2 snoc]:
	assumes Nil1: "\<And>ys. P [] ys"
	and Nil2: "\<And>xs. P xs []"
	and snoc: "\<And>xs x ys y. P xs ys \<Longrightarrow> P (xs@[x]) (ys@[y])"
	shows "P xs ys"
	proof (induct xs arbitrary: ys rule: rev_induct, rule Nil1)
	case (snoc b bs) with assms(2,3) show ?case by (cases ys rule: rev_cases) auto
	qed

	lemma list_induct2_snoc_Cons [case_names Nil1 Nil2 snoc_Cons]:
	assumes Nil1 : "\<And>ys. P [] ys"
	and Nil2 : "\<And>xs. P xs []"
	and snoc_Cons: "\<And>xs x y ys. P xs ys \<Longrightarrow> P (xs@[x]) (y#ys)"
	shows "P xs ys"
	proof (induct ys arbitrary: xs, rule Nil2)
	case (Cons y ys) with Nil1 snoc_Cons show ?case
	by (cases xs rule: rev_cases) auto
	qed

	lemma prod_list_induct3_snoc_Conssnoc_Cons_pairwise:
	assumes "\<And>ys zs. Q ([],ys,zs)" "\<And>xs zs. Q (xs,[],zs)" "\<And>xs ys. Q (xs,ys,[])"
	"\<And>xs x y z zs. Q (xs@[x],[y],z#zs)"
	and step:
	"\<And>xs x y ys w z zs. Q (xs,ys,zs) \<Longrightarrow> Q (xs,ys@[w],z#zs) \<Longrightarrow>
	Q (xs@[x],y#ys,zs) \<Longrightarrow> Q (xs@[x],y#ys@[w],z#zs)"
	shows "Q t"
	proof (
	induct t
	taking: "\<lambda>(xs,ys,zs). length xs + length ys + length zs"
	rule : measure_induct_rule
	)
	case (less t)
	show ?case
	proof (cases t)
	case (fields xs ys zs) from assms less fields show ?thesis
	by (cases xs ys zs rule: three_lists_cases_snoc_mid_Cons) auto
	qed
	qed

	lemma list_induct3_snoc_Conssnoc_Cons_pairwise
	[case_names Nil1 Nil2 Nil3 snoc_single_Cons snoc_Conssnoc_Cons]:
	assumes Nil1 : "\<And>ys zs. P [] ys zs"
	and Nil2 : "\<And>xs zs. P xs [] zs"
	and Nil3 : "\<And>xs ys. P xs ys []"
	and snoc_single_Cons : "\<And>xs x y z zs. P (xs@[x]) [y] (z#zs)"
	and snoc_Conssnoc_Cons:
	"\<And>xs x y ys w z zs. P xs ys zs \<Longrightarrow> P xs (ys@[w]) (z#zs) \<Longrightarrow>
	P (xs@[x]) (y#ys) zs \<Longrightarrow> P (xs@[x]) (y#ys@[w]) (z#zs)"
	shows "P xs ys zs"
	using assms
	prod_list_induct3_snoc_Conssnoc_Cons_pairwise[of "\<lambda>(xs,ys,zs). P xs ys zs"]
	by auto


	subsubsection \<open>Alternating lists\<close>

	primrec alternating_list :: "nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list"
	where zero: "alternating_list 0 s t = []"
	\| Suc : "alternating_list (Suc k) s t =
	alternating_list k s t @ [if even k then s else t]"
	\<comment> \<open>could be defined using Cons, but we want the alternating list to always start with the same
	letter as it grows, and it's easier to do that via append\<close>

	lemma alternating_list2: "alternating_list 2 s t = [s,t]"
	using arg_cong[OF Suc_1, THEN sym, of "\<lambda>n. alternating_list n s t"] by simp

	lemma length_alternating_list: "length (alternating_list n s t) = n"
	by (induct n) auto

	lemma alternating_list_Suc_Cons:
	"alternating_list (Suc k) s t = s # alternating_list k t s"
	by (induct k) auto

	lemma alternating_list_SucSuc_ConsCons:
	"alternating_list (Suc (Suc k)) s t = s # t # alternating_list k s t"
	using alternating_list_Suc_Cons[of "Suc k" s] alternating_list_Suc_Cons[of k t]
	by simp

	lemma alternating_list_alternates:
	"alternating_list n s t = as@[a,b,c]@bs \<Longrightarrow> a=c"
	proof (induct n arbitrary: bs)
	case (Suc m) hence prevcase:
	"\<And>xs. alternating_list m s t = as @ [a,b,c] @ xs \<Longrightarrow> a = c"
	"alternating_list (Suc m) s t = as @ [a,b,c] @ bs"
	by auto
	show ?case
	proof (cases bs rule: rev_cases)
	case Nil show ?thesis
	proof (cases m)
	case 0 with prevcase(2) show ?thesis by simp
	next
	case (Suc k) with prevcase(2) Nil show ?thesis by (cases k) auto
	qed
	next
	case (snoc ds d) with prevcase show ?thesis by simp
	qed
	qed simp

	lemma alternating_list_split:
	"alternating_list (m+n) s t = alternating_list m s t @
	(if even m then alternating_list n s t else alternating_list n t s)"
	using alternating_list_SucSuc_ConsCons[of _ s]
	by (induct n rule: nat_induct_step2) auto

	lemma alternating_list_append:
	"even m \<Longrightarrow>
	alternating_list m s t @ alternating_list n s t = alternating_list (m+n) s t"
	"odd m \<Longrightarrow>
	alternating_list m s t @ alternating_list n t s = alternating_list (m+n) s t"
	using alternating_list_split[THEN sym, of m] by auto

	lemma rev_alternating_list:
	"rev (alternating_list n s t) =
	(if even n then alternating_list n t s else alternating_list n s t)"
	using alternating_list_SucSuc_ConsCons[of _ s]
	by (induct n rule: nat_induct_step2) auto

	lemma set_alternating_list: "set (alternating_list n s t) \<subseteq> {s,t}"
	by (induct n) auto

	lemma set_alternating_list1:
	assumes "n \<ge> 1"
	shows "s \<in> set (alternating_list n s t)"
	proof (cases n)
	case 0 with assms show ?thesis by simp
	next
	case (Suc m) thus ?thesis using alternating_list_Suc_Cons[of m s] by simp
	qed

	lemma set_alternating_list2:
	"n \<ge> 2 \<Longrightarrow> set (alternating_list n s t) = {s,t}"
	proof (induct n rule: nat_induct_step2)
	case (SucSuc m) thus ?case
	using set_alternating_list alternating_list_SucSuc_ConsCons[of m s t] by fastforce
	qed auto

	lemma alternating_list_in_lists: "a\<in>A \<Longrightarrow> b\<in>A \<Longrightarrow> alternating_list n a b \<in> lists A"
	by (induct n) auto


	subsubsection \<open>Binary relation chains\<close>

	text \<open>Here we consider lists where each pair of adjacent elements satisfy a given relation.\<close>

	fun binrelchain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
	where "binrelchain P [] = True"
	\| "binrelchain P [x] = True"
	\| "binrelchain P (x # y # xs) = (P x y \<and> binrelchain P (y#xs))"

	lemma binrelchain_Cons_reduce: "binrelchain P (x#xs) \<Longrightarrow> binrelchain P xs"
	by (induct xs) auto

	lemma binrelchain_append_reduce1: "binrelchain P (xs@ys) \<Longrightarrow> binrelchain P xs"
	proof (induct xs rule: list_induct_CCons)
	case (CCons x y xs) with binrelchain_Cons_reduce show ?case by fastforce
	qed auto

	lemma binrelchain_append_reduce2:
	"binrelchain P (xs@ys) \<Longrightarrow> binrelchain P ys"
	proof (induct xs)
	case (Cons x xs) with binrelchain_Cons_reduce show ?case by fastforce
	qed simp

	lemma binrelchain_Conssnoc_reduce:
	"binrelchain P (x#xs@[y]) \<Longrightarrow> binrelchain P xs"
	using binrelchain_append_reduce1 binrelchain_Cons_reduce by fastforce

	lemma binrelchain_overlap_join:
	"binrelchain P (xs@[x]) \<Longrightarrow> binrelchain P (x#ys) \<Longrightarrow> binrelchain P (xs@x#ys)"
	by (induct xs rule: list_induct_CCons) auto

	lemma binrelchain_join:
	"\<lbrakk> binrelchain P (xs@[x]); binrelchain P (y#ys); P x y \<rbrakk> \<Longrightarrow>
	binrelchain P (xs @ x # y # ys)"
	using binrelchain_overlap_join by fastforce

	lemma binrelchain_snoc:
	"binrelchain P (xs@[x]) \<Longrightarrow> P x y \<Longrightarrow> binrelchain P (xs@[x,y])"
	using binrelchain_join by fastforce

	lemma binrelchain_sym_rev:
	assumes "\<And>x y. P x y \<Longrightarrow> P y x"
	shows "binrelchain P xs \<Longrightarrow> binrelchain P (rev xs)"
	proof (induct xs rule: list_induct_CCons)
	case (CCons x y xs) with assms show ?case by (auto intro: binrelchain_snoc)
	qed auto

	lemma binrelchain_remdup_adj:
	"binrelchain P (xs@[x,x]@ys) \<Longrightarrow> binrelchain P (xs@x#ys)"
	by (induct xs rule: list_induct_CCons) auto

	abbreviation "proper_binrelchain P xs \<equiv> binrelchain P xs \<and> distinct xs"

	lemma binrelchain_obtain_proper:
	"x\<noteq>y \<Longrightarrow> binrelchain P (x#xs@[y]) \<Longrightarrow>
	\<exists>zs. set zs \<subseteq> set xs \<and> length zs \<le> length xs \<and> proper_binrelchain P (x#zs@[y])"
	proof (induct xs arbitrary: x)
	case (Cons w ws)
	show ?case
	proof (cases "w=x" "w=y" rule: two_cases)
	case one
	from one(1) Cons(3) have "binrelchain P (x#ws@[y])"
	using binrelchain_Cons_reduce by simp
	with Cons(1,2) obtain zs
	where "set zs \<subseteq> set ws" "length zs \<le> length ws" "proper_binrelchain P (x#zs@[y])"
	by auto
	thus ?thesis by auto
	next
	case other
	with Cons(3) have "proper_binrelchain P (x#[]@[y])"
	using binrelchain_append_reduce1 by simp
	moreover have "length [] \<le> length (w#ws)" "set [] \<subseteq> set (w#ws)" by auto
	ultimately show ?thesis by blast
	next
	case neither
	from Cons(3) have "binrelchain P (w#ws@[y])"
	using binrelchain_Cons_reduce by simp
	with neither(2) Cons(1) obtain zs
	where zs: "set zs \<subseteq> set ws" "length zs \<le> length ws"
	"proper_binrelchain P (w#zs@[y])"
	by auto
	show ?thesis
	proof (cases "x\<in>set zs")
	case True
	from this obtain as bs where asbs: "zs = as@x#bs"
	using in_set_conv_decomp[of x] by auto
	with zs(3) have "proper_binrelchain P (x#bs@[y])"
	using binrelchain_append_reduce2[of P "w#as"] by auto
	moreover from zs(1) asbs have "set bs \<subseteq> set (w#ws)" by auto
	moreover from asbs zs(2) have "length bs \<le> length (w#ws)" by simp
	ultimately show ?thesis by auto
	next
	case False
	with zs(3) neither(1) Cons(2,3) have "proper_binrelchain P (x#(w#zs)@[y])"
	by simp
	moreover from zs(1) have "set (w#zs) \<subseteq> set (w#ws)" by auto
	moreover from zs(2) have "length (w#zs) \<le> length (w#ws)" by simp
	ultimately show ?thesis by blast
	qed
	qed (fastforce simp add: Cons(2))
	qed simp

	lemma binrelchain_trans_Cons_snoc:
	assumes "\<And>x y z. P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
	shows "binrelchain P (x#xs@[y]) \<Longrightarrow> P x y"
	proof (induct xs arbitrary: x)
	case Cons with assms show ?case using binrelchain_Cons_reduce by auto
	qed simp

	lemma binrelchain_cong:
	assumes "\<And>x y. P x y \<Longrightarrow> Q x y"
	shows "binrelchain P xs \<Longrightarrow> binrelchain Q xs"
	using assms binrelchain_Cons_reduce
	by (induct xs rule: list_induct_CCons) auto

	lemma binrelchain_funcong_Cons_snoc:
	assumes "\<And>x y. P x y \<Longrightarrow> f y = f x" "binrelchain P (x#xs@[y])"
	shows "f y = f x"
	using assms binrelchain_cong[of P]
	binrelchain_trans_Cons_snoc[of "\<lambda>x y. f y = f x" x xs y]
	by auto

	lemma binrelchain_funcong_extra_condition_Cons_snoc:
	assumes "\<And>x y. Q x \<Longrightarrow> P x y \<Longrightarrow> Q y" "\<And>x y. Q x \<Longrightarrow> P x y \<Longrightarrow> f y = f x"
	shows "Q x \<Longrightarrow> binrelchain P (x#zs@[y]) \<Longrightarrow> f y = f x"
	proof (induct zs arbitrary: x)
	case (Cons z zs) with assms show ?case
	using binrelchain_Cons_reduce[of P x "z#zs@[y]"] by fastforce
	qed (simp add: assms)

	lemma binrelchain_setfuncong_Cons_snoc:
	"\<lbrakk> \<forall>x\<in>A. \<forall>y. P x y \<longrightarrow> y\<in>A; \<forall>x\<in>A. \<forall>y. P x y \<longrightarrow> f y = f x; x\<in>A;
	binrelchain P (x#zs@[y]) \<rbrakk> \<Longrightarrow> f y = f x"
	using binrelchain_funcong_extra_condition_Cons_snoc[of "\<lambda>x. x\<in>A" P f x zs y]
	by fast

	lemma binrelchain_propcong_Cons_snoc:
	assumes "\<And>x y. Q x \<Longrightarrow> P x y \<Longrightarrow> Q y"
	shows "Q x \<Longrightarrow> binrelchain P (x#xs@[y]) \<Longrightarrow> Q y"
	proof (induct xs arbitrary: x)
	case Cons with assms show ?case using binrelchain_Cons_reduce by auto
	qed (simp add: assms)

	subsubsection \<open>Set of subseqs\<close>

	lemma subseqs_Cons: "subseqs (x#xs) = map (Cons x) (subseqs xs) @ (subseqs xs)"
	using cong_let[of "subseqs xs" "\<lambda>xss. map (Cons x) xss @ xss"] by simp

	abbreviation "ssubseqs xs \<equiv> set (subseqs xs)"

	lemma nil_ssubseqs: "[] \<in> ssubseqs xs"
	proof (induct xs)
	case (Cons x xs) thus ?case using subseqs_Cons[of x] by simp
	qed simp

	lemma ssubseqs_Cons: "ssubseqs (x#xs) = (Cons x) ` (ssubseqs xs) \<union> ssubseqs xs"
	using subseqs_Cons[of x] by simp

	lemma ssubseqs_refl: "xs \<in> ssubseqs xs"
	proof (induct xs)
	case (Cons x xs) thus ?case using ssubseqs_Cons by fast
	qed (rule nil_ssubseqs)

	lemma ssubseqs_subset: "as \<in> ssubseqs bs \<Longrightarrow> ssubseqs as \<subseteq> ssubseqs bs"
	proof (induct bs arbitrary: as)
	case (Cons b bs) show ?case
	proof (cases "as \<in> set (subseqs bs)")
	case True with Cons show ?thesis using ssubseqs_Cons by fastforce
	next
	case False with Cons show ?thesis
	using nil_ssubseqs[of "b#bs"] ssubseqs_Cons[of "hd as"] ssubseqs_Cons[of b]
	by (cases as) auto
	qed
	qed simp

	lemma ssubseqs_lists:
	"as \<in> lists A \<Longrightarrow> bs \<in> ssubseqs as \<Longrightarrow> bs \<in> lists A"
	proof (induct as arbitrary: bs)
	case (Cons a as) thus ?case using ssubseqs_Cons[of a] by fastforce
	qed simp

	lemma delete1_ssubseqs:
	"as@bs \<in> ssubseqs (as@[a]@bs)"
	proof (induct as)
	case Nil show ?case using ssubseqs_refl ssubseqs_Cons[of a bs] by auto
	next
	case (Cons x xs) thus ?case using ssubseqs_Cons[of x] by simp
	qed

	lemma delete2_ssubseqs:
	"as@bs@cs \<in> ssubseqs (as@[a]@bs@[b]@cs)"
	using delete1_ssubseqs[of "as@[a]@bs"] delete1_ssubseqs ssubseqs_subset
	by fastforce



	subsection \<open>Orders and posets\<close>

	text \<open>
	We have chosen to work with the @{const ordering} locale instead of the @{class order} class to
	more easily facilitate simultaneously working with both an order and its dual.
	\<close>

	subsubsection \<open>Morphisms of posets\<close>

	locale OrderingSetMap =
	domain : ordering less_eq less
	+ codomain: ordering less_eq' less'
	for less_eq :: "'a\<Rightarrow>'a\<Rightarrow>bool" (infix "\<^bold>\<le>" 50)
	and less :: "'a\<Rightarrow>'a\<Rightarrow>bool" (infix "\<^bold><" 50)
	and less_eq' :: "'b\<Rightarrow>'b\<Rightarrow>bool" (infix "\<^bold>\<le>*" 50)
	and less' :: "'b\<Rightarrow>'b\<Rightarrow>bool" (infix "\<^bold><*" 50)
	+ fixes P :: "'a set"
	and f :: "'a\<Rightarrow>'b"
	assumes ordsetmap: "a\<in>P \<Longrightarrow> b\<in>P \<Longrightarrow> a \<^bold>\<le> b \<Longrightarrow> f a \<^bold>\<le>* f b"
	begin

	lemma comp:
	assumes "OrderingSetMap less_eq' less' less_eq'' less'' Q g"
	"f`P \<subseteq> Q"
	shows "OrderingSetMap less_eq less less_eq'' less'' P (g\<circ>f)"
	proof -
	from assms(1) interpret I: OrderingSetMap less_eq' less' less_eq'' less'' Q g .
	show ?thesis
	by standard (use assms(2) in \<open>auto intro: ordsetmap I.ordsetmap\<close>)
	qed

	lemma subset: "Q\<subseteq>P \<Longrightarrow> OrderingSetMap (\<^bold>\<le>) (\<^bold><) (\<^bold>\<le>) (\<^bold><) Q f"
	using ordsetmap by unfold_locales fast

	end (* context OrderingSetMap *)

	locale OrderingSetIso = OrderingSetMap less_eq less less_eq' less' P f
	for less_eq :: "'a\<Rightarrow>'a\<Rightarrow>bool" (infix "\<^bold>\<le>" 50)
	and less :: "'a\<Rightarrow>'a\<Rightarrow>bool" (infix "\<^bold><" 50)
	and less_eq' :: "'b\<Rightarrow>'b\<Rightarrow>bool" (infix "\<^bold>\<le>*" 50)
	and less' :: "'b\<Rightarrow>'b\<Rightarrow>bool" (infix "\<^bold><*" 50)
	and P :: "'a set"
	and f :: "'a\<Rightarrow>'b"
	+ assumes inj : "inj_on f P"
	and rev_OrderingSetMap:
	"OrderingSetMap less_eq' less' less_eq less (f`P) (the_inv_into P f)"

	abbreviation "subset_ordering_iso \<equiv> OrderingSetIso (\<subseteq>) (\<subset>) (\<subseteq>) (\<subset>)"

	lemma (in OrderingSetMap) isoI:
	assumes "inj_on f P" "\<And>a b. a\<in>P \<Longrightarrow> b\<in>P \<Longrightarrow> f a \<^bold>\<le>* f b \<Longrightarrow> a \<^bold>\<le> b"
	shows "OrderingSetIso less_eq less less_eq' less' P f"
	using assms the_inv_into_f_f[OF assms(1)]
	by unfold_locales auto

	lemma OrderingSetIsoI_orders_greater2less:
	fixes f :: "'a::order \<Rightarrow> 'b::order"
	assumes "inj_on f P" "\<And>a b. a \<in> P \<Longrightarrow> b \<in> P \<Longrightarrow> (b\<le>a) = (f a \<le> f b)"
	shows "OrderingSetIso (greater_eq::'a\<Rightarrow>'a\<Rightarrow>bool) (greater::'a\<Rightarrow>'a\<Rightarrow>bool)
	(less_eq::'b\<Rightarrow>'b\<Rightarrow>bool) (less::'b\<Rightarrow>'b\<Rightarrow>bool) P f"
	proof
	from assms(2) show "\<And>a b. a \<in> P \<Longrightarrow> b \<in> P \<Longrightarrow> b\<le>a \<Longrightarrow> f a \<le> f b" by auto
	from assms(2)
	show "\<And>a b. a \<in> f ` P \<Longrightarrow> b \<in> f ` P \<Longrightarrow> b\<le>a \<Longrightarrow>
	the_inv_into P f a \<le> the_inv_into P f b"
	using the_inv_into_f_f[OF assms(1)]
	by force
	qed (rule assms(1))


	context OrderingSetIso
	begin

	lemmas ordsetmap = ordsetmap

	lemma ordsetmap_strict: "\<lbrakk> a\<in>P; b\<in>P; a\<^bold><b \<rbrakk> \<Longrightarrow> f a \<^bold><* f b"
	using domain.strict_iff_order codomain.strict_iff_order ordsetmap inj
	inj_on_contraD
	by fastforce

	lemmas inv_ordsetmap = OrderingSetMap.ordsetmap[OF rev_OrderingSetMap]

	lemma rev_ordsetmap: "\<lbrakk> a\<in>P; b\<in>P; f a \<^bold>\<le>* f b \<rbrakk> \<Longrightarrow> a \<^bold>\<le> b"
	using inv_ordsetmap the_inv_into_f_f[OF inj] by fastforce

	lemma inv_iso: "OrderingSetIso less_eq' less' less_eq less (f`P) (the_inv_into P f)"
	using inv_ordsetmap inj_on_the_inv_into[OF inj] the_inv_into_onto[OF inj]
	ordsetmap the_inv_into_the_inv_into[OF inj]
	by unfold_locales auto

	lemmas inv_ordsetmap_strict = OrderingSetIso.ordsetmap_strict[OF inv_iso]

	lemma rev_ordsetmap_strict: "\<lbrakk> a\<in>P; b\<in>P; f a \<^bold><* f b \<rbrakk> \<Longrightarrow> a \<^bold>< b"
	using inv_ordsetmap_strict the_inv_into_f_f[OF inj] by fastforce

	lemma iso_comp:
	assumes "OrderingSetIso less_eq' less' less_eq'' less'' Q g" "f`P \<subseteq> Q"
	shows "OrderingSetIso less_eq less less_eq'' less'' P (g\<circ>f)"
	proof (rule OrderingSetMap.isoI)
	from assms show "OrderingSetMap (\<^bold>\<le>) (\<^bold><) less_eq'' less'' P (g \<circ> f)"
	using OrderingSetIso.axioms(1) comp by fast
	from assms(2) show "inj_on (g \<circ> f) P"
	using OrderingSetIso.inj[OF assms(1)]
	comp_inj_on[OF inj, OF subset_inj_on]
	by fast
	next
	fix a b
	from assms(2) show "\<lbrakk> a\<in>P; b\<in>P; less_eq'' ((g\<circ>f) a) ((g\<circ>f) b) \<rbrakk> \<Longrightarrow> a\<^bold>\<le>b"
	using OrderingSetIso.rev_ordsetmap[OF assms(1)] rev_ordsetmap by force
	qed

	lemma iso_subset:
	"Q\<subseteq>P \<Longrightarrow> OrderingSetIso (\<^bold>\<le>) (\<^bold><) (\<^bold>\<le>) (\<^bold><) Q f"
	using subset[of Q] subset_inj_on[OF inj] rev_ordsetmap
	by (blast intro: OrderingSetMap.isoI)

	lemma iso_dual:
	\<open>OrderingSetIso (\<lambda>a b. less_eq b a) (\<lambda>a b. less b a)
	(\<lambda>a b. less_eq' b a) (\<lambda>a b. less' b a) P f\<close>
	apply (rule OrderingSetMap.isoI)
	apply unfold_locales
	using inj
	apply (auto simp add: domain.refl codomain.refl
	domain.irrefl codomain.irrefl
	domain.order_iff_strict codomain.order_iff_strict
	ordsetmap_strict rev_ordsetmap_strict inj_onD
	intro: domain.trans codomain.trans
	domain.strict_trans codomain.strict_trans
	domain.antisym codomain.antisym)
	done

	end (* context OrderingSetIso *)

	lemma induced_pow_fun_subset_ordering_iso:
	assumes "inj_on f A"
	shows "subset_ordering_iso (Pow A) ((`) f)"
	proof
	show "\<And>a b. a \<in> Pow A \<Longrightarrow> b \<in> Pow A \<Longrightarrow> a \<subseteq> b \<Longrightarrow> f ` a \<subseteq> f ` b" by fast
	from assms show 2:"inj_on ((`) f) (Pow A)"
	using induced_pow_fun_inj_on by fast
	show "\<And>a b. a \<in> (`) f ` Pow A \<Longrightarrow> b \<in> (`) f ` Pow A \<Longrightarrow> a \<subseteq> b
	\<Longrightarrow> the_inv_into (Pow A) ((`) f) a \<subseteq> the_inv_into (Pow A) ((`) f) b"
	proof-
	fix Y1 Y2
	assume Y: "Y1 \<in> ((`) f) ` Pow A" "Y2 \<in> ((`) f) ` Pow A" "Y1 \<subseteq> Y2"
	from Y(1,2) obtain X1 X2 where "X1\<subseteq>A" "X2\<subseteq>A" "Y1 = f`X1" "Y2 = f`X2"
	by auto
	with assms Y(3)
	show "the_inv_into (Pow A) ((`) f) Y1 \<subseteq> the_inv_into (Pow A) ((`) f) Y2"
	using inj_onD[OF assms] the_inv_into_f_f[OF 2, of X1]
	the_inv_into_f_f[OF 2, of X2]
	by blast
	qed
	qed

	subsubsection \<open>More @{const arg_min}\<close>

	lemma is_arg_minI:
	"\<lbrakk> P x; \<And>y. P y \<Longrightarrow> \<not> m y < m x \<rbrakk> \<Longrightarrow> is_arg_min m P x"
	by (simp add: is_arg_min_def)

	lemma is_arg_min_linorderI:
	"\<lbrakk> P x; \<And>y. P y \<Longrightarrow> m x \<le> (m y::_::linorder) \<rbrakk> \<Longrightarrow> is_arg_min m P x"
	by (simp add: is_arg_min_linorder)

	lemma is_arg_min_eq:
	"\<lbrakk> is_arg_min m P x; P z; m z = m x \<rbrakk> \<Longrightarrow> is_arg_min m P z"
	by (metis is_arg_min_def)

	lemma is_arg_minD1: "is_arg_min m P x \<Longrightarrow> P x"
	unfolding is_arg_min_def by fast

	lemma is_arg_minD2: "is_arg_min m P x \<Longrightarrow> P y \<Longrightarrow> \<not> m y < m x"
	unfolding is_arg_min_def by fast

	lemma is_arg_min_size: fixes m :: "'a \<Rightarrow> 'b::linorder"
	shows "is_arg_min m P x \<Longrightarrow> m x = m (arg_min m P)"
	by (metis arg_min_equality is_arg_min_linorder)

	lemma is_arg_min_size_subprop:
	fixes m :: "'a\<Rightarrow>'b::linorder"
	assumes "is_arg_min m P x" "Q x" "\<And>y. Q y \<Longrightarrow> P y"
	shows "m (arg_min m Q) = m (arg_min m P)"
	proof-
	have "\<not> is_arg_min m Q x \<Longrightarrow> \<not> is_arg_min m P x"
	proof
	assume x: "\<not> is_arg_min m Q x"
	from assms(2,3) show False
	using contrapos_nn[OF x, OF is_arg_minI] is_arg_minD2[OF assms(1)] by auto
	qed
	with assms(1) show ?thesis
	using is_arg_min_size[of m] is_arg_min_size[of m] by fastforce
	qed

	subsubsection \<open>Bottom of a set\<close>

	context ordering
	begin

	definition has_bottom :: "'a set \<Rightarrow> bool"
	where "has_bottom P \<equiv> \<exists>z\<in>P. \<forall>x\<in>P. z \<^bold>\<le> x"

	lemma has_bottomI: "z\<in>P \<Longrightarrow> (\<And>x. x\<in>P \<Longrightarrow> z \<^bold>\<le> x) \<Longrightarrow> has_bottom P"
	using has_bottom_def by auto

	lemma has_uniq_bottom: "has_bottom P \<Longrightarrow> \<exists>!z\<in>P. \<forall>x\<in>P. z\<^bold>\<le>x"
	using has_bottom_def antisym by force

	definition bottom :: "'a set \<Rightarrow> 'a"
	where "bottom P \<equiv> (THE z. z\<in>P \<and> (\<forall>x\<in>P. z\<^bold>\<le>x))"

	lemma bottomD:
	assumes "has_bottom P"
	shows "bottom P \<in> P" "x\<in>P \<Longrightarrow> bottom P \<^bold>\<le> x"
	using assms has_uniq_bottom theI'[of "\<lambda>z. z\<in>P \<and> (\<forall>x\<in>P. z\<^bold>\<le>x)"]
	unfolding bottom_def
	by auto

	lemma bottomI: "z\<in>P \<Longrightarrow> (\<And>y. y\<in>P \<Longrightarrow> z \<^bold>\<le> y) \<Longrightarrow> z = bottom P"
	using has_bottomI has_uniq_bottom
	the1_equality[THEN sym, of "\<lambda>z. z\<in>P \<and> (\<forall>x\<in>P. z\<^bold>\<le>x)"]
	unfolding bottom_def
	by simp

	end (* context ordering *)

	lemma has_bottom_pow: "order.has_bottom (Pow A)"
	by (fast intro: order.has_bottomI)

	lemma bottom_pow: "order.bottom (Pow A) = {}"
	proof (rule order.bottomI[THEN sym]) qed auto

	context OrderingSetMap
	begin

	abbreviation "dombot \<equiv> domain.bottom P"
	abbreviation "codbot \<equiv> codomain.bottom (f`P)"

	lemma im_has_bottom: "domain.has_bottom P \<Longrightarrow> codomain.has_bottom (f`P)"
	using domain.bottomD ordsetmap by (fast intro: codomain.has_bottomI)

	lemma im_bottom: "domain.has_bottom P \<Longrightarrow> f dombot = codbot"
	using domain.bottomD ordsetmap by (auto intro: codomain.bottomI)

	end (* context OrderingSetMap *)

	lemma (in OrderingSetIso) pullback_has_bottom:
	assumes "codomain.has_bottom (f`P)"
	shows "domain.has_bottom P"
	proof (rule domain.has_bottomI)
	from assms show "the_inv_into P f codbot \<in> P"
	using codomain.bottomD(1) the_inv_into_into[OF inj] by fast
	from assms show "\<And>x. x\<in>P \<Longrightarrow> the_inv_into P f codbot \<^bold>\<le> x"
	using codomain.bottomD inv_ordsetmap[of codbot] the_inv_into_f_f[OF inj]
	by fastforce
	qed

	lemma (in OrderingSetIso) pullback_bottom:
	"\<lbrakk> domain.has_bottom P; x\<in>P; f x = codomain.bottom (f`P) \<rbrakk> \<Longrightarrow>
	x = domain.bottom P"
	using im_has_bottom codomain.bottomD(2) rev_ordsetmap
	by (auto intro: domain.bottomI)

	subsubsection \<open>Minimal and pseudominimal elements in sets\<close>

	text \<open>
	We will call an element of a poset pseudominimal if the only element below it is the bottom of
	the poset.
	\<close>

	context ordering
	begin

	definition minimal_in :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
	where "minimal_in P x \<equiv> x\<in>P \<and> (\<forall>z\<in>P. \<not> z \<^bold>< x)"

	definition pseudominimal_in :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
	where "pseudominimal_in P x \<equiv> minimal_in (P - {bottom P}) x"
	\<comment> \<open>only makes sense for @{term "has_bottom P"}\<close>

	lemma minimal_inD1: "minimal_in P x \<Longrightarrow> x\<in>P"
	using minimal_in_def by fast

	lemma minimal_inD2: "minimal_in P x \<Longrightarrow> z\<in>P \<Longrightarrow> \<not> z \<^bold>< x"
	using minimal_in_def by fast

	lemma pseudominimal_inD1: "pseudominimal_in P x \<Longrightarrow> x\<in>P"
	using pseudominimal_in_def minimal_inD1 by fast

	lemma pseudominimal_inD2:
	"pseudominimal_in P x \<Longrightarrow> z\<in>P \<Longrightarrow> z\<^bold><x \<Longrightarrow> z = bottom P"
	using pseudominimal_in_def minimal_inD2 by fast

	lemma pseudominimal_inI:
	assumes "x\<in>P" "x \<noteq> bottom P" "\<And>z. z\<in>P \<Longrightarrow> z\<^bold><x \<Longrightarrow> z = bottom P"
	shows "pseudominimal_in P x"
	using assms
	unfolding pseudominimal_in_def minimal_in_def
	by fast

	lemma pseudominimal_ne_bottom: "pseudominimal_in P x \<Longrightarrow> x \<noteq> bottom P"
	using pseudominimal_in_def minimal_inD1 by fast

	lemma pseudominimal_comp:
	"\<lbrakk> pseudominimal_in P x; pseudominimal_in P y; x\<^bold>\<le>y \<rbrakk> \<Longrightarrow> x = y"
	using pseudominimal_inD1 pseudominimal_inD2 pseudominimal_ne_bottom
	strict_iff_order[of x y]
	by force

	end (* context ordering *)

	lemma pseudominimal_in_pow:
	assumes "order.pseudominimal_in (Pow A) x"
	shows "\<exists>a\<in>A. x = {a}"
	proof-
	from assms obtain a where "{a} \<subseteq> x"
	using order.pseudominimal_ne_bottom bottom_pow[of A] by fast
	with assms show ?thesis
	using order.pseudominimal_inD1 order.pseudominimal_inD2[of _ x "{a}"]
	bottom_pow
	by fast
	qed

	lemma pseudominimal_in_pow_singleton:
	"a\<in>A \<Longrightarrow> order.pseudominimal_in (Pow A) {a}"
	using singleton_pow bottom_pow by (fast intro: order.pseudominimal_inI)

	lemma no_pseudominimal_in_pow_is_empty:
	"(\<And>x. \<not> order.pseudominimal_in (Pow A) {x}) \<Longrightarrow> A = {}"
	using pseudominimal_in_pow_singleton by (fast intro: equals0I)

	lemma (in OrderingSetIso) pseudominimal_map:
	"domain.has_bottom P \<Longrightarrow> domain.pseudominimal_in P x \<Longrightarrow>
	codomain.pseudominimal_in (f`P) (f x)"
	using domain.pseudominimal_inD1 pullback_bottom
	domain.pseudominimal_ne_bottom rev_ordsetmap_strict
	domain.pseudominimal_inD2 im_bottom
	by (blast intro: codomain.pseudominimal_inI)

	lemma (in OrderingSetIso) pullback_pseudominimal_in:
	"\<lbrakk> domain.has_bottom P; x\<in>P; codomain.pseudominimal_in (f`P) (f x) \<rbrakk> \<Longrightarrow>
	domain.pseudominimal_in P x"
	using im_bottom codomain.pseudominimal_ne_bottom ordsetmap_strict
	codomain.pseudominimal_inD2 pullback_bottom
	by (blast intro: domain.pseudominimal_inI)

	subsubsection \<open>Set of elements below another\<close>

	abbreviation (in ordering) below_in :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a set" (infix ".\<^bold>\<le>" 70)
	where "P.\<^bold>\<le>x \<equiv> {y\<in>P. y\<^bold>\<le>x}"

	abbreviation (in ord) below_in :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a set" (infix ".\<le>" 70)
	where "P.\<le>x \<equiv> {y\<in>P. y\<le>x}"

	context ordering
	begin

	lemma below_in_refl: "x\<in>P \<Longrightarrow> x \<in> P.\<^bold>\<le>x"
	using refl by fast

	lemma below_in_singleton: "x\<in>P \<Longrightarrow> P.\<^bold>\<le>x \<subseteq> {y} \<Longrightarrow> y = x"
	using below_in_refl by fast

	lemma bottom_in_below_in: "has_bottom P \<Longrightarrow> x\<in>P \<Longrightarrow> bottom P \<in> P.\<^bold>\<le>x"
	using bottomD by fast

	lemma below_in_singleton_is_bottom:
	"\<lbrakk> has_bottom P; x\<in>P; P.\<^bold>\<le>x = {x} \<rbrakk> \<Longrightarrow> x = bottom P"
	using bottom_in_below_in by fast

	lemma bottom_below_in:
	"has_bottom P \<Longrightarrow> x\<in>P \<Longrightarrow> bottom (P.\<^bold>\<le>x) = bottom P"
	using bottom_in_below_in by (fast intro: bottomI[THEN sym])

	lemma bottom_below_in_relative:
	"\<lbrakk> has_bottom (P.\<^bold>\<le>y); x\<in>P; x\<^bold>\<le>y \<rbrakk> \<Longrightarrow> bottom (P.\<^bold>\<le>x) = bottom (P.\<^bold>\<le>y)"
	using bottomD trans by (blast intro: bottomI[THEN sym])

	lemma has_bottom_pseudominimal_in_below_inI:
	assumes "has_bottom P" "x\<in>P" "pseudominimal_in P y" "y\<^bold>\<le>x"
	shows "pseudominimal_in (P.\<^bold>\<le>x) y"
	using assms(3,4) pseudominimal_inD1[OF assms(3)]
	pseudominimal_inD2[OF assms(3)]
	bottom_below_in[OF assms(1,2)] pseudominimal_ne_bottom
	by (force intro: pseudominimal_inI)

	lemma has_bottom_pseudominimal_in_below_in:
	assumes "has_bottom P" "x\<in>P" "pseudominimal_in (P.\<^bold>\<le>x) y"
	shows "pseudominimal_in P y"
	using pseudominimal_inD1[OF assms(3)]
	pseudominimal_inD2[OF assms(3)]
	pseudominimal_ne_bottom[OF assms(3)]
	bottom_below_in[OF assms(1,2)]
	strict_implies_order[of _ y] trans[of _ y x]
	by (force intro: pseudominimal_inI)

	lemma pseudominimal_in_below_in:
	assumes "has_bottom (P.\<^bold>\<le>y)" "x\<in>P" "x\<^bold>\<le>y" "pseudominimal_in (P.\<^bold>\<le>x) w"
	shows "pseudominimal_in (P.\<^bold>\<le>y) w"
	using assms(3) trans[of w x y] trans[of _ w x] strict_iff_order
	pseudominimal_inD1[OF assms(4)]
	pseudominimal_inD2[OF assms(4)]
	pseudominimal_ne_bottom[OF assms(4)]
	bottom_below_in_relative[OF assms(1-3)]
	by (force intro: pseudominimal_inI)

	lemma collect_pseudominimals_below_in_less_eq_top:
	assumes "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) (P.\<^bold>\<le>x) f"
	"f`(P.\<^bold>\<le>x) = Pow A" "a \<subseteq> {y. pseudominimal_in (P.\<^bold>\<le>x) y}"
	defines "w \<equiv> the_inv_into (P.\<^bold>\<le>x) f (\<Union>(f`a))"
	shows "w \<^bold>\<le> x"
	proof-
	from assms(2,3) have "(\<Union>(f`a)) \<in> f`(P.\<^bold>\<le>x)"
	using pseudominimal_inD1 by fastforce
	with assms(4) show ?thesis
	using OrderingSetIso.inj[OF assms(1)] the_inv_into_into[of f "P.\<^bold>\<le>x"] by force
	qed

	lemma collect_pseudominimals_below_in_poset:
	assumes "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) (P.\<^bold>\<le>x) f"
	"f`(P.\<^bold>\<le>x) = Pow A"
	"a \<subseteq> {y. pseudominimal_in (P.\<^bold>\<le>x) y}"
	defines "w \<equiv> the_inv_into (P.\<^bold>\<le>x) f (\<Union>(f`a))"
	shows "w \<in> P"
	using assms(2-4) OrderingSetIso.inj[OF assms(1)] pseudominimal_inD1
	the_inv_into_into[of f "P.\<^bold>\<le>x" "\<Union>(f`a)"]
	by force

	lemma collect_pseudominimals_below_in_eq:
	assumes "x\<in>P" "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) (P.\<^bold>\<le>x) f"
	"f`(P.\<^bold>\<le>x) = Pow A" "a \<subseteq> {y. pseudominimal_in (P.\<^bold>\<le>x) y}"
	defines w: "w \<equiv> the_inv_into (P.\<^bold>\<le>x) f (\<Union>(f`a))"
	shows "a = {y. pseudominimal_in (P.\<^bold>\<le>w) y}"
	proof
	from assms(3) have has_bot_ltx: "has_bottom (P.\<^bold>\<le>x)"
	using has_bottom_pow OrderingSetIso.pullback_has_bottom[OF assms(2)]
	by auto
	from assms(3,4) have Un_fa: "(\<Union>(f`a)) \<in> f`(P.\<^bold>\<le>x)"
	using pseudominimal_inD1 by fastforce
	from assms have w_le_x: "w\<^bold>\<le>x" and w_P: "w\<in>P"
	using collect_pseudominimals_below_in_less_eq_top
	collect_pseudominimals_below_in_poset
	by auto
	show "a \<subseteq> {y. pseudominimal_in (P.\<^bold>\<le>w) y}"
	proof
	fix y assume y: "y \<in> a"
	show "y \<in> {y. pseudominimal_in (P.\<^bold>\<le>w) y}"
	proof (rule CollectI, rule pseudominimal_inI, rule CollectI, rule conjI)
	from y assms(4) have y_le_x: "y \<in> P.\<^bold>\<le>x" using pseudominimal_inD1 by fast
	thus "y\<in>P" by simp
	from y w show "y \<^bold>\<le> w"
	using y_le_x Un_fa OrderingSetIso.inv_ordsetmap[OF assms(2)]
	the_inv_into_f_f[OF OrderingSetIso.inj, OF assms(2), of y]
	by fastforce
	from assms(1) y assms(4) show "y \<noteq> bottom (P.\<^bold>\<le>w)"
	using w_P w_le_x has_bot_ltx bottom_below_in_relative
	pseudominimal_ne_bottom
	by fast
	next
	fix z assume z: "z \<in> P.\<^bold>\<le>w" "z\<^bold><y"
	with y assms(4) have "z = bottom (P.\<^bold>\<le>x)"
	using w_le_x trans pseudominimal_inD2[ of "P.\<^bold>\<le>x" y z] by fast
	moreover from assms(1) have "bottom (P.\<^bold>\<le>w) = bottom (P.\<^bold>\<le>x)"
	using has_bot_ltx w_P w_le_x bottom_below_in_relative by fast
	ultimately show "z = bottom (P.\<^bold>\<le>w)" by simp
	qed
	qed
	show "a \<supseteq> {y. pseudominimal_in (P.\<^bold>\<le>w) y}"
	proof
	fix v assume "v \<in> {y. pseudominimal_in (P.\<^bold>\<le>w) y}"
	hence "pseudominimal_in (P.\<^bold>\<le>w) v" by fast
	moreover hence v_pm_ltx: "pseudominimal_in (P.\<^bold>\<le>x) v"
	using has_bot_ltx w_P w_le_x pseudominimal_in_below_in by fast
	ultimately
	have "f v \<le> (\<Union>(f`a))"
	using w pseudominimal_inD1[of _ v] pseudominimal_inD1[of _ v] w_le_x w_P
	OrderingSetIso.ordsetmap[OF assms(2), of v w] Un_fa
	OrderingSetIso.inj[OF assms(2)]
	f_the_inv_into_f
	by force
	with assms(3) obtain y where "y\<in>a" "f v \<subseteq> f y"
	using v_pm_ltx has_bot_ltx pseudominimal_in_pow
	OrderingSetIso.pseudominimal_map[OF assms(2)]
	by force
	with assms(2,4) show "v \<in> a"
	using v_pm_ltx pseudominimal_inD1 pseudominimal_comp[of _ v y]
	OrderingSetIso.rev_ordsetmap[OF assms(2), of v y]
	by fast
	qed
	qed

	end (* context ordering *)

	subsubsection \<open>Lower bounds\<close>

	context ordering
	begin

	definition lbound_of :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
	where "lbound_of x y b \<equiv> b\<^bold>\<le>x \<and> b\<^bold>\<le>y"

	lemma lbound_ofI: "b\<^bold>\<le>x \<Longrightarrow> b\<^bold>\<le>y \<Longrightarrow> lbound_of x y b"
	using lbound_of_def by fast

	lemma lbound_ofD1: "lbound_of x y b \<Longrightarrow> b\<^bold>\<le>x"
	using lbound_of_def by fast

	lemma lbound_ofD2: "lbound_of x y b \<Longrightarrow> b\<^bold>\<le>y"
	using lbound_of_def by fast

	definition glbound_in_of :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
	where "glbound_in_of P x y b \<equiv>
	b\<in>P \<and> lbound_of x y b \<and> (\<forall>a\<in>P. lbound_of x y a \<longrightarrow> a\<^bold>\<le>b)"

	lemma glbound_in_ofI:
	"\<lbrakk> b\<in>P; lbound_of x y b; \<And>a. a\<in>P \<Longrightarrow> lbound_of x y a \<Longrightarrow> a\<^bold>\<le>b \<rbrakk> \<Longrightarrow>
	glbound_in_of P x y b"
	using glbound_in_of_def by auto

	lemma glbound_in_ofD_in: "glbound_in_of P x y b \<Longrightarrow> b\<in>P"
	using glbound_in_of_def by fast

	lemma glbound_in_ofD_lbound: "glbound_in_of P x y b \<Longrightarrow> lbound_of x y b"
	using glbound_in_of_def by fast

	lemma glbound_in_ofD_glbound:
	"glbound_in_of P x y b \<Longrightarrow> a\<in>P \<Longrightarrow> lbound_of x y a \<Longrightarrow> a\<^bold>\<le>b"
	using glbound_in_of_def by fast

	lemma glbound_in_of_less_eq1: "glbound_in_of P x y b \<Longrightarrow> b\<^bold>\<le>x"
	using glbound_in_ofD_lbound lbound_ofD1 by fast

	lemma glbound_in_of_less_eq2: "glbound_in_of P x y b \<Longrightarrow> b\<^bold>\<le>y"
	using glbound_in_ofD_lbound lbound_ofD2 by fast

	lemma pseudominimal_in_below_in_less_eq_glbound:
	assumes "pseudominimal_in (P.\<^bold>\<le>x) w" "pseudominimal_in (P.\<^bold>\<le>y) w"
	"glbound_in_of P x y b"
	shows "w \<^bold>\<le> b"
	using assms lbound_ofI glbound_in_ofD_glbound
	pseudominimal_inD1[of "P.\<^bold>\<le>x"] pseudominimal_inD1[of "P.\<^bold>\<le>y"]
	by fast

	end (* context ordering *)

	subsubsection \<open>Simplex-like posets\<close>

	text \<open>Define a poset to be simplex-like if it is isomorphic to the power set of some set.\<close>

	context ordering
	begin

	definition simplex_like :: "'a set \<Rightarrow> bool"
	where "simplex_like P \<equiv> finite P \<and>
	(\<exists>f A::nat set.
	OrderingSetIso less_eq less (\<subseteq>) (\<subset>) P f \<and> f`P = Pow A
	)"

	lemma simplex_likeI:
	assumes "finite P" "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) P f"
	"f`P = Pow (A::nat set)"
	shows "simplex_like P"
	using assms simplex_like_def by auto

	lemma simplex_likeD_finite: "simplex_like P \<Longrightarrow> finite P"
	using simplex_like_def by simp

	lemma simplex_likeD_iso:
	"simplex_like P \<Longrightarrow>
	\<exists>f A::nat set. OrderingSetIso less_eq less (\<subseteq>) (\<subset>) P f \<and> f`P = Pow A"
	using simplex_like_def by simp

	lemma simplex_like_has_bottom: "simplex_like P \<Longrightarrow> has_bottom P"
	using simplex_likeD_iso has_bottom_pow OrderingSetIso.pullback_has_bottom
	by fastforce

	lemma simplex_like_no_pseudominimal_imp_singleton:
	assumes "simplex_like P" "\<And>x. \<not> pseudominimal_in P x"
	shows "\<exists>p. P = {p}"
	proof-
	obtain f and A::"nat set"
	where fA: "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) P f" "f`P = Pow A"
	using simplex_likeD_iso[OF assms(1)]
	by auto
	define e where e: "e \<equiv> {}:: nat set"
	with fA(2) have "e \<in> f`P" using Pow_bottom by simp
	from this obtain p where "p \<in> P" "f p = e" by fast
	have "\<And>x. \<not> order.pseudominimal_in (Pow A) {x}"
	proof
	fix x::nat assume "order.pseudominimal_in (Pow A) {x}"
	moreover with fA(2) have "{x} \<in> f`P"
	using order.pseudominimal_inD1 by fastforce
	ultimately show False
	using assms fA simplex_like_has_bottom
	OrderingSetIso.pullback_pseudominimal_in
	by fastforce
	qed
	with e fA(2) show ?thesis
	using no_pseudominimal_in_pow_is_empty
	inj_on_to_singleton[OF OrderingSetIso.inj, OF fA(1)]
	by force
	qed

	lemma simplex_like_no_pseudominimal_in_below_in_imp_singleton:
	"\<lbrakk> x\<in>P; simplex_like (P.\<^bold>\<le>x); \<And>z. \<not> pseudominimal_in (P.\<^bold>\<le>x) z \<rbrakk> \<Longrightarrow>
	P.\<^bold>\<le>x = {x}"
	using simplex_like_no_pseudominimal_imp_singleton below_in_singleton[of x P]
	by fast

	lemma pseudo_simplex_like_has_bottom:
	"OrderingSetIso less_eq less (\<subseteq>) (\<subset>) P f \<Longrightarrow> f`P = Pow A \<Longrightarrow>
	has_bottom P"
	using has_bottom_pow OrderingSetIso.pullback_has_bottom by fastforce

	lemma pseudo_simplex_like_above_pseudominimal_is_top:
	assumes "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) P f" "f`P = Pow A" "t\<in>P"
	"\<And>x. pseudominimal_in P x \<Longrightarrow> x \<^bold>\<le> t"
	shows "f t = A"
	proof
	from assms(2,3) show "f t \<subseteq> A" by fast
	show "A \<subseteq> f t"
	proof
	fix a assume "a\<in>A"
	moreover with assms(2) have "{a} \<in> f`P" by simp
	ultimately show "a \<in> f t"
	using assms pseudominimal_in_pow_singleton[of a A]
	pseudo_simplex_like_has_bottom[of P f]
	OrderingSetIso.pullback_pseudominimal_in[OF assms(1)]
	OrderingSetIso.ordsetmap[OF assms(1), of _ t]
	by force
	qed
	qed

	lemma pseudo_simplex_like_below_in_above_pseudominimal_is_top:
	assumes "x\<in>P" "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) (P.\<^bold>\<le>x) f"
	"f`(P.\<^bold>\<le>x) = Pow A" "t \<in> P.\<^bold>\<le>x"
	"\<And>y. pseudominimal_in (P.\<^bold>\<le>x) y \<Longrightarrow> y \<^bold>\<le> t"
	shows "t = x"
	using assms(1,3-5)
	pseudo_simplex_like_above_pseudominimal_is_top[OF assms(2)]
	below_in_refl[of x P] OrderingSetIso.ordsetmap[OF assms(2), of t x]
	inj_onD[OF OrderingSetIso.inj[OF assms(2)], of t x]
	by auto

	lemma simplex_like_below_in_above_pseudominimal_is_top:
	assumes "x\<in>P" "simplex_like (P.\<^bold>\<le>x)" "t \<in> P.\<^bold>\<le>x"
	"\<And>y. pseudominimal_in (P.\<^bold>\<le>x) y \<Longrightarrow> y \<^bold>\<le> t"
	shows "t = x"
	using assms simplex_likeD_iso
	pseudo_simplex_like_below_in_above_pseudominimal_is_top[of x P _ _ t]
	by blast

	end (* context ordering *)

	lemma (in OrderingSetIso) simplex_like_map:
	assumes "domain.simplex_like P"
	shows "codomain.simplex_like (f`P)"
	proof-
	obtain g::"'a \<Rightarrow> nat set" and A::"nat set"
	where gA: "OrderingSetIso (\<^bold>\<le>) (\<^bold><) (\<subseteq>) (\<subset>) P g" "g`P = Pow A"
	using domain.simplex_likeD_iso[OF assms]
	by auto
	from gA(1) inj
	have "OrderingSetIso (\<^bold>\<le>) (\<^bold><) (\<subseteq>) (\<subset>) (f`P)
	(g \<circ> (the_inv_into P f))"
	using OrderingSetIso.iso_comp[OF inv_iso] the_inv_into_onto
	by fast
	moreover from gA(2) inj have "(g \<circ> (the_inv_into P f)) ` (f`P) = Pow A"
	using the_inv_into_onto by (auto simp add: image_comp[THEN sym])
	moreover from assms have "finite (f`P)"
	using domain.simplex_likeD_finite by fast
	ultimately show ?thesis by (auto intro: codomain.simplex_likeI)
	qed

	lemma (in OrderingSetIso) pullback_simplex_like:
	assumes "finite P" "codomain.simplex_like (f`P)"
	shows "domain.simplex_like P"
	proof-
	obtain g::"'b \<Rightarrow> nat set" and A::"nat set"
	where gA: "OrderingSetIso (\<^bold>\<le>) (\<^bold><) (\<subseteq>) (\<subset>) (f`P) g"
	"g`(f`P) = Pow A"
	using codomain.simplex_likeD_iso[OF assms(2)]
	by auto
	from assms(1) gA(2) show ?thesis
	using iso_comp[OF gA(1)]
	by (auto intro: domain.simplex_likeI simp add: image_comp)
	qed

	lemma simplex_like_pow:
	assumes "finite A"
	shows "order.simplex_like (Pow A)"
	proof-
	from assms obtain f::"'a\<Rightarrow>nat" where "inj_on f A"
	using finite_imp_inj_to_nat_seg[of A] by auto
	hence "subset_ordering_iso (Pow A) ((`) f)"
	using induced_pow_fun_subset_ordering_iso by fast
	with assms show ?thesis using induced_pow_fun_surj
	by (blast intro: order.simplex_likeI)
	qed

	subsubsection \<open>The superset ordering\<close>

	abbreviation "supset_has_bottom \<equiv> ordering.has_bottom (\<supseteq>)"
	abbreviation "supset_bottom \<equiv> ordering.bottom (\<supseteq>)"
	abbreviation "supset_lbound_of \<equiv> ordering.lbound_of (\<supseteq>)"
	abbreviation "supset_glbound_in_of \<equiv> ordering.glbound_in_of (\<supseteq>)"
	abbreviation "supset_simplex_like \<equiv> ordering.simplex_like (\<supseteq>) (\<supset>)"
	abbreviation "supset_pseudominimal_in \<equiv>
	ordering.pseudominimal_in (\<supseteq>) (\<supset>)"

	abbreviation supset_below_in :: "'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set set" (infix ".\<supseteq>" 70)
	where "P.\<supseteq>A \<equiv> ordering.below_in (\<supseteq>) P A"

	lemma supset_poset: "ordering (\<supseteq>) (\<supset>)" ..

	lemmas supset_bottomI = ordering.bottomI [OF supset_poset]
	lemmas supset_pseudominimal_inI = ordering.pseudominimal_inI [OF supset_poset]
	lemmas supset_pseudominimal_inD1 = ordering.pseudominimal_inD1 [OF supset_poset]
	lemmas supset_pseudominimal_inD2 = ordering.pseudominimal_inD2 [OF supset_poset]
	lemmas supset_lbound_ofI = ordering.lbound_ofI [OF supset_poset]
	lemmas supset_lbound_of_def = ordering.lbound_of_def [OF supset_poset]
	lemmas supset_glbound_in_ofI = ordering.glbound_in_ofI [OF supset_poset]
	lemmas supset_pseudominimal_ne_bottom =
	ordering.pseudominimal_ne_bottom[OF supset_poset]
	lemmas supset_has_bottom_pseudominimal_in_below_inI =
	ordering.has_bottom_pseudominimal_in_below_inI[OF supset_poset]
	lemmas supset_has_bottom_pseudominimal_in_below_in =
	ordering.has_bottom_pseudominimal_in_below_in[OF supset_poset]

	lemma OrderingSetIso_pow_complement:
	"OrderingSetIso (\<supseteq>) (\<supset>) (\<subseteq>) (\<subset>) (Pow A) ((-) A)"
	using inj_on_minus_set by (fast intro: OrderingSetIsoI_orders_greater2less)

	lemma simplex_like_pow_above_in:
	assumes "finite A" "X\<subseteq>A"
	shows "supset_simplex_like ((Pow A).\<supseteq>X)"
	proof (
	rule OrderingSetIso.pullback_simplex_like, rule OrderingSetIso.iso_subset,
	rule OrderingSetIso_pow_complement
	)
	from assms(1) show "finite ((Pow A).\<supseteq>X)" by simp
	from assms(1) have "finite (Pow (A-X))" by fast
	moreover from assms(2) have "((-) A) ` ((Pow A).\<supseteq>X) = Pow (A-X)"
	by auto
	ultimately
	show "ordering.simplex_like (\<subseteq>) (\<subset>) ( ((-) A) ` ((Pow A).\<supseteq>X))"
	using simplex_like_pow
	by fastforce
	qed fast

	end (* theory *)
	diff --git a/thys/CZH_Elementary_Categories/czh_ecategories/CZH_ECAT_PCategory.thy b/thys/CZH_Elementary_Categories/czh_ecategories/CZH_ECAT_PCategory.thy
	--- a/thys/CZH_Elementary_Categories/czh_ecategories/CZH_ECAT_PCategory.thy
	+++ b/thys/CZH_Elementary_Categories/czh_ecategories/CZH_ECAT_PCategory.thy
	@@ -1,5905 +1,5909 @@
	(* Copyright 2021 (C) Mihails Milehins *)

	section\<open>Product category\<close>
	theory CZH_ECAT_PCategory
	imports
	CZH_ECAT_NTCF
	CZH_ECAT_Small_Category
	CZH_Foundations.CZH_SMC_PSemicategory
	begin



	subsection\<open>Background\<close>


	text\<open>See Chapter II-3 in \cite{mac_lane_categories_2010}.\<close>

	named_theorems cat_prod_cs_simps
	named_theorems cat_prod_cs_intros



	subsection\<open>Product category: definition and elementary properties\<close>

	definition cat_prod :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
	where "cat_prod I \<AA> =
	[
	(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Obj\<rparr>),
	(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>),
	(\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>). (\<lambda>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Dom\<rparr>\<lparr>f\<lparr>i\<rparr>\<rparr>)),
	(\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>). (\<lambda>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Cod\<rparr>\<lparr>f\<lparr>i\<rparr>\<rparr>)),
	(
	\<lambda>gf\<in>\<^sub>\<circ>composable_arrs (dg_prod I \<AA>).
	(\<lambda>i\<in>\<^sub>\<circ>I. vpfst gf\<lparr>i\<rparr> \<circ>\<^sub>A\<^bsub>\<AA> i\<^esub> vpsnd gf\<lparr>i\<rparr>)
	),
	(\<lambda>a\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Obj\<rparr>). (\<lambda>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>CId\<rparr>\<lparr>a\<lparr>i\<rparr>\<rparr>))
	]\<^sub>\<circ>"

	syntax "_PCATEGORY" :: "pttrn \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
	("(3\<Prod>\<^sub>C_\<in>\<^sub>\<circ>_./ _)" [0, 0, 10] 10)
	translations "\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA>" \<rightleftharpoons> "CONST cat_prod I (\<lambda>i. \<AA>)"


	text\<open>Components.\<close>

	lemma cat_prod_components:
	shows "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr> = (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Obj\<rparr>)"
	and "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr> = (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>)"
	and "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Dom\<rparr> =
	(\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>). (\<lambda>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Dom\<rparr>\<lparr>f\<lparr>i\<rparr>\<rparr>))"
	and "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Cod\<rparr> =
	(\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>). (\<lambda>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Cod\<rparr>\<lparr>f\<lparr>i\<rparr>\<rparr>))"
	and "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Comp\<rparr> =
	(
	\<lambda>gf\<in>\<^sub>\<circ>composable_arrs (dg_prod I \<AA>).
	(\<lambda>i\<in>\<^sub>\<circ>I. vpfst gf\<lparr>i\<rparr> \<circ>\<^sub>A\<^bsub>\<AA> i\<^esub> vpsnd gf\<lparr>i\<rparr>)
	)"
	and "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr> =
	(\<lambda>a\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Obj\<rparr>). (\<lambda>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>CId\<rparr>\<lparr>a\<lparr>i\<rparr>\<rparr>))"
	unfolding cat_prod_def dg_field_simps by (simp_all add: nat_omega_simps)


	text\<open>Slicing.\<close>

	lemma cat_smc_cat_prod[slicing_commute]:
	"smc_prod I (\<lambda>i. cat_smc (\<AA> i)) = cat_smc (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	unfolding dg_prod_def cat_smc_def cat_prod_def smc_prod_def dg_field_simps
	by (simp_all add: nat_omega_simps)

	context
	fixes \<AA> \<phi> :: "V \<Rightarrow> V"
	and \<CC> :: V
	begin

	lemmas_with [
	where \<AA>=\<open>\<lambda>i. cat_smc (\<AA> i)\<close>, unfolded slicing_simps slicing_commute
	]:
	cat_prod_ObjI = smc_prod_ObjI
	and cat_prod_ObjD = smc_prod_ObjD
	and cat_prod_ObjE = smc_prod_ObjE
	and cat_prod_Obj_cong = smc_prod_Obj_cong
	and cat_prod_ArrI = smc_prod_ArrI
	and cat_prod_ArrD = smc_prod_ArrD
	and cat_prod_ArrE = smc_prod_ArrE
	and cat_prod_Arr_cong = smc_prod_Arr_cong
	and cat_prod_Dom_vsv[cat_cs_intros] = smc_prod_Dom_vsv
	and cat_prod_Dom_vdomain[cat_cs_simps] = smc_prod_Dom_vdomain
	and cat_prod_Dom_app = smc_prod_Dom_app
	and cat_prod_Dom_app_component_app[cat_cs_simps] =
	smc_prod_Dom_app_component_app
	and cat_prod_Cod_vsv[cat_cs_intros] = smc_prod_Cod_vsv
	and cat_prod_Cod_app = smc_prod_Cod_app
	and cat_prod_Cod_vdomain[cat_cs_simps] = smc_prod_Cod_vdomain
	and cat_prod_Cod_app_component_app[cat_cs_simps] =
	smc_prod_Cod_app_component_app
	and cat_prod_Comp = smc_prod_Comp
	and cat_prod_Comp_vdomain[cat_cs_simps] = smc_prod_Comp_vdomain
	and cat_prod_Comp_app = smc_prod_Comp_app
	and cat_prod_Comp_app_component[cat_cs_simps] =
	smc_prod_Comp_app_component
	and cat_prod_Comp_app_vdomain = smc_prod_Comp_app_vdomain
	and cat_prod_vunion_Obj_in_Obj = smc_prod_vunion_Obj_in_Obj
	and cat_prod_vdiff_vunion_Obj_in_Obj = smc_prod_vdiff_vunion_Obj_in_Obj
	and cat_prod_vunion_Arr_in_Arr = smc_prod_vunion_Arr_in_Arr
	and cat_prod_vdiff_vunion_Arr_in_Arr = smc_prod_vdiff_vunion_Arr_in_Arr

	end



	subsection\<open>Local assumptions for a product category\<close>

	locale pcategory_base = \<Z> \<alpha> for \<alpha> I \<AA> +
	assumes pcat_categories: "i \<in>\<^sub>\<circ> I \<Longrightarrow> category \<alpha> (\<AA> i)"
	and pcat_index_in_Vset[cat_cs_intros]: "I \<in>\<^sub>\<circ> Vset \<alpha>"

	lemma (in pcategory_base) pcat_categories'[cat_prod_cs_intros]:
	assumes "i \<in>\<^sub>\<circ> I" and "\<alpha>' = \<alpha>"
	shows "category \<alpha>' (\<AA> i)"
	using assms(1) unfolding assms(2) by (rule pcat_categories)


	text\<open>Rules.\<close>

	lemma (in pcategory_base) pcategory_base_axioms'[cat_prod_cs_intros]:
	assumes "\<alpha>' = \<alpha>" and "I' = I"
	shows "pcategory_base \<alpha>' I' \<AA>"
	unfolding assms by (rule pcategory_base_axioms)

	mk_ide rf pcategory_base_def[unfolded pcategory_base_axioms_def]
	\|intro pcategory_baseI\|
	\|dest pcategory_baseD[dest]\|
	\|elim pcategory_baseE[elim]\|

	lemma pcategory_base_psemicategory_baseI:
	assumes "psemicategory_base \<alpha> I (\<lambda>i. cat_smc (\<AA> i))"
	and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> category \<alpha> (\<AA> i)"
	shows "pcategory_base \<alpha> I \<AA>"
	proof-
	interpret psemicategory_base \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close> by (rule assms(1))
	show ?thesis
	by (intro pcategory_baseI)
	(auto simp: assms(2) psmc_index_in_Vset psmc_Obj_in_Vset psmc_Arr_in_Vset)
	qed


	text\<open>Product category is a product semicategory.\<close>

	context pcategory_base
	begin

	lemma pcat_psemicategory_base: "psemicategory_base \<alpha> I (\<lambda>i. cat_smc (\<AA> i))"
	proof(intro psemicategory_baseI)
	from pcat_index_in_Vset show "I \<in>\<^sub>\<circ> Vset \<alpha>" by auto
	qed (auto simp: category.cat_semicategory cat_prod_cs_intros)

	interpretation psmc: psemicategory_base \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	by (rule pcat_psemicategory_base)

	lemmas_with [unfolded slicing_simps slicing_commute]:
	pcat_Obj_in_Vset = psmc.psmc_Obj_in_Vset
	and pcat_Arr_in_Vset = psmc.psmc_Arr_in_Vset
	and pcat_smc_prod_Obj_in_Vset = psmc.psmc_smc_prod_Obj_in_Vset
	and pcat_smc_prod_Arr_in_Vset = psmc.psmc_smc_prod_Arr_in_Vset
	and cat_prod_Dom_app_in_Obj[cat_cs_intros] = psmc.smc_prod_Dom_app_in_Obj
	and cat_prod_Cod_app_in_Obj[cat_cs_intros] = psmc.smc_prod_Cod_app_in_Obj
	and cat_prod_is_arrI = psmc.smc_prod_is_arrI
	and cat_prod_is_arrD[dest] = psmc.smc_prod_is_arrD
	and cat_prod_is_arrE[elim] = psmc.smc_prod_is_arrE

	end

	lemma cat_prod_dg_prod_is_arr:
	"g : b \<mapsto>\<^bsub>dg_prod I \<AA>\<^esub> c \<longleftrightarrow> g : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> c"
	unfolding is_arr_def cat_prod_def smc_prod_def dg_prod_def dg_field_simps
	by (simp add: nat_omega_simps)

	lemma smc_prod_composable_arrs_dg_prod:
	"composable_arrs (dg_prod I \<AA>) = composable_arrs (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	unfolding composable_arrs_def cat_prod_dg_prod_is_arr by simp


	text\<open>Elementary properties.\<close>

	lemma (in pcategory_base) pcat_vsubset_index_pcategory_base:
	assumes "J \<subseteq>\<^sub>\<circ> I"
	shows "pcategory_base \<alpha> J \<AA>"
	proof(intro pcategory_baseI)
	show "category \<alpha> (\<AA> i)" if "i \<in>\<^sub>\<circ> J" for i
	using that assms by (auto intro: cat_prod_cs_intros)
	from assms show "J \<in>\<^sub>\<circ> Vset \<alpha>" by (simp add: vsubset_in_VsetI cat_cs_intros)
	qed auto


	subsubsection\<open>Identity\<close>

	lemma cat_prod_CId_vsv[cat_cs_intros]: "vsv ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>)"
	unfolding cat_prod_components by auto

	lemma cat_prod_CId_vdomain[cat_cs_simps]:
	"\<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>) = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>"
	unfolding cat_prod_components by simp

	lemma cat_prod_CId_app:
	assumes "a \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>"
	shows "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>a\<rparr> = (\<lambda>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>CId\<rparr>\<lparr>a\<lparr>i\<rparr>\<rparr>)"
	using assms unfolding cat_prod_components by simp

	lemma cat_prod_CId_app_component[cat_cs_simps]:
	assumes "a \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>" and "i \<in>\<^sub>\<circ> I"
	shows "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>a\<rparr>\<lparr>i\<rparr> = \<AA> i\<lparr>CId\<rparr>\<lparr>a\<lparr>i\<rparr>\<rparr>"
	using assms unfolding cat_prod_components by simp

	lemma (in pcategory_base) cat_prod_CId_vrange:
	"\<R>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>) \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>)"
	proof(intro vsubsetI)
	interpret CId: vsv \<open>((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>)\<close> by (rule cat_prod_CId_vsv)
	fix f assume "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>)"
	then obtain a where f_def: "f = ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>)\<lparr>a\<rparr>"
	and "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>)"
	by (blast dest: CId.vrange_atD)
	then have a: "a \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>"
	unfolding cat_prod_components by simp
	show "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>)"
	unfolding f_def cat_prod_CId_app[OF a]
	proof(rule VLambda_in_vproduct)
	fix i assume prems: "i \<in>\<^sub>\<circ> I"
	interpret \<AA>: category \<alpha> \<open>\<AA> i\<close>
	by (simp add: \<open>i \<in>\<^sub>\<circ> I\<close> cat_cs_intros cat_prod_cs_intros)
	from prems a have "a\<lparr>i\<rparr> \<in>\<^sub>\<circ> \<AA> i\<lparr>Obj\<rparr>" unfolding cat_prod_components by auto
	with is_arrD(1) show "\<AA> i\<lparr>CId\<rparr>\<lparr>a\<lparr>i\<rparr>\<rparr> \<in>\<^sub>\<circ> \<AA> i\<lparr>Arr\<rparr>"
	by (auto intro: cat_cs_intros)
	qed
	qed


	subsubsection\<open>A product \<open>\<alpha>\<close>-category is a tiny \<open>\<beta>\<close>-category\<close>

	lemma (in pcategory_base) pcat_tiny_category_cat_prod:
	assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
	shows "tiny_category \<beta> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	proof-

	interpret \<beta>: \<Z> \<beta> by (rule assms(1))

	show ?thesis
	proof(intro tiny_categoryI, (unfold slicing_simps)?)

	show \<Pi>: "tiny_semicategory \<beta> (cat_smc (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i))"
	unfolding slicing_commute[symmetric]
	by
	(
	intro psemicategory_base.psmc_tiny_semicategory_smc_prod;
	(rule assms pcat_psemicategory_base)?
	)
	interpret \<Pi>: tiny_semicategory \<beta> \<open>cat_smc (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close> by (rule \<Pi>)

	show "vfsequence (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)" unfolding cat_prod_def by auto
	show "vcard (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i) = 6\<^sub>\<nat>"
	unfolding cat_prod_def by (simp add: nat_omega_simps)

	show CId: "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> a"
	if a: "a \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>" for a
	proof(rule cat_prod_is_arrI)
	have [cat_cs_intros]: "a\<lparr>i\<rparr> \<in>\<^sub>\<circ> \<AA> i\<lparr>Obj\<rparr>" if i: "i \<in>\<^sub>\<circ> I" for i
	by (rule cat_prod_ObjD(3)[OF a i])
	from that show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>a\<rparr>\<lparr>i\<rparr> : a\<lparr>i\<rparr> \<mapsto>\<^bsub>\<AA> i\<^esub> a\<lparr>i\<rparr>"
	if "i \<in>\<^sub>\<circ> I" for i
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros that
	)
	qed (use that in \<open>auto simp: cat_prod_components cat_prod_CId_app that\<close>)

	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> f = f"
	if "f : a \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> b" for f a b
	proof(rule cat_prod_Arr_cong)
	note f = \<Pi>.smc_is_arrD[unfolded slicing_simps, OF that]
	note a = f(2) and b = f(3) and f = f(1)
	from CId[OF b] have CId_b:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr> : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> b"
	by simp
	from \<Pi>.smc_Comp_is_arr[unfolded slicing_simps, OF this that] show
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> f \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>"
	by (simp add: cat_cs_intros)
	from that show "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>" by auto
	fix i assume prems: "i \<in>\<^sub>\<circ> I"
	interpret \<AA>i: category \<alpha> \<open>\<AA> i\<close> by (simp add: prems cat_prod_cs_intros)
	from prems cat_prod_is_arrD(7)[OF that] have fi:
	"f\<lparr>i\<rparr> : a\<lparr>i\<rparr> \<mapsto>\<^bsub>\<AA> i\<^esub> b\<lparr>i\<rparr>"
	by auto
	from prems show "((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> f)\<lparr>i\<rparr> = f\<lparr>i\<rparr>"
	unfolding cat_prod_Comp_app_component[OF CId_b that prems]
	unfolding cat_prod_CId_app[OF b]
	by (auto intro: \<AA>i.cat_CId_left_left[OF fi])
	qed

	show "f \<circ>\<^sub>A\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr> = f"
	if "f : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> c" for f b c
	proof(rule cat_prod_Arr_cong)
	note f = \<Pi>.smc_is_arrD[unfolded slicing_simps, OF that]
	note b = f(2) and c = f(3) and f = f(1)
	from CId[OF b] have CId_b:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr> : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> b"
	by simp
	from \<Pi>.smc_Comp_is_arr[unfolded slicing_simps, OF that this] show
	"f \<circ>\<^sub>A\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr> \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>"
	by (simp add: cat_cs_intros)
	from that show "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>" by auto
	fix i assume prems: "i \<in>\<^sub>\<circ> I"
	interpret \<AA>i: category \<alpha> \<open>\<AA> i\<close> by (simp add: prems cat_prod_cs_intros)
	from prems cat_prod_is_arrD[OF that] have fi: "f\<lparr>i\<rparr> : b\<lparr>i\<rparr> \<mapsto>\<^bsub>\<AA> i\<^esub> c\<lparr>i\<rparr>"
	by simp
	from prems show "(f \<circ>\<^sub>A\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>b\<rparr>)\<lparr>i\<rparr> = f\<lparr>i\<rparr>"
	unfolding cat_prod_Comp_app_component[OF that CId_b prems]
	unfolding cat_prod_CId_app[OF b]
	by (auto intro: \<AA>i.cat_CId_right_left[OF fi])
	qed

	qed (auto simp: cat_cs_intros cat_cs_simps intro: cat_cs_intros)

	qed



	subsection\<open>Further local assumptions for product categories\<close>


	subsubsection\<open>Definition and elementary properties\<close>

	locale pcategory = pcategory_base \<alpha> I \<AA> for \<alpha> I \<AA> +
	assumes pcat_Obj_vsubset_Vset: "J \<subseteq>\<^sub>\<circ> I \<Longrightarrow> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J. \<AA> i)\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
	and pcat_Hom_vifunion_in_Vset:
	"\<lbrakk>
	J \<subseteq>\<^sub>\<circ> I;
	A \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J. \<AA> i)\<lparr>Obj\<rparr>;
	B \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J. \<AA> i)\<lparr>Obj\<rparr>;
	A \<in>\<^sub>\<circ> Vset \<alpha>;
	B \<in>\<^sub>\<circ> Vset \<alpha>
	\<rbrakk> \<Longrightarrow> (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J. \<AA> i) a b) \<in>\<^sub>\<circ> Vset \<alpha>"


	text\<open>Rules.\<close>

	lemma (in pcategory) pcategory_axioms'[cat_prod_cs_intros]:
	assumes "\<alpha>' = \<alpha>" and "I' = I"
	shows "pcategory \<alpha>' I' \<AA>"
	unfolding assms by (rule pcategory_axioms)

	mk_ide rf pcategory_def[unfolded pcategory_axioms_def]
	\|intro pcategoryI\|
	\|dest pcategoryD[dest]\|
	\|elim pcategoryE[elim]\|

	lemmas [cat_prod_cs_intros] = pcategoryD(1)

	lemma pcategory_psemicategoryI:
	assumes "psemicategory \<alpha> I (\<lambda>i. cat_smc (\<AA> i))"
	and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> category \<alpha> (\<AA> i)"
	shows "pcategory \<alpha> I \<AA>"
	proof-
	interpret psemicategory \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close> by (rule assms(1))
	note [unfolded slicing_simps slicing_commute, cat_cs_intros] =
	psmc_Obj_vsubset_Vset
	psmc_Hom_vifunion_in_Vset
	show ?thesis
	by (intro pcategoryI pcategory_base_psemicategory_baseI)
	(auto simp: assms(2) smc_prod_cs_intros intro!: cat_cs_intros)
	qed


	text\<open>Product category is a product semicategory.\<close>

	context pcategory
	begin

	lemma pcat_psemicategory: "psemicategory \<alpha> I (\<lambda>i. cat_smc (\<AA> i))"
	proof(intro psemicategoryI, unfold slicing_simps slicing_commute)
	show "psemicategory_base \<alpha> I (\<lambda>i. cat_smc (\<AA> i))"
	by (rule pcat_psemicategory_base)
	qed (auto intro!: pcat_Obj_vsubset_Vset pcat_Hom_vifunion_in_Vset)

	interpretation psmc: psemicategory \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	by (rule pcat_psemicategory)

	lemmas_with [unfolded slicing_simps slicing_commute]:
	pcat_Obj_vsubset_Vset' = psmc.psmc_Obj_vsubset_Vset'
	and pcat_Hom_vifunion_in_Vset' = psmc.psmc_Hom_vifunion_in_Vset'
	and pcat_cat_prod_vunion_is_arr = psmc.psmc_smc_prod_vunion_is_arr
	and pcat_cat_prod_vdiff_vunion_is_arr = psmc.psmc_smc_prod_vdiff_vunion_is_arr

	lemmas_with [unfolded slicing_simps slicing_commute]:
	pcat_cat_prod_vunion_Comp = psmc.psmc_smc_prod_vunion_Comp
	and pcat_cat_prod_vdiff_vunion_Comp = psmc.psmc_smc_prod_vdiff_vunion_Comp

	end


	text\<open>Elementary properties.\<close>

	lemma (in pcategory) pcat_vsubset_index_pcategory:
	assumes "J \<subseteq>\<^sub>\<circ> I"
	shows "pcategory \<alpha> J \<AA>"
	proof(intro pcategoryI pcategory_psemicategoryI)
	show "cat_prod J' \<AA>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>" if \<open>J' \<subseteq>\<^sub>\<circ> J\<close> for J'
	proof-
	from that assms have "J' \<subseteq>\<^sub>\<circ> I" by simp
	then show "cat_prod J' \<AA>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>" by (rule pcat_Obj_vsubset_Vset)
	qed
	fix A B J' assume prems:
	"J' \<subseteq>\<^sub>\<circ> J"
	"A \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J'. \<AA> i)\<lparr>Obj\<rparr>"
	"B \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J'. \<AA> i)\<lparr>Obj\<rparr>"
	"A \<in>\<^sub>\<circ> Vset \<alpha>"
	"B \<in>\<^sub>\<circ> Vset \<alpha>"
	show "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J'. \<AA> i) a b) \<in>\<^sub>\<circ> Vset \<alpha>"
	proof-
	from prems(1) assms have "J' \<subseteq>\<^sub>\<circ> I" by simp
	from pcat_Hom_vifunion_in_Vset[OF this prems(2-5)] show ?thesis.
	qed

	qed (rule pcat_vsubset_index_pcategory_base[OF assms])


	subsubsection\<open>A product \<open>\<alpha>\<close>-category is an \<open>\<alpha>\<close>-category\<close>

	lemma (in pcategory) pcat_category_cat_prod: "category \<alpha> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	proof-
	interpret tiny_category \<open>\<alpha> + \<omega>\<close> \<open>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i\<close>
	by (intro pcat_tiny_category_cat_prod)
	(auto simp: \<Z>_\<alpha>_\<alpha>\<omega> \<Z>.intro \<Z>_Limit_\<alpha>\<omega> \<Z>_\<omega>_\<alpha>\<omega>)
	show ?thesis
	by (rule category_if_category)
	(
	auto
	intro!: pcat_Hom_vifunion_in_Vset pcat_Obj_vsubset_Vset
	intro: cat_cs_intros
	)
	qed



	subsection\<open>Local assumptions for a finite product category\<close>


	subsubsection\<open>Definition and elementary properties\<close>

	locale finite_pcategory = pcategory_base \<alpha> I \<AA> for \<alpha> I \<AA> +
	assumes fin_pcat_index_vfinite: "vfinite I"


	text\<open>Rules.\<close>

	lemma (in finite_pcategory) finite_pcategory_axioms[cat_prod_cs_intros]:
	assumes "\<alpha>' = \<alpha>" and "I' = I"
	shows "finite_pcategory \<alpha>' I' \<AA>"
	unfolding assms by (rule finite_pcategory_axioms)

	mk_ide rf finite_pcategory_def[unfolded finite_pcategory_axioms_def]
	\|intro finite_pcategoryI\|
	\|dest finite_pcategoryD[dest]\|
	\|elim finite_pcategoryE[elim]\|

	lemmas [cat_prod_cs_intros] = finite_pcategoryD(1)

	lemma finite_pcategory_finite_psemicategoryI:
	assumes "finite_psemicategory \<alpha> I (\<lambda>i. cat_smc (\<AA> i))"
	and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> category \<alpha> (\<AA> i)"
	shows "finite_pcategory \<alpha> I \<AA>"
	proof-
	interpret finite_psemicategory \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close> by (rule assms(1))
	show ?thesis
	by
	(
	intro
	assms
	finite_pcategoryI
	pcategory_base_psemicategory_baseI
	finite_psemicategoryD(1)[OF assms(1)]
	fin_psmc_index_vfinite
	)
	qed


	subsubsection\<open>
	Local assumptions for a finite product semicategory and local
	assumptions for an arbitrary product semicategory
	\<close>

	sublocale finite_pcategory \<subseteq> pcategory \<alpha> I \<AA>
	proof-
	interpret finite_psemicategory \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	proof(intro finite_psemicategoryI psemicategory_baseI)
	fix i assume "i \<in>\<^sub>\<circ> I"
	then interpret \<AA>i: category \<alpha> \<open>\<AA> i\<close> by (simp add: pcat_categories)
	show "semicategory \<alpha> (cat_smc (\<AA> i))" by (simp add: \<AA>i.cat_semicategory)
	qed (auto intro!: cat_cs_intros fin_pcat_index_vfinite)
	show "pcategory \<alpha> I \<AA>"
	by (intro pcategory_psemicategoryI)
	(simp_all add: pcat_categories psemicategory_axioms)
	qed



	subsection\<open>Binary union and complement\<close>

	lemma (in pcategory) pcat_cat_prod_vunion_CId:
	assumes "vdisjnt J K"
	and "J \<subseteq>\<^sub>\<circ> I"
	and "K \<subseteq>\<^sub>\<circ> I"
	and "a \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>K. \<AA> j)\<lparr>Obj\<rparr>"
	shows
	"(\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>CId\<rparr>\<lparr>a\<rparr> \<union>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>K. \<AA> j)\<lparr>CId\<rparr>\<lparr>b\<rparr> =
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J \<union>\<^sub>\<circ> K. \<AA> i)\<lparr>CId\<rparr>\<lparr>a \<union>\<^sub>\<circ> b\<rparr>"
	proof-

	interpret J\<AA>: pcategory \<alpha> J \<AA>
	using assms(2) by (simp add: pcat_vsubset_index_pcategory)
	interpret K\<AA>: pcategory \<alpha> K \<AA>
	using assms(3) by (simp add: pcat_vsubset_index_pcategory)
	interpret JK\<AA>: pcategory \<alpha> \<open>J \<union>\<^sub>\<circ> K\<close> \<AA>
	using assms(2,3) by (simp add: pcat_vsubset_index_pcategory)

	interpret J\<AA>': category \<alpha> \<open>cat_prod J \<AA>\<close>
	by (rule J\<AA>.pcat_category_cat_prod)
	interpret K\<AA>': category \<alpha> \<open>cat_prod K \<AA>\<close>
	by (rule K\<AA>.pcat_category_cat_prod)
	interpret JK\<AA>': category \<alpha> \<open>cat_prod (J \<union>\<^sub>\<circ> K) \<AA>\<close>
	by (rule JK\<AA>.pcat_category_cat_prod)

	from assms(4) have CId_a: "cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>(\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<^esub> a"
	by (auto intro: cat_cs_intros)
	from assms(5) have CId_b: "cat_prod K \<AA>\<lparr>CId\<rparr>\<lparr>b\<rparr> : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ck\<in>\<^sub>\<circ>K. \<AA> k)\<^esub> b"
	by (auto intro: cat_cs_intros)
	have CId_a_CId_b: "cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr> \<union>\<^sub>\<circ> cat_prod K \<AA>\<lparr>CId\<rparr>\<lparr>b\<rparr> :
	a \<union>\<^sub>\<circ> b \<mapsto>\<^bsub>cat_prod (J \<union>\<^sub>\<circ> K) \<AA>\<^esub> a \<union>\<^sub>\<circ> b"
	by (rule pcat_cat_prod_vunion_is_arr[OF assms(1-3) CId_a CId_b])
	from CId_a have a: "a \<in>\<^sub>\<circ> cat_prod J \<AA>\<lparr>Obj\<rparr>" by (auto intro: cat_cs_intros)
	from CId_b have b: "b \<in>\<^sub>\<circ> cat_prod K \<AA>\<lparr>Obj\<rparr>" by (auto intro: cat_cs_intros)
	from CId_a_CId_b have ab: "a \<union>\<^sub>\<circ> b \<in>\<^sub>\<circ> cat_prod (J \<union>\<^sub>\<circ> K) \<AA>\<lparr>Obj\<rparr>"
	by (auto intro: cat_cs_intros)

	note CId_aD = J\<AA>.cat_prod_is_arrD[OF CId_a]
	and CId_bD = K\<AA>.cat_prod_is_arrD[OF CId_b]

	show ?thesis
	proof(rule cat_prod_Arr_cong[of _ \<open>J \<union>\<^sub>\<circ> K\<close> \<AA>])
	from CId_a_CId_b show
	"cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr> \<union>\<^sub>\<circ> cat_prod K \<AA>\<lparr>CId\<rparr>\<lparr>b\<rparr> \<in>\<^sub>\<circ> cat_prod (J \<union>\<^sub>\<circ> K) \<AA>\<lparr>Arr\<rparr>"
	by auto
	from ab show "cat_prod (J \<union>\<^sub>\<circ> K) \<AA>\<lparr>CId\<rparr>\<lparr>a \<union>\<^sub>\<circ> b\<rparr> \<in>\<^sub>\<circ> cat_prod (J \<union>\<^sub>\<circ> K) \<AA>\<lparr>Arr\<rparr>"
	by (auto intro: JK\<AA>'.cat_is_arrD(1) cat_cs_intros)
	fix i assume "i \<in>\<^sub>\<circ> J \<union>\<^sub>\<circ> K"
	then consider (iJ) \<open>i \<in>\<^sub>\<circ> J\<close> \| (iK) \<open>i \<in>\<^sub>\<circ> K\<close> by auto
	then show "(cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr> \<union>\<^sub>\<circ> cat_prod K \<AA>\<lparr>CId\<rparr>\<lparr>b\<rparr>)\<lparr>i\<rparr> =
	cat_prod (J \<union>\<^sub>\<circ> K) \<AA>\<lparr>CId\<rparr>\<lparr>a \<union>\<^sub>\<circ> b\<rparr>\<lparr>i\<rparr>"
	by cases
	(
	auto simp:
	assms(1)
	CId_aD(1-4)
	CId_bD(1-4)
	cat_prod_CId_app[OF ab]
	cat_prod_CId_app[OF a]
	cat_prod_CId_app[OF b]
	)
	qed

	qed

	lemma (in pcategory) pcat_cat_prod_vdiff_vunion_CId:
	assumes "J \<subseteq>\<^sub>\<circ> I"
	and "a \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> j)\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>Obj\<rparr>"
	shows
	"(\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> j)\<lparr>CId\<rparr>\<lparr>a\<rparr> \<union>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>CId\<rparr>\<lparr>b\<rparr> =
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>a \<union>\<^sub>\<circ> b\<rparr>"
	by
	(
	vdiff_of_vunion'
	rule: pcat_cat_prod_vunion_CId assms: assms(2-3) subset: assms(1)
	)



	subsection\<open>Projection\<close>


	subsubsection\<open>Definition and elementary properties\<close>


	text\<open>See Chapter II-3 in \cite{mac_lane_categories_2010}.\<close>

	definition cf_proj :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> V" (\<open>\<pi>\<^sub>C\<close>)
	where "\<pi>\<^sub>C I \<AA> i =
	[
	(\<lambda>a\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Obj\<rparr>). a\<lparr>i\<rparr>),
	(\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>). f\<lparr>i\<rparr>),
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i),
	\<AA> i
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma cf_proj_components:
	shows "\<pi>\<^sub>C I \<AA> i\<lparr>ObjMap\<rparr> = (\<lambda>a\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Obj\<rparr>). a\<lparr>i\<rparr>)"
	and "\<pi>\<^sub>C I \<AA> i\<lparr>ArrMap\<rparr> = (\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>). f\<lparr>i\<rparr>)"
	and "\<pi>\<^sub>C I \<AA> i\<lparr>HomDom\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	and "\<pi>\<^sub>C I \<AA> i\<lparr>HomCod\<rparr> = \<AA> i"
	unfolding cf_proj_def dghm_field_simps by (simp_all add: nat_omega_simps)


	text\<open>Slicing\<close>

	lemma cf_smcf_cf_proj[slicing_commute]:
	"\<pi>\<^sub>S\<^sub>M\<^sub>C I (\<lambda>i. cat_smc (\<AA> i)) i = cf_smcf (\<pi>\<^sub>C I \<AA> i)"
	unfolding
	cat_smc_def
	cf_smcf_def
	smcf_proj_def
	cf_proj_def
	cat_prod_def
	smc_prod_def
	dg_prod_def
	dg_field_simps
	dghm_field_simps
	by (simp add: nat_omega_simps)

	context pcategory
	begin

	interpretation psmc: psemicategory \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	by (rule pcat_psemicategory)

	lemmas_with [unfolded slicing_simps slicing_commute]:
	pcat_cf_proj_is_semifunctor = psmc.psmc_smcf_proj_is_semifunctor

	end


	subsubsection\<open>Projection functor is a functor\<close>

	lemma (in pcategory) pcat_cf_proj_is_functor:
	assumes "i \<in>\<^sub>\<circ> I"
	shows "\<pi>\<^sub>C I \<AA> i : (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	proof(intro is_functorI)
	interpret \<AA>: category \<alpha> \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close>
	by (simp add: pcat_category_cat_prod)
	show "vfsequence (\<pi>\<^sub>C I \<AA> i)" unfolding cf_proj_def by simp
	show "category \<alpha> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)" by (simp add: \<AA>.category_axioms)
	show "vcard (\<pi>\<^sub>C I \<AA> i) = 4\<^sub>\<nat>"
	unfolding cf_proj_def by (simp add: nat_omega_simps)
	show "\<pi>\<^sub>C I \<AA> i\<lparr>ArrMap\<rparr>\<lparr>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> = \<AA> i\<lparr>CId\<rparr>\<lparr>\<pi>\<^sub>C I \<AA> i\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>"
	if "c \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>" for c
	proof-
	interpret \<AA>i: category \<alpha> \<open>\<AA> i\<close>
	by (auto intro: assms cat_prod_cs_intros)
	from that have "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>c\<rparr> : c \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<^esub> c"
	by (simp add: \<AA>.cat_CId_is_arr)
	then have "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>c\<rparr> \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>"
	by (auto intro: cat_cs_intros)
	with assms have
	"\<pi>\<^sub>C I \<AA> i\<lparr>ArrMap\<rparr>\<lparr>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>c\<rparr>\<lparr>i\<rparr>"
	unfolding cf_proj_components cat_prod_components by simp
	also from assms have "\<dots> = \<AA> i\<lparr>CId\<rparr>\<lparr>c\<lparr>i\<rparr>\<rparr>"
	unfolding cat_prod_CId_app[OF that] by simp
	also from that have "\<dots> = \<AA> i\<lparr>CId\<rparr>\<lparr>\<pi>\<^sub>C I \<AA> i\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>"
	unfolding cf_proj_components cat_prod_components by simp
	finally show
	"\<pi>\<^sub>C I \<AA> i\<lparr>ArrMap\<rparr>\<lparr>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> = \<AA> i\<lparr>CId\<rparr>\<lparr>\<pi>\<^sub>C I \<AA> i\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>"
	by simp
	qed
	qed
	(
	auto simp:
	assms cf_proj_components pcat_cf_proj_is_semifunctor cat_prod_cs_intros
	)

	lemma (in pcategory) pcat_cf_proj_is_functor':
	assumes "i \<in>\<^sub>\<circ> I" and "\<CC> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)" and "\<DD> = \<AA> i"
	shows "\<pi>\<^sub>C I \<AA> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1) unfolding assms(2,3) by (rule pcat_cf_proj_is_functor)

	lemmas [cat_cs_intros] = pcategory.pcat_cf_proj_is_functor'



	subsection\<open>Category product universal property functor\<close>


	subsubsection\<open>Definition and elementary properties\<close>

	text\<open>
	The functor that is presented in this section is used in the proof of
	the universal property of the product category later in this work.
	\<close>

	definition cf_up :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
	where "cf_up I \<AA> \<CC> \<phi> =
	[
	(\<lambda>a\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. (\<lambda>i\<in>\<^sub>\<circ>I. \<phi> i\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>)),
	(\<lambda>f\<in>\<^sub>\<circ>\<CC>\<lparr>Arr\<rparr>. (\<lambda>i\<in>\<^sub>\<circ>I. \<phi> i\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>)),
	\<CC>,
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma cf_up_components:
	shows "cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr> = (\<lambda>a\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. (\<lambda>i\<in>\<^sub>\<circ>I. \<phi> i\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>))"
	and "cf_up I \<AA> \<CC> \<phi>\<lparr>ArrMap\<rparr> = (\<lambda>f\<in>\<^sub>\<circ>\<CC>\<lparr>Arr\<rparr>. (\<lambda>i\<in>\<^sub>\<circ>I. \<phi> i\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>))"
	and "cf_up I \<AA> \<CC> \<phi>\<lparr>HomDom\<rparr> = \<CC>"
	and "cf_up I \<AA> \<CC> \<phi>\<lparr>HomCod\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	unfolding cf_up_def dghm_field_simps by (simp_all add: nat_omega_simps)


	text\<open>Slicing.\<close>

	lemma smcf_dghm_cf_up[slicing_commute]:
	"smcf_up I (\<lambda>i. cat_smc (\<AA> i)) (cat_smc \<CC>) (\<lambda>i. cf_smcf (\<phi> i)) =
	cf_smcf (cf_up I \<AA> \<CC> \<phi>)"
	unfolding
	cat_smc_def
	cf_smcf_def
	cf_up_def
	smcf_up_def
	cat_prod_def
	smc_prod_def
	dg_prod_def
	dg_field_simps
	dghm_field_simps
	by (simp add: nat_omega_simps)

	context
	fixes \<AA> \<phi> :: "V \<Rightarrow> V"
	and \<CC> :: V
	begin

	lemmas_with
	[
	where \<AA>=\<open>\<lambda>i. cat_smc (\<AA> i)\<close> and \<phi>=\<open>\<lambda>i. cf_smcf (\<phi> i)\<close> and \<CC> = \<open>cat_smc \<CC>\<close>,
	unfolded slicing_simps slicing_commute
	]:
	cf_up_ObjMap_vdomain[simp] = smcf_up_ObjMap_vdomain
	and cf_up_ObjMap_app = smcf_up_ObjMap_app
	and cf_up_ObjMap_app_vdomain[simp] = smcf_up_ObjMap_app_vdomain
	and cf_up_ObjMap_app_component = smcf_up_ObjMap_app_component
	and cf_up_ArrMap_vdomain[simp] = smcf_up_ArrMap_vdomain
	and cf_up_ArrMap_app = smcf_up_ArrMap_app
	and cf_up_ArrMap_app_vdomain[simp] = smcf_up_ArrMap_app_vdomain
	and cf_up_ArrMap_app_component = smcf_up_ArrMap_app_component

	lemma cf_up_ObjMap_vrange:
	assumes "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> \<phi> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	shows "\<R>\<^sub>\<circ> (cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>"
	proof
	(
	rule smcf_up_ObjMap_vrange[
	where \<AA>=\<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	and \<phi>=\<open>\<lambda>i. cf_smcf (\<phi> i)\<close>
	and \<CC>=\<open>cat_smc \<CC>\<close>,
	unfolded slicing_simps slicing_commute
	]
	)
	fix i assume "i \<in>\<^sub>\<circ> I"
	then interpret is_functor \<alpha> \<CC> \<open>\<AA> i\<close> \<open>\<phi> i\<close> by (rule assms)
	show "cf_smcf (\<phi> i) : cat_smc \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> cat_smc (\<AA> i)"
	by (rule cf_is_semifunctor)
	qed

	lemma cf_up_ObjMap_app_vrange:
	assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> \<phi> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	shows " \<R>\<^sub>\<circ> (cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>) \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Obj\<rparr>)"
	proof
	(
	rule smcf_up_ObjMap_app_vrange[
	where \<AA>=\<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	and \<phi>=\<open>\<lambda>i. cf_smcf (\<phi> i)\<close>
	and \<CC>=\<open>cat_smc \<CC>\<close>,
	unfolded slicing_simps slicing_commute
	]
	)
	show "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by (rule assms)
	fix i assume "i \<in>\<^sub>\<circ> I"
	then interpret is_functor \<alpha> \<CC> \<open>\<AA> i\<close> \<open>\<phi> i\<close> by (rule assms(2))
	show "cf_smcf (\<phi> i) : cat_smc \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> cat_smc (\<AA> i)"
	by (rule cf_is_semifunctor)
	qed

	lemma cf_up_ArrMap_vrange:
	assumes "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> \<phi> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	shows "\<R>\<^sub>\<circ> (cf_up I \<AA> \<CC> \<phi>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>"
	proof
	(
	rule smcf_up_ArrMap_vrange[
	where \<AA>=\<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	and \<phi>=\<open>\<lambda>i. cf_smcf (\<phi> i)\<close>
	and \<CC>=\<open>cat_smc \<CC>\<close>,
	unfolded slicing_simps slicing_commute
	]
	)
	fix i assume "i \<in>\<^sub>\<circ> I"
	then interpret is_functor \<alpha> \<CC> \<open>\<AA> i\<close> \<open>\<phi> i\<close> by (rule assms)
	show "cf_smcf (\<phi> i) : cat_smc \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> cat_smc (\<AA> i)"
	by (rule cf_is_semifunctor)
	qed

	lemma cf_up_ArrMap_app_vrange:
	assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> \<phi> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	shows " \<R>\<^sub>\<circ> (cf_up I \<AA> \<CC> \<phi>\<lparr>ArrMap\<rparr>\<lparr>a\<rparr>) \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<AA> i\<lparr>Arr\<rparr>)"
	proof
	(
	rule smcf_up_ArrMap_app_vrange
	[
	where \<AA>=\<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	and \<phi>=\<open>\<lambda>i. cf_smcf (\<phi> i)\<close>
	and \<CC>=\<open>cat_smc \<CC>\<close>,
	unfolded slicing_simps slicing_commute
	]
	)
	fix i assume "i \<in>\<^sub>\<circ> I"
	then interpret is_functor \<alpha> \<CC> \<open>\<AA> i\<close> \<open>\<phi> i\<close> by (rule assms(2))
	show "cf_smcf (\<phi> i) : cat_smc \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> cat_smc (\<AA> i)"
	by (rule cf_is_semifunctor)
	qed (rule assms)

	end

	context pcategory
	begin

	interpretation psmc: psemicategory \<alpha> I \<open>\<lambda>i. cat_smc (\<AA> i)\<close>
	by (rule pcat_psemicategory)

	lemmas_with [unfolded slicing_simps slicing_commute]:
	pcat_smcf_comp_smcf_proj_smcf_up = psmc.psmc_Comp_smcf_proj_smcf_up
	and pcat_smcf_up_eq_smcf_proj = psmc.psmc_smcf_up_eq_smcf_proj

	end


	subsubsection\<open>Category product universal property functor is a functor\<close>

	lemma (in pcategory) pcat_cf_up_is_functor:
	assumes "category \<alpha> \<CC>" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> \<phi> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	shows "cf_up I \<AA> \<CC> \<phi> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	proof-
	interpret \<CC>: category \<alpha> \<CC> by (simp add: assms(1))
	interpret \<AA>: category \<alpha> \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close> by (rule pcat_category_cat_prod)
	show ?thesis
	proof(intro is_functorI)
	show "vfsequence (cf_up I \<AA> \<CC> \<phi>)" unfolding cf_up_def by simp
	show "vcard (cf_up I \<AA> \<CC> \<phi>) = 4\<^sub>\<nat>"
	unfolding cf_up_def by (simp add: nat_omega_simps)
	show "cf_smcf (cf_up I \<AA> \<CC> \<phi>) : cat_smc \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> cat_smc (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	unfolding slicing_commute[symmetric]
	by (rule psemicategory.psmc_smcf_up_is_semifunctor)
	(
	auto simp:
	assms(2)
	pcat_psemicategory
	is_functor.cf_is_semifunctor
	slicing_intros
	)
	show "cf_up I \<AA> \<CC> \<phi>\<lparr>ArrMap\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> =
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>"
	if "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for c
	proof(rule cat_prod_Arr_cong)
	from that is_arrD(1) have CId_c: "\<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr> \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	by (auto intro: cat_cs_intros)
	from CId_c cf_up_ArrMap_vrange[OF assms(2), simplified]
	show "cf_up I \<AA> \<CC> \<phi>\<lparr>ArrMap\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>"
	unfolding cf_up_components by force
	have cf_up_\<phi>_c: "cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Obj\<rparr>"
	unfolding cat_prod_components
	proof(intro vproductI ballI)
	fix i assume prems: "i \<in>\<^sub>\<circ> I"
	interpret \<phi>: is_functor \<alpha> \<CC> \<open>\<AA> i\<close> \<open>\<phi> i\<close> by (simp add: prems assms(2))
	from that show "cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<lparr>i\<rparr> \<in>\<^sub>\<circ> \<AA> i\<lparr>Obj\<rparr>"
	unfolding cf_up_ObjMap_app_component[OF that prems]
	by (auto intro: cat_cs_intros)
	qed (simp_all add: cf_up_ObjMap_app that cf_up_ObjMap_app[OF that])
	from \<AA>.cat_CId_is_arr[OF this] show
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr> \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>Arr\<rparr>"
	by auto
	fix i assume prems: "i \<in>\<^sub>\<circ> I"
	interpret \<phi>: is_functor \<alpha> \<CC> \<open>\<AA> i\<close> \<open>\<phi> i\<close> by (simp add: prems assms(2))
	from cf_up_\<phi>_c prems show
	"cf_up I \<AA> \<CC> \<phi>\<lparr>ArrMap\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>\<lparr>i\<rparr> =
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<lparr>CId\<rparr>\<lparr>cf_up I \<AA> \<CC> \<phi>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>\<lparr>i\<rparr>"
	unfolding cf_up_ArrMap_app_component[OF CId_c prems] cat_prod_components
	by
	(
	simp add:
	that cf_up_ObjMap_app_component[OF that prems] \<phi>.cf_ObjMap_CId
	)
	qed
	qed (auto simp: cf_up_components cat_cs_intros)
	qed


	subsubsection\<open>Further properties\<close>

	lemma (in pcategory) pcat_Comp_cf_proj_cf_up:
	assumes "category \<alpha> \<CC>"
	and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> \<phi> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	and "i \<in>\<^sub>\<circ> I"
	shows "\<phi> i = \<pi>\<^sub>C I \<AA> i \<circ>\<^sub>C\<^sub>F (cf_up I \<AA> \<CC> \<phi>)"
	proof-
	interpret \<phi>: is_functor \<alpha> \<CC> \<open>\<AA> i\<close> \<open>\<phi> i\<close> by (rule assms(2)[OF assms(3)])
	interpret \<pi>: is_functor \<alpha> \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close> \<open>\<AA> i\<close> \<open>\<pi>\<^sub>C I \<AA> i\<close>
	by (simp add: assms(3) pcat_cf_proj_is_functor)
	interpret up: is_functor \<alpha> \<CC> \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close> \<open>cf_up I \<AA> \<CC> \<phi>\<close>
	by (simp add: assms(2) \<phi>.HomDom.category_axioms pcat_cf_up_is_functor)
	show ?thesis
	proof(rule cf_smcf_eqI)
	show "\<pi>\<^sub>C I \<AA> i \<circ>\<^sub>C\<^sub>F cf_up I \<AA> \<CC> \<phi> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	by (auto intro: cat_cs_intros)
	from assms show "cf_smcf (\<phi> i) = cf_smcf (\<pi>\<^sub>C I \<AA> i \<circ>\<^sub>C\<^sub>F cf_up I \<AA> \<CC> \<phi>)"
	unfolding slicing_simps slicing_commute[symmetric]
	by
	(
	intro pcat_smcf_comp_smcf_proj_smcf_up[
	where \<phi>=\<open>\<lambda>i. cf_smcf (\<phi> i)\<close>, unfolded slicing_commute[symmetric]
	]
	)
	(auto simp: is_functor.cf_is_semifunctor)
	qed (auto intro: cat_cs_intros)
	qed

	lemma (in pcategory) pcat_cf_up_eq_cf_proj:
	assumes "\<FF> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> \<phi> i = \<pi>\<^sub>C I \<AA> i \<circ>\<^sub>C\<^sub>F \<FF>"
	shows "cf_up I \<AA> \<CC> \<phi> = \<FF>"
	proof(rule cf_smcf_eqI)
	interpret \<FF>: is_functor \<alpha> \<CC> \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close> \<FF> by (rule assms(1))
	show "cf_up I \<AA> \<CC> \<phi> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)"
	proof(rule pcat_cf_up_is_functor)
	fix i assume prems: "i \<in>\<^sub>\<circ> I"
	then interpret \<pi>: is_functor \<alpha> \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close> \<open>\<AA> i\<close> \<open>\<pi>\<^sub>C I \<AA> i\<close>
	by (rule pcat_cf_proj_is_functor)
	show "\<phi> i : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> i"
	unfolding assms(2)[OF prems] by (auto intro: cat_cs_intros)
	qed (auto intro: cat_cs_intros)
	show "\<FF> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)" by (rule assms(1))
	from assms show "cf_smcf (cf_up I \<AA> \<CC> \<phi>) = cf_smcf \<FF>"
	unfolding slicing_commute[symmetric]
	by (intro pcat_smcf_up_eq_smcf_proj) (auto simp: slicing_commute)
	qed simp_all



	subsection\<open>Prodfunctor with respect to a fixed argument\<close>

	text\<open>
	A prodfunctor is a functor whose domain is a product category.
	It is a generalization of the concept of the bifunctor,
	as presented in Chapter II-3 in \cite{mac_lane_categories_2010}.
	\<close>

	definition prodfunctor_proj :: "V \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "prodfunctor_proj \<SS> I \<AA> \<DD> J c =
	[
	(\<lambda>b\<in>\<^sub>\<circ>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i)\<lparr>Obj\<rparr>. \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>),
	(\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i)\<lparr>Arr\<rparr>. \<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>),
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i),
	\<DD>
	]\<^sub>\<circ>"

	syntax "_PPRODFUNCTOR_PROJ" :: "V \<Rightarrow> pttrn \<Rightarrow> V \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	(\<open>(_\<^bsub>(3\<Prod>\<^sub>C_\<in>\<^sub>\<circ>_-\<^sub>\<circ>_./_),_\<^esub>/'(/-,_/'))\<close> [51, 51, 51, 51, 51, 51, 51] 51)
	translations "\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I-\<^sub>\<circ>J. \<AA>,\<DD>\<^esub>(-,c)" \<rightleftharpoons>
	"CONST prodfunctor_proj \<SS> I (\<lambda>i. \<AA>) \<DD> J c"


	text\<open>Components.\<close>

	lemma prodfunctor_proj_components:
	shows "(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i,\<DD>\<^esub>(-,c))\<lparr>ObjMap\<rparr> =
	(\<lambda>b\<in>\<^sub>\<circ>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i)\<lparr>Obj\<rparr>. \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>)"
	and "(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i,\<DD>\<^esub>(-,c))\<lparr>ArrMap\<rparr> =
	(\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i)\<lparr>Arr\<rparr>. \<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>)"
	and "(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i,\<DD>\<^esub>(-,c))\<lparr>HomDom\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i)"
	and "(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i,\<DD>\<^esub>(-,c))\<lparr>HomCod\<rparr> = \<DD>"
	unfolding prodfunctor_proj_def dghm_field_simps
	by (simp_all add: nat_omega_simps)


	subsubsection\<open>Object map\<close>

	mk_VLambda prodfunctor_proj_components(1)
	\|vsv prodfunctor_proj_ObjMap_vsv[cat_cs_intros]\|
	\|vdomain prodfunctor_proj_ObjMap_vdomain[cat_cs_simps]\|
	\|app prodfunctor_proj_ObjMap_app[cat_cs_simps]\|


	subsubsection\<open>Arrow map\<close>

	mk_VLambda prodfunctor_proj_components(2)
	\|vsv prodfunctor_proj_ArrMap_vsv[cat_cs_intros]\|
	\|vdomain prodfunctor_proj_ArrMap_vdomain[cat_cs_simps]\|
	\|app prodfunctor_proj_ArrMap_app[cat_cs_simps]\|


	subsubsection\<open>Prodfunctor with respect to a fixed argument is a functor\<close>

	lemma (in pcategory) pcat_prodfunctor_proj_is_functor:
	assumes "\<SS> : (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "c \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>Obj\<rparr>"
	and "J \<subseteq>\<^sub>\<circ> I"
	shows "(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i,\<DD>\<^esub>(-,c)) : (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	proof-

	interpret is_functor \<alpha> \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i)\<close> \<DD> \<SS> by (rule assms(1))
	interpret \<AA>: pcategory \<alpha> J \<AA>
	using assms(3) by (intro pcat_vsubset_index_pcategory) auto
	interpret J_\<AA>: category \<alpha> \<open>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>J. \<AA> i\<close> by (rule \<AA>.pcat_category_cat_prod)
	interpret IJ: pcategory \<alpha> \<open>I -\<^sub>\<circ> J\<close> \<AA>
	using assms(3) by (intro pcat_vsubset_index_pcategory) auto
	interpret IJ_\<AA>: category \<alpha> \<open>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i\<close>
	by (rule IJ.pcat_category_cat_prod)

	let ?IJ\<AA> = \<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i)\<close>

	from assms(2) have "c \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. \<AA> j\<lparr>Obj\<rparr>)"
	unfolding cat_prod_components by simp
	then have "(\<Prod>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. \<AA> j\<lparr>Obj\<rparr>) \<noteq> 0" by (auto intro!: cat_cs_intros)

	show ?thesis
	proof(intro is_functorI', unfold prodfunctor_proj_components)

	show "vfsequence (prodfunctor_proj \<SS> I \<AA> \<DD> J c)"
	unfolding prodfunctor_proj_def by simp
	show "vcard (prodfunctor_proj \<SS> I \<AA> \<DD> J c) = 4\<^sub>\<nat>"
	unfolding prodfunctor_proj_def by (simp add: nat_omega_simps)

	show "\<R>\<^sub>\<circ> (\<lambda>b\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Obj\<rparr>. \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	proof(intro vsubsetI)
	fix x assume "x \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<lambda>b\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Obj\<rparr>. \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>)"
	then obtain b where x_def: "x = \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>" and b: "b \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Obj\<rparr>"
	by auto
	have "b \<union>\<^sub>\<circ> c \<in>\<^sub>\<circ> cat_prod I \<AA>\<lparr>Obj\<rparr>"
	proof(rule cat_prod_vdiff_vunion_Obj_in_Obj)
	show "b \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Obj\<rparr>" by (rule b)
	qed (intro assms(2,3))+
	then show "x \<in>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>" unfolding x_def by (auto intro: cat_cs_intros)
	qed

	show is_arr:
	"(\<lambda>f\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Arr\<rparr>. \<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>)\<lparr>f\<rparr> :
	(\<lambda>b\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Obj\<rparr>. \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>)\<lparr>a\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub>
	(\<lambda>b\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Obj\<rparr>. \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>)\<lparr>b\<rparr>"
	(is \<open>?V_f: ?V_a \<mapsto>\<^bsub>\<DD>\<^esub> ?V_b\<close>)
	if "f : a \<mapsto>\<^bsub>?IJ\<AA>\<^esub> b" for f a b
	proof-
	let ?fc = \<open>f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<close>
	have "?fc : a \<union>\<^sub>\<circ> c \<mapsto>\<^bsub>cat_prod I \<AA>\<^esub> b \<union>\<^sub>\<circ> c"
	proof(rule pcat_cat_prod_vdiff_vunion_is_arr)
	show "f : a \<mapsto>\<^bsub>?IJ\<AA>\<^esub> b" by (rule that)
	qed (auto simp: assms cat_cs_intros)
	then have "\<SS>\<lparr>ArrMap\<rparr>\<lparr>?fc\<rparr> : \<SS>\<lparr>ObjMap\<rparr>\<lparr>a \<union>\<^sub>\<circ> c\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>"
	by (auto intro: cat_cs_intros)
	moreover from that have "f \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Arr\<rparr>" "a \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Obj\<rparr>" "b \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Obj\<rparr>"
	by (auto intro: cat_cs_intros)
	ultimately show ?thesis by simp
	qed

	show
	"(\<lambda>f\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Arr\<rparr>. \<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>)\<lparr>g \<circ>\<^sub>A\<^bsub>?IJ\<AA>\<^esub> f\<rparr> =
	(\<lambda>f\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Arr\<rparr>. \<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>)\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub>
	(\<lambda>f\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Arr\<rparr>. \<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>)\<lparr>f\<rparr>"
	if "g : b' \<mapsto>\<^bsub>?IJ\<AA>\<^esub> c'" and "f : a' \<mapsto>\<^bsub>?IJ\<AA>\<^esub> b'" for g b' c' f a'
	proof-
	from that have gf: "g \<circ>\<^sub>A\<^bsub>?IJ\<AA>\<^esub> f : a' \<mapsto>\<^bsub>?IJ\<AA>\<^esub> c'"
	by (auto intro: cat_cs_intros)
	from assms(2) have CId_c: "cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr> : c \<mapsto>\<^bsub>cat_prod J \<AA>\<^esub> c"
	by (auto intro: cat_cs_intros)
	then have [simp]:
	"cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr> \<circ>\<^sub>A\<^bsub>cat_prod J \<AA>\<^esub> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr> =
	cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>"
	by (auto simp: cat_cs_simps)
	from assms(3) that(1) CId_c have g_CId_c:
	"g \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr> : b' \<union>\<^sub>\<circ> c \<mapsto>\<^bsub>cat_prod I \<AA>\<^esub> c' \<union>\<^sub>\<circ> c"
	by (rule pcat_cat_prod_vdiff_vunion_is_arr)
	from assms(3) that(2) CId_c have f_CId_c:
	"f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr> : a' \<union>\<^sub>\<circ> c \<mapsto>\<^bsub>cat_prod I \<AA>\<^esub> b' \<union>\<^sub>\<circ> c"
	by (rule pcat_cat_prod_vdiff_vunion_is_arr)
	have
	"\<SS>\<lparr>ArrMap\<rparr>\<lparr>(g \<circ>\<^sub>A\<^bsub>?IJ\<AA>\<^esub> f) \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> =
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>g \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub>
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>"
	unfolding
	pcat_cat_prod_vdiff_vunion_Comp[
	OF assms(3) that(1) CId_c that(2) CId_c, simplified
	]
	by (intro cf_ArrMap_Comp[OF g_CId_c f_CId_c])
	moreover from gf have "g \<circ>\<^sub>A\<^bsub>?IJ\<AA>\<^esub> f \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Arr\<rparr>" by auto
	moreover from that have "g \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Arr\<rparr>" "f \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Arr\<rparr>" by auto
	ultimately show ?thesis by simp
	qed

	show
	"(\<lambda>f\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Arr\<rparr>. \<SS>\<lparr>ArrMap\<rparr>\<lparr>f \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>)\<lparr>?IJ\<AA>\<lparr>CId\<rparr>\<lparr>c'\<rparr>\<rparr> =
	\<DD>\<lparr>CId\<rparr>\<lparr>(\<lambda>b\<in>\<^sub>\<circ>?IJ\<AA>\<lparr>Obj\<rparr>. \<SS>\<lparr>ObjMap\<rparr>\<lparr>b \<union>\<^sub>\<circ> c\<rparr>)\<lparr>c'\<rparr>\<rparr>"
	if "c' \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Obj\<rparr>" for c'
	proof-
	have "?IJ\<AA>\<lparr>CId\<rparr>\<lparr>c'\<rparr> \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr> = cat_prod I \<AA>\<lparr>CId\<rparr>\<lparr>c' \<union>\<^sub>\<circ> c\<rparr>"
	unfolding pcat_cat_prod_vdiff_vunion_CId[OF assms(3) that assms(2)] ..
	moreover from assms(3) that assms(2) have "c' \<union>\<^sub>\<circ> c \<in>\<^sub>\<circ> cat_prod I \<AA>\<lparr>Obj\<rparr>"
	by (rule cat_prod_vdiff_vunion_Obj_in_Obj)
	ultimately have "\<SS>\<lparr>ArrMap\<rparr>\<lparr>?IJ\<AA>\<lparr>CId\<rparr>\<lparr>c'\<rparr> \<union>\<^sub>\<circ> cat_prod J \<AA>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> =
	\<DD>\<lparr>CId\<rparr>\<lparr>\<SS>\<lparr>ObjMap\<rparr>\<lparr>c' \<union>\<^sub>\<circ> c\<rparr>\<rparr>"
	by (auto intro: cat_cs_intros)
	moreover from that have CId_c': "?IJ\<AA>\<lparr>CId\<rparr>\<lparr>c'\<rparr> \<in>\<^sub>\<circ> ?IJ\<AA>\<lparr>Arr\<rparr>"
	by (auto dest!: IJ_\<AA>.cat_CId_is_arr)
	ultimately show ?thesis by (simp add: that)
	qed

	qed (auto intro: cat_cs_intros)

	qed

	lemma (in pcategory) pcat_prodfunctor_proj_is_functor':
	assumes "\<SS> : (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I. \<AA> i) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "c \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>J. \<AA> j)\<lparr>Obj\<rparr>"
	and "J \<subseteq>\<^sub>\<circ> I"
	and "\<AA>' = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i)"
	and "\<BB>' = \<DD>"
	shows "(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>I -\<^sub>\<circ> J. \<AA> i,\<DD>\<^esub>(-,c)) : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>'"
	using assms(1-3)
	unfolding assms(4,5)
	by (rule pcat_prodfunctor_proj_is_functor)

	lemmas [cat_cs_intros] = pcategory.pcat_prodfunctor_proj_is_functor'



	subsection\<open>Singleton category\<close>


	subsubsection\<open>Slicing\<close>

	context
	fixes \<CC> :: V
	begin

	lemmas_with [where \<CC>=\<open>cat_smc \<CC>\<close>, unfolded slicing_simps slicing_commute]:
	cat_singleton_ObjI = smc_singleton_ObjI
	and cat_singleton_ObjE = smc_singleton_ObjE
	and cat_singleton_ArrI = smc_singleton_ArrI
	and cat_singleton_ArrE = smc_singleton_ArrE

	end

	context category
	begin

	interpretation smc: semicategory \<alpha> \<open>cat_smc \<CC>\<close> by (rule cat_semicategory)

	lemmas_with [unfolded slicing_simps slicing_commute]:
	cat_finite_psemicategory_cat_singleton =
	smc.smc_finite_psemicategory_smc_singleton
	and cat_singleton_is_arrI = smc.smc_singleton_is_arrI
	and cat_singleton_is_arrD = smc.smc_singleton_is_arrD
	and cat_singleton_is_arrE = smc.smc_singleton_is_arrE

	end


	subsubsection\<open>Identity\<close>

	lemma cat_singleton_CId_app:
	assumes "set {\<langle>j, a\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)\<lparr>Obj\<rparr>"
	shows "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)\<lparr>CId\<rparr>\<lparr>set {\<langle>j, a\<rangle>}\<rparr> = set {\<langle>j, \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr>\<rangle>}"
	using assms unfolding cat_prod_components VLambda_vsingleton by simp


	subsubsection\<open>Singleton category is a category\<close>

	lemma (in category) cat_finite_pcategory_cat_singleton:
	assumes "j \<in>\<^sub>\<circ> Vset \<alpha>"
	shows "finite_pcategory \<alpha> (set {j}) (\<lambda>i. \<CC>)"
	by
	(
	auto intro:
	assms
	category_axioms
	finite_pcategory_finite_psemicategoryI
	cat_finite_psemicategory_cat_singleton
	)

	lemma (in category) cat_category_cat_singleton:
	assumes "j \<in>\<^sub>\<circ> Vset \<alpha>"
	shows "category \<alpha> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)"
	proof-
	interpret finite_pcategory \<alpha> \<open>set {j}\<close> \<open>\<lambda>i. \<CC>\<close>
	using assms by (rule cat_finite_pcategory_cat_singleton)
	show ?thesis by (rule pcat_category_cat_prod)
	qed



	subsection\<open>Singleton functor\<close>


	subsubsection\<open>Definition and elementary properties\<close>

	definition cf_singleton :: "V \<Rightarrow> V \<Rightarrow> V"
	where "cf_singleton j \<CC> =
	[
	(\<lambda>a\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. set {\<langle>j, a\<rangle>}),
	(\<lambda>f\<in>\<^sub>\<circ>\<CC>\<lparr>Arr\<rparr>. set {\<langle>j, f\<rangle>}),
	\<CC>,
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma cf_singleton_components:
	shows "cf_singleton j \<CC>\<lparr>ObjMap\<rparr> = (\<lambda>a\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. set {\<langle>j, a\<rangle>})"
	and "cf_singleton j \<CC>\<lparr>ArrMap\<rparr> = (\<lambda>f\<in>\<^sub>\<circ>\<CC>\<lparr>Arr\<rparr>. set {\<langle>j, f\<rangle>})"
	and "cf_singleton j \<CC>\<lparr>HomDom\<rparr> = \<CC>"
	and "cf_singleton j \<CC>\<lparr>HomCod\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)"
	unfolding cf_singleton_def dghm_field_simps by (simp_all add: nat_omega_simps)


	text\<open>Slicing.\<close>

	lemma cf_smcf_cf_singleton[slicing_commute]:
	"smcf_singleton j (cat_smc \<CC>)= cf_smcf (cf_singleton j \<CC>)"
	unfolding smcf_singleton_def cf_singleton_def slicing_simps slicing_commute
	by
	(
	simp add:
	nat_omega_simps dghm_field_simps dg_field_simps cat_smc_def cf_smcf_def
	)

	context
	fixes \<CC> :: V
	begin

	lemmas_with [where \<CC>=\<open>cat_smc \<CC>\<close>, unfolded slicing_simps slicing_commute]:
	cf_singleton_ObjMap_vsv[cat_cs_intros] = smcf_singleton_ObjMap_vsv
	and cf_singleton_ObjMap_vdomain[cat_cs_simps] = smcf_singleton_ObjMap_vdomain
	and cf_singleton_ObjMap_vrange = smcf_singleton_ObjMap_vrange
	and cf_singleton_ObjMap_app[cat_prod_cs_simps] = smcf_singleton_ObjMap_app
	and cf_singleton_ArrMap_vsv[cat_cs_intros] = smcf_singleton_ArrMap_vsv
	and cf_singleton_ArrMap_vdomain[cat_cs_simps] = smcf_singleton_ArrMap_vdomain
	and cf_singleton_ArrMap_vrange = smcf_singleton_ArrMap_vrange
	and cf_singleton_ArrMap_app[cat_prod_cs_simps] = smcf_singleton_ArrMap_app

	end


	subsubsection\<open>Singleton functor is an isomorphism of categories\<close>

	lemma (in category) cat_cf_singleton_is_functor:
	assumes "j \<in>\<^sub>\<circ> Vset \<alpha>"
	shows "cf_singleton j \<CC> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)"
	proof(intro is_iso_functorI is_functorI)
	from assms show smcf_singleton: "cf_smcf (cf_singleton j \<CC>) :
	cat_smc \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> cat_smc (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)"
	unfolding slicing_commute[symmetric]
	by (intro semicategory.smc_smcf_singleton_is_iso_semifunctor)
	(auto intro: smc_cs_intros slicing_intros)
	show "vfsequence (cf_singleton j \<CC>)" unfolding cf_singleton_def by simp
	show "vcard (cf_singleton j \<CC>) = 4\<^sub>\<nat>"
	unfolding cf_singleton_def by (simp add: nat_omega_simps)
	show "cf_smcf (cf_singleton j \<CC>) :
	cat_smc \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> cat_smc (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)"
	by (intro is_iso_semifunctor.axioms(1) smcf_singleton)
	show "cf_singleton j \<CC>\<lparr>ArrMap\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> =
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)\<lparr>CId\<rparr>\<lparr>cf_singleton j \<CC>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>"
	if "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for c
	proof-
	from that have CId_c: "\<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr> : c \<mapsto>\<^bsub>\<CC>\<^esub> c" by (auto simp: cat_cs_intros)
	have "set {\<langle>j, c\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)\<lparr>Obj\<rparr>"
	by (simp add: cat_singleton_ObjI that)
	with that have "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {j}. \<CC>)\<lparr>CId\<rparr>\<lparr>cf_singleton j \<CC>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr> =
	set {\<langle>j, \<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rangle>}"
	by (simp add: cf_singleton_ObjMap_app cat_singleton_CId_app)
	moreover from CId_c have
	"cf_singleton j \<CC>\<lparr>ArrMap\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> = set {\<langle>j, \<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rangle>}"
	by (auto simp: cf_singleton_ArrMap_app cat_cs_intros)
	ultimately show ?thesis by simp
	qed
	qed
	(
	auto simp:
	cat_cs_intros assms cat_category_cat_singleton cf_singleton_components
	)



	subsection\<open>Product of two categories\<close>


	subsubsection\<open>Definition and elementary properties.\<close>


	text\<open>See Chapter II-3 in \cite{mac_lane_categories_2010}.\<close>

	definition cat_prod_2 :: "V \<Rightarrow> V \<Rightarrow> V" (infixr \<open>\<times>\<^sub>C\<close> 80)
	where "\<AA> \<times>\<^sub>C \<BB> \<equiv> cat_prod (2\<^sub>\<nat>) (\<lambda>i. if i = 0 then \<AA> else \<BB>)"


	text\<open>Slicing.\<close>

	lemma cat_smc_cat_prod_2[slicing_commute]:
	"cat_smc \<AA> \<times>\<^sub>S\<^sub>M\<^sub>C cat_smc \<BB> = cat_smc (\<AA> \<times>\<^sub>C \<BB>)"
	unfolding cat_prod_2_def smc_prod_2_def slicing_commute[symmetric] if_distrib
	by simp

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	lemmas_with
	[
	where \<AA>=\<open>cat_smc \<AA>\<close> and \<BB>=\<open>cat_smc \<BB>\<close>,
	unfolded slicing_simps slicing_commute,
	OF \<AA>.cat_semicategory \<BB>.cat_semicategory
	]:
	cat_prod_2_ObjI = smc_prod_2_ObjI
	and cat_prod_2_ObjI'[cat_prod_cs_intros] = smc_prod_2_ObjI'
	and cat_prod_2_ObjE = smc_prod_2_ObjE
	and cat_prod_2_ArrI = smc_prod_2_ArrI
	and cat_prod_2_ArrI'[cat_prod_cs_intros] = smc_prod_2_ArrI'
	and cat_prod_2_ArrE = smc_prod_2_ArrE
	and cat_prod_2_is_arrI = smc_prod_2_is_arrI
	and cat_prod_2_is_arrI'[cat_prod_cs_intros] = smc_prod_2_is_arrI'
	and cat_prod_2_is_arrE = smc_prod_2_is_arrE
	and cat_prod_2_Dom_vsv = smc_prod_2_Dom_vsv
	and cat_prod_2_Dom_vdomain[cat_cs_simps] = smc_prod_2_Dom_vdomain
	and cat_prod_2_Dom_app[cat_prod_cs_simps] = smc_prod_2_Dom_app
	and cat_prod_2_Dom_vrange = smc_prod_2_Dom_vrange
	and cat_prod_2_Cod_vsv = smc_prod_2_Cod_vsv
	and cat_prod_2_Cod_vdomain[cat_cs_simps] = smc_prod_2_Cod_vdomain
	and cat_prod_2_Cod_app[cat_prod_cs_simps] = smc_prod_2_Cod_app
	and cat_prod_2_Cod_vrange = smc_prod_2_Cod_vrange
	and cat_prod_2_op_cat_cat_Obj[cat_op_simps] = smc_prod_2_op_smc_smc_Obj
	and cat_prod_2_cat_op_cat_Obj[cat_op_simps] = smc_prod_2_smc_op_smc_Obj
	and cat_prod_2_op_cat_cat_Arr[cat_op_simps] = smc_prod_2_op_smc_smc_Arr
	and cat_prod_2_cat_op_cat_Arr[cat_op_simps] = smc_prod_2_smc_op_smc_Arr

	lemmas_with
	[
	where \<AA>=\<open>cat_smc \<AA>\<close> and \<BB>=\<open>cat_smc \<BB>\<close>,
	unfolded slicing_simps slicing_commute,
	OF \<AA>.cat_semicategory \<BB>.cat_semicategory
	]:
	cat_prod_2_Comp_app[cat_prod_cs_simps] = smc_prod_2_Comp_app

	end


	subsubsection\<open>Product of two categories is a category\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<Z> \<alpha> by (rule categoryD[OF \<AA>])
	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	lemma finite_pcategory_cat_prod_2: "finite_pcategory \<alpha> (2\<^sub>\<nat>) (if2 \<AA> \<BB>)"
	proof(intro finite_pcategoryI pcategory_baseI)
	from Axiom_of_Infinity show z1_in_Vset: "2\<^sub>\<nat> \<in>\<^sub>\<circ> Vset \<alpha>" by blast
	show "category \<alpha> (i = 0 ? \<AA> : \<BB>)" if "i \<in>\<^sub>\<circ> 2\<^sub>\<nat>" for i
	by (auto simp: cat_cs_intros)
	qed auto

	interpretation finite_pcategory \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 \<AA> \<BB>\<close>
	by (intro finite_pcategory_cat_prod_2 \<AA> \<BB>)

	lemma category_cat_prod_2[cat_cs_intros]: "category \<alpha> (\<AA> \<times>\<^sub>C \<BB>)"
	unfolding cat_prod_2_def by (rule pcat_category_cat_prod)

	end


	subsubsection\<open>Identity\<close>

	lemma cat_prod_2_CId_vsv[cat_cs_intros]: "vsv ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>)"
	unfolding cat_prod_2_def cat_prod_components by simp

	lemma cat_prod_2_CId_vdomain[cat_cs_simps]:
	"\<D>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>) = (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	unfolding cat_prod_2_def cat_prod_components by simp

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	interpretation finite_pcategory \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>(\<lambda>i. if i = 0 then \<AA> else \<BB>)\<close>
	by (intro finite_pcategory_cat_prod_2 \<AA> \<BB>)

	lemma cat_prod_2_CId_app[cat_prod_cs_simps]:
	assumes "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	shows "(\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> = [\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>]\<^sub>\<circ>"
	proof-
	have "(\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> =
	(\<lambda>i\<in>\<^sub>\<circ>2\<^sub>\<nat>. (if i = 0 then \<AA> else \<BB>)\<lparr>CId\<rparr>\<lparr>[a, b]\<^sub>\<circ>\<lparr>i\<rparr>\<rparr>)"
	by
	(
	rule
	cat_prod_CId_app[
	OF assms[unfolded cat_prod_2_def], folded cat_prod_2_def
	]
	)
	also have
	"(\<lambda>i\<in>\<^sub>\<circ>2\<^sub>\<nat>. (if i = 0 then \<AA> else \<BB>)\<lparr>CId\<rparr>\<lparr>[a, b]\<^sub>\<circ>\<lparr>i\<rparr>\<rparr>) =
	[\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>]\<^sub>\<circ>"
	proof(rule vsv_eqI, unfold vdomain_VLambda)
	fix i assume "i \<in>\<^sub>\<circ> 2\<^sub>\<nat>"
	then consider \<open>i = 0\<close> \| \<open>i = 1\<^sub>\<nat>\<close> unfolding two by auto
	then show
	"(\<lambda>i\<in>\<^sub>\<circ>2\<^sub>\<nat>. (if i = 0 then \<AA> else \<BB>)\<lparr>CId\<rparr>\<lparr>[a, b]\<^sub>\<circ>\<lparr>i\<rparr>\<rparr>)\<lparr>i\<rparr> =
	[\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>]\<^sub>\<circ>\<lparr>i\<rparr>"
	by cases (simp_all add: two nat_omega_simps)
	qed (auto simp: two nat_omega_simps)
	finally show ?thesis by simp
	qed

	lemma cat_prod_2_CId_vrange: "\<R>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>) \<subseteq>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>"
	proof(rule vsv.vsv_vrange_vsubset, unfold cat_cs_simps)
	show "vsv ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>)" by (rule cat_prod_2_CId_vsv)
	fix ab assume "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	then obtain a b where ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF \<AA> \<BB>])
	from \<AA> \<BB> a b show "(\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>\<lparr>ab\<rparr> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>"
	unfolding ab_def by (cs_concl cs_intro: cat_cs_intros cat_prod_cs_intros)
	qed

	end


	subsubsection\<open>Opposite product category\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	lemma op_smc_smc_prod_2[smc_op_simps]:
	"op_cat (\<AA> \<times>\<^sub>C \<BB>) = op_cat \<AA> \<times>\<^sub>C op_cat \<BB>"
	proof(rule cat_smc_eqI [of \<alpha>])
	from \<AA> \<BB> show cat_lhs: "category \<alpha> (op_cat (\<AA> \<times>\<^sub>C \<BB>))"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros
	)
	interpret cat_lhs: category \<alpha> \<open>op_cat (\<AA> \<times>\<^sub>C \<BB>)\<close> by (rule cat_lhs)
	from \<AA> \<BB> show cat_rhs: "category \<alpha> (op_cat \<AA> \<times>\<^sub>C op_cat \<BB>)"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
	)
	interpret cat_rhs: category \<alpha> \<open>op_cat \<AA> \<times>\<^sub>C op_cat \<BB>\<close> by (rule cat_rhs)
	show "op_cat (\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr> = (op_cat \<AA> \<times>\<^sub>C op_cat \<BB>)\<lparr>CId\<rparr>"
	unfolding cat_op_simps
	proof(rule vsv_eqI, unfold cat_cs_simps)
	show "vsv ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>)" by (rule cat_prod_2_CId_vsv)
	show "vsv ((op_cat \<AA> \<times>\<^sub>C op_cat \<BB>)\<lparr>CId\<rparr>)" by (rule cat_prod_2_CId_vsv)
	from \<AA> \<BB> show "(\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr> = (op_cat \<AA> \<times>\<^sub>C op_cat \<BB>)\<lparr>Obj\<rparr>"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_op_intros
	)
	show "(\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>\<lparr>ab\<rparr> = (op_cat \<AA> \<times>\<^sub>C op_cat \<BB>)\<lparr>CId\<rparr>\<lparr>ab\<rparr>"
	if "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>" for ab
	using that unfolding cat_cs_simps
	proof-
	from that obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF \<AA> \<BB>])
	from \<AA> \<BB> a b show "(\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>\<lparr>ab\<rparr> = (op_cat \<AA> \<times>\<^sub>C op_cat \<BB>)\<lparr>CId\<rparr>\<lparr>ab\<rparr>"
	unfolding ab_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_op_simps cat_prod_cs_simps
	cs_intro: cat_op_intros cat_prod_cs_intros
	)
	qed
	qed

	from \<AA> \<BB> show "cat_smc (op_cat (\<AA> \<times>\<^sub>C \<BB>)) = cat_smc (op_cat \<AA> \<times>\<^sub>C op_cat \<BB>)"
	unfolding slicing_commute[symmetric]
	by (cs_concl cs_shallow cs_simp: smc_op_simps cs_intro: slicing_intros)

	qed

	end


	subsubsection\<open>Flip\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	lemma cat_prod_2_Obj_fconverse[cat_cs_simps]:
	"((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>)\<inverse>\<^sub>\<bullet> = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	proof-
	interpret fbrelation \<open>((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>)\<close>
	by (auto elim: cat_prod_2_ObjE[OF \<AA> \<BB>])
	show ?thesis
	proof(intro vsubset_antisym vsubsetI)
	fix ba assume prems: "ba \<in>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>)\<inverse>\<^sub>\<bullet>"
	then obtain a b where ba_def: "ba = [b, a]\<^sub>\<circ>" by clarsimp
	from prems[unfolded ba_def] have "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>" by auto
	then have "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (auto elim: cat_prod_2_ObjE[OF \<AA> \<BB>])
	with \<AA> \<BB> show "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	unfolding ba_def by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
	next
	fix ba assume "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF \<BB> \<AA>])
	from b a show "ba \<in>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>)\<inverse>\<^sub>\<bullet>"
	unfolding ba_def by (auto simp: cat_prod_2_ObjI[OF \<AA> \<BB> a b])
	qed
	qed

	lemma cat_prod_2_Arr_fconverse[cat_cs_simps]:
	"((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>)\<inverse>\<^sub>\<bullet> = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	proof-
	interpret fbrelation \<open>((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>)\<close>
	by (auto elim: cat_prod_2_ArrE[OF \<AA> \<BB>])
	show ?thesis
	proof(intro vsubset_antisym vsubsetI)
	fix ba assume prems: "ba \<in>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>)\<inverse>\<^sub>\<bullet>"
	then obtain a b where ba_def: "ba = [b, a]\<^sub>\<circ>" by clarsimp
	from prems[unfolded ba_def] have "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>" by auto
	then have "a \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	by (auto elim: cat_prod_2_ArrE[OF \<AA> \<BB>])
	with \<AA> \<BB> show "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	unfolding ba_def
	by
	(
	cs_concl
	cs_simp: cat_prod_cs_simps
	cs_intro: cat_prod_cs_intros cat_cs_intros
	)
	next
	fix ba assume "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	then obtain a b
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[OF \<BB> \<AA>])
	from b a show "ba \<in>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>)\<inverse>\<^sub>\<bullet>"
	unfolding ba_def by (auto simp: cat_prod_2_ArrI[OF \<AA> \<BB> a b])
	qed
	qed

	end



	subsection\<open>Projections for the product of two categories\<close>


	subsubsection\<open>Definition and elementary properties\<close>


	text\<open>See Chapter II-3 in \cite{mac_lane_categories_2010}.\<close>

	definition cf_proj_fst :: "V \<Rightarrow> V \<Rightarrow> V" (\<open>\<pi>\<^sub>C\<^sub>.\<^sub>1\<close>)
	where "\<pi>\<^sub>C\<^sub>.\<^sub>1 \<AA> \<BB> = cf_proj (2\<^sub>\<nat>) (\<lambda>i. if i = 0 then \<AA> else \<BB>) 0"
	definition cf_proj_snd :: "V \<Rightarrow> V \<Rightarrow> V" (\<open>\<pi>\<^sub>C\<^sub>.\<^sub>2\<close>)
	where "\<pi>\<^sub>C\<^sub>.\<^sub>2 \<AA> \<BB> = cf_proj (2\<^sub>\<nat>) (\<lambda>i. if i = 0 then \<AA> else \<BB>) (1\<^sub>\<nat>)"


	text\<open>Slicing\<close>

	lemma cf_smcf_cf_proj_fst[slicing_commute]:
	"\<pi>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>1 (cat_smc \<AA>) (cat_smc \<BB>) = cf_smcf (\<pi>\<^sub>C\<^sub>.\<^sub>1 \<AA> \<BB>)"
	unfolding
	cf_proj_fst_def smcf_proj_fst_def slicing_commute[symmetric] if_distrib ..

	lemma cf_smcf_cf_proj_snd[slicing_commute]:
	"\<pi>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>2 (cat_smc \<AA>) (cat_smc \<BB>) = cf_smcf (\<pi>\<^sub>C\<^sub>.\<^sub>2 \<AA> \<BB>)"
	unfolding
	cf_proj_snd_def smcf_proj_snd_def slicing_commute[symmetric] if_distrib ..

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	lemmas_with
	[
	where \<AA>=\<open>cat_smc \<AA>\<close> and \<BB>=\<open>cat_smc \<BB>\<close>,
	unfolded slicing_simps slicing_commute,
	OF \<AA>.cat_semicategory \<BB>.cat_semicategory
	]:
	cf_proj_fst_ObjMap_app = smcf_proj_fst_ObjMap_app
	and cf_proj_snd_ObjMap_app = smcf_proj_snd_ObjMap_app
	and cf_proj_fst_ArrMap_app = smcf_proj_fst_ArrMap_app
	and cf_proj_snd_ArrMap_app = smcf_proj_snd_ArrMap_app

	end


	subsubsection\<open>
	Domain and codomain of a projection of a product of two categories
	\<close>

	lemma cf_proj_fst_HomDom: "\<pi>\<^sub>C\<^sub>.\<^sub>1 \<AA> \<BB>\<lparr>HomDom\<rparr> = \<AA> \<times>\<^sub>C \<BB>"
	unfolding cf_proj_fst_def cf_proj_components cat_prod_2_def ..

	lemma cf_proj_fst_HomCod: "\<pi>\<^sub>C\<^sub>.\<^sub>1 \<AA> \<BB>\<lparr>HomCod\<rparr> = \<AA>"
	unfolding cf_proj_fst_def cf_proj_components cat_prod_2_def by simp

	lemma cf_proj_snd_HomDom: "\<pi>\<^sub>C\<^sub>.\<^sub>2 \<AA> \<BB>\<lparr>HomDom\<rparr> = \<AA> \<times>\<^sub>C \<BB>"
	unfolding cf_proj_snd_def cf_proj_components cat_prod_2_def ..

	lemma cf_proj_snd_HomCod: "\<pi>\<^sub>C\<^sub>.\<^sub>2 \<AA> \<BB>\<lparr>HomCod\<rparr> = \<BB>"
	unfolding cf_proj_snd_def cf_proj_components cat_prod_2_def by simp


	subsubsection\<open>Projection of a product of two categories is a functor\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<Z> \<alpha> by (rule categoryD[OF \<AA>])
	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)
	interpretation finite_pcategory \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 \<AA> \<BB>\<close>
	by (intro finite_pcategory_cat_prod_2 \<AA> \<BB>)

	lemma cf_proj_fst_is_functor:
	assumes "i \<in>\<^sub>\<circ> I"
	shows "\<pi>\<^sub>C\<^sub>.\<^sub>1 \<AA> \<BB> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
	by
	(
	rule
	pcat_cf_proj_is_functor[
	where i=0, simplified, folded cf_proj_fst_def cat_prod_2_def
	]
	)

	lemma cf_proj_fst_is_functor'[cat_cs_intros]:
	assumes "i \<in>\<^sub>\<circ> I" and "\<CC> = \<AA> \<times>\<^sub>C \<BB>" and "\<DD> = \<AA>"
	shows "\<pi>\<^sub>C\<^sub>.\<^sub>1 \<AA> \<BB> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1) unfolding assms(2,3) by (rule cf_proj_fst_is_functor)

	lemma cf_proj_snd_is_functor:
	assumes "i \<in>\<^sub>\<circ> I"
	shows "\<pi>\<^sub>C\<^sub>.\<^sub>2 \<AA> \<BB> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	by
	(
	rule
	pcat_cf_proj_is_functor[
	where i=\<open>1\<^sub>\<nat>\<close>, simplified, folded cf_proj_snd_def cat_prod_2_def
	]
	)

	lemma cf_proj_snd_is_functor'[cat_cs_intros]:
	assumes "i \<in>\<^sub>\<circ> I" and "\<CC> = \<AA> \<times>\<^sub>C \<BB>" and "\<DD> = \<BB>"
	shows "\<pi>\<^sub>C\<^sub>.\<^sub>2 \<AA> \<BB> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1) unfolding assms(2,3) by (rule cf_proj_snd_is_functor)

	end



	subsection\<open>Product of three categories\<close>


	subsubsection\<open>Definition and elementary properties.\<close>

	definition cat_prod_3 :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" ("(_ \<times>\<^sub>C\<^sub>3 _ \<times>\<^sub>C\<^sub>3 _)" [81, 81, 81] 80)
	where "\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>3\<^sub>\<nat>. if3 \<AA> \<BB> \<CC> i)"

	abbreviation cat_pow_3 :: "V \<Rightarrow> V" (\<open>_^\<^sub>C\<^sub>3\<close> [81] 80)
	where "\<CC>^\<^sub>C\<^sub>3 \<equiv> \<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>"


	text\<open>Slicing.\<close>

	lemma cat_smc_cat_prod_3[slicing_commute]:
	"cat_smc \<AA> \<times>\<^sub>S\<^sub>M\<^sub>C\<^sub>3 cat_smc \<BB> \<times>\<^sub>S\<^sub>M\<^sub>C\<^sub>3 cat_smc \<CC> = cat_smc (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)"
	unfolding cat_prod_3_def smc_prod_3_def slicing_commute[symmetric] if_distrib
	by (simp add: if_distrib[symmetric])

	context
	fixes \<alpha> \<AA> \<BB> \<CC>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>" and \<CC>: "category \<alpha> \<CC>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)
	interpretation \<CC>: category \<alpha> \<CC> by (rule \<CC>)

	lemmas_with
	[
	where \<AA>=\<open>cat_smc \<AA>\<close> and \<BB>=\<open>cat_smc \<BB>\<close> and \<CC>=\<open>cat_smc \<CC>\<close>,
	unfolded slicing_simps slicing_commute,
	OF \<AA>.cat_semicategory \<BB>.cat_semicategory \<CC>.cat_semicategory
	]:
	cat_prod_3_ObjI = smc_prod_3_ObjI
	and cat_prod_3_ObjI'[cat_prod_cs_intros] = smc_prod_3_ObjI'
	and cat_prod_3_ObjE = smc_prod_3_ObjE
	and cat_prod_3_ArrI = smc_prod_3_ArrI
	and cat_prod_3_ArrI'[cat_prod_cs_intros] = smc_prod_3_ArrI'
	and cat_prod_3_ArrE = smc_prod_3_ArrE
	and cat_prod_3_is_arrI = smc_prod_3_is_arrI
	and cat_prod_3_is_arrI'[cat_prod_cs_intros] = smc_prod_3_is_arrI'
	and cat_prod_3_is_arrE = smc_prod_3_is_arrE
	and cat_prod_3_Dom_vsv = smc_prod_3_Dom_vsv
	and cat_prod_3_Dom_vdomain[cat_cs_simps] = smc_prod_3_Dom_vdomain
	and cat_prod_3_Dom_app[cat_prod_cs_simps] = smc_prod_3_Dom_app
	and cat_prod_3_Dom_vrange = smc_prod_3_Dom_vrange
	and cat_prod_3_Cod_vsv = smc_prod_3_Cod_vsv
	and cat_prod_3_Cod_vdomain[cat_cs_simps] = smc_prod_3_Cod_vdomain
	and cat_prod_3_Cod_app[cat_prod_cs_simps] = smc_prod_3_Cod_app
	and cat_prod_3_Cod_vrange = smc_prod_3_Cod_vrange

	lemmas_with
	[
	where \<AA>=\<open>cat_smc \<AA>\<close> and \<BB>=\<open>cat_smc \<BB>\<close> and \<CC>=\<open>cat_smc \<CC>\<close>,
	unfolded slicing_simps slicing_commute,
	OF \<AA>.cat_semicategory \<BB>.cat_semicategory \<CC>.cat_semicategory
	]:
	cat_prod_3_Comp_app[cat_prod_cs_simps] = smc_prod_3_Comp_app

	end


	subsubsection\<open>Product of three categories is a category\<close>

	context
	fixes \<alpha> \<AA> \<BB> \<CC>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>" and \<CC>: "category \<alpha> \<CC>"
	begin

	interpretation \<Z> \<alpha> by (rule categoryD[OF \<AA>])
	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)
	interpretation \<CC>: category \<alpha> \<CC> by (rule \<CC>)

	lemma finite_pcategory_cat_prod_3: "finite_pcategory \<alpha> (3\<^sub>\<nat>) (if3 \<AA> \<BB> \<CC>)"
	proof(intro finite_pcategoryI pcategory_baseI)
	from Axiom_of_Infinity show z1_in_Vset: "3\<^sub>\<nat> \<in>\<^sub>\<circ> Vset \<alpha>" by blast
	show "category \<alpha> (if3 \<AA> \<BB> \<CC> i)" if "i \<in>\<^sub>\<circ> 3\<^sub>\<nat>" for i
	by (auto simp: cat_cs_intros)
	qed auto

	interpretation finite_pcategory \<alpha> \<open>3\<^sub>\<nat>\<close> \<open>if3 \<AA> \<BB> \<CC>\<close>
	by (intro finite_pcategory_cat_prod_3 \<AA> \<BB> \<CC>)

	lemma category_cat_prod_3[cat_cs_intros]: "category \<alpha> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)"
	unfolding cat_prod_3_def by (rule pcat_category_cat_prod)

	end


	subsubsection\<open>Identity\<close>

	lemma cat_prod_3_CId_vsv[cat_cs_intros]: "vsv ((\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>)"
	unfolding cat_prod_3_def cat_prod_components by simp

	lemma cat_prod_3_CId_vdomain[cat_cs_simps]:
	"\<D>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>) = (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	unfolding cat_prod_3_def cat_prod_components by simp

	context
	fixes \<alpha> \<AA> \<BB> \<CC>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>" and \<CC>: "category \<alpha> \<CC>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)
	interpretation \<CC>: category \<alpha> \<CC> by (rule \<CC>)

	interpretation finite_pcategory \<alpha> \<open>3\<^sub>\<nat>\<close> \<open>if3 \<AA> \<BB> \<CC>\<close>
	by (intro finite_pcategory_cat_prod_3 \<AA> \<BB> \<CC>)

	lemma cat_prod_3_CId_app[cat_prod_cs_simps]:
	assumes "[a, b, c]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	shows "(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>\<lparr>a, b, c\<rparr>\<^sub>\<bullet> = [\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>, \<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>]\<^sub>\<circ>"
	proof-
	have "(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>\<lparr>a, b, c\<rparr>\<^sub>\<bullet> =
	(\<lambda>i\<in>\<^sub>\<circ>3\<^sub>\<nat>. if3 \<AA> \<BB> \<CC> i\<lparr>CId\<rparr>\<lparr>[a, b, c]\<^sub>\<circ>\<lparr>i\<rparr>\<rparr>)"
	by
	(
	rule
	cat_prod_CId_app[
	OF assms[unfolded cat_prod_3_def], folded cat_prod_3_def
	]
	)
	also have
	"(\<lambda>i\<in>\<^sub>\<circ>3\<^sub>\<nat>. if3 \<AA> \<BB> \<CC> i\<lparr>CId\<rparr>\<lparr>[a, b, c]\<^sub>\<circ>\<lparr>i\<rparr>\<rparr>) = [\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>, \<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>]\<^sub>\<circ>"
	proof(rule vsv_eqI, unfold vdomain_VLambda)
	fix i assume "i \<in>\<^sub>\<circ> 3\<^sub>\<nat>"
	then consider \<open>i = 0\<close> \| \<open>i = 1\<^sub>\<nat>\<close> \| \<open>i = 2\<^sub>\<nat>\<close> unfolding three by auto
	then show
	"(\<lambda>i\<in>\<^sub>\<circ>3\<^sub>\<nat>. (if3 \<AA> \<BB> \<CC> i)\<lparr>CId\<rparr>\<lparr>[a, b, c]\<^sub>\<circ>\<lparr>i\<rparr>\<rparr>)\<lparr>i\<rparr> =
	[\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>, \<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>]\<^sub>\<circ>\<lparr>i\<rparr>"
	by cases (simp_all add: three nat_omega_simps)
	qed (auto simp: three nat_omega_simps)
	finally show ?thesis by simp
	qed

	lemma cat_prod_3_CId_vrange:
	"\<R>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>) \<subseteq>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>"
	proof(rule vsv.vsv_vrange_vsubset, unfold cat_cs_simps)
	show "vsv ((\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>)" by (rule cat_prod_3_CId_vsv)
	fix abc assume "abc \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	then obtain a b c where abc_def: "abc = [a, b, c]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and c: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	by (elim cat_prod_3_ObjE[OF \<AA> \<BB> \<CC>])
	from \<AA> \<BB> \<CC> a b c show "(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>\<lparr>abc\<rparr> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>"
	unfolding abc_def
	by (cs_concl cs_intro: cat_cs_intros cat_prod_cs_intros)
	qed

	end



	subsection\<open>
	Conversion of a product of three categories to products of two categories
	\<close>

	definition cf_cat_prod_21_of_3 :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC> =
	[
	(\<lambda>A\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>. [[A\<lparr>0\<rparr>, A\<lparr>1\<^sub>\<nat>\<rparr>]\<^sub>\<circ>, A\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>),
	(\<lambda>F\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>. [[F\<lparr>0\<rparr>, F\<lparr>1\<^sub>\<nat>\<rparr>]\<^sub>\<circ>, F\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>),
	\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>,
	(\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>
	]\<^sub>\<circ>"

	definition cf_cat_prod_12_of_3 :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC> =
	[
	(\<lambda>A\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>. [A\<lparr>0\<rparr>, [A\<lparr>1\<^sub>\<nat>\<rparr>, A\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>]\<^sub>\<circ>),
	(\<lambda>F\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>. [F\<lparr>0\<rparr>, [F\<lparr>1\<^sub>\<nat>\<rparr>, F\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>]\<^sub>\<circ>),
	\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>,
	\<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>)
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma cf_cat_prod_21_of_3_components:
	shows "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr> =
	(\<lambda>A\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>. [[A\<lparr>0\<rparr>, A\<lparr>1\<^sub>\<nat>\<rparr>]\<^sub>\<circ>, A\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>)"
	and "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr> =
	(\<lambda>F\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>. [[F\<lparr>0\<rparr>, F\<lparr>1\<^sub>\<nat>\<rparr>]\<^sub>\<circ>, F\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>)"
	and [cat_cs_simps]: "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>HomDom\<rparr> = \<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>"
	and [cat_cs_simps]: "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>HomCod\<rparr> = (\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>"
	unfolding cf_cat_prod_21_of_3_def dghm_field_simps
	by (simp_all add: nat_omega_simps)

	lemma cf_cat_prod_12_of_3_components:
	shows "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr> =
	(\<lambda>A\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>. [A\<lparr>0\<rparr>, [A\<lparr>1\<^sub>\<nat>\<rparr>, A\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>]\<^sub>\<circ>)"
	and "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr> =
	(\<lambda>F\<in>\<^sub>\<circ>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>. [F\<lparr>0\<rparr>, [F\<lparr>1\<^sub>\<nat>\<rparr>, F\<lparr>2\<^sub>\<nat>\<rparr>]\<^sub>\<circ>]\<^sub>\<circ>)"
	and [cat_cs_simps]: "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>HomDom\<rparr> = \<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>"
	and [cat_cs_simps]: "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>HomCod\<rparr> = \<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>)"
	unfolding cf_cat_prod_12_of_3_def dghm_field_simps
	by (simp_all add: nat_omega_simps)


	subsubsection\<open>Object\<close>

	mk_VLambda cf_cat_prod_21_of_3_components(1)
	\|vsv cf_cat_prod_21_of_3_ObjMap_vsv[cat_cs_intros]\|
	\|vdomain cf_cat_prod_21_of_3_ObjMap_vdomain[cat_cs_simps]\|
	\|app cf_cat_prod_21_of_3_ObjMap_app'\|

	mk_VLambda cf_cat_prod_12_of_3_components(1)
	\|vsv cf_cat_prod_12_of_3_ObjMap_vsv[cat_cs_intros]\|
	\|vdomain cf_cat_prod_12_of_3_ObjMap_vdomain[cat_cs_simps]\|
	\|app cf_cat_prod_12_of_3_ObjMap_app'\|

	lemma cf_cat_prod_21_of_3_ObjMap_app[cat_cs_simps]:
	assumes "A = [a, b, c]\<^sub>\<circ>" and "[a, b, c]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	shows "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> = [[a, b]\<^sub>\<circ>, c]\<^sub>\<circ>"
	using assms(2)
	unfolding assms(1)
	by (simp add: cf_cat_prod_21_of_3_ObjMap_app' nat_omega_simps)

	lemma cf_cat_prod_12_of_3_ObjMap_app[cat_cs_simps]:
	assumes "A = [a, b, c]\<^sub>\<circ>" and "[a, b, c]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	shows "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> = [a, [b, c]\<^sub>\<circ>]\<^sub>\<circ>"
	using assms(2)
	unfolding assms(1)
	by (simp add: cf_cat_prod_12_of_3_ObjMap_app' nat_omega_simps)

	lemma cf_cat_prod_21_of_3_ObjMap_vrange:
	assumes "category \<alpha> \<AA>" and "category \<alpha> \<BB>" and "category \<alpha> \<CC>"
	shows "\<R>\<^sub>\<circ> (cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	proof-
	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<CC>: category \<alpha> \<CC> by (rule assms(3))
	show ?thesis
	proof(rule vsv.vsv_vrange_vsubset, unfold cf_cat_prod_21_of_3_ObjMap_vdomain)
	fix A assume prems: "A \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	then show "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> \<in>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	by (elim cat_prod_3_ObjE[OF assms], insert prems, simp only:)
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed (cs_concl cs_shallow cs_intro: cat_cs_intros)
	qed

	lemma cf_cat_prod_12_of_3_ObjMap_vrange:
	assumes "category \<alpha> \<AA>" and "category \<alpha> \<BB>" and "category \<alpha> \<CC>"
	shows "\<R>\<^sub>\<circ> (cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> (\<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>))\<lparr>Obj\<rparr>"
	proof-
	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<CC>: category \<alpha> \<CC> by (rule assms(3))
	show ?thesis
	proof(rule vsv.vsv_vrange_vsubset, unfold cf_cat_prod_12_of_3_ObjMap_vdomain)
	fix A assume prems: "A \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	then show "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>))\<lparr>Obj\<rparr>"
	by (elim cat_prod_3_ObjE[OF assms], insert prems, simp only:)
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed (cs_concl cs_shallow cs_intro: cat_cs_intros)
	qed


	subsubsection\<open>Arrow\<close>

	mk_VLambda cf_cat_prod_21_of_3_components(2)
	\|vsv cf_cat_prod_21_of_3_ArrMap_vsv[cat_cs_intros]\|
	\|vdomain cf_cat_prod_21_of_3_ArrMap_vdomain[cat_cs_simps]\|
	\|app cf_cat_prod_21_of_3_ArrMap_app'\|

	mk_VLambda cf_cat_prod_12_of_3_components(2)
	\|vsv cf_cat_prod_12_of_3_ArrMap_vsv[cat_cs_intros]\|
	\|vdomain cf_cat_prod_12_of_3_ArrMap_vdomain[cat_cs_simps]\|
	\|app cf_cat_prod_12_of_3_ArrMap_app'\|

	lemma cf_cat_prod_21_of_3_ArrMap_app[cat_cs_simps]:
	assumes "F = [h, g, f]\<^sub>\<circ>" and "[h, g, f]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>"
	shows "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr> = [[h, g]\<^sub>\<circ>, f]\<^sub>\<circ>"
	using assms(2) unfolding assms(1)
	by (simp add: cf_cat_prod_21_of_3_ArrMap_app' nat_omega_simps)

	lemma cf_cat_prod_12_of_3_ArrMap_app[cat_cs_simps]:
	assumes "F = [h, g, f]\<^sub>\<circ>" and "[h, g, f]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>"
	shows "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr> = [h, [g, f]\<^sub>\<circ>]\<^sub>\<circ>"
	using assms(2)
	unfolding assms(1)
	by (simp add: cf_cat_prod_12_of_3_ArrMap_app' nat_omega_simps)


	subsubsection\<open>
	Conversion of a product of three categories to products
	of two categories is a functor
	\<close>

	lemma cf_cat_prod_21_of_3_is_functor:
	assumes "category \<alpha> \<AA>" and "category \<alpha> \<BB>" and "category \<alpha> \<CC>"
	shows "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC> : \<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> (\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>"
	proof-

	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<CC>: category \<alpha> \<CC> by (rule assms(3))

	show ?thesis
	proof(rule is_functorI')
	show "vfsequence (cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>)"
	unfolding cf_cat_prod_21_of_3_def by auto
	show "vcard (cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>) = 4\<^sub>\<nat>"
	unfolding cf_cat_prod_21_of_3_def by (simp add: nat_omega_simps)
	show "\<R>\<^sub>\<circ> (cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> ((\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	by (rule cf_cat_prod_21_of_3_ObjMap_vrange[OF assms])
	show
	"cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr> :
	cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> \<mapsto>\<^bsub>(\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>\<^esub>
	cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>B\<rparr>"
	if "F : A \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> B"
	for A B F
	using that
	by (elim cat_prod_3_is_arrE[OF assms], insert that, simp only:)
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	show
	"cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>G \<circ>\<^sub>A\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> F\<rparr> =
	cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>G\<rparr> \<circ>\<^sub>A\<^bsub>(\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>\<^esub>
	cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr>"
	if "G : B \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> C" and "F : A \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> B"
	for B C G A F
	proof-
	from that(2) obtain f f' f'' a a' a'' b b' b''
	where F_def: "F = [f, f', f'']\<^sub>\<circ>"
	and A_def: "A = [a, a', a'']\<^sub>\<circ>"
	and B_def: "B = [b, b', b'']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b"
	and f': "f' : a' \<mapsto>\<^bsub>\<BB>\<^esub> b'"
	and f'': "f'' : a'' \<mapsto>\<^bsub>\<CC>\<^esub> b''"
	by (elim cat_prod_3_is_arrE[OF assms])
	with that(1) obtain g g' g'' c c' c''
	where G_def: "G = [g, g', g'']\<^sub>\<circ>"
	and C_def: "C = [c, c', c'']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<AA>\<^esub> c"
	and g': "g' : b' \<mapsto>\<^bsub>\<BB>\<^esub> c'"
	and g'': "g'' : b'' \<mapsto>\<^bsub>\<CC>\<^esub> c''"
	by (auto elim: cat_prod_3_is_arrE[OF assms])
	from that f f' f'' g g' g'' show ?thesis
	unfolding F_def A_def B_def G_def C_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show
	"cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>\<lparr>C\<rparr>\<rparr> =
	((\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>)\<lparr>CId\<rparr>\<lparr>cf_cat_prod_21_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>C\<rparr>\<rparr>"
	if "C \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>" for C
	using that
	by (elim cat_prod_3_ObjE[OF assms], insert that, simp only: )
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

	qed

	lemma cf_cat_prod_21_of_3_is_functor'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "category \<alpha> \<CC>"
	and "\<AA>' = \<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>"
	and "\<BB>' = (\<AA> \<times>\<^sub>C \<BB>) \<times>\<^sub>C \<CC>"
	shows "cf_cat_prod_21_of_3 \<AA> \<BB> \<CC> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>'"
	using assms(1-3) unfolding assms(4,5) by (rule cf_cat_prod_21_of_3_is_functor)

	lemma cf_cat_prod_12_of_3_is_functor:
	assumes "category \<alpha> \<AA>" and "category \<alpha> \<BB>" and "category \<alpha> \<CC>"
	shows "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC> : \<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>)"
	proof-

	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<CC>: category \<alpha> \<CC> by (rule assms(3))

	show ?thesis
	proof(rule is_functorI')
	show "vfsequence (cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>)"
	unfolding cf_cat_prod_12_of_3_def by auto
	show "vcard (cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>) = 4\<^sub>\<nat>"
	unfolding cf_cat_prod_12_of_3_def by (simp add: nat_omega_simps)
	show "\<R>\<^sub>\<circ> (cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> (\<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>))\<lparr>Obj\<rparr>"
	by (rule cf_cat_prod_12_of_3_ObjMap_vrange[OF assms])
	show
	"cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr> :
	cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>)\<^esub>
	cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>B\<rparr>"
	if "F : A \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> B"
	for A B F
	using that
	by (elim cat_prod_3_is_arrE[OF assms], insert that, simp only:)
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	show
	"cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>G \<circ>\<^sub>A\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> F\<rparr> =
	cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>G\<rparr> \<circ>\<^sub>A\<^bsub>\<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>)\<^esub>
	cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr>"
	if "G : B \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> C" and "F : A \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>\<^esub> B"
	for B C G A F
	proof-
	from that(2) obtain f f' f'' a a' a'' b b' b''
	where F_def: "F = [f, f', f'']\<^sub>\<circ>"
	and A_def: "A = [a, a', a'']\<^sub>\<circ>"
	and B_def: "B = [b, b', b'']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b"
	and f': "f' : a' \<mapsto>\<^bsub>\<BB>\<^esub> b'"
	and f'': "f'' : a'' \<mapsto>\<^bsub>\<CC>\<^esub> b''"
	by (elim cat_prod_3_is_arrE[OF assms])
	with that(1) obtain g g' g'' c c' c''
	where G_def: "G = [g, g', g'']\<^sub>\<circ>"
	and C_def: "C = [c, c', c'']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<AA>\<^esub> c"
	and g': "g' : b' \<mapsto>\<^bsub>\<BB>\<^esub> c'"
	and g'': "g'' : b'' \<mapsto>\<^bsub>\<CC>\<^esub> c''"
	by (auto elim: cat_prod_3_is_arrE[OF assms])
	from that f f' f'' g g' g'' show ?thesis
	unfolding F_def A_def B_def G_def C_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show
	"cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>(\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>CId\<rparr>\<lparr>C\<rparr>\<rparr> =
	(\<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>))\<lparr>CId\<rparr>\<lparr>cf_cat_prod_12_of_3 \<AA> \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>C\<rparr>\<rparr>"
	if "C \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>" for C
	using that
	by (elim cat_prod_3_ObjE[OF assms], insert that, simp only: )
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

	qed

	lemma cf_cat_prod_12_of_3_is_functor'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "category \<alpha> \<CC>"
	and "\<AA>' = \<AA> \<times>\<^sub>C\<^sub>3 \<BB> \<times>\<^sub>C\<^sub>3 \<CC>"
	and "\<BB>' = \<AA> \<times>\<^sub>C (\<BB> \<times>\<^sub>C \<CC>)"
	shows "cf_cat_prod_12_of_3 \<AA> \<BB> \<CC> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>'"
	using assms(1-3) unfolding assms(4,5) by (rule cf_cat_prod_12_of_3_is_functor)



	subsection\<open>Bifunctors\<close>

	text\<open>
	A bifunctor is defined as a functor from a product of two categories
	to a category (see Chapter II-3 in \cite{mac_lane_categories_2010}).
	This subsection exposes the elementary properties of the projections of the
	bifunctors established by fixing an argument in a functor (see Chapter II-3
	in \cite{mac_lane_categories_2010} for further information).
	\<close>


	subsubsection\<open>Definitions and elementary properties\<close>

	definition bifunctor_proj_fst :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	(\<open>(_\<^bsub>_,_\<^esub>/'(/-,_/')/\<^sub>C\<^sub>F)\<close> [51, 51, 51, 51] 51)
	where "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F =
	(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat> -\<^sub>\<circ> set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>),\<SS>\<lparr>HomCod\<rparr>\<^esub>(-,set {\<langle>1\<^sub>\<nat>, b\<rangle>})) \<circ>\<^sub>C\<^sub>F
	cf_singleton 0 \<AA>"

	definition bifunctor_proj_snd :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	(\<open>(_\<^bsub>_,_\<^esub>/'(/_,-/')/\<^sub>C\<^sub>F)\<close> [51, 51, 51, 51] 51)
	where "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F =
	(\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat> -\<^sub>\<circ> set {0}. (i = 0 ? \<AA> : \<BB>),\<SS>\<lparr>HomCod\<rparr>\<^esub>(-,set {\<langle>0, a\<rangle>})) \<circ>\<^sub>C\<^sub>F
	cf_singleton (1\<^sub>\<nat>) \<BB>"

	abbreviation bcf_ObjMap_app :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (infixl "\<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>O\<index>" 55)
	where "a \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>O\<^bsub>\<SS>\<^esub> b \<equiv> \<SS>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	abbreviation bcf_ArrMap_app :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (infixl "\<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>A\<index>" 55)
	where "g \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>A\<^bsub>\<SS>\<^esub> f \<equiv> \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet>"


	text\<open>Elementary properties.\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)
	interpretation finite_pcategory \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 \<AA> \<BB>\<close>
	by (intro finite_pcategory_cat_prod_2 \<AA> \<BB>)

	lemma cat_singleton_qm_fst_def[simp]:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>)) = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)"
	proof(rule cat_eqI[of \<alpha>])
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Obj\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Obj\<rparr>"
	unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
	show [simp]: "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Arr\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Arr\<rparr>"
	unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
	show [simp]: "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Dom\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Dom\<rparr>"
	unfolding cat_prod_components
	by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
	show [simp]:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Cod\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Cod\<rparr>"
	unfolding cat_prod_components
	by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
	have [simp]:
	"f : a \<mapsto>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>)\<^esub> b \<longleftrightarrow>
	f : a \<mapsto>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>\<^esub> b"
	for f a b
	unfolding is_arr_def by simp
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Comp\<rparr>"
	proof(rule vsv_eqI)
	show "vsv ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>)"
	unfolding cat_prod_components by simp
	show "vsv ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Comp\<rparr>)"
	unfolding cat_prod_components by simp
	show "\<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>) =
	\<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Comp\<rparr>)"
	by (simp add: composable_arrs_def cat_cs_simps)
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>\<lparr>gf\<rparr> =
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Comp\<rparr>\<lparr>gf\<rparr>"
	if "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>)" for gf
	proof-
	from that have "gf \<in>\<^sub>\<circ> composable_arrs (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))"
	by (simp add: cat_cs_simps)
	then obtain g f a b c where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<^esub> c"
	and f: "f : a \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<^esub> b"
	by clarsimp
	then have g': "g : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<^esub> c"
	and f': "f : a \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<^esub> b"
	by simp_all
	show ?thesis
	unfolding gf_def
	unfolding cat_prod_Comp_app[OF g f] cat_prod_Comp_app[OF g' f']
	by (subst (1 2) VLambda_vsingleton_def) simp
	qed
	qed
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. (i = 0 ? \<AA> : \<BB>))\<lparr>CId\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>CId\<rparr>"
	unfolding cat_prod_components
	by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
	qed
	(
	simp_all add:
	\<AA>.cat_category_cat_singleton
	pcategory.pcat_category_cat_prod
	pcat_vsubset_index_pcategory
	vsubset_vsingleton_leftI
	)

	lemma cat_singleton_qm_snd_def[simp]:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>)) = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)"
	proof(rule cat_eqI[of \<alpha>])
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Obj\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Obj\<rparr>"
	unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
	show [simp]:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Arr\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Arr\<rparr>"
	unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
	show [simp]:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Dom\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Dom\<rparr>"
	unfolding cat_prod_components
	by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
	show [simp]:
	"(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Cod\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Cod\<rparr>"
	unfolding cat_prod_components
	by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
	have [simp]: "f : a \<mapsto>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>)\<^esub> b \<longleftrightarrow>
	f : a \<mapsto>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>\<^esub> b"
	for f a b
	unfolding is_arr_def by simp
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Comp\<rparr>"
	proof(rule vsv_eqI)
	show "vsv ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>)"
	unfolding cat_prod_components by simp
	show "vsv ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Comp\<rparr>)"
	unfolding cat_prod_components by simp
	show "\<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>) =
	\<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Comp\<rparr>)"
	by (simp add: composable_arrs_def cat_cs_simps)
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>\<lparr>gf\<rparr> =
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Comp\<rparr>\<lparr>gf\<rparr>"
	if "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> ((\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>Comp\<rparr>)" for gf
	proof-
	from that have "gf \<in>\<^sub>\<circ> composable_arrs (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))"
	by (simp add: cat_cs_simps)
	then obtain g f a b c where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<^esub> c"
	and f: "f : a \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<^esub> b"
	by clarsimp
	then have g': "g : b \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<^esub> c"
	and f': "f : a \<mapsto>\<^bsub>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<^esub> b"
	by simp_all
	show ?thesis
	unfolding gf_def
	unfolding cat_prod_Comp_app[OF g f] cat_prod_Comp_app[OF g' f']
	by (subst (1 2) VLambda_vsingleton_def) simp
	qed
	qed
	show "(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. (i = 0 ? \<AA> : \<BB>))\<lparr>CId\<rparr> = (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>CId\<rparr>"
	unfolding cat_prod_components
	by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
	qed
	(
	simp_all add:
	\<BB>.cat_category_cat_singleton
	pcategory.pcat_category_cat_prod
	pcat_vsubset_index_pcategory
	vsubset_vsingleton_leftI
	)

	end


	subsubsection\<open>Object map\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	interpretation finite_pcategory \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 \<AA> \<BB>\<close>
	by (intro finite_pcategory_cat_prod_2 \<AA> \<BB>)

	lemmas_with [OF \<AA>.category_axioms \<BB>.category_axioms, simp]:
	cat_singleton_qm_fst_def and cat_singleton_qm_snd_def

	lemma bifunctor_proj_fst_ObjMap_app[cat_cs_simps]:
	assumes "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	shows "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	proof-

	let ?\<DD> = \<open>\<SS>\<lparr>HomCod\<rparr>\<close>
	let ?\<SS> = \<open>\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat>-\<^sub>\<circ>set {1\<^sub>\<nat>}.(i = 0 ? \<AA> : \<BB>),?\<DD>\<^esub>(-,set {\<langle>1\<^sub>\<nat>, b\<rangle>})\<close>
	let ?cfs = \<open>cf_singleton 0 \<AA>\<close>

	from assms have a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (all\<open>elim cat_prod_2_ObjE[OF \<AA> \<BB>]\<close>) auto

	from a have za: "set {\<langle>0, a\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Obj\<rparr>"
	by (intro cat_singleton_ObjI[where a=a]) simp
	have [simp]: "vinsert \<langle>0, a\<rangle> (set {\<langle>1\<^sub>\<nat>, b\<rangle>}) = [a, b]\<^sub>\<circ>"
	- using ord_of_nat_succ_vempty unfolding vcons_def by auto
	+ using ord_of_nat_succ_vempty unfolding vcons_def
	+ by (simp add: vinsert_vempty insert_commute vinsert_vsingleton)

	have "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> = (?\<SS>\<lparr>ObjMap\<rparr> \<circ>\<^sub>\<circ> ?cfs\<lparr>ObjMap\<rparr>)\<lparr>a\<rparr>"
	unfolding bifunctor_proj_fst_def dghm_comp_components by simp
	also have "\<dots> = ?\<SS>\<lparr>ObjMap\<rparr>\<lparr>?cfs\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>\<rparr>"
	by (rule vsv_vcomp_at)
	(
	simp_all add:
	two a za
	cf_singleton_components
	prodfunctor_proj_components
	cf_singleton_ObjMap_app

	)
	also from za have "\<dots> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	unfolding two cf_singleton_ObjMap_app[OF a] prodfunctor_proj_components
	by simp
	finally show ?thesis by simp

	qed

	lemma bifunctor_proj_snd_ObjMap_app[cat_cs_simps]:
	assumes "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	shows "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>b\<rparr> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	proof-

	let ?\<DD> = \<open>\<SS>\<lparr>HomCod\<rparr>\<close>
	let ?\<SS> = \<open>\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat>-\<^sub>\<circ>set {0}.(i = 0 ? \<AA> : \<BB>),?\<DD>\<^esub>(-,set {\<langle>0, a\<rangle>})\<close>
	let ?cfs = \<open>cf_singleton (1\<^sub>\<nat>) \<BB>\<close>

	from assms have a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (all\<open>elim cat_prod_2_ObjE[OF \<AA> \<BB>]\<close>) auto
	from a have za: "set {\<langle>0, a\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Obj\<rparr>"
	by (intro cat_singleton_ObjI[where a=a]) simp
	from b have ob: "set {\<langle>1\<^sub>\<nat>, b\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Obj\<rparr>"
	by (intro cat_singleton_ObjI[where a=b]) simp
	have[simp]: "vinsert \<langle>1\<^sub>\<nat>, b\<rangle> (set {\<langle>0, a\<rangle>}) = [a, b]\<^sub>\<circ>"
	- using ord_of_nat_succ_vempty unfolding vcons_def by auto
	+ using ord_of_nat_succ_vempty unfolding vcons_def
	+ by (simp add: vinsert_vempty)

	have "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>b\<rparr> = (?\<SS>\<lparr>ObjMap\<rparr> \<circ>\<^sub>\<circ> ?cfs\<lparr>ObjMap\<rparr>)\<lparr>b\<rparr>"
	unfolding bifunctor_proj_snd_def dghm_comp_components by simp
	also have "\<dots> = ?\<SS>\<lparr>ObjMap\<rparr>\<lparr>?cfs\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>\<rparr>"
	by (rule vsv_vcomp_at)
	(
	simp_all add:
	two
	cf_singleton_components
	prodfunctor_proj_components
	cf_singleton_ObjMap_app
	ob b
	)
	also from ob have "\<dots> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	unfolding two cf_singleton_ObjMap_app[OF b] prodfunctor_proj_components
	by simp
	finally show ?thesis by simp

	qed

	end


	subsubsection\<open>Arrow map\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	interpretation finite_pcategory \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 \<AA> \<BB>\<close>
	by (intro finite_pcategory_cat_prod_2 \<AA> \<BB>)

	lemmas_with [OF \<AA>.category_axioms \<BB>.category_axioms, simp]:
	cat_singleton_qm_fst_def and cat_singleton_qm_snd_def

	lemma bifunctor_proj_fst_ArrMap_app[cat_cs_simps]:
	assumes "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "f \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	shows "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>f, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	proof-

	let ?\<DD> = \<open>\<SS>\<lparr>HomCod\<rparr>\<close>
	let ?\<SS> = \<open>\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat>-\<^sub>\<circ>set {1\<^sub>\<nat>}.(i = 0 ? \<AA> : \<BB>),?\<DD>\<^esub>(-,set {\<langle>1\<^sub>\<nat>, b\<rangle>})\<close>
	let ?cfs = \<open>cf_singleton 0 \<AA>\<close>

	from assms(1) have "\<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr> : b \<mapsto>\<^bsub>\<BB>\<^esub> b" by (auto intro: cat_cs_intros)
	then have CId_b: "\<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr> \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>" by auto

	from assms(2) have zf: "set {\<langle>0, f\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Arr\<rparr>"
	by (intro cat_singleton_ArrI[where a=f]) simp
	from assms(1) have ob: "set {\<langle>1\<^sub>\<nat>, b\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Obj\<rparr>"
	by (intro cat_singleton_ObjI[where a=b]) simp
	have [simp]: "vinsert \<langle>0, f\<rangle> (set {\<langle>1\<^sub>\<nat>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rangle>}) = [f, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>]\<^sub>\<circ>"
	- using ord_of_nat_succ_vempty unfolding vcons_def by auto
	+ using ord_of_nat_succ_vempty unfolding vcons_def
	+ by (simp add: insert_commute ord_of_nat_vone vinsert_vempty vinsert_vsingleton)

	have "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> = (?\<SS>\<lparr>ArrMap\<rparr> \<circ>\<^sub>\<circ> ?cfs\<lparr>ArrMap\<rparr>)\<lparr>f\<rparr>"
	unfolding bifunctor_proj_fst_def dghm_comp_components by simp
	also have "\<dots> = ?\<SS>\<lparr>ArrMap\<rparr>\<lparr>?cfs\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>\<rparr>"
	by (rule vsv_vcomp_at)
	(
	simp_all add:
	two
	assms(2)
	cf_singleton_components
	prodfunctor_proj_components
	cf_singleton_ArrMap_app
	zf
	)
	also from assms(1) zf have "\<dots> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>f, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	unfolding cf_singleton_ArrMap_app[OF assms(2)] prodfunctor_proj_components
	by (simp add: two cat_singleton_CId_app[OF ob])
	finally show ?thesis by simp

	qed

	lemma bifunctor_proj_snd_ArrMap_app[cat_cs_simps]:
	assumes "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and "g \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	shows "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, g\<rparr>\<^sub>\<bullet>"
	proof-

	let ?\<DD> = \<open>\<SS>\<lparr>HomCod\<rparr>\<close>
	let ?\<SS> = \<open>\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat>-\<^sub>\<circ>set {0}.(i = 0 ? \<AA> : \<BB>),?\<DD>\<^esub>(-,set {\<langle>0, a\<rangle>})\<close>
	let ?cfs = \<open>cf_singleton (1\<^sub>\<nat>) \<BB>\<close>

	from assms(1) have "\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>\<AA>\<^esub> a" by (auto intro: cat_cs_intros)
	then have CId_a: "\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr> \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>" by auto

	from assms(2) have og: "set {\<langle>1\<^sub>\<nat>, g\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<lparr>Arr\<rparr>"
	by (intro cat_singleton_ArrI[where a=g]) simp
	from assms(1) have ob: "set {\<langle>0, a\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<lparr>Obj\<rparr>"
	by (intro cat_singleton_ObjI[where a=a]) simp
	have [simp]: "vinsert \<langle>1\<^sub>\<nat>, g\<rangle> (set {\<langle>0, \<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>\<rangle>}) = [\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, g]\<^sub>\<circ>"
	- using ord_of_nat_succ_vempty unfolding vcons_def by auto
	+ using ord_of_nat_succ_vempty unfolding vcons_def
	+ by (simp add: vinsert_vempty)

	have "(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> = (?\<SS>\<lparr>ArrMap\<rparr> \<circ>\<^sub>\<circ> ?cfs\<lparr>ArrMap\<rparr>)\<lparr>g\<rparr>"
	unfolding two bifunctor_proj_snd_def dghm_comp_components by simp
	also have "\<dots> = ?\<SS>\<lparr>ArrMap\<rparr>\<lparr>?cfs\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>\<rparr>"
	by (rule vsv_vcomp_at)
	(
	simp_all add:
	two
	assms(2)
	cf_singleton_components
	prodfunctor_proj_components
	cf_singleton_ArrMap_app
	og
	)
	also from assms(1) og have "\<dots> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, g\<rparr>\<^sub>\<bullet>"
	unfolding cf_singleton_ArrMap_app[OF assms(2)] prodfunctor_proj_components
	by (simp add: two cat_singleton_CId_app[OF ob])
	finally show ?thesis by simp

	qed

	end


	subsubsection\<open>Bifunctor projections are functors\<close>

	context
	fixes \<alpha> \<AA> \<BB>
	assumes \<AA>: "category \<alpha> \<AA>" and \<BB>: "category \<alpha> \<BB>"
	begin

	interpretation \<AA>: category \<alpha> \<AA> by (rule \<AA>)
	interpretation \<BB>: category \<alpha> \<BB> by (rule \<BB>)

	interpretation finite_pcategory \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 \<AA> \<BB>\<close>
	by (intro finite_pcategory_cat_prod_2 \<AA> \<BB>)

	lemmas_with [OF \<AA>.category_axioms \<BB>.category_axioms, simp]:
	cat_singleton_qm_fst_def and cat_singleton_qm_snd_def

	lemma bifunctor_proj_fst_is_functor:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	proof-

	interpret \<SS>: is_functor \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<DD> \<SS> by (rule assms(1))

	show ?thesis
	unfolding bifunctor_proj_fst_def
	proof
	(
	intro cf_comp_is_functorI[where \<BB>=\<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)\<close>],
	unfold \<SS>.cf_HomCod
	)
	from assms(2) have zb:
	"set {\<langle>1\<^sub>\<nat>, b\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. if j = 0 then \<AA> else \<BB>)\<lparr>Obj\<rparr>"
	unfolding cat_prod_components by (intro vproduct_vsingletonI) simp_all
	have o_zo: "set {1\<^sub>\<nat>} \<subseteq>\<^sub>\<circ> 2\<^sub>\<nat>" by clarsimp
	from pcat_prodfunctor_proj_is_functor[
	folded cat_prod_2_def, where J=\<open>set {1\<^sub>\<nat>}\<close>, OF assms(1) zb o_zo
	]
	show "\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat>-\<^sub>\<circ>set {1\<^sub>\<nat>}.(i = 0 ? \<AA> : \<BB>),\<DD>\<^esub>(-,set {\<langle>1\<^sub>\<nat>, b\<rangle>}) :
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	unfolding two by simp
	from category.cat_cf_singleton_is_functor[OF \<AA>.category_axioms, of 0] show
	"cf_singleton 0 \<AA> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {0}. \<AA>)"
	by force
	qed

	qed

	lemma bifunctor_proj_fst_is_functor'[cat_cs_intros]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "\<AA>' = \<AA>"
	shows "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1,2) unfolding assms(3) by (rule bifunctor_proj_fst_is_functor)

	lemma bifunctor_proj_fst_ObjMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "vsv ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>)"
	proof-
	interpret \<SS>: is_functor \<alpha> \<AA> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_fst_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ObjMap_vsv)
	qed

	lemma bifunctor_proj_fst_ObjMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "\<D>\<^sub>\<circ> ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<AA> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_fst_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ObjMap_vdomain)
	qed

	lemma bifunctor_proj_fst_ArrMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "vsv ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>)"
	proof-
	interpret \<SS>: is_functor \<alpha> \<AA> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_fst_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ArrMap_vsv)
	qed

	lemma bifunctor_proj_fst_ArrMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "\<D>\<^sub>\<circ> ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>) = \<AA>\<lparr>Arr\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<AA> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_fst_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ArrMap_vdomain)
	qed

	lemma bifunctor_proj_snd_is_functor:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	proof-

	interpret \<SS>: is_functor \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<DD> \<SS> by (rule assms(1))

	show ?thesis
	unfolding bifunctor_proj_snd_def
	proof
	(
	intro cf_comp_is_functorI[where \<BB>=\<open>(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)\<close>],
	unfold \<SS>.cf_HomCod
	)
	from assms(2) have zb:
	"set {\<langle>0, a\<rangle>} \<in>\<^sub>\<circ> (\<Prod>\<^sub>Cj\<in>\<^sub>\<circ>set {0}. if j = 0 then \<AA> else \<BB>)\<lparr>Obj\<rparr>"
	unfolding cat_prod_components by (intro vproduct_vsingletonI) simp_all
	have o_zo: "set {0} \<subseteq>\<^sub>\<circ> 2\<^sub>\<nat>" by clarsimp
	from
	pcat_prodfunctor_proj_is_functor[
	folded cat_prod_2_def, where J=\<open>set {0}\<close>, OF assms(1) zb o_zo
	]
	show "\<SS>\<^bsub>\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>2\<^sub>\<nat>-\<^sub>\<circ>set {0}.(i = 0 ? \<AA> : \<BB>),\<DD>\<^esub>(-,set {\<langle>0, a\<rangle>}) :
	(\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	unfolding two by simp
	from category.cat_cf_singleton_is_functor[OF \<BB>.category_axioms, of \<open>1\<^sub>\<nat>\<close>]
	show "cf_singleton (1\<^sub>\<nat>) \<BB> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> (\<Prod>\<^sub>Ci\<in>\<^sub>\<circ>set {1\<^sub>\<nat>}. \<BB>)"
	by force
	qed

	qed

	lemma bifunctor_proj_snd_is_functor'[cat_cs_intros]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and "\<BB>' = \<BB>"
	shows "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1,2) unfolding assms(3) by (rule bifunctor_proj_snd_is_functor)

	lemma bifunctor_proj_snd_ObjMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "vsv ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>)"
	proof-
	interpret \<SS>: is_functor \<alpha> \<BB> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_snd_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ObjMap_vsv)
	qed

	lemma bifunctor_proj_snd_ObjMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "\<D>\<^sub>\<circ> ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>) = \<BB>\<lparr>Obj\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<BB> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_snd_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ObjMap_vdomain)
	qed

	lemma bifunctor_proj_snd_ArrMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "vsv ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>)"
	proof-
	interpret \<SS>: is_functor \<alpha> \<BB> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_snd_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ArrMap_vsv)
	qed

	lemma bifunctor_proj_snd_ArrMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "\<D>\<^sub>\<circ> ((\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>) = \<BB>\<lparr>Arr\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<BB> \<DD> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F\<close>
	by (rule bifunctor_proj_snd_is_functor[OF assms])
	show ?thesis by (rule \<SS>.cf_ArrMap_vdomain)
	qed

	end



	subsection\<open>Bifunctor flip\<close>


	subsubsection\<open>Definition and elementary properties\<close>

	definition bifunctor_flip :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "bifunctor_flip \<AA> \<BB> \<FF> =
	[fflip (\<FF>\<lparr>ObjMap\<rparr>), fflip (\<FF>\<lparr>ArrMap\<rparr>), \<BB> \<times>\<^sub>C \<AA>, \<FF>\<lparr>HomCod\<rparr>]\<^sub>\<circ>"


	text\<open>Components\<close>

	lemma bifunctor_flip_components:
	shows "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr> = fflip (\<FF>\<lparr>ObjMap\<rparr>)"
	and "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr> = fflip (\<FF>\<lparr>ArrMap\<rparr>)"
	and "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>HomDom\<rparr> = \<BB> \<times>\<^sub>C \<AA>"
	and "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>HomCod\<rparr> = \<FF>\<lparr>HomCod\<rparr>"
	unfolding bifunctor_flip_def dghm_field_simps
	by (simp_all add: nat_omega_simps)


	subsubsection\<open>Bifunctor flip object map\<close>

	lemma bifunctor_flip_ObjMap_vsv[cat_cs_intros]:
	"vsv (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>)"
	unfolding bifunctor_flip_components by (rule fflip_vsv)

	lemma bifunctor_flip_ObjMap_app:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b, a\<rparr>\<^sub>\<bullet> = \<FF>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding bifunctor_flip_components assms(4,5)
	by
	(
	cs_concl cs_shallow
	cs_simp: V_cs_simps cat_cs_simps cs_intro: cat_prod_cs_intros
	)

	lemma bifunctor_flip_ObjMap_app'[cat_cs_simps]:
	assumes "ba = [b, a]\<^sub>\<circ>"
	and "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr> = \<FF>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	using assms(2-6) unfolding assms(1) by (rule bifunctor_flip_ObjMap_app)

	lemma bifunctor_flip_ObjMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	using assms
	unfolding bifunctor_flip_components
	by (cs_concl cs_shallow cs_simp: V_cs_simps cat_cs_simps)

	lemma bifunctor_flip_ObjMap_vrange[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) = \<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>)"
	proof-

	interpret \<FF>: is_functor \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<FF> by (rule assms(3))

	show ?thesis
	proof(intro vsubset_antisym)

	show "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>)"
	proof
	(
	intro vsv.vsv_vrange_vsubset,
	unfold bifunctor_flip_ObjMap_vdomain[OF assms]
	)
	fix ba assume "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(2,1)])
	from assms a b show
	"bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>)"
	unfolding ba_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: V_cs_intros cat_prod_cs_intros
	)
	qed (auto intro: cat_cs_intros)

	show "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>)"
	proof(intro vsv.vsv_vrange_vsubset, unfold \<FF>.cf_ObjMap_vdomain)
	fix ab assume prems: "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(1,2)])
	from assms a b have ba: "[b, a]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
	from assms bifunctor_flip_ObjMap_vsv prems a b ba show
	"\<FF>\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>)"
	by
	(
	cs_concl cs_shallow
	cs_simp: ab_def cat_cs_simps cs_intro: V_cs_intros
	)
	qed auto

	qed

	qed


	subsubsection\<open>Bifunctor flip arrow map\<close>

	lemma bifunctor_flip_ArrMap_vsv[cat_cs_intros]:
	"vsv (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>)"
	unfolding bifunctor_flip_components by (rule fflip_vsv)

	lemma bifunctor_flip_ArrMap_app:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	and "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	shows "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f, g\<rparr>\<^sub>\<bullet> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding bifunctor_flip_components
	by
	(
	cs_concl cs_shallow
	cs_simp: V_cs_simps cat_cs_simps cs_intro: cat_prod_cs_intros
	)

	lemma bifunctor_flip_ArrMap_app'[cat_cs_simps]:
	assumes "fg = [f, g]\<^sub>\<circ>"
	and "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	and "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	shows "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>fg\<rparr> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet>"
	using assms(2-6) unfolding assms(1) by (rule bifunctor_flip_ArrMap_app)

	lemma bifunctor_flip_ArrMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	using assms
	unfolding bifunctor_flip_components
	by (cs_concl cs_shallow cs_simp: V_cs_simps cat_cs_simps)

	lemma bifunctor_flip_ArrMap_vrange[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>) = \<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>)"
	proof-

	interpret \<FF>: is_functor \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<FF> by (rule assms(3))

	show ?thesis
	proof(intro vsubset_antisym)

	show "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>)"
	proof
	(
	intro vsv.vsv_vrange_vsubset,
	unfold bifunctor_flip_ArrMap_vdomain[OF assms]
	)
	fix fg assume "fg \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	then obtain f g
	where fg_def: "fg = [f, g]\<^sub>\<circ>"
	and f: "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	and g: "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[OF assms(2,1)])
	from f obtain a b where f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" by (auto intro: is_arrI)
	from g obtain a' b' where g: "g : a' \<mapsto>\<^bsub>\<AA>\<^esub> b'" by (auto intro: is_arrI)
	from \<FF>.cf_ArrMap_vsv assms f g show
	"bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>fg\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>)"
	unfolding fg_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps
	cs_intro: V_cs_intros cat_cs_intros cat_prod_cs_intros
	)
	qed (auto intro: cat_cs_intros)

	show "\<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>)"
	proof(intro vsv.vsv_vrange_vsubset, unfold \<FF>.cf_ArrMap_vdomain)
	fix gf assume prems: "gf \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>"
	then obtain g f
	where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and g: "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	and f: "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[OF assms(1,2)])
	from assms g f have fg: "[f, g]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
	from assms bifunctor_flip_ArrMap_vsv prems g f fg show
	"\<FF>\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>)"
	unfolding gf_def
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: V_cs_intros)
	qed auto

	qed

	qed


	subsubsection\<open>Bifunctor flip is a bifunctor\<close>

	lemma bifunctor_flip_is_functor:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "bifunctor_flip \<AA> \<BB> \<FF> : \<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> "
	proof-

	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<FF>: is_functor \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<FF> by (rule assms)

	show ?thesis
	proof(intro is_functorI')
	show "vfsequence (bifunctor_flip \<AA> \<BB> \<FF>)"
	unfolding bifunctor_flip_def by simp
	from assms(1,2) show "category \<alpha> (\<BB> \<times>\<^sub>C \<AA>)"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)
	show "vcard (bifunctor_flip \<AA> \<BB> \<FF>) = 4\<^sub>\<nat>"
	unfolding bifunctor_flip_def by (simp add: nat_omega_simps)
	show "vsv (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>)" by (auto intro: cat_cs_intros)
	show "vsv (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>)" by (auto intro: cat_cs_intros)
	from assms show "\<D>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	from assms \<FF>.cf_ObjMap_vrange show
	"\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	from assms show "\<D>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	show "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> :
	bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub>
	bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b'a'\<rparr>"
	if "gf : ba \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<AA>\<^esub> b'a'" for ba b'a' gf
	proof-
	from that obtain g f a b a' b'
	where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b'a'_def: "b'a' = [b', a']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<BB>\<^esub> b'"
	and f: "f : a \<mapsto>\<^bsub>\<AA>\<^esub> a'"
	by (elim cat_prod_2_is_arrE[OF assms(2,1)])
	from assms g f show ?thesis
	unfolding gf_def ba_def b'a'_def
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show
	"bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>gg' \<circ>\<^sub>A\<^bsub>\<BB> \<times>\<^sub>C \<AA>\<^esub> ff'\<rparr> =
	bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>gg'\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub>
	bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr>"
	if gg': "gg' : bb' \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<AA>\<^esub> cc'" and ff': "ff' : aa' \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<AA>\<^esub> bb'"
	for bb' cc' gg' aa' ff'
	proof-
	obtain g g' b b' c c'
	where gg'_def: "gg' = [g, g']\<^sub>\<circ>"
	and bb'_def: "bb' = [b, b']\<^sub>\<circ>"
	and cc'_def: "cc' = [c, c']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<BB>\<^esub> c"
	and g': "g' : b' \<mapsto>\<^bsub>\<AA>\<^esub> c'"
	by (elim cat_prod_2_is_arrE[OF assms(2,1) gg'])
	moreover obtain f f' a a' b'' b'''
	where ff'_def: "ff' = [f, f']\<^sub>\<circ>"
	and aa'_def: "aa' = [a, a']\<^sub>\<circ>"
	and "bb' = [b'', b''']\<^sub>\<circ>"
	and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b''"
	and "f' : a' \<mapsto>\<^bsub>\<AA>\<^esub> b'''"
	by (elim cat_prod_2_is_arrE[OF assms(2,1) ff'])
	ultimately have f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" and f': "f' : a' \<mapsto>\<^bsub>\<AA>\<^esub> b'"
	by (auto simp: cat_op_simps)
	from assms g g' f f' have [cat_cs_simps]:
	"\<FF>\<lparr>ArrMap\<rparr>\<lparr>g' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f', g \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f\<rparr>\<^sub>\<bullet> =
	\<FF>\<lparr>ArrMap\<rparr>\<lparr>[g', g]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>\<AA> \<times>\<^sub>C \<BB>\<^esub> [f', f]\<^sub>\<circ>\<rparr>"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_prod_2_Comp_app cs_intro: cat_prod_cs_intros
	)
	from assms g g' f f' show
	"bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>gg' \<circ>\<^sub>A\<^bsub>\<BB> \<times>\<^sub>C \<AA>\<^esub> ff'\<rparr> =
	bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>gg'\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub>
	bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr>"
	unfolding gg'_def ff'_def (slow)
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_prod_cs_simps cat_cs_simps
	cs_intro: cat_prod_cs_intros cat_cs_intros
	)
	qed
	show
	"bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>(\<BB> \<times>\<^sub>C \<AA>)\<lparr>CId\<rparr>\<lparr>ba\<rparr>\<rparr> =
	\<CC>\<lparr>CId\<rparr>\<lparr>bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr>\<rparr>"
	if "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>" for ba
	proof-
	from that obtain b a
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
	from assms b a have [cat_cs_simps]:
	"\<FF>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet> =
	\<FF>\<lparr>ArrMap\<rparr>\<lparr>(\<AA> \<times>\<^sub>C \<BB>)\<lparr>CId\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>\<rparr>"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_prod_2_CId_app cs_intro: cat_prod_cs_intros
	)
	from assms b a show ?thesis
	unfolding ba_def
	by
	(
	cs_concl cs_shallow
	cs_intro: cat_cs_intros cat_prod_cs_intros
	cs_simp: cat_prod_cs_simps cat_cs_simps
	)
	qed
	qed (auto simp: bifunctor_flip_components cat_cs_simps cat_cs_intros)

	qed

	lemma bifunctor_flip_is_functor'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<DD> = \<BB> \<times>\<^sub>C \<AA>"
	shows "bifunctor_flip \<AA> \<BB> \<FF> : \<DD> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	using assms(1-3) unfolding assms(4) by (intro bifunctor_flip_is_functor)


	subsubsection\<open>Double-flip of a bifunctor\<close>

	lemma bifunctor_flip_flip[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>) = \<FF>"
	proof(rule cf_eqI)

	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<FF>: is_functor \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<FF> by (rule assms(3))

	from assms show
	"bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>) : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)

	from assms have ObjMap_dom_lhs:
	"\<D>\<^sub>\<circ> (bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>)\<lparr>ObjMap\<rparr>) =
	(\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	have ObjMap_dom_rhs: "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	by (simp add: cat_cs_simps)
	from assms have ArrMap_dom_lhs:
	"\<D>\<^sub>\<circ> (bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>)\<lparr>ArrMap\<rparr>) =
	(\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	have ArrMap_dom_rhs: "\<D>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) = (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>"
	by (simp add: cat_cs_simps)

	show "bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>)\<lparr>ObjMap\<rparr> = \<FF>\<lparr>ObjMap\<rparr>"
	proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
	fix ab assume "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>" and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (rule cat_prod_2_ObjE[OF assms(1,2)])
	from assms a b show
	"bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>)\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr> = \<FF>\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr>"
	unfolding ab_def
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	qed (auto simp: cat_cs_intros)

	show "bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>)\<lparr>ArrMap\<rparr> = \<FF>\<lparr>ArrMap\<rparr>"
	proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
	fix ab assume "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>"
	then obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>" and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	by (rule cat_prod_2_ArrE[OF assms(1,2)])
	from assms a b show
	"bifunctor_flip \<BB> \<AA> (bifunctor_flip \<AA> \<BB> \<FF>)\<lparr>ArrMap\<rparr>\<lparr>ab\<rparr> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>ab\<rparr>"
	unfolding ab_def
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	qed (auto simp: cat_cs_intros)

	qed (simp_all add: assms(3))


	subsubsection\<open>A projection of a bifunctor flip\<close>

	lemma bifunctor_flip_proj_snd[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F = \<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F"
	proof(rule cf_eqI)

	from assms show f_\<FF>b: "bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)
	from assms show \<FF>b: "\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)

	from assms have ObjMap_dom_lhs:
	"\<D>\<^sub>\<circ> ((bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	from assms have ObjMap_dom_rhs: "\<D>\<^sub>\<circ> ((\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	from assms have ArrMap_dom_lhs:
	"\<D>\<^sub>\<circ> ((bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>) = \<AA>\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	from assms have ArrMap_dom_rhs: "\<D>\<^sub>\<circ> ((\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>) = \<AA>\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)

	show "(bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr> = (\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>"
	proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
	from assms show "vsv ((bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>)"
	by (intro bifunctor_proj_snd_ObjMap_vsv)
	(cs_concl cs_shallow cs_intro: cat_cs_intros)
	from assms show "vsv ((\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>)"
	by (intro bifunctor_proj_fst_ObjMap_vsv)
	(cs_concl cs_shallow cs_intro: cat_cs_intros)
	fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	with assms show
	"(bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> =
	(\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros)
	qed simp

	show
	"(bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr> = (\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>"
	proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
	from assms show "vsv ((bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>)"
	by (intro bifunctor_proj_snd_ArrMap_vsv)
	(cs_concl cs_shallow cs_intro: cat_cs_intros)
	from assms show "vsv ((\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>)"
	by (intro bifunctor_proj_fst_ArrMap_vsv)
	(cs_concl cs_shallow cs_intro: cat_cs_intros)
	fix f assume "f \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	with assms show
	"(bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
	(\<FF>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	qed simp

	qed simp_all

	lemma bifunctor_flip_proj_fst[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "bifunctor_flip \<AA> \<BB> \<FF>\<^bsub>\<BB>,\<AA>\<^esub>(-,a)\<^sub>C\<^sub>F = \<FF>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F"
	proof-
	from assms have f_\<FF>: "bifunctor_flip \<AA> \<BB> \<FF> : \<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)
	show ?thesis
	by
	(
	rule
	bifunctor_flip_proj_snd
	[
	OF assms(2,1) f_\<FF> assms(4),
	unfolded bifunctor_flip_flip[OF assms(1,2,3)],
	symmetric
	]
	)
	qed


	subsubsection\<open>A flip of a bifunctor isomorphism\<close>

	lemma bifunctor_flip_is_iso_functor:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<FF> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "bifunctor_flip \<AA> \<BB> \<FF> : \<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<CC> "
	proof-

	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<FF>: is_iso_functor \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<FF> by (rule assms(3))

	from assms have f_\<FF>: "bifunctor_flip \<AA> \<BB> \<FF> : \<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> "
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)

	from f_\<FF> have ObjMap_dom:
	"\<D>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_simp: cat_cs_simps)
	from f_\<FF> have ArrMap_dom:
	"\<D>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	by (cs_concl cs_simp: cat_cs_simps)

	show ?thesis
	proof(intro is_iso_functorI' vsv.vsv_valeq_v11I, unfold ObjMap_dom ArrMap_dom)
	from assms show "bifunctor_flip \<AA> \<BB> \<FF> : \<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	fix ba b'a'
	assume prems:
	"ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	"b'a' \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	"bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr> = bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b'a'\<rparr>"
	from prems(1) obtain b a
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(2,1)])
	from prems(2) obtain a' b'
	where b'a'_def: "b'a' = [b', a']\<^sub>\<circ>"
	and b': "b' \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a': "a' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (rule cat_prod_2_ObjE[OF assms(2,1)])
	from prems(3) assms a b b' a' have \<FF>ab_\<FF>a'b':
	"\<FF>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> = \<FF>\<lparr>ObjMap\<rparr>\<lparr>a', b'\<rparr>\<^sub>\<bullet>"
	unfolding ba_def b'a'_def
	by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cf_cs_intros)
	from assms a b a' b' have "[a, b]\<^sub>\<circ> = [a', b']\<^sub>\<circ>"
	by
	(
	cs_concl cs_shallow
	cs_intro:
	\<FF>.ObjMap.v11_eq_iff[THEN iffD1, OF _ _ \<FF>ab_\<FF>a'b']
	cat_prod_cs_intros
	)
	then show "ba = b'a'" unfolding ba_def b'a'_def by simp
	next
	fix fg f'g' assume prems:
	"fg \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	"f'g' \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	"bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>fg\<rparr> = bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'g'\<rparr>"
	from prems(1) obtain f g
	where fg_def: "fg = [f, g]\<^sub>\<circ>"
	and f: "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	and g: "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[OF assms(2,1)])
	from prems(2) obtain f' g'
	where f'g'_def: "f'g' = [f', g']\<^sub>\<circ>"
	and f': "f' \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	and g': "g' \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	by (rule cat_prod_2_ArrE[OF assms(2,1)])
	from prems(3) assms f g f' g' have \<FF>gf_\<FF>g'f':
	"\<FF>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>g', f'\<rparr>\<^sub>\<bullet>"
	unfolding fg_def f'g'_def
	by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cf_cs_intros)
	from assms g f g' f' have "[g, f]\<^sub>\<circ> = [g', f']\<^sub>\<circ>"
	by
	(
	cs_concl cs_shallow
	cs_intro:
	\<FF>.ArrMap.v11_eq_iff[THEN iffD1, OF _ _ \<FF>gf_\<FF>g'f']
	cat_prod_cs_intros
	)
	then show "fg = f'g'" unfolding fg_def f'g'_def by simp
	next

	show "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) = \<CC>\<lparr>Obj\<rparr>"
	proof(rule vsubset_antisym)
	show "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	proof(rule vsv.vsv_vrange_vsubset, unfold ObjMap_dom)
	fix ba assume "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	then obtain b a
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(2,1)])
	from assms b a show "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr> \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	unfolding ba_def
	by (cs_concl cs_intro: cat_cs_intros cf_cs_intros cat_prod_cs_intros)
	qed (auto simp: cat_cs_intros)
	show "\<CC>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>)"
	proof(intro vsubsetI)
	fix c assume prems: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	from prems obtain ab
	where ab: "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>" and \<FF>ab: "\<FF>\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr> = c"
	by blast
	from ab obtain b a
	where ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(1,2)])
	show "c \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>)"
	proof(intro vsv.vsv_vimageI2', unfold ObjMap_dom)
	from assms a b show "[b, a]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
	from assms b a prems show "c = bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b, a\<rparr>\<^sub>\<bullet>"
	by
	(
	cs_concl cs_shallow
	cs_simp: \<FF>ab[unfolded ab_def] cat_cs_simps
	cs_intro: cf_cs_intros
	)
	qed (auto intro: cat_cs_intros)
	qed
	qed

	show "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
	proof(rule vsubset_antisym)
	show "\<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	proof(rule vsv.vsv_vrange_vsubset, unfold ArrMap_dom)
	show "vsv (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>)" by (auto intro: cat_cs_intros)
	fix fg assume "fg \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	then obtain f g
	where fg_def: "fg = [f, g]\<^sub>\<circ>"
	and f: "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	and g: "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[OF assms(2,1)])
	from g f obtain a b a' b'
	where f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" and g: "g : a' \<mapsto>\<^bsub>\<AA>\<^esub> b'"
	by (auto intro!: is_arrI)
	from assms f g show "bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>fg\<rparr> \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	by
	(
	cs_concl cs_shallow
	cs_simp: fg_def cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show "\<CC>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>)"
	proof(intro vsubsetI)
	fix c assume prems: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	from prems obtain ab
	where ab: "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Arr\<rparr>" and \<FF>ab: "\<FF>\<lparr>ArrMap\<rparr>\<lparr>ab\<rparr> = c"
	by blast
	from ab obtain b a
	where ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[OF assms(1,2)])
	show "c \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>)"
	proof(intro vsv.vsv_vimageI2', unfold ArrMap_dom)
	from assms a b show "[b, a]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
	from assms b a prems show "c = bifunctor_flip \<AA> \<BB> \<FF>\<lparr>ArrMap\<rparr>\<lparr>b, a\<rparr>\<^sub>\<bullet>"
	by
	(
	cs_concl cs_shallow
	cs_simp: \<FF>ab[unfolded ab_def] cat_cs_simps
	cs_intro: cat_cs_intros
	)
	qed (auto intro: cat_cs_intros)
	qed
	qed

	qed (auto intro: cat_cs_intros)

	qed



	subsection\<open>Array bifunctor\<close>


	subsubsection\<open>Definition and elementary properties\<close>


	text\<open>See Chapter II-3 in \cite{mac_lane_categories_2010}.\<close>

	definition cf_array :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
	where "cf_array \<BB> \<CC> \<DD> \<FF> \<GG> =
	[
	(\<lambda>a\<in>\<^sub>\<circ>(\<BB> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>. \<GG> (vpfst a)\<lparr>ObjMap\<rparr>\<lparr>vpsnd a\<rparr>),
	(
	\<lambda>f\<in>\<^sub>\<circ>(\<BB> \<times>\<^sub>C \<CC>)\<lparr>Arr\<rparr>.
	\<GG> (\<BB>\<lparr>Cod\<rparr>\<lparr>vpfst f\<rparr>)\<lparr>ArrMap\<rparr>\<lparr>vpsnd f\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub>
	\<FF> (\<CC>\<lparr>Dom\<rparr>\<lparr>vpsnd f\<rparr>)\<lparr>ArrMap\<rparr>\<lparr>vpfst f\<rparr>
	),
	\<BB> \<times>\<^sub>C \<CC>,
	\<DD>
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma cf_array_components:
	shows "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr> =
	(\<lambda>a\<in>\<^sub>\<circ>(\<BB> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>. \<GG> (vpfst a)\<lparr>ObjMap\<rparr>\<lparr>vpsnd a\<rparr>)"
	and "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr> =
	(
	\<lambda>f\<in>\<^sub>\<circ>(\<BB> \<times>\<^sub>C \<CC>)\<lparr>Arr\<rparr>.
	\<GG> (\<BB>\<lparr>Cod\<rparr>\<lparr>vpfst f\<rparr>)\<lparr>ArrMap\<rparr>\<lparr>vpsnd f\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub>
	\<FF> (\<CC>\<lparr>Dom\<rparr>\<lparr>vpsnd f\<rparr>)\<lparr>ArrMap\<rparr>\<lparr>vpfst f\<rparr>
	)"
	and "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>HomDom\<rparr> = \<BB> \<times>\<^sub>C \<CC>"
	and "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>HomCod\<rparr> = \<DD>"
	unfolding cf_array_def dghm_field_simps by (simp_all add: nat_omega_simps)


	subsubsection\<open>Object map\<close>

	lemma cf_array_ObjMap_vsv: "vsv (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>)"
	unfolding cf_array_components by simp

	lemma cf_array_ObjMap_vdomain[cat_cs_simps]:
	"\<D>\<^sub>\<circ> (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>) = (\<BB> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	unfolding cf_array_components by simp

	lemma cf_array_ObjMap_app[cat_cs_simps]:
	assumes "[b, c]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	shows "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>b, c\<rparr>\<^sub>\<bullet> = \<GG> b\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
	using assms unfolding cf_array_components by (simp add: nat_omega_simps)

	lemma cf_array_ObjMap_vrange:
	assumes "category \<alpha> \<BB>"
	and "category \<alpha> \<CC>"
	and "\<And>b. b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> \<GG> b : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	proof(rule vsv.vsv_vrange_vsubset, unfold cf_array_ObjMap_vdomain)
	show "vsv (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>)" by (rule cf_array_ObjMap_vsv)
	fix x assume prems: "x \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	then obtain b c where x_def: "x = [b, c]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and c: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(1,2)])
	interpret \<GG>b: is_functor \<alpha> \<CC> \<DD> \<open>\<GG> b\<close> by (rule assms(3)[OF b])
	from prems c show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>x\<rparr> \<in>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	unfolding x_def cf_array_components
	by (auto simp: nat_omega_simps cat_cs_intros)
	qed


	subsubsection\<open>Arrow map\<close>

	lemma cf_array_ArrMap_vsv: "vsv (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>)"
	unfolding cf_array_components by simp

	lemma cf_array_ArrMap_vdomain[cat_cs_simps]:
	"\<D>\<^sub>\<circ> (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>) = (\<BB> \<times>\<^sub>C \<CC>)\<lparr>Arr\<rparr>"
	unfolding cf_array_components by simp

	lemma cf_array_ArrMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<BB>"
	and "category \<alpha> \<CC>"
	and "g : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
	and "f : a' \<mapsto>\<^bsub>\<CC>\<^esub> b'"
	shows "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> =
	\<GG> b\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<FF> a'\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>"
	proof-
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(1))
	interpret \<CC>: category \<alpha> \<CC> by (rule assms(2))
	from cat_prod_2_is_arrI[OF assms] have "[g, f]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<CC>)\<lparr>Arr\<rparr>" by auto
	with assms show ?thesis
	unfolding cf_array_components by (simp add: nat_omega_simps cat_cs_simps)
	qed

	lemma cf_array_ArrMap_vrange:
	assumes "category \<alpha> \<BB>"
	and "category \<alpha> \<CC>"
	and "\<And>c. c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<FF> c : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<And>b. b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> \<GG> b : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and [cat_cs_simps]:
	"\<And>b c. b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<GG> b\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> = \<FF> c\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
	shows "\<R>\<^sub>\<circ> (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	proof(rule vsv.vsv_vrange_vsubset, unfold cf_array_ArrMap_vdomain)
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(1))
	interpret \<CC>: category \<alpha> \<CC> by (rule assms(2))
	interpret \<BB>\<CC>: category \<alpha> \<open>\<BB> \<times>\<^sub>C \<CC>\<close>
	by (simp add: \<BB>.category_axioms \<CC>.category_axioms category_cat_prod_2)
	fix gf assume prems: "gf \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<CC>)\<lparr>Arr\<rparr>"
	then obtain bc b'c' where gf: "gf : bc \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<CC>\<^esub> b'c'" by auto
	then obtain g f b c b' c'
	where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and "bc = [b, c]\<^sub>\<circ>"
	and "b'c' = [b', c']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<BB>\<^esub> b'"
	and f: "f : c \<mapsto>\<^bsub>\<CC>\<^esub> c'"
	by (elim cat_prod_2_is_arrE[OF assms(1,2)])
	then have b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and b': "b' \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and c: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and c': "c' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	by auto
	interpret \<GG>b: is_functor \<alpha> \<CC> \<DD> \<open>\<GG> b\<close> by (rule assms(4)[OF b])
	interpret \<FF>c: is_functor \<alpha> \<BB> \<DD> \<open>\<FF> c\<close> by (rule assms(3)[OF c])
	interpret \<GG>b': is_functor \<alpha> \<CC> \<DD> \<open>\<GG> b'\<close> by (rule assms(4)[OF b'])
	interpret \<FF>c': is_functor \<alpha> \<BB> \<DD> \<open>\<FF> c'\<close> by (rule assms(3)[OF c'])
	from
	\<GG>b.is_functor_axioms
	\<FF>c.is_functor_axioms
	\<GG>b'.is_functor_axioms
	\<FF>c'.is_functor_axioms
	\<GG>b.HomCod.category_axioms
	g f
	have "\<GG> b'\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<FF> c\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<in>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	with g f prems show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> \<in>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	unfolding gf_def cf_array_components
	by (simp add: nat_omega_simps cat_cs_simps)
	qed (simp add: cf_array_ArrMap_vsv)


	subsubsection\<open>Array bifunctor is a bifunctor\<close>

	lemma cf_array_specification:
	\<comment>\<open>See Proposition 1 from Chapter II-3 in \cite{mac_lane_categories_2010}.\<close>
	assumes "category \<alpha> \<BB>"
	and "category \<alpha> \<CC>"
	and "category \<alpha> \<DD>"
	and "\<And>c. c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<FF> c : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<And>b. b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> \<GG> b : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<And>b c. b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<GG> b\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> = \<FF> c\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
	and
	"\<And>b c b' c' f g. \<lbrakk> f : b \<mapsto>\<^bsub>\<BB>\<^esub> b'; g : c \<mapsto>\<^bsub>\<CC>\<^esub> c' \<rbrakk> \<Longrightarrow>
	\<GG> b'\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<FF> c\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
	\<FF> c'\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<GG> b\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>"
	shows cf_array_is_functor: "cf_array \<BB> \<CC> \<DD> \<FF> \<GG> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and cf_array_ObjMap_app_fst: "\<And>b c. \<lbrakk> b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>; c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow>
	cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>b, c\<rparr>\<^sub>\<bullet> = \<FF> c\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
	and cf_array_ObjMap_app_snd: "\<And>b c. \<lbrakk> b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>; c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow>
	cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>b, c\<rparr>\<^sub>\<bullet> = \<GG> b\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
	and cf_array_ArrMap_app_fst: "\<And>a b f c. \<lbrakk> f : a \<mapsto>\<^bsub>\<BB>\<^esub> b; c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>\<rbrakk> \<Longrightarrow>
	cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>f, \<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>\<^sub>\<bullet> = \<FF> c\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>"
	and cf_array_ArrMap_app_snd: "\<And>a b g c. \<lbrakk> g : a \<mapsto>\<^bsub>\<CC>\<^esub> b; c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow>
	cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>\<BB>\<lparr>CId\<rparr>\<lparr>c\<rparr>, g\<rparr>\<^sub>\<bullet> = \<GG> c\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>"
	proof-

	interpret \<BB>: category \<alpha> \<BB> by (rule assms(1))
	interpret \<CC>: category \<alpha> \<CC> by (rule assms(2))
	interpret \<DD>: category \<alpha> \<DD> by (rule assms(3))

	from assms(4) have [cat_cs_intros]: "\<FF> c : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<DD>'"
	if "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "\<BB>' = \<BB>" "\<DD>' = \<DD>" "\<alpha>' = \<alpha>" for \<alpha>' c \<BB>' \<DD>'
	using that(1) unfolding that(2-4) by (intro assms(4))
	from assms(4) have [cat_cs_intros]: "\<GG> c : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<DD>'"
	if "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" "\<CC>' = \<CC>" "\<DD>' = \<DD>" "\<alpha>' = \<alpha>" for \<alpha>' c \<CC>' \<DD>'
	using that(1) unfolding that(2-4) by (intro assms(5))

	show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	proof(intro is_functorI')
	show "vfsequence (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>)" unfolding cf_array_def by auto
	from assms(1,2) show "category \<alpha> (\<BB> \<times>\<^sub>C \<CC>)"
	by (simp add: category_cat_prod_2)
	show "vcard (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>) = 4\<^sub>\<nat>"
	unfolding cf_array_def by (simp add: nat_omega_simps)
	show "\<R>\<^sub>\<circ> (cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	by (rule cf_array_ObjMap_vrange) (auto simp: assms intro: cat_cs_intros)
	show cf_array_is_arrI: "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr> :
	cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>aa'\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>bb'\<rparr>"
	if ff': "ff' : aa' \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<CC>\<^esub> bb'" for aa' bb' ff'
	proof-
	obtain f f' a a' b b'
	where ff'_def: "ff' = [f, f']\<^sub>\<circ>"
	and aa'_def: "aa' = [a, a']\<^sub>\<circ>"
	and bb'_def: "bb' = [b, b']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
	and f': "f' : a' \<mapsto>\<^bsub>\<CC>\<^esub> b'"
	by (elim cat_prod_2_is_arrE[OF \<BB>.category_axioms \<CC>.category_axioms ff'])
	then have a: "a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a': "a' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and b': "b' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	by auto
	from f' assms(5)[OF a] a have
	"\<GG> a\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF> a'\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> \<FF> b'\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
	by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
	with assms(1-3) f f' assms(4)[OF b'] show ?thesis
	unfolding ff'_def aa'_def bb'_def
	by
	(
	cs_concl
	cs_simp: cat_cs_simps assms(6)
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gg' \<circ>\<^sub>A\<^bsub>\<BB> \<times>\<^sub>C \<CC>\<^esub> ff'\<rparr> =
	cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gg'\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr>"
	if gg': "gg' : bb' \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<CC>\<^esub> cc'" and ff': "ff' : aa' \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<CC>\<^esub> bb'"
	for bb' cc' gg' aa' ff'
	proof-
	obtain g g' b b' c c'
	where gg'_def: "gg' = [g, g']\<^sub>\<circ>"
	and bb'_def: "bb' = [b, b']\<^sub>\<circ>"
	and cc'_def: "cc' = [c, c']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<BB>\<^esub> c"
	and g': "g' : b' \<mapsto>\<^bsub>\<CC>\<^esub> c'"
	by (elim cat_prod_2_is_arrE[OF \<BB>.category_axioms \<CC>.category_axioms gg'])
	moreover obtain f f' a a' b'' b'''
	where ff'_def: "ff' = [f, f']\<^sub>\<circ>"
	and aa'_def: "aa' = [a, a']\<^sub>\<circ>"
	and "bb' = [b'', b''']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b''"
	and f': "f' : a' \<mapsto>\<^bsub>\<CC>\<^esub> b'''"
	by (elim cat_prod_2_is_arrE[OF \<BB>.category_axioms \<CC>.category_axioms ff'])
	ultimately have f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" and f': "f' : a' \<mapsto>\<^bsub>\<CC>\<^esub> b'" by auto
	with g have a: "a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a': "a' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and b': "b' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and c': "b' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	by auto
	from f' assms(5)[OF a] a have \<GG>a_f':
	"\<GG> a\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF> a'\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> \<FF> b'\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
	by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
	from f' b assms(5)[OF b] have \<GG>b_f':
	"\<GG> b\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF> a'\<lparr>ObjMap\<rparr>\<lparr>b\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> \<FF> b'\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
	by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
	from f' c assms(5)[OF c] have \<GG>c_f':
	"\<GG> c\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF> a'\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> \<FF> b'\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
	by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
	have
	"\<FF> b'\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> (\<FF> b'\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<GG> a\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>) =
	(\<GG> c\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<FF> a'\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>) \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<FF> a'\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>"
	using f' f g \<GG>b_f' assms(4)[OF a'] assms(4)[OF b']
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps assms(7) cs_intro: cat_cs_intros
	)
	also have "\<dots> =
	\<GG> c\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> (\<FF> a'\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<FF> a'\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>)"
	using assms(2) f f' g g' assms(4)[OF a'] assms(5)[OF c]
	by (cs_concl cs_simp: assms(6) cat_cs_simps cs_intro: cat_cs_intros)
	finally have [cat_cs_simps]:
	"\<FF> b'\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> (\<FF> b'\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<GG> a\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>) =
	\<GG> c\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> (\<FF> a'\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> \<FF> a'\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>)"
	by simp
	show ?thesis
	using
	\<GG>a_f' \<GG>c_f'
	f f'
	g g'
	assms(1,2)
	assms(4)[OF a']
	assms(4)[OF c']
	assms(5)[OF c]
	unfolding gg'_def ff'_def aa'_def bb'_def cc'_def (slow)
	by
	(
	cs_concl
	cs_simp: assms(6,7) cat_prod_cs_simps cat_cs_simps
	cs_intro: cat_prod_cs_intros cat_cs_intros
	)
	qed
	show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>(\<BB> \<times>\<^sub>C \<CC>)\<lparr>CId\<rparr>\<lparr>cc'\<rparr>\<rparr> =
	\<DD>\<lparr>CId\<rparr>\<lparr>cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>cc'\<rparr>\<rparr>"
	if "cc' \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>" for cc'
	proof-
	from that obtain c c'
	where cc'_def: "cc' = [c, c']\<^sub>\<circ>"
	and c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and c': "c' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
	from assms(1,2,3) c c' assms(4)[OF c'] assms(5)[OF c] show ?thesis
	unfolding cc'_def (slow)
	by
	(
	cs_concl
	cs_simp: cat_prod_cs_simps cat_cs_simps assms(6)
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	qed (auto simp: cf_array_components cat_cs_intros)

	show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>b, c\<rparr>\<^sub>\<bullet> = \<FF> c\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
	if "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for b c
	using that assms(1,2,3)
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps assms(6) cs_intro: cat_prod_cs_intros
	)
	show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>b, c\<rparr>\<^sub>\<bullet> = \<GG> b\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
	if "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for b c
	using that assms(1,2,3)
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros)
	show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>f, \<CC>\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr>\<^sub>\<bullet> = \<FF> c\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>"
	if f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" and c: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for a b f c
	proof-
	from f have "a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by auto
	from assms(5)[OF this(1)] assms(5)[OF this(2)] assms(4)[OF c] show ?thesis
	using assms(1,2,3) f c
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps assms(6) cs_intro: cat_cs_intros
	)
	qed

	show "cf_array \<BB> \<CC> \<DD> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>\<BB>\<lparr>CId\<rparr>\<lparr>c\<rparr>, g\<rparr>\<^sub>\<bullet> = \<GG> c\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>"
	if g: "g : a \<mapsto>\<^bsub>\<CC>\<^esub> b" and c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" for a b g c
	proof-
	from g have "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by auto
	from assms(4)[OF this(1)] assms(4)[OF this(2)] assms(5)[OF c] show ?thesis
	using assms(1,2,3) g c
	by
	(
	cs_concl
	cs_simp: cat_cs_simps assms(6)[symmetric] cs_intro: cat_cs_intros
	)
	qed

	qed



	subsection\<open>Composition of a covariant bifunctor and covariant functors\<close>


	subsubsection\<open>Definition and elementary properties.\<close>

	definition cf_bcomp :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_bcomp \<SS> \<FF> \<GG> =
	[
	(
	\<lambda>a\<in>\<^sub>\<circ>(\<FF>\<lparr>HomDom\<rparr> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Obj\<rparr>.
	\<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>vpfst a\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>vpsnd a\<rparr>\<rparr>\<^sub>\<bullet>
	),
	(
	\<lambda>f\<in>\<^sub>\<circ>(\<FF>\<lparr>HomDom\<rparr> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Arr\<rparr>.
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>vpfst f\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>vpsnd f\<rparr>\<rparr>\<^sub>\<bullet>
	),
	\<FF>\<lparr>HomDom\<rparr> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>,
	\<SS>\<lparr>HomCod\<rparr>
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma cf_bcomp_components:
	shows "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr> =
	(
	\<lambda>a\<in>\<^sub>\<circ>(\<FF>\<lparr>HomDom\<rparr> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Obj\<rparr>.
	\<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>vpfst a\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>vpsnd a\<rparr>\<rparr>\<^sub>\<bullet>
	)"
	and "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr> =
	(
	\<lambda>f\<in>\<^sub>\<circ>(\<FF>\<lparr>HomDom\<rparr> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Arr\<rparr>.
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>vpfst f\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>vpsnd f\<rparr>\<rparr>\<^sub>\<bullet>
	)"
	and "cf_bcomp \<SS> \<FF> \<GG>\<lparr>HomDom\<rparr> = \<FF>\<lparr>HomDom\<rparr> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>"
	and "cf_bcomp \<SS> \<FF> \<GG>\<lparr>HomCod\<rparr> = \<SS>\<lparr>HomCod\<rparr>"
	unfolding cf_bcomp_def dghm_field_simps by (simp_all add: nat_omega_simps)


	subsubsection\<open>Object map\<close>

	lemma cf_bcomp_ObjMap_vsv: "vsv (cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>)"
	unfolding cf_bcomp_components by simp

	lemma cf_bcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>) = (\<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms)
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms)
	show ?thesis unfolding cf_bcomp_components by (simp add: cat_cs_simps)
	qed

	lemma cf_bcomp_ObjMap_app[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>"
	shows "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	from assms show ?thesis
	unfolding cf_bcomp_components
	by (simp_all add: cat_cs_simps nat_omega_simps)
	qed

	lemma cf_bcomp_ObjMap_vrange:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	proof
	(
	rule vsv.vsv_vrange_vsubset,
	unfold cf_bcomp_ObjMap_vdomain[OF assms(1,2)]
	)
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	show "vsv (cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>)" by (rule cf_bcomp_ObjMap_vsv)
	fix bc assume "bc \<in>\<^sub>\<circ> (\<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>"
	with \<FF>.HomDom.category_axioms \<GG>.HomDom.category_axioms obtain b c
	where bc_def: "bc = [b, c]\<^sub>\<circ>" and b: "b \<in>\<^sub>\<circ> \<BB>'\<lparr>Obj\<rparr>" and c: "c \<in>\<^sub>\<circ> \<CC>'\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[rotated -1])
	from assms b c show "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>bc\<rparr> \<in>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	unfolding bc_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed


	subsubsection\<open>Arrow map\<close>

	lemma cf_bcomp_ArrMap_vsv: "vsv (cf_bcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>)"
	unfolding cf_bcomp_components by simp

	lemma cf_bcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>) = (\<BB>' \<times>\<^sub>C \<CC>')\<lparr>Arr\<rparr>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	show ?thesis unfolding cf_bcomp_components by (simp add: cat_cs_simps)
	qed

	lemma cf_bcomp_ArrMap_app[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "[g, f]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB>' \<times>\<^sub>C \<CC>')\<lparr>Arr\<rparr>"
	shows "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>\<rparr>\<^sub>\<bullet>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	from assms show ?thesis
	unfolding cf_bcomp_components by (simp_all add: nat_omega_simps cat_cs_simps)
	qed

	lemma cf_bcomp_ArrMap_vrange:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	proof(rule vsv.vsv_vrange_vsubset, unfold cf_bcomp_ArrMap_vdomain[OF assms(1,2)])
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	fix gf assume "gf \<in>\<^sub>\<circ> (\<BB>' \<times>\<^sub>C \<CC>')\<lparr>Arr\<rparr>"
	with \<FF>.HomDom.category_axioms \<GG>.HomDom.category_axioms obtain g f
	where gf_def: "gf = [g, f]\<^sub>\<circ>" and g: "g \<in>\<^sub>\<circ> \<BB>'\<lparr>Arr\<rparr>" and f: "f \<in>\<^sub>\<circ> \<CC>'\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[rotated -1])
	from g obtain a b where g: "g : a \<mapsto>\<^bsub>\<BB>'\<^esub> b" by auto
	from f obtain a' b' where f: "f : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'" by auto
	from assms g f show "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> \<in>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	unfolding gf_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed (simp add: cf_bcomp_ArrMap_vsv)


	subsubsection\<open>
	Composition of a covariant bifunctor and
	covariant functors is a functor
	\<close>

	lemma cf_bcomp_is_functor:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "cf_bcomp \<SS> \<FF> \<GG> : \<BB>' \<times>\<^sub>C \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	proof-

	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	interpret \<SS>: is_functor \<alpha> \<open>\<BB> \<times>\<^sub>C \<CC>\<close> \<DD> \<SS> by (rule assms(3))

	show ?thesis
	proof(intro is_functorI')
	show "vfsequence (cf_bcomp \<SS> \<FF> \<GG>)" unfolding cf_bcomp_def by simp
	show "category \<alpha> (\<BB>' \<times>\<^sub>C \<CC>')"
	by
	(
	simp add:
	\<FF>.HomDom.category_axioms
	\<GG>.HomDom.category_axioms
	category_cat_prod_2
	)
	show "vcard (cf_bcomp \<SS> \<FF> \<GG>) = 4\<^sub>\<nat>"
	unfolding cf_bcomp_def by (simp add: nat_omega_simps)
	from assms show "\<R>\<^sub>\<circ> (cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	by (rule cf_bcomp_ObjMap_vrange)
	show "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr> :
	cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>aa'\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>bb'\<rparr>"
	if ff': "ff' : aa' \<mapsto>\<^bsub>\<BB>' \<times>\<^sub>C \<CC>'\<^esub> bb'" for aa' bb' ff'
	proof-
	obtain f f' a a' b b'
	where ff'_def: "ff' = [f, f']\<^sub>\<circ>"
	and aa'_def: "aa' = [a, a']\<^sub>\<circ>"
	and bb'_def: "bb' = [b, b']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>\<BB>'\<^esub> b"
	and f': "f' : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'"
	by
	(
	elim
	cat_prod_2_is_arrE[
	OF \<FF>.HomDom.category_axioms \<GG>.HomDom.category_axioms ff'
	]
	)
	from assms f f' show ?thesis
	unfolding ff'_def aa'_def bb'_def
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show "cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gg' \<circ>\<^sub>A\<^bsub>\<BB>' \<times>\<^sub>C \<CC>'\<^esub> ff'\<rparr> =
	cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gg'\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub> cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr>"
	if gg': "gg' : bb' \<mapsto>\<^bsub>\<BB>' \<times>\<^sub>C \<CC>'\<^esub> cc'"
	and ff': "ff' : aa' \<mapsto>\<^bsub>\<BB>' \<times>\<^sub>C \<CC>'\<^esub> bb'"
	for bb' cc' gg' aa' ff'
	proof-
	obtain g g' b b' c c'
	where gg'_def: "gg' = [g, g']\<^sub>\<circ>"
	and bb'_def: "bb' = [b, b']\<^sub>\<circ>"
	and cc'_def: "cc' = [c, c']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<BB>'\<^esub> c"
	and g': "g' : b' \<mapsto>\<^bsub>\<CC>'\<^esub> c'"
	by
	(
	elim cat_prod_2_is_arrE[
	OF \<FF>.HomDom.category_axioms \<GG>.HomDom.category_axioms gg'
	]
	)
	moreover obtain f f' a a' b'' b'''
	where ff'_def: "ff' = [f, f']\<^sub>\<circ>"
	and aa'_def: "aa' = [a, a']\<^sub>\<circ>"
	and "bb' = [b'', b''']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>\<BB>'\<^esub> b''"
	and f': "f' : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'''"
	by
	(
	elim cat_prod_2_is_arrE[
	OF \<FF>.HomDom.category_axioms \<GG>.HomDom.category_axioms ff'
	]
	)
	ultimately have f: "f : a \<mapsto>\<^bsub>\<BB>'\<^esub> b" and f': "f' : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'" by auto
	from assms f f' g g' have [cat_cs_simps]:
	"[\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>g'\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<GG>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>]\<^sub>\<circ> =
	[\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>g'\<rparr>]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>\<BB> \<times>\<^sub>C \<CC>\<^esub> [\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>]\<^sub>\<circ>"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	from assms f f' g g' show ?thesis
	unfolding gg'_def ff'_def aa'_def bb'_def cc'_def
	by
	(
	cs_concl
	cs_simp: cat_prod_cs_simps cat_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show
	"cf_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>(\<BB>' \<times>\<^sub>C \<CC>')\<lparr>CId\<rparr>\<lparr>cc'\<rparr>\<rparr> =
	\<DD>\<lparr>CId\<rparr>\<lparr>cf_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>cc'\<rparr>\<rparr>"
	if "cc' \<in>\<^sub>\<circ> (\<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>" for cc'
	proof-
	from that obtain c c'
	where cc'_def: "cc' = [c, c']\<^sub>\<circ>"
	and c: "c \<in>\<^sub>\<circ> \<BB>'\<lparr>Obj\<rparr>"
	and c': "c' \<in>\<^sub>\<circ> \<CC>'\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
	from assms c c' have [cat_cs_simps]:
	"[\<BB>\<lparr>CId\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>, \<CC>\<lparr>CId\<rparr>\<lparr>\<GG>\<lparr>ObjMap\<rparr>\<lparr>c'\<rparr>\<rparr>]\<^sub>\<circ> =
	(\<BB> \<times>\<^sub>C \<CC>)\<lparr>CId\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>c'\<rparr>\<rparr>\<^sub>\<bullet>"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	from assms c c' show ?thesis
	unfolding cc'_def
	by
	(
	cs_concl
	cs_simp: cat_prod_cs_simps cat_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	qed (auto simp: cf_bcomp_components cat_cs_intros cat_cs_simps)

	qed

	lemma cf_bcomp_is_functor'[cat_cs_intros]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<AA>' = \<BB>' \<times>\<^sub>C \<CC>'"
	shows "cf_bcomp \<SS> \<FF> \<GG> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1-3) unfolding assms(4) by (rule cf_bcomp_is_functor)



	subsection\<open>Composition of a contracovariant bifunctor and covariant functors\<close>

	text\<open>
	The term \<open>contracovariant bifunctor\<close> is used to refer to a bifunctor
	that is contravariant in the first argument and covariant in the second
	argument.
	\<close>

	definition cf_cn_cov_bcomp :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_cn_cov_bcomp \<SS> \<FF> \<GG> =
	[
	(
	\<lambda>a\<in>\<^sub>\<circ>(op_cat (\<FF>\<lparr>HomDom\<rparr>) \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Obj\<rparr>.
	\<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>vpfst a\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>vpsnd a\<rparr>\<rparr>\<^sub>\<bullet>
	),
	(
	\<lambda>f\<in>\<^sub>\<circ>(op_cat (\<FF>\<lparr>HomDom\<rparr>) \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Arr\<rparr>.
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>vpfst f\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>vpsnd f\<rparr>\<rparr>\<^sub>\<bullet>
	),
	op_cat (\<FF>\<lparr>HomDom\<rparr>) \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>,
	\<SS>\<lparr>HomCod\<rparr>
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma cf_cn_cov_bcomp_components:
	shows "cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr> =
	(
	\<lambda>a\<in>\<^sub>\<circ>(op_cat (\<FF>\<lparr>HomDom\<rparr>) \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Obj\<rparr>.
	\<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>vpfst a\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>vpsnd a\<rparr>\<rparr>\<^sub>\<bullet>
	)"
	and "cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr> =
	(
	\<lambda>f\<in>\<^sub>\<circ>(op_cat (\<FF>\<lparr>HomDom\<rparr>) \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>)\<lparr>Arr\<rparr>.
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>vpfst f\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>vpsnd f\<rparr>\<rparr>\<^sub>\<bullet>
	)"
	and "cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>HomDom\<rparr> = op_cat (\<FF>\<lparr>HomDom\<rparr>) \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>"
	and "cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>HomCod\<rparr> = \<SS>\<lparr>HomCod\<rparr>"
	unfolding cf_cn_cov_bcomp_def dghm_field_simps
	by (simp_all add: nat_omega_simps)


	subsubsection\<open>Object map\<close>

	lemma cf_cn_cov_bcomp_ObjMap_vsv: "vsv (cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>)"
	unfolding cf_cn_cov_bcomp_components by simp

	lemma cf_cn_cov_bcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>) = (op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	show ?thesis
	unfolding cf_cn_cov_bcomp_components
	by (simp add: nat_omega_simps cat_cs_simps)
	qed

	lemma cf_cn_cov_bcomp_ObjMap_app[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> (op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>"
	shows
	"cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> =
	\<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	from assms show ?thesis
	unfolding cf_cn_cov_bcomp_components
	by (simp_all add: cat_cs_simps nat_omega_simps)
	qed

	lemma cf_cn_cov_bcomp_ObjMap_vrange:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	proof
	(
	rule vsv.vsv_vrange_vsubset,
	unfold cf_cn_cov_bcomp_ObjMap_vdomain[OF assms(1,2)]
	)
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	show "vsv (cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>)"
	by (rule cf_cn_cov_bcomp_ObjMap_vsv)
	fix bc assume "bc \<in>\<^sub>\<circ> (op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>"
	with \<FF>.HomDom.category_op \<GG>.HomDom.category_axioms obtain b c
	where bc_def: "bc = [b, c]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> op_cat \<BB>'\<lparr>Obj\<rparr>"
	and c: "c \<in>\<^sub>\<circ> \<CC>'\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[rotated -1])
	from assms b c show "cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>bc\<rparr> \<in>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	unfolding bc_def cat_op_simps
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	qed


	subsubsection\<open>Arrow map\<close>

	lemma cf_cn_cov_bcomp_ArrMap_vsv: "vsv (cf_cn_cov_bcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>)"
	unfolding cf_cn_cov_bcomp_components by simp

	lemma cf_cn_cov_bcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>) = (op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>Arr\<rparr>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	show ?thesis unfolding cf_cn_cov_bcomp_components by (simp add: cat_cs_simps)
	qed

	lemma cf_cn_cov_bcomp_ArrMap_app[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "[g, f]\<^sub>\<circ> \<in>\<^sub>\<circ> (op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>Arr\<rparr>"
	shows "cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> =
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>\<rparr>\<^sub>\<bullet>"
	proof-
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	from assms show ?thesis
	unfolding cf_cn_cov_bcomp_components
	by (simp_all add: nat_omega_simps cat_cs_simps)
	qed

	lemma cf_cn_cov_bcomp_ArrMap_vrange:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	proof
	(
	rule vsv.vsv_vrange_vsubset,
	unfold cf_cn_cov_bcomp_ArrMap_vdomain[OF assms(1,2)]
	)
	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	fix gf assume "gf \<in>\<^sub>\<circ> (op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>Arr\<rparr>"
	with \<FF>.HomDom.category_op \<GG>.HomDom.category_axioms obtain g f
	where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and g: "g \<in>\<^sub>\<circ> op_cat \<BB>'\<lparr>Arr\<rparr>"
	and f: "f \<in>\<^sub>\<circ> \<CC>'\<lparr>Arr\<rparr>"
	by (elim cat_prod_2_ArrE[rotated -1])
	from g obtain a b where g: "g : a \<mapsto>\<^bsub>\<BB>'\<^esub> b" unfolding cat_op_simps by auto
	from f obtain a' b' where f: "f : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'" by auto
	from assms g f show "cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> \<in>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	unfolding gf_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	qed (rule cf_cn_cov_bcomp_ArrMap_vsv)


	subsubsection\<open>
	Composition of a contracovariant bifunctor and functors is a functor
	\<close>

	lemma cf_cn_cov_bcomp_is_functor:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "cf_cn_cov_bcomp \<SS> \<FF> \<GG> : op_cat \<BB>' \<times>\<^sub>C \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	proof-

	interpret \<FF>: is_functor \<alpha> \<BB>' \<BB> \<FF> by (rule assms(1))
	interpret \<GG>: is_functor \<alpha> \<CC>' \<CC> \<GG> by (rule assms(2))
	interpret \<SS>: is_functor \<alpha> \<open>op_cat \<BB> \<times>\<^sub>C \<CC>\<close> \<DD> \<SS> by (rule assms(3))

	show ?thesis
	proof(intro is_functorI')
	show "vfsequence (cf_cn_cov_bcomp \<SS> \<FF> \<GG>)"
	unfolding cf_cn_cov_bcomp_def by simp
	show "category \<alpha> (op_cat \<BB>' \<times>\<^sub>C \<CC>')"
	by
	(
	simp add:
	\<FF>.HomDom.category_op \<GG>.HomDom.category_axioms category_cat_prod_2
	)
	show "vcard (cf_cn_cov_bcomp \<SS> \<FF> \<GG>) = 4\<^sub>\<nat>"
	unfolding cf_cn_cov_bcomp_def by (simp add: nat_omega_simps)
	from assms show "\<R>\<^sub>\<circ> (cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	by (rule cf_cn_cov_bcomp_ObjMap_vrange)
	show
	"cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr> :
	cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>aa'\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub>
	cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>bb'\<rparr>"
	if ff': "ff' : aa' \<mapsto>\<^bsub>op_cat \<BB>' \<times>\<^sub>C \<CC>'\<^esub> bb'" for aa' bb' ff'
	proof-
	obtain f f' a a' b b'
	where ff'_def: "ff' = [f, f']\<^sub>\<circ>"
	and aa'_def: "aa' = [a, a']\<^sub>\<circ>"
	and bb'_def: "bb' = [b, b']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>op_cat \<BB>'\<^esub> b"
	and f': "f' : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'"
	by
	(
	elim
	cat_prod_2_is_arrE[
	OF \<FF>.HomDom.category_op \<GG>.HomDom.category_axioms ff'
	]
	)
	from assms f f' show ?thesis
	unfolding ff'_def aa'_def bb'_def cat_op_simps
	by (slow)
	(
	cs_concl
	cs_simp: cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	qed
	show
	"cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gg' \<circ>\<^sub>A\<^bsub>op_cat \<BB>' \<times>\<^sub>C \<CC>'\<^esub> ff'\<rparr> =
	cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>gg'\<rparr> \<circ>\<^sub>A\<^bsub>\<DD>\<^esub>
	cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>ff'\<rparr>"
	if gg': "gg' : bb' \<mapsto>\<^bsub>op_cat \<BB>' \<times>\<^sub>C \<CC>'\<^esub> cc'"
	and ff': "ff' : aa' \<mapsto>\<^bsub>op_cat \<BB>' \<times>\<^sub>C \<CC>'\<^esub> bb'"
	for bb' cc' gg' aa' ff'
	proof-
	obtain g g' b b' c c'
	where gg'_def: "gg' = [g, g']\<^sub>\<circ>"
	and bb'_def: "bb' = [b, b']\<^sub>\<circ>"
	and cc'_def: "cc' = [c, c']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>op_cat \<BB>'\<^esub> c"
	and g': "g' : b' \<mapsto>\<^bsub>\<CC>'\<^esub> c'"
	by
	(
	elim cat_prod_2_is_arrE[
	OF \<FF>.HomDom.category_op \<GG>.HomDom.category_axioms gg'
	]
	)
	moreover obtain f f' a a' b'' b'''
	where ff'_def: "ff' = [f, f']\<^sub>\<circ>"
	and aa'_def: "aa' = [a, a']\<^sub>\<circ>"
	and "bb' = [b'', b''']\<^sub>\<circ>"
	and f: "f : a \<mapsto>\<^bsub>op_cat \<BB>'\<^esub> b''"
	and "f' : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'''"
	by
	(
	elim cat_prod_2_is_arrE[
	OF \<FF>.HomDom.category_op \<GG>.HomDom.category_axioms ff'
	]
	)
	ultimately have f: "f : a \<mapsto>\<^bsub>op_cat \<BB>'\<^esub> b" and f': "f' : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'"
	by auto
	from assms f f' g g' have [cat_cs_simps]:
	"[
	\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>,
	\<GG>\<lparr>ArrMap\<rparr>\<lparr>g'\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<GG>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>
	]\<^sub>\<circ> =
	[\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>g'\<rparr>]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>op_cat \<BB> \<times>\<^sub>C \<CC>\<^esub>
	[\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>, \<GG>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>]\<^sub>\<circ>"
	unfolding cat_op_simps
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_prod_cs_simps cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	from assms f f' g g' show ?thesis
	unfolding gg'_def ff'_def aa'_def bb'_def cc'_def cat_op_simps
	by
	(
	cs_concl
	cs_simp: cat_prod_cs_simps cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	qed
	show
	"cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ArrMap\<rparr>\<lparr>(op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>CId\<rparr>\<lparr>cc'\<rparr>\<rparr> =
	\<DD>\<lparr>CId\<rparr>\<lparr>cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<lparr>ObjMap\<rparr>\<lparr>cc'\<rparr>\<rparr>"
	if "cc' \<in>\<^sub>\<circ> (op_cat \<BB>' \<times>\<^sub>C \<CC>')\<lparr>Obj\<rparr>" for cc'
	proof-
	from that obtain c c'
	where cc'_def: "cc' = [c, c']\<^sub>\<circ>"
	and c: "c \<in>\<^sub>\<circ> op_cat \<BB>'\<lparr>Obj\<rparr>"
	and c': "c' \<in>\<^sub>\<circ> \<CC>'\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[rotated 2])
	(auto intro: cat_cs_intros)
	from assms c c' have [cat_cs_simps]:
	"[\<BB>\<lparr>CId\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>, \<CC>\<lparr>CId\<rparr>\<lparr>\<GG>\<lparr>ObjMap\<rparr>\<lparr>c'\<rparr>\<rparr>]\<^sub>\<circ> =
	(op_cat \<BB> \<times>\<^sub>C \<CC>)\<lparr>CId\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>, \<GG>\<lparr>ObjMap\<rparr>\<lparr>c'\<rparr>\<rparr>\<^sub>\<bullet>"
	unfolding cat_op_simps
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_prod_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	from assms c c' show ?thesis
	unfolding cc'_def cat_op_simps
	by (slow)
	(
	cs_concl
	cs_simp: cat_prod_cs_simps cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	qed
	qed (auto simp: cf_cn_cov_bcomp_components cat_cs_simps intro: cat_cs_intros)

	qed

	lemma cf_cn_cov_bcomp_is_functor'[cat_cs_intros]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<AA>' = op_cat \<BB>' \<times>\<^sub>C \<CC>'"
	shows "cf_cn_cov_bcomp \<SS> \<FF> \<GG> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1-3) unfolding assms(4) by (rule cf_cn_cov_bcomp_is_functor)


	subsubsection\<open>Projection of a contracovariant bifunctor and functors\<close>

	lemma cf_cn_cov_bcomp_bifunctor_proj_snd[cat_cs_simps]:
	assumes "\<FF> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "b \<in>\<^sub>\<circ> \<BB>'\<lparr>Obj\<rparr>"
	shows
	"cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F =
	(\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>"
	proof(rule cf_eqI)
	from assms show [intro]:
	"cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	"(\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG> : \<CC>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	by (cs_concl cs_intro: cat_cs_intros cat_op_intros)+
	from assms have ObjMap_dom_lhs:
	"\<D>\<^sub>\<circ> ((cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>) = \<CC>'\<lparr>Obj\<rparr>"
	and ObjMap_dom_rhs:
	"\<D>\<^sub>\<circ> (((\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>)\<lparr>ObjMap\<rparr>) = \<CC>'\<lparr>Obj\<rparr>"
	and ArrMap_dom_lhs:
	"\<D>\<^sub>\<circ> ((cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>) = \<CC>'\<lparr>Arr\<rparr>"
	and ArrMap_dom_rhs:
	"\<D>\<^sub>\<circ> (((\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>)\<lparr>ArrMap\<rparr>) = \<CC>'\<lparr>Arr\<rparr>"
	by (cs_concl cs_intro: cat_cs_intros cat_op_intros cs_simp: cat_cs_simps)+
	show
	"(cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr> =
	((\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>)\<lparr>ObjMap\<rparr>"
	proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
	fix a assume "a \<in>\<^sub>\<circ> \<CC>'\<lparr>Obj\<rparr>"
	with assms show
	"(cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> =
	((\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
	by
	(
	cs_concl
	cs_simp: cat_prod_cs_simps cat_cs_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	qed (auto intro: is_functor.cf_ObjMap_vsv)
	show
	"(cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr> =
	((\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>)\<lparr>ArrMap\<rparr>"
	proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
	fix f assume "f \<in>\<^sub>\<circ> \<CC>'\<lparr>Arr\<rparr>"
	then obtain a' b' where "f : a' \<mapsto>\<^bsub>\<CC>'\<^esub> b'" by (auto intro: is_arrI)
	with assms show
	"(cf_cn_cov_bcomp \<SS> \<FF> \<GG>\<^bsub>op_cat \<BB>',\<CC>'\<^esub>(b,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
	((\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>"
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
	)
	qed (auto intro: is_functor.cf_ArrMap_vsv)
	qed simp_all



	subsection\<open>Composition of a covariant bifunctor and a covariant functor\<close>


	subsubsection\<open>Definition and elementary properties\<close>

	definition cf_lcomp :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_lcomp \<CC> \<SS> \<FF> = cf_bcomp \<SS> \<FF> (cf_id \<CC>)"

	definition cf_rcomp :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_rcomp \<BB> \<SS> \<GG> = cf_bcomp \<SS> (cf_id \<BB>) \<GG>"


	text\<open>Components.\<close>

	lemma cf_lcomp_components:
	shows "cf_lcomp \<CC> \<SS> \<FF>\<lparr>HomDom\<rparr> = \<FF>\<lparr>HomDom\<rparr> \<times>\<^sub>C \<CC>"
	and "cf_lcomp \<CC> \<SS> \<FF>\<lparr>HomCod\<rparr> = \<SS>\<lparr>HomCod\<rparr>"
	unfolding cf_lcomp_def cf_bcomp_components dghm_id_components by simp_all

	lemma cf_rcomp_components:
	shows "cf_rcomp \<BB> \<SS> \<GG>\<lparr>HomDom\<rparr> = \<BB> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>"
	and "cf_rcomp \<BB> \<SS> \<GG>\<lparr>HomCod\<rparr> = \<SS>\<lparr>HomCod\<rparr>"
	unfolding cf_rcomp_def cf_bcomp_components dghm_id_components by simp_all


	subsubsection\<open>Object map\<close>

	lemma cf_lcomp_ObjMap_vsv: "vsv (cf_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>)"
	unfolding cf_lcomp_def by (rule cf_bcomp_ObjMap_vsv)

	lemma cf_rcomp_ObjMap_vsv: "vsv (cf_rcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>)"
	unfolding cf_rcomp_def by (rule cf_bcomp_ObjMap_vsv)

	lemma cf_lcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	shows "\<D>\<^sub>\<circ> (cf_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>) = (\<AA> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_lcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_rcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<BB>" and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_rcomp \<BB> \<SS> \<GG>\<lparr>ObjMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_rcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_lcomp_ObjMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	shows "cf_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>\<lparr>a, c\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>, c\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_lcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

	lemma cf_rcomp_ObjMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "cf_rcomp \<BB> \<SS> \<GG>\<lparr>ObjMap\<rparr>\<lparr>b, a\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>b, \<GG>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_rcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

	lemma cf_lcomp_ObjMap_vrange:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_lcomp_def
	by (intro cf_bcomp_ObjMap_vrange) (cs_concl cs_intro: cat_cs_intros)+

	lemma cf_rcomp_ObjMap_vrange:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_rcomp \<BB> \<SS> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_rcomp_def
	by (intro cf_bcomp_ObjMap_vrange) (cs_concl cs_intro: cat_cs_intros)+


	subsubsection\<open>Arrow map\<close>

	lemma cf_lcomp_ArrMap_vsv: "vsv (cf_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>)"
	unfolding cf_lcomp_def by (rule cf_bcomp_ArrMap_vsv)

	lemma cf_rcomp_ArrMap_vsv: "vsv (cf_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>)"
	unfolding cf_rcomp_def by (rule cf_bcomp_ArrMap_vsv)

	lemma cf_lcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	shows "\<D>\<^sub>\<circ> (cf_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>) = (\<AA> \<times>\<^sub>C \<CC>)\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_lcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_rcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<BB>" and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_rcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_lcomp_ArrMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "f \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	and "g \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	shows "cf_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f, g\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>, g\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_lcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

	lemma cf_rcomp_ArrMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
	and "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	shows "cf_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>\<lparr>f, g\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>f, \<GG>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_rcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

	lemma cf_lcomp_ArrMap_vrange:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_lcomp_def
	by (intro cf_bcomp_ArrMap_vrange) (cs_concl cs_intro: cat_cs_intros)+

	lemma cf_rcomp_ArrMap_vrange:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_rcomp_def
	by (intro cf_bcomp_ArrMap_vrange) (cs_concl cs_intro: cat_cs_intros)+


	subsubsection\<open>
	Composition of a covariant bifunctor and a covariant functor is a functor
	\<close>

	lemma cf_lcomp_is_functor:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "cf_lcomp \<CC> \<SS> \<FF> : \<AA> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms
	unfolding cf_lcomp_def
	by (cs_concl cs_intro: cat_cs_intros)+

	lemma cf_lcomp_is_functor'[cat_cs_intros]:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<AA>' = \<AA> \<times>\<^sub>C \<CC>"
	shows "cf_lcomp \<CC> \<SS> \<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1-3) unfolding assms(4) by (rule cf_lcomp_is_functor)

	lemma cf_rcomp_is_functor:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "cf_rcomp \<BB> \<SS> \<GG> : \<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms
	unfolding cf_rcomp_def
	by (cs_concl cs_intro: cat_cs_intros)+

	lemma cf_rcomp_is_functor'[cat_cs_intros]:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<AA>' = \<BB> \<times>\<^sub>C \<AA>"
	shows "cf_rcomp \<BB> \<SS> \<GG> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1-3) unfolding assms(4) by (rule cf_rcomp_is_functor)



	subsection\<open>Composition of a contracovariant bifunctor and a covariant functor\<close>

	definition cf_cn_cov_lcomp :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_cn_cov_lcomp \<CC> \<SS> \<FF> = cf_cn_cov_bcomp \<SS> \<FF> (cf_id \<CC>)"

	definition cf_cn_cov_rcomp :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "cf_cn_cov_rcomp \<BB> \<SS> \<GG> = cf_cn_cov_bcomp \<SS> (cf_id \<BB>) \<GG>"


	text\<open>Components.\<close>

	lemma cf_cn_cov_lcomp_components:
	shows "cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>HomDom\<rparr> = op_cat (\<FF>\<lparr>HomDom\<rparr>) \<times>\<^sub>C \<CC>"
	and "cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>HomCod\<rparr> = \<SS>\<lparr>HomCod\<rparr>"
	unfolding cf_cn_cov_lcomp_def cf_cn_cov_bcomp_components dghm_id_components
	by simp_all

	lemma cf_cn_cov_rcomp_components:
	shows "cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>HomDom\<rparr> = op_cat \<BB> \<times>\<^sub>C \<GG>\<lparr>HomDom\<rparr>"
	and "cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>HomCod\<rparr> = \<SS>\<lparr>HomCod\<rparr>"
	unfolding cf_cn_cov_rcomp_def cf_cn_cov_bcomp_components dghm_id_components
	by simp_all


	subsubsection\<open>Object map\<close>

	lemma cf_cn_cov_lcomp_ObjMap_vsv: "vsv (cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>)"
	unfolding cf_cn_cov_lcomp_def by (rule cf_cn_cov_bcomp_ObjMap_vsv)

	lemma cf_cn_cov_rcomp_ObjMap_vsv: "vsv (cf_cn_cov_rcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>)"
	unfolding cf_cn_cov_rcomp_def by (rule cf_cn_cov_bcomp_ObjMap_vsv)

	lemma cf_cn_cov_lcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	shows "\<D>\<^sub>\<circ> (cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>) = (op_cat \<AA> \<times>\<^sub>C \<CC>)\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_cn_cov_lcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_cn_cov_rcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<BB>" and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>ObjMap\<rparr>) = (op_cat \<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_cn_cov_rcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_cn_cov_lcomp_ObjMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "a \<in>\<^sub>\<circ> op_cat \<AA>\<lparr>Obj\<rparr>"
	and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	shows "cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>\<lparr>a, c\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>, c\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_cn_cov_lcomp_def cat_op_simps
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)

	lemma cf_cn_cov_rcomp_ObjMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> op_cat \<BB>\<lparr>Obj\<rparr>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>ObjMap\<rparr>\<lparr>b, a\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ObjMap\<rparr>\<lparr>b, \<GG>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_cn_cov_rcomp_def cat_op_simps
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)

	lemma cf_cn_cov_lcomp_ObjMap_vrange:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_cn_cov_lcomp_def
	by (intro cf_cn_cov_bcomp_ObjMap_vrange)
	(cs_concl cs_intro: cat_cs_intros)+

	lemma cf_cn_cov_rcomp_ObjMap_vrange:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Obj\<rparr>"
	using assms
	unfolding cf_cn_cov_rcomp_def
	by (intro cf_cn_cov_bcomp_ObjMap_vrange)
	(cs_concl cs_intro: cat_cs_intros)+


	subsubsection\<open>Arrow map\<close>

	lemma cf_cn_cov_lcomp_ArrMap_vsv: "vsv (cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>)"
	unfolding cf_cn_cov_lcomp_def by (rule cf_cn_cov_bcomp_ArrMap_vsv)

	lemma cf_cn_cov_rcomp_ArrMap_vsv: "vsv (cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>)"
	unfolding cf_cn_cov_rcomp_def by (rule cf_cn_cov_bcomp_ArrMap_vsv)

	lemma cf_cn_cov_lcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	shows "\<D>\<^sub>\<circ> (cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>) = (op_cat \<AA> \<times>\<^sub>C \<CC>)\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_cn_cov_lcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_cn_cov_rcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<BB>" and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>) = (op_cat \<BB> \<times>\<^sub>C \<AA>)\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_cn_cov_rcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_cn_cov_lcomp_ArrMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "f \<in>\<^sub>\<circ> op_cat \<AA>\<lparr>Arr\<rparr>"
	and "g \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	shows "cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f, g\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>, g\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_cn_cov_lcomp_def cat_op_simps
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)

	lemma cf_cn_cov_rcomp_ArrMap_app[cat_cs_simps]:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "f \<in>\<^sub>\<circ> op_cat \<BB>\<lparr>Arr\<rparr>"
	and "g \<in>\<^sub>\<circ> \<AA>\<lparr>Arr\<rparr>"
	shows "cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>\<lparr>f, g\<rparr>\<^sub>\<bullet> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>f, \<GG>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding cf_cn_cov_rcomp_def cat_op_simps
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_op_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)

	lemma cf_cn_cov_lcomp_ArrMap_vrange:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_cn_cov_lcomp_def
	by (intro cf_cn_cov_bcomp_ArrMap_vrange)
	(cs_concl cs_intro: cat_cs_intros)+

	lemma cf_cn_cov_rcomp_ArrMap_vrange:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "\<R>\<^sub>\<circ> (cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<DD>\<lparr>Arr\<rparr>"
	using assms
	unfolding cf_cn_cov_rcomp_def cat_op_simps
	by (intro cf_cn_cov_bcomp_ArrMap_vrange)
	(cs_concl cs_intro: cat_cs_intros)+


	subsubsection\<open>
	Composition of a contracovariant bifunctor and a covariant functor is a functor
	\<close>

	lemma cf_cn_cov_lcomp_is_functor:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "cf_cn_cov_lcomp \<CC> \<SS> \<FF> : op_cat \<AA> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms
	unfolding cf_cn_cov_lcomp_def cat_op_simps
	by (cs_concl cs_intro: cat_cs_intros)+

	lemma cf_cn_cov_lcomp_is_functor'[cat_cs_intros]:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<AA>\<CC> = op_cat \<AA> \<times>\<^sub>C \<CC>"
	shows "cf_cn_cov_lcomp \<CC> \<SS> \<FF> : \<AA>\<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1-3) unfolding assms(4) by (rule cf_cn_cov_lcomp_is_functor)

	lemma cf_cn_cov_rcomp_is_functor:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	shows "cf_cn_cov_rcomp \<BB> \<SS> \<GG> : op_cat \<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms
	unfolding cf_cn_cov_rcomp_def cat_op_simps
	by (cs_concl cs_intro: cat_cs_intros)+

	lemma cf_cn_cov_rcomp_is_functor'[cat_cs_intros]:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "\<BB>\<AA> = op_cat \<BB> \<times>\<^sub>C \<AA>"
	shows "cf_cn_cov_rcomp \<BB> \<SS> \<GG> : \<BB>\<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	using assms(1-3) unfolding assms(4) by (rule cf_cn_cov_rcomp_is_functor)


	subsubsection\<open>
	Projection of a composition of a contracovariant bifunctor and a covariant
	functor
	\<close>

	lemma cf_cn_cov_rcomp_bifunctor_proj_snd[cat_cs_simps]:
	assumes "category \<alpha> \<BB>"
	and "\<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows
	"cf_cn_cov_rcomp \<BB> \<SS> \<GG>\<^bsub>op_cat \<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F =
	(\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(b,-)\<^sub>C\<^sub>F) \<circ>\<^sub>C\<^sub>F \<GG>"
	using assms
	unfolding cf_cn_cov_rcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

	lemma cf_cn_cov_lcomp_bifunctor_proj_snd[cat_cs_simps]:
	assumes "category \<alpha> \<CC>"
	and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
	and "\<SS> : op_cat \<BB> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
	and "b \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows
	"cf_cn_cov_lcomp \<CC> \<SS> \<FF>\<^bsub>op_cat \<AA>,\<CC>\<^esub>(b,-)\<^sub>C\<^sub>F =
	(\<SS>\<^bsub>op_cat \<BB>,\<CC>\<^esub>(\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>,-)\<^sub>C\<^sub>F)"
	using assms
	unfolding cf_cn_cov_lcomp_def
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros)



	subsection\<open>Composition of bifunctors\<close>


	subsubsection\<open>Definitions and elementary properties\<close>

	definition cf_blcomp :: "V \<Rightarrow> V"
	where "cf_blcomp \<SS> =
	cf_lcomp (\<SS>\<lparr>HomCod\<rparr>) \<SS> \<SS> \<circ>\<^sub>C\<^sub>F
	cf_cat_prod_21_of_3 (\<SS>\<lparr>HomCod\<rparr>) (\<SS>\<lparr>HomCod\<rparr>) (\<SS>\<lparr>HomCod\<rparr>)"

	definition cf_brcomp :: "V \<Rightarrow> V"
	where "cf_brcomp \<SS> =
	cf_rcomp (\<SS>\<lparr>HomCod\<rparr>) \<SS> \<SS> \<circ>\<^sub>C\<^sub>F
	cf_cat_prod_12_of_3 (\<SS>\<lparr>HomCod\<rparr>) (\<SS>\<lparr>HomCod\<rparr>) (\<SS>\<lparr>HomCod\<rparr>)"


	text\<open>Alternative forms of the definitions.\<close>

	lemma cf_blcomp_def':
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "cf_blcomp \<SS> = cf_lcomp \<CC> \<SS> \<SS> \<circ>\<^sub>C\<^sub>F cf_cat_prod_21_of_3 \<CC> \<CC> \<CC>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	show ?thesis
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cf_blcomp_def cs_intro: cat_cs_intros
	)
	qed

	lemma cf_brcomp_def':
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "cf_brcomp \<SS> = cf_rcomp \<CC> \<SS> \<SS> \<circ>\<^sub>C\<^sub>F cf_cat_prod_12_of_3 \<CC> \<CC> \<CC>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	show ?thesis
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cf_brcomp_def cs_intro: cat_cs_intros
	)
	qed


	subsubsection\<open>Compositions of bifunctors are functors\<close>

	lemma cf_blcomp_is_functor:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "cf_blcomp \<SS> : \<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	show ?thesis
	by (cs_concl cs_simp: cat_cs_simps cf_blcomp_def' cs_intro: cat_cs_intros)
	qed

	lemma cf_blcomp_is_functor'[cat_cs_intros]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<AA>' = \<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>"
	shows "cf_blcomp \<SS> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	using assms(1) unfolding assms(2) by (rule cf_blcomp_is_functor)

	lemma cf_brcomp_is_functor:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "cf_brcomp \<SS> : \<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	show ?thesis
	by (cs_concl cs_simp: cat_cs_simps cf_brcomp_def' cs_intro: cat_cs_intros)
	qed

	lemma cf_brcomp_is_functor'[cat_cs_intros]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<AA>' = \<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>"
	shows "cf_brcomp \<SS> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	using assms(1) unfolding assms(2) by (rule cf_brcomp_is_functor)


	subsubsection\<open>Object map\<close>

	lemma cf_blcomp_ObjMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "vsv (cf_blcomp \<SS>\<lparr>ObjMap\<rparr>)"
	proof-
	interpret cf_blcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_blcomp \<SS>\<close>
	by (rule cf_blcomp_is_functor[OF assms])
	show ?thesis by auto
	qed

	lemma cf_brcomp_ObjMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "vsv (cf_brcomp \<SS>\<lparr>ObjMap\<rparr>)"
	proof-
	interpret cf_brcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_brcomp \<SS>\<close>
	by (rule cf_brcomp_is_functor[OF assms])
	show ?thesis by auto
	qed

	lemma cf_blcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_blcomp \<SS>\<lparr>ObjMap\<rparr>) = (\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_blcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_blcomp \<SS>\<close>
	by (rule cf_blcomp_is_functor[OF assms])
	show ?thesis
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	qed

	lemma cf_brcomp_ObjMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_brcomp \<SS>\<lparr>ObjMap\<rparr>) = (\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Obj\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_brcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_brcomp \<SS>\<close>
	by (rule cf_brcomp_is_functor[OF assms])
	show ?thesis
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	qed

	lemma cf_blcomp_ObjMap_app[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "A = [a, b, c]\<^sub>\<circ>"
	and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	shows "cf_blcomp \<SS>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> = (a \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>O\<^bsub>\<SS>\<^esub> b) \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>O\<^bsub>\<SS>\<^esub> c"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_blcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_blcomp \<SS>\<close>
	by (rule cf_blcomp_is_functor[OF assms(1)])
	from assms(3-5) show ?thesis
	unfolding assms(2)
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps cf_blcomp_def'
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed

	lemma cf_brcomp_ObjMap_app[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "A = [a, b, c]\<^sub>\<circ>"
	and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
	shows "cf_brcomp \<SS>\<lparr>ObjMap\<rparr>\<lparr>A\<rparr> = a \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>O\<^bsub>\<SS>\<^esub> (b \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>O\<^bsub>\<SS>\<^esub> c)"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_brcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_brcomp \<SS>\<close>
	by (rule cf_brcomp_is_functor[OF assms(1)])
	from assms(3-5) show ?thesis
	unfolding assms(2)
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps cf_brcomp_def'
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed


	subsubsection\<open>Arrow map\<close>

	lemma cf_blcomp_ArrMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "vsv (cf_blcomp \<SS>\<lparr>ArrMap\<rparr>)"
	proof-
	interpret cf_blcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_blcomp \<SS>\<close>
	by (rule cf_blcomp_is_functor[OF assms])
	show ?thesis by auto
	qed

	lemma cf_brcomp_ArrMap_vsv[cat_cs_intros]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "vsv (cf_brcomp \<SS>\<lparr>ArrMap\<rparr>)"
	proof-
	interpret cf_brcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_brcomp \<SS>\<close>
	by (rule cf_brcomp_is_functor[OF assms])
	show ?thesis by auto
	qed

	lemma cf_blcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_blcomp \<SS>\<lparr>ArrMap\<rparr>) = (\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_blcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_blcomp \<SS>\<close>
	by (rule cf_blcomp_is_functor[OF assms])
	show ?thesis
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	qed

	lemma cf_brcomp_ArrMap_vdomain[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (cf_brcomp \<SS>\<lparr>ArrMap\<rparr>) = (\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>)\<lparr>Arr\<rparr>"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_brcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_brcomp \<SS>\<close>
	by (rule cf_brcomp_is_functor[OF assms])
	show ?thesis
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	qed

	lemma cf_blcomp_ArrMap_app[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "F = [h, g, f]\<^sub>\<circ>"
	and "h \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	and "g \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	and "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	shows "cf_blcomp \<SS>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr> = (h \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>A\<^bsub>\<SS>\<^esub> g) \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>A\<^bsub>\<SS>\<^esub> f"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_blcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_blcomp \<SS>\<close>
	by (rule cf_blcomp_is_functor[OF assms(1)])
	from assms(3-5) show ?thesis
	unfolding assms(2)
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps cf_blcomp_def'
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed

	lemma cf_brcomp_ArrMap_app[cat_cs_simps]:
	assumes "\<SS> : \<CC> \<times>\<^sub>C \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "F = [h, g, f]\<^sub>\<circ>"
	and "h \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	and "g \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	and "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	shows "cf_brcomp \<SS>\<lparr>ArrMap\<rparr>\<lparr>F\<rparr> = h \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>A\<^bsub>\<SS>\<^esub> (g \<otimes>\<^sub>H\<^sub>M\<^sub>.\<^sub>A\<^bsub>\<SS>\<^esub> f)"
	proof-
	interpret \<SS>: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C \<CC>\<close> \<CC> \<SS> by (rule assms)
	interpret cf_brcomp: is_functor \<alpha> \<open>\<CC> \<times>\<^sub>C\<^sub>3 \<CC> \<times>\<^sub>C\<^sub>3 \<CC>\<close> \<CC> \<open>cf_brcomp \<SS>\<close>
	by (rule cf_brcomp_is_functor[OF assms(1)])
	from assms(3-5) show ?thesis
	unfolding assms(2)
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cat_prod_cs_simps cf_brcomp_def'
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed



	subsection\<open>Binatural transformation\<close>


	subsubsection\<open>Definitions and elementary properties\<close>

	text\<open>
	In this work, a \<open>binatural transformation\<close> is used to denote a natural
	transformation of bifunctors.
	\<close>

	definition bnt_proj_fst :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	(\<open>(_\<^bsub>_,_\<^esub>/'(/-,_/')/\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<close> [51, 51, 51, 51] 51)
	where "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F =
	[
	(\<lambda>a\<in>\<^sub>\<circ>\<AA>\<lparr>Obj\<rparr>. \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>),
	\<NN>\<lparr>NTDom\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F,
	\<NN>\<lparr>NTCod\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F,
	\<AA>,
	\<NN>\<lparr>NTDGCod\<rparr>
	]\<^sub>\<circ>"

	definition bnt_proj_snd :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	(\<open>(_\<^bsub>_,_\<^esub>/'(/_,-/')/\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<close> [51, 51, 51, 51] 51)
	where "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F =
	[
	(\<lambda>b\<in>\<^sub>\<circ>\<BB>\<lparr>Obj\<rparr>. \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>),
	\<NN>\<lparr>NTDom\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F,
	\<NN>\<lparr>NTCod\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F,
	\<BB>,
	\<NN>\<lparr>NTDGCod\<rparr>
	]\<^sub>\<circ>"


	text\<open>Components\<close>

	lemma bnt_proj_fst_components:
	shows "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr> = (\<lambda>a\<in>\<^sub>\<circ>\<AA>\<lparr>Obj\<rparr>. \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>)"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTDom\<rparr> = \<NN>\<lparr>NTDom\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTCod\<rparr> = \<NN>\<lparr>NTCod\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTDGDom\<rparr> = \<AA>"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTDGCod\<rparr> = \<NN>\<lparr>NTDGCod\<rparr>"
	unfolding bnt_proj_fst_def nt_field_simps by (simp_all add: nat_omega_simps)

	lemma bnt_proj_snd_components:
	shows "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr> = (\<lambda>b\<in>\<^sub>\<circ>\<BB>\<lparr>Obj\<rparr>. \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>)"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTDom\<rparr> = \<NN>\<lparr>NTDom\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTCod\<rparr> = \<NN>\<lparr>NTCod\<rparr>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTDGDom\<rparr> = \<BB>"
	and "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTDGCod\<rparr> = \<NN>\<lparr>NTDGCod\<rparr>"
	unfolding bnt_proj_snd_def nt_field_simps by (simp_all add: nat_omega_simps)


	subsubsection\<open>Natural transformation maps\<close>

	mk_VLambda bnt_proj_fst_components(1)[folded VLambda_vconst_on]
	\|vsv bnt_proj_fst_NTMap_vsv[cat_cs_intros]\|
	\|vdomain bnt_proj_fst_NTMap_vdomain[cat_cs_simps]\|
	\|app bnt_proj_fst_NTMap_app[cat_cs_simps]\|

	lemma bnt_proj_fst_vrange:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "\<R>\<^sub>\<circ> ((\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	proof-
	interpret \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule assms(3))
	show ?thesis
	unfolding bnt_proj_fst_components
	proof(rule vrange_VLambda_vsubset)
	fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	with assms show "\<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_prod_cs_intros)
	qed
	qed

	mk_VLambda bnt_proj_snd_components(1)[folded VLambda_vconst_on]
	\|vsv bnt_proj_snd_NTMap_vsv[intro]\|
	\|vdomain bnt_proj_snd_NTMap_vdomain[cat_cs_simps]\|
	\|app bnt_proj_snd_NTMap_app[cat_cs_simps]\|

	lemma bnt_proj_snd_vrange:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "\<R>\<^sub>\<circ> ((\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	proof-
	interpret \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule assms(3))
	show ?thesis
	unfolding bnt_proj_snd_components
	proof(rule vrange_VLambda_vsubset)
	fix b assume "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	with assms show "\<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_prod_cs_intros)
	qed
	qed


	subsubsection\<open>Binatural transformation projection is a natural transformation\<close>

	lemma bnt_proj_snd_is_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-
	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule assms(3))
	show ?thesis
	proof(intro is_ntcfI')
	show "vfsequence (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)" unfolding bnt_proj_snd_def by simp
	show "vcard (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F) = 5\<^sub>\<nat>"
	unfolding bnt_proj_snd_def by (simp add: nat_omega_simps)
	from assms show "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	from assms show "\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	show "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>b\<rparr> :
	(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>b\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> (\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
	if "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" for b
	using that assms
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	show "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
	(\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>a'\<rparr>"
	if "f : a' \<mapsto>\<^bsub>\<BB>\<^esub> b" for a' b f
	using that assms
	by
	(
	cs_concl
	cs_simp: is_ntcf.ntcf_Comp_commute cat_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed (auto simp: bnt_proj_snd_components cat_cs_simps)
	qed

	lemma bnt_proj_snd_is_ntcf'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and "\<FF> = \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F"
	and "\<GG> = \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<FF> \<mapsto>\<^sub>C\<^sub>F \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	using assms by (auto intro: bnt_proj_snd_is_ntcf)

	lemma bnt_proj_fst_is_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-
	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule assms(3))
	show ?thesis
	proof(intro is_ntcfI')
	show "vfsequence (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)" unfolding bnt_proj_fst_def by simp
	show "vcard (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F) = 5\<^sub>\<nat>"
	unfolding bnt_proj_fst_def by (simp add: nat_omega_simps)
	from assms show "\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)
	from assms show "\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)
	show "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
	(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> (\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
	if "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" for a
	using that assms
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	show "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>b'\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
	(\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
	if "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b'" for a b' f
	using that assms
	by
	(
	cs_concl
	cs_simp: is_ntcf.ntcf_Comp_commute cat_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed (auto simp: bnt_proj_fst_components cat_cs_simps)
	qed

	lemma bnt_proj_fst_is_ntcf'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and "\<FF> = \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F"
	and "\<GG> = \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F"
	and "\<AA>' = \<AA>"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<FF> \<mapsto>\<^sub>C\<^sub>F \<GG> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	using assms(1-4) unfolding assms(5-7) by (rule bnt_proj_fst_is_ntcf)


	subsubsection\<open>Array binatural transformation is a natural transformation\<close>

	lemma ntcf_array_is_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<SS> : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "vfsequence \<NN>"
	and "vcard \<NN> = 5\<^sub>\<nat>"
	and "\<NN>\<lparr>NTDom\<rparr> = \<SS>"
	and "\<NN>\<lparr>NTCod\<rparr> = \<SS>'"
	and "\<NN>\<lparr>NTDGDom\<rparr> = \<AA> \<times>\<^sub>C \<BB>"
	and "\<NN>\<lparr>NTDGCod\<rparr> = \<CC>"
	and "vsv (\<NN>\<lparr>NTMap\<rparr>)"
	and "\<D>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) = (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	and "\<And>a b. \<lbrakk> a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow>
	\<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> : \<SS>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> \<mapsto>\<^bsub>\<CC>\<^esub> \<SS>'\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	and "\<And>a. a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr> \<Longrightarrow>
	\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<And>b. b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow>
	\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-

	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<NN>: vsv \<open>\<NN>\<lparr>NTMap\<rparr>\<close> by (rule assms(11))

	have [cat_cs_intros]:
	"\<lbrakk> a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>; A = \<SS>\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>; B = \<SS>'\<lparr>ObjMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> \<rbrakk> \<Longrightarrow>
	\<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> : A \<mapsto>\<^bsub>\<CC>\<^esub> B"
	for a b A B
	by (auto intro: assms(13))

	show ?thesis
	proof(intro is_ntcfI')

	show "\<NN>\<lparr>NTMap\<rparr>\<lparr>ab\<rparr> : \<SS>\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> \<SS>'\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr>"
	if "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>" for ab
	proof-
	from that obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>" and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(1,2)])
	from a b show ?thesis unfolding ab_def by (rule assms(13))
	qed

	show
	"\<NN>\<lparr>NTMap\<rparr>\<lparr>a'b'\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> = \<SS>'\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>ab\<rparr>"
	if "gf : ab \<mapsto>\<^bsub>\<AA> \<times>\<^sub>C \<BB>\<^esub> a'b'" for ab a'b' gf
	proof-
	from that obtain g f a b a' b'
	where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a'b'_def: "a'b' = [a', b']\<^sub>\<circ>"
	and g: "g : a \<mapsto>\<^bsub>\<AA>\<^esub> a'"
	and f: "f : b \<mapsto>\<^bsub>\<BB>\<^esub> b'"
	by (elim cat_prod_2_is_arrE[OF assms(1,2)])
	then have a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and a': "a' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and b': "b' \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by auto
	show ?thesis
	unfolding gf_def ab_def a'b'_def
	proof-
	from is_ntcfD'(13)[OF assms(15)[OF b] g] g f assms(1,2,3,4)
	have [cat_cs_simps]:
	"(\<SS>'\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>) =
	(\<NN>\<lparr>NTMap\<rparr>\<lparr>a', b\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>)"
	by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros) auto
	from is_ntcfD'(13)[OF assms(14)[OF a'] f] g f assms(1,2)
	have \<SS>'\<NN>:
	"\<SS>'\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>a', b\<rparr>\<^sub>\<bullet> =
	\<NN>\<lparr>NTMap\<rparr>\<lparr>a', b'\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>,f\<rparr>\<^sub>\<bullet>"
	by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros) auto
	from g f assms(1-4) have [cat_cs_simps]:
	"\<SS>'\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (\<NN>\<lparr>NTMap\<rparr>\<lparr>a', b\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> q) =
	\<NN>\<lparr>NTMap\<rparr>\<lparr>a', b'\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>,f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> q)"
	if "q : r \<mapsto>\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ObjMap\<rparr>\<lparr>a', b\<rparr>\<^sub>\<bullet>" for q r
	using that
	by
	(
	cs_concl
	cs_simp: \<SS>'\<NN> category.cat_Comp_assoc[symmetric]
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)

	from assms(1-4) g f have
	"\<SS>'\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>'\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet> =
	\<SS>'\<lparr>ArrMap\<rparr>\<lparr>[\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>\<AA> \<times>\<^sub>C \<BB>\<^esub> [g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>]\<^sub>\<circ>\<rparr>"
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	also from assms(1-4) g f have "\<dots> = \<SS>'\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet>"
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	finally have \<SS>'_gf: "\<SS>'\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> =
	\<SS>'\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>'\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	by simp
	from assms(1-4) g f have
	"\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet> =
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>[\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>\<AA> \<times>\<^sub>C \<BB>\<^esub> [g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>]\<^sub>\<circ>\<rparr>"
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	also from assms(1-4) g f have "\<dots> = \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet>"
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_prod_cs_simps
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	finally have \<SS>_gf: "\<SS>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> =
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	by simp
	from assms(1-4) g f assms(13)[OF a b] assms(13)[OF a' b] have
	"\<SS>'\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> =
	(\<SS>'\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>a', b\<rparr>\<^sub>\<bullet>) \<circ>\<^sub>A\<^bsub>\<CC>\<^esub>
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	unfolding \<SS>'_gf
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	also from assms(1-4) g f have
	"\<dots> = (\<NN>\<lparr>NTMap\<rparr>\<lparr>a', b'\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>,f\<rparr>\<^sub>\<bullet>) \<circ>\<^sub>A\<^bsub>\<CC>\<^esub>
	\<SS>\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>"
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	also from assms(1-4) g f assms(13)[OF a' b'] have
	"\<dots> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a', b'\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub>
	(\<SS>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>a'\<rparr>,f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, \<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>\<rparr>\<^sub>\<bullet>)"
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	also from assms(1-4) g f assms(13)[OF a' b'] have
	"\<dots> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a', b'\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet>"
	unfolding \<SS>_gf[symmetric] by simp
	finally show
	"\<NN>\<lparr>NTMap\<rparr>\<lparr>a', b'\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<SS>\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> =
	\<SS>'\<lparr>ArrMap\<rparr>\<lparr>g, f\<rparr>\<^sub>\<bullet> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	by simp
	qed
	qed

	qed (auto simp: assms)

	qed


	subsubsection\<open>Binatural transformation projections and isomorphisms\<close>

	lemma is_iso_ntcf_if_bnt_proj_snd_is_iso_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<And>a. a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr> \<Longrightarrow>
	\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-
	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	show ?thesis
	proof(intro is_iso_ntcfI)
	show "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" by (rule assms(3))
	fix ab assume "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>" and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(1,2)])
	interpret \<NN>a: is_iso_ntcf
	\<alpha> \<BB> \<CC> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F\<close> \<open>\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F\<close> \<open>\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F\<close>
	by (rule assms(4)[OF a])
	from b have \<NN>ab: "\<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> = (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>b\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	from \<NN>a.iso_ntcf_is_arr_isomorphism[OF b] assms(1,2,3) a b show
	"\<NN>\<lparr>NTMap\<rparr>\<lparr>ab\<rparr> : \<SS>\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> \<SS>'\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr>"
	by
	(
	cs_prems cs_shallow
	cs_simp: cat_cs_simps ab_def cs_intro: cat_prod_cs_intros
	)
	qed
	qed

	lemma is_iso_ntcf_if_bnt_proj_fst_is_iso_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<And>b. b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow>
	\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-
	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	show ?thesis
	proof(intro is_iso_ntcfI)
	show "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" by (rule assms(3))
	fix ab assume "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>" and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(1,2)])
	interpret \<NN>a: is_iso_ntcf
	\<alpha> \<AA> \<CC> \<open>\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F\<close> \<open>\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F\<close> \<open>\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F\<close>
	by (rule assms(4)[OF b])
	from b have \<NN>ab: "\<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet> = (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>b\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	from \<NN>a.iso_ntcf_is_arr_isomorphism[OF a] assms(1,2,3) a b show
	"\<NN>\<lparr>NTMap\<rparr>\<lparr>ab\<rparr> : \<SS>\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> \<SS>'\<lparr>ObjMap\<rparr>\<lparr>ab\<rparr>"
	unfolding ab_def
	by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros)
	qed
	qed

	lemma bnt_proj_snd_is_iso_ntcf_if_is_iso_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F :
	\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof(intro is_iso_ntcfI)
	from assms show "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F :
	\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_intro: cat_cs_intros ntcf_cs_intros)
	show "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>b\<rparr> :
	(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>b\<rparr> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> (\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
	if "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" for b
	using assms that
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros cat_arrow_cs_intros
	)
	qed

	lemma bnt_proj_snd_is_iso_ntcf_if_is_iso_ntcf'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<FF> = \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F"
	and "\<GG> = \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>C\<^sub>F"
	and "\<BB>' = \<BB>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<FF> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<GG> : \<BB>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	unfolding assms(4-6)
	by (rule bnt_proj_snd_is_iso_ntcf_if_is_iso_ntcf[OF assms(1-3,7)])

	lemma bnt_proj_fst_is_iso_ntcf_if_is_iso_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F :
	\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof(intro is_iso_ntcfI)
	from assms show "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F :
	\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_intro: cat_cs_intros ntcf_cs_intros)
	show "(\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
	(\<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> (\<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
	if "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" for a
	using assms that
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps
	cs_intro: cat_prod_cs_intros cat_arrow_cs_intros
	)
	qed

	lemma bnt_proj_fst_is_iso_ntcf_if_is_iso_ntcf'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<FF> = \<SS>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F"
	and "\<GG> = \<SS>'\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>C\<^sub>F"
	and "\<AA>' = \<AA>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F : \<FF> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<GG> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	unfolding assms(4-6)
	by (rule bnt_proj_fst_is_iso_ntcf_if_is_iso_ntcf[OF assms(1-3,7)])



	subsection\<open>Binatural transformation flip\<close>


	subsubsection\<open>Definition and elementary properties\<close>

	definition bnt_flip :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
	where "bnt_flip \<AA> \<BB> \<NN> =
	[
	fflip (\<NN>\<lparr>NTMap\<rparr>),
	bifunctor_flip \<AA> \<BB> (\<NN>\<lparr>NTDom\<rparr>),
	bifunctor_flip \<AA> \<BB> (\<NN>\<lparr>NTCod\<rparr>),
	\<BB> \<times>\<^sub>C \<AA>,
	\<NN>\<lparr>NTDGCod\<rparr>
	]\<^sub>\<circ>"


	text\<open>Components.\<close>

	lemma bnt_flip_components:
	shows "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr> = fflip (\<NN>\<lparr>NTMap\<rparr>)"
	and "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTDom\<rparr> = bifunctor_flip \<AA> \<BB> (\<NN>\<lparr>NTDom\<rparr>)"
	and "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTCod\<rparr> = bifunctor_flip \<AA> \<BB> (\<NN>\<lparr>NTCod\<rparr>)"
	and "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTDGDom\<rparr> = \<BB> \<times>\<^sub>C \<AA>"
	and "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTDGCod\<rparr> = \<NN>\<lparr>NTDGCod\<rparr>"
	unfolding bnt_flip_def nt_field_simps by (simp_all add: nat_omega_simps)

	context
	fixes \<alpha> \<AA> \<BB> \<CC> \<SS> \<SS>' \<NN>
	assumes \<NN>: "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	begin

	interpretation \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule \<NN>)

	lemmas bnt_flip_components' =
	bnt_flip_components[where \<AA>=\<AA> and \<BB>=\<BB> and \<NN>=\<NN>, unfolded cat_cs_simps]

	lemmas [cat_cs_simps] = bnt_flip_components'(2-5)

	end


	subsubsection\<open>Natural transformation map\<close>

	lemma bnt_flip_NTMap_vsv[cat_cs_intros]: "vsv (bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>)"
	unfolding bnt_flip_components by (rule fflip_vsv)

	lemma bnt_flip_NTMap_app:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>\<lparr>b, a\<rparr>\<^sub>\<bullet> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	using assms
	unfolding bnt_flip_components
	by
	(
	cs_concl cs_shallow
	cs_simp: V_cs_simps cat_cs_simps cs_intro: cat_prod_cs_intros
	)

	lemma bnt_flip_NTMap_app'[cat_cs_simps]:
	assumes "ba = [b, a]\<^sub>\<circ>"
	and "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>\<lparr>ba\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
	using assms(2-6) unfolding assms(1) by (rule bnt_flip_NTMap_app)

	lemma bnt_flip_NTMap_vdomain[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<D>\<^sub>\<circ> (bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>) = (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	using assms
	unfolding bnt_flip_components
	by (cs_concl cs_shallow cs_simp: V_cs_simps cat_cs_simps)

	lemma bnt_flip_NTMap_vrange[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "\<R>\<^sub>\<circ> (bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>) = \<R>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>)"
	proof-

	interpret \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule assms(3))

	show ?thesis
	proof(intro vsubset_antisym)

	show "\<R>\<^sub>\<circ> (bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>)"
	proof
	(
	intro vsv.vsv_vrange_vsubset,
	unfold bnt_flip_NTMap_vdomain[OF assms]
	)
	fix ba assume "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(2,1)])
	from \<NN>.ntcf_NTMap_vsv assms a b show
	"bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>\<lparr>ba\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>)"
	unfolding ba_def
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps cs_intro: V_cs_intros cat_prod_cs_intros
	)
	qed (cs_concl cs_shallow cs_intro: cat_cs_intros)

	show "\<R>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>)"
	proof(intro vsv.vsv_vrange_vsubset, unfold \<NN>.ntcf_NTMap_vdomain)
	fix ab assume prems: "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[OF assms(1,2)])
	from assms a b have ba: "[b, a]\<^sub>\<circ> \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
	from assms bnt_flip_NTMap_vsv prems a b ba show
	"\<NN>\<lparr>NTMap\<rparr>\<lparr>ab\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>)"
	unfolding ab_def
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: V_cs_intros)
	qed auto

	qed

	qed


	subsubsection\<open>Binatural transformation flip natural transformation map\<close>

	lemma bnt_flip_NTMap_is_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "bnt_flip \<AA> \<BB> \<NN> :
	bifunctor_flip \<AA> \<BB> \<SS> \<mapsto>\<^sub>C\<^sub>F bifunctor_flip \<AA> \<BB> \<SS>' :
	\<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof-

	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))

	interpret \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule assms(3))

	show ?thesis
	proof(intro is_ntcfI')
	show "vfsequence (bnt_flip \<AA> \<BB> \<NN>)" unfolding bnt_flip_def by simp
	show "vcard (bnt_flip \<AA> \<BB> \<NN>) = 5\<^sub>\<nat>"
	unfolding bnt_flip_def by (simp add: nat_omega_simps)
	show "bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>\<lparr>ba\<rparr> :
	bifunctor_flip \<AA> \<BB> \<SS>\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub>
	bifunctor_flip \<AA> \<BB> \<SS>'\<lparr>ObjMap\<rparr>\<lparr>ba\<rparr>"
	if "ba \<in>\<^sub>\<circ> (\<BB> \<times>\<^sub>C \<AA>)\<lparr>Obj\<rparr>" for ba
	proof-
	from that obtain b a
	where ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
	from assms a b show ?thesis
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps ba_def
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed
	show
	"bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>\<lparr>b'a'\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> bifunctor_flip \<AA> \<BB> \<SS>\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> =
	bifunctor_flip \<AA> \<BB> \<SS>'\<lparr>ArrMap\<rparr>\<lparr>gf\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> bnt_flip \<AA> \<BB> \<NN>\<lparr>NTMap\<rparr>\<lparr>ba\<rparr>"
	if "gf : ba \<mapsto>\<^bsub>\<BB> \<times>\<^sub>C \<AA>\<^esub> b'a'" for ba b'a' gf
	proof-
	from that obtain g f a b a' b'
	where gf_def: "gf = [g, f]\<^sub>\<circ>"
	and ba_def: "ba = [b, a]\<^sub>\<circ>"
	and b'a'_def: "b'a' = [b', a']\<^sub>\<circ>"
	and g: "g : b \<mapsto>\<^bsub>\<BB>\<^esub> b'"
	and f: "f : a \<mapsto>\<^bsub>\<AA>\<^esub> a'"
	by (elim cat_prod_2_is_arrE[OF assms(2,1)])
	from assms g f show ?thesis
	unfolding gf_def ba_def b'a'_def
	by
	(
	cs_concl
	cs_simp: cat_cs_simps cat_cs_simps \<NN>.ntcf_Comp_commute
	cs_intro: cat_cs_intros cat_prod_cs_intros
	)
	qed

	qed
	(
	use assms in
	\<open>cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros\<close>
	)+

	qed

	lemma bnt_flip_NTMap_is_ntcf'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<T> = bifunctor_flip \<AA> \<BB> \<SS>"
	and "\<T>' = bifunctor_flip \<AA> \<BB> \<SS>'"
	and "\<DD> = \<BB> \<times>\<^sub>C \<AA>"
	shows "bnt_flip \<AA> \<BB> \<NN> : \<T> \<mapsto>\<^sub>C\<^sub>F \<T>' : \<DD> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	using assms(1-3) unfolding assms(4-6) by (intro bnt_flip_NTMap_is_ntcf)


	subsubsection\<open>Double-flip of a binatural transformation\<close>

	lemma bnt_flip_flip[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "bnt_flip \<BB> \<AA> (bnt_flip \<AA> \<BB> \<NN>) = \<NN>"
	proof(rule ntcf_eqI)
	interpret \<AA>: category \<alpha> \<AA> by (rule assms(1))
	interpret \<BB>: category \<alpha> \<BB> by (rule assms(2))
	interpret \<NN>: is_ntcf \<alpha> \<open>\<AA> \<times>\<^sub>C \<BB>\<close> \<CC> \<SS> \<SS>' \<NN> by (rule assms(3))
	from assms show
	"bnt_flip \<BB> \<AA> (bnt_flip \<AA> \<BB> \<NN>) : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	then have dom_lhs:
	"\<D>\<^sub>\<circ> (bnt_flip \<BB> \<AA> (bnt_flip \<AA> \<BB> \<NN>)\<lparr>NTMap\<rparr>) = (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_simp: cat_cs_simps)
	show "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" by (rule assms(3))
	then have dom_rhs: "\<D>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) = (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	show "bnt_flip \<BB> \<AA> (bnt_flip \<AA> \<BB> \<NN>)\<lparr>NTMap\<rparr> = \<NN>\<lparr>NTMap\<rparr>"
	proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
	fix ab assume "ab \<in>\<^sub>\<circ> (\<AA> \<times>\<^sub>C \<BB>)\<lparr>Obj\<rparr>"
	then obtain a b
	where ab_def: "ab = [a, b]\<^sub>\<circ>"
	and a: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	by (rule cat_prod_2_ObjE[OF assms(1,2)])
	from assms a b show
	"bnt_flip \<BB> \<AA> (bnt_flip \<AA> \<BB> \<NN>)\<lparr>NTMap\<rparr>\<lparr>ab\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>ab\<rparr>"
	by
	(
	cs_concl cs_shallow
	cs_simp: cat_cs_simps ab_def cs_intro: cat_cs_intros
	)
	qed (cs_concl cs_shallow cs_intro: V_cs_intros cat_cs_intros)+
	qed simp_all


	subsubsection\<open>A projection of a flip of a binatural transformation\<close>

	lemma bnt_flip_proj_snd[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	shows "bnt_flip \<AA> \<BB> \<NN>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F = \<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F"
	proof(rule ntcf_eqI)
	from assms show "bnt_flip \<AA> \<BB> \<NN>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F :
	bifunctor_flip \<AA> \<BB> \<SS>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F bifunctor_flip \<AA> \<BB> \<SS>'\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F :
	\<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)
	from assms show "\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F :
	bifunctor_flip \<AA> \<BB> \<SS>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F bifunctor_flip \<AA> \<BB> \<SS>'\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>C\<^sub>F :
	\<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
	from assms have dom_lhs:
	"\<D>\<^sub>\<circ> ((bnt_flip \<AA> \<BB> \<NN>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	from assms have dom_rhs: "\<D>\<^sub>\<circ> ((\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	show "(bnt_flip \<AA> \<BB> \<NN>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr> = (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>"
	proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
	fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	with assms show
	"(bnt_flip \<AA> \<BB> \<NN>\<^bsub>\<BB>,\<AA>\<^esub>(b,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> = (\<NN>\<^bsub>\<AA>,\<BB>\<^esub>(-,b)\<^sub>N\<^sub>T\<^sub>C\<^sub>F)\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
	by (cs_concl cs_shallow cs_simp: cat_cs_simps)
	qed (auto simp: cat_cs_intros)
	qed simp_all

	lemma bnt_flip_proj_fst[cat_cs_simps]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
	shows "bnt_flip \<AA> \<BB> \<NN>\<^bsub>\<BB>,\<AA>\<^esub>(-,a)\<^sub>N\<^sub>T\<^sub>C\<^sub>F = \<NN>\<^bsub>\<AA>,\<BB>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F"
	proof-
	from assms have f_\<NN>:
	"bnt_flip \<AA> \<BB> \<NN> :
	bifunctor_flip \<AA> \<BB> \<SS> \<mapsto>\<^sub>C\<^sub>F bifunctor_flip \<AA> \<BB> \<SS>' :
	\<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_shallow cs_intro: cat_cs_intros)
	show ?thesis
	by
	(
	rule
	bnt_flip_proj_snd
	[
	OF assms(2,1) f_\<NN> assms(4),
	unfolded bnt_flip_flip[OF assms(1,2,3)],
	symmetric
	]
	)
	qed


	subsubsection\<open>A flip of a binatural isomorphism\<close>

	lemma bnt_flip_is_iso_ntcf:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	shows "bnt_flip \<AA> \<BB> \<NN> :
	bifunctor_flip \<AA> \<BB> \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o bifunctor_flip \<AA> \<BB> \<SS>' :
	\<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	proof(rule is_iso_ntcf_if_bnt_proj_snd_is_iso_ntcf)
	from assms show f_\<NN>: "bnt_flip \<AA> \<BB> \<NN> :
	bifunctor_flip \<AA> \<BB> \<SS> \<mapsto>\<^sub>C\<^sub>F bifunctor_flip \<AA> \<BB> \<SS>' :
	\<BB> \<times>\<^sub>C \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_intro: cat_cs_intros ntcf_cs_intros)
	fix a assume "a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
	with assms f_\<NN> show
	"bnt_flip \<AA> \<BB> \<NN>\<^bsub>\<BB>,\<AA>\<^esub>(a,-)\<^sub>N\<^sub>T\<^sub>C\<^sub>F :
	bifunctor_flip \<AA> \<BB> \<SS>\<^bsub>\<BB>,\<AA>\<^esub>(a,-)\<^sub>C\<^sub>F \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o
	bifunctor_flip \<AA> \<BB> \<SS>'\<^bsub>\<BB>,\<AA>\<^esub>(a,-)\<^sub>C\<^sub>F :
	\<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros ntcf_cs_intros)
	qed (simp_all add: assms)

	lemma bnt_flip_is_iso_ntcf'[cat_cs_intros]:
	assumes "category \<alpha> \<AA>"
	and "category \<alpha> \<BB>"
	and "\<NN> : \<SS> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<SS>' : \<AA> \<times>\<^sub>C \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	and "\<FF> = bifunctor_flip \<AA> \<BB> \<SS>"
	and "\<GG> = bifunctor_flip \<AA> \<BB> \<SS>'"
	and "\<DD> = \<BB> \<times>\<^sub>C \<AA>"
	shows "bnt_flip \<AA> \<BB> \<NN> : \<FF> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<GG> : \<DD> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
	using bnt_flip_is_iso_ntcf[OF assms(1-3)] unfolding assms(4-6) by simp

	text\<open>\newpage\<close>

	end
	\ No newline at end of file
	diff --git a/thys/Collections/GenCF/Impl/Impl_Bit_Set.thy b/thys/Collections/GenCF/Impl/Impl_Bit_Set.thy
	--- a/thys/Collections/GenCF/Impl/Impl_Bit_Set.thy
	+++ b/thys/Collections/GenCF/Impl/Impl_Bit_Set.thy
	@@ -1,384 +1,384 @@
	section "Bitvector based Sets of Naturals"
	theory Impl_Bit_Set
	imports
	"../../Iterator/Iterator"
	"../Intf/Intf_Set"
	- Native_Word.Bits_Integer
	+ Native_Word.Code_Target_Integer_Bit
	begin
	text \<open>
	Based on the Native-Word library, using bit-operations on arbitrary
	precision integers. Fast for sets of small numbers,
	direct and fast implementations of equal, union, inter, diff.

	Note: On Poly/ML 5.5.1, bit-operations on arbitrary precision integers are
	rather inefficient. Use MLton instead, here they are efficiently implemented.
	\<close>

	type_synonym bitset = integer

	definition bs_\<alpha> :: "bitset \<Rightarrow> nat set" where "bs_\<alpha> s \<equiv> { n . bit s n}"


	context
	includes integer.lifting bit_operations_syntax
	begin

	definition bs_empty :: "unit \<Rightarrow> bitset" where "bs_empty \<equiv> \<lambda>_. 0"


	lemma bs_empty_correct: "bs_\<alpha> (bs_empty ()) = {}"
	unfolding bs_\<alpha>_def bs_empty_def
	apply transfer
	by auto

	definition bs_isEmpty :: "bitset \<Rightarrow> bool" where "bs_isEmpty s \<equiv> s=0"

	lemma bs_isEmpty_correct: "bs_isEmpty s \<longleftrightarrow> bs_\<alpha> s = {}"
	unfolding bs_isEmpty_def bs_\<alpha>_def
	by transfer (auto simp: bit_eq_iff)

	term set_bit
	definition bs_insert :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
	"bs_insert i s \<equiv> set_bit s i True"

	lemma bs_insert_correct: "bs_\<alpha> (bs_insert i s) = insert i (bs_\<alpha> s)"
	unfolding bs_\<alpha>_def bs_insert_def
	by transfer (auto simp add: bit_simps)

	definition bs_delete :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
	"bs_delete i s \<equiv> set_bit s i False"

	lemma bs_delete_correct: "bs_\<alpha> (bs_delete i s) = (bs_\<alpha> s) - {i}"
	unfolding bs_\<alpha>_def bs_delete_def
	by transfer (auto simp add: bit_simps split: if_splits)

	definition bs_mem :: "nat \<Rightarrow> bitset \<Rightarrow> bool" where
	"bs_mem i s \<equiv> bit s i"

	lemma bs_mem_correct: "bs_mem i s \<longleftrightarrow> i\<in>bs_\<alpha> s"
	unfolding bs_mem_def bs_\<alpha>_def by transfer auto


	definition bs_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
	"bs_eq s1 s2 \<equiv> (s1=s2)"

	lemma bs_eq_correct: "bs_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 = bs_\<alpha> s2"
	unfolding bs_eq_def bs_\<alpha>_def
	including integer.lifting
	by transfer (simp add: bit_eq_iff set_eq_iff)

	definition bs_subset_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
	"bs_subset_eq s1 s2 \<equiv> s1 AND NOT s2 = 0"

	lemma bs_subset_eq_correct: "bs_subset_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<subseteq> bs_\<alpha> s2"
	unfolding bs_\<alpha>_def bs_subset_eq_def
	by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

	definition bs_disjoint :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
	"bs_disjoint s1 s2 \<equiv> s1 AND s2 = 0"

	lemma bs_disjoint_correct: "bs_disjoint s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<inter> bs_\<alpha> s2 = {}"
	unfolding bs_\<alpha>_def bs_disjoint_def
	by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

	definition bs_union :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
	"bs_union s1 s2 = s1 OR s2"

	lemma bs_union_correct: "bs_\<alpha> (bs_union s1 s2) = bs_\<alpha> s1 \<union> bs_\<alpha> s2"
	unfolding bs_\<alpha>_def bs_union_def
	by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

	definition bs_inter :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
	"bs_inter s1 s2 = s1 AND s2"

	lemma bs_inter_correct: "bs_\<alpha> (bs_inter s1 s2) = bs_\<alpha> s1 \<inter> bs_\<alpha> s2"
	unfolding bs_\<alpha>_def bs_inter_def
	by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

	definition bs_diff :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
	"bs_diff s1 s2 = s1 AND NOT s2"

	lemma bs_diff_correct: "bs_\<alpha> (bs_diff s1 s2) = bs_\<alpha> s1 - bs_\<alpha> s2"
	unfolding bs_\<alpha>_def bs_diff_def
	by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

	definition bs_UNIV :: "unit \<Rightarrow> bitset" where "bs_UNIV \<equiv> \<lambda>_. -1"

	lemma bs_UNIV_correct: "bs_\<alpha> (bs_UNIV ()) = UNIV"
	unfolding bs_\<alpha>_def bs_UNIV_def
	by transfer (auto)

	definition bs_complement :: "bitset \<Rightarrow> bitset" where
	"bs_complement s = NOT s"

	lemma bs_complement_correct: "bs_\<alpha> (bs_complement s) = - bs_\<alpha> s"
	unfolding bs_\<alpha>_def bs_complement_def
	by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

	end

	lemmas bs_correct[simp] =
	bs_empty_correct
	bs_isEmpty_correct
	bs_insert_correct
	bs_delete_correct
	bs_mem_correct
	bs_eq_correct
	bs_subset_eq_correct
	bs_disjoint_correct
	bs_union_correct
	bs_inter_correct
	bs_diff_correct
	bs_UNIV_correct
	bs_complement_correct


	subsection \<open>Autoref Setup\<close>

	definition bs_set_rel_def_internal:
	"bs_set_rel Rk \<equiv>
	if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
	lemma bs_set_rel_def:
	"\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
	unfolding bs_set_rel_def_internal relAPP_def by simp

	lemmas [autoref_rel_intf] = REL_INTFI[of "bs_set_rel" i_set]

	lemma bs_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>bs_set_rel)"
	unfolding bs_set_rel_def by auto


	term bs_empty

	lemma [autoref_rules]: "(bs_empty (),{})\<in>\<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_UNIV (),UNIV)\<in>\<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_isEmpty,op_set_isEmpty)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
	by (auto simp: bs_set_rel_def br_def)

	term insert
	lemma [autoref_rules]: "(bs_insert,insert)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	term op_set_delete
	lemma [autoref_rules]: "(bs_delete,op_set_delete)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_mem,(\<in>))\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_eq,(=))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_subset_eq,(\<subseteq>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_union,(\<union>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_inter,(\<inter>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_diff,(-))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_complement,uminus)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
	by (auto simp: bs_set_rel_def br_def)

	lemma [autoref_rules]: "(bs_disjoint,op_set_disjoint)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
	by (auto simp: bs_set_rel_def br_def)


	export_code
	bs_empty
	bs_isEmpty
	bs_insert
	bs_delete
	bs_mem
	bs_eq
	bs_subset_eq
	bs_disjoint
	bs_union
	bs_inter
	bs_diff
	bs_UNIV
	bs_complement
	in SML

	(*

	TODO: Iterator

	definition "maxbi s \<equiv> GREATEST i. s!!i"

	lemma cmp_BIT_append_conv[simp]: "i < i BIT b \<longleftrightarrow> ((i\<ge>0 \<and> b=1) \<or> i>0)"
	by (cases b) (auto simp: Bit_B0 Bit_B1)

	lemma BIT_append_cmp_conv[simp]: "i BIT b < i \<longleftrightarrow> ((i<0 \<and> (i=-1 \<longrightarrow> b=0)))"
	by (cases b) (auto simp: Bit_B0 Bit_B1)

	lemma BIT_append_eq[simp]: fixes i :: int shows "i BIT b = i \<longleftrightarrow> (i=0 \<and> b=0) \<or> (i=-1 \<and> b=1)"
	by (cases b) (auto simp: Bit_B0 Bit_B1)

	lemma int_no_bits_eq_zero[simp]:
	fixes s::int shows "(\<forall>i. \<not>s!!i) \<longleftrightarrow> s=0"
	apply clarsimp
	by (metis bin_eqI bin_nth_code(1))

	lemma int_obtain_bit:
	fixes s::int
	assumes "s\<noteq>0"
	obtains i where "s!!i"
	by (metis assms int_no_bits_eq_zero)

	lemma int_bit_bound:
	fixes s::int
	assumes "s\<ge>0" and "s!!i"
	shows "i \<le> Bits_Integer.log2 s"
	proof (rule ccontr)
	assume "\<not>i\<le>Bits_Integer.log2 s"
	hence "i>Bits_Integer.log2 s" by simp
	hence "i - 1 \<ge> Bits_Integer.log2 s" by simp
	hence "s AND bin_mask (i - 1) = s" by (simp add: int_and_mask `s\<ge>0`)
	hence "\<not> (s!!i)"
	by clarsimp (metis Nat.diff_le_self bin_nth_mask bin_nth_ops(1) leD)
	thus False using `s!!i` ..
	qed

	lemma int_bit_bound':
	fixes s::int
	assumes "s\<ge>0" and "s!!i"
	shows "i < Bits_Integer.log2 s + 1"
	using assms int_bit_bound by smt

	lemma int_obtain_bit_pos:
	fixes s::int
	assumes "s>0"
	obtains i where "s!!i" "i < Bits_Integer.log2 s + 1"
	by (metis assms int_bit_bound' int_no_bits_eq_zero less_imp_le less_irrefl)

	lemma maxbi_set: fixes s::int shows "s>0 \<Longrightarrow> s!!maxbi s"
	unfolding maxbi_def
	apply (rule int_obtain_bit_pos, assumption)
	apply (rule GreatestI_nat, assumption)
	apply (intro allI impI)
	apply (rule int_bit_bound'[rotated], assumption)
	by auto

	lemma maxbi_max: fixes s::int shows "i>maxbi s \<Longrightarrow> \<not> s!!i"
	oops

	function get_maxbi :: "nat \<Rightarrow> int \<Rightarrow> nat" where
	"get_maxbi n s = (let
	b = 1<<n
	in
	if b\<le>s then get_maxbi (n+1) s
	else n
	)"
	by pat_completeness auto

	termination
	apply (rule "termination"[of "measure (\<lambda>(n,s). nat (s + 1 - (1<<n)))"])
	apply simp
	apply auto
	by (smt bin_mask_ge0 bin_mask_p1_conv_shift)


	partial_function (tailrec)
	bs_iterate_aux :: "nat \<Rightarrow> bitset \<Rightarrow> ('\<sigma> \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
	where "bs_iterate_aux i s c f \<sigma> = (
	if s < 1 << i then \<sigma>
	else if \<not>c \<sigma> then \<sigma>
	else if test_bit s i then bs_iterate_aux (i+1) s c f (f i \<sigma>)
	else bs_iterate_aux (i+1) s c f \<sigma>
	)"

	definition bs_iteratei :: "bitset \<Rightarrow> (nat,'\<sigma>) set_iterator" where
	"bs_iteratei s = bs_iterate_aux 0 s"


	definition bs_set_rel_def_internal:
	"bs_set_rel Rk \<equiv>
	if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
	lemma bs_set_rel_def:
	"\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
	unfolding bs_set_rel_def_internal relAPP_def by simp


	definition "bs_to_list \<equiv> it_to_list bs_iteratei"

	lemma "(1::int)<<i = 2^i"
	by (simp add: shiftl_int_def)

	lemma
	fixes s :: int
	assumes "s\<ge>0"
	shows "s < 1<<i \<longleftrightarrow> Bits_Integer.log2 s \<le> i"
	using assms
	proof (induct i arbitrary: s)
	case 0 thus ?case by auto
	next
	case (Suc i)
	note GE=`0\<le>s`
	show ?case proof
	assume "s < 1 << Suc i"

	have "s \<le> (s >> 1) BIT 1"

	hence "(s >> 1) < (1<<i)" using GE apply auto
	with Suc.hyps[of "s div 2"]


	apply auto



	lemma "distinct (bs_to_list s)"
	unfolding bs_to_list_def it_to_list_def bs_iteratei_def[abs_def]
	proof -
	{
	fix l i
	assume "distinct l"
	show "distinct (bs_iterate_aux 0 s (\<lambda>_. True) (\<lambda>x l. l @ [x]) [])"

	}


	apply auto




	lemma "set (bs_to_list s) = bs_\<alpha> s"


	lemma autoref_iam_is_iterator[autoref_ga_rules]:
	shows "is_set_to_list nat_rel bs_set_rel bs_to_list"
	unfolding is_set_to_list_def is_set_to_sorted_list_def
	apply clarsimp
	unfolding it_to_sorted_list_def
	apply (refine_rcg refine_vcg)
	apply (simp_all add: bs_set_rel_def br_def)

	proof (clarsimp)



	definition

	"iterate s c f \<sigma> \<equiv> let
	i=0;
	b=0;
	(_,_,s) = while
	in

	end"


	*)


	end
	diff --git a/thys/Collections/Lib/Code_Target_ICF.thy b/thys/Collections/Lib/Code_Target_ICF.thy
	--- a/thys/Collections/Lib/Code_Target_ICF.thy
	+++ b/thys/Collections/Lib/Code_Target_ICF.thy
	@@ -1,8 +1,8 @@
	section \<open>Default Code Generator Setup for the Isabelle Collection Framework\<close>
	theory Code_Target_ICF
	imports
	"HOL-Library.Code_Target_Numeral"
	- Native_Word.Code_Target_Bits_Int
	+ Native_Word.Code_Target_Int_Bit
	begin

	end
	diff --git a/thys/Completeness/PermutationLemmas.thy b/thys/Completeness/PermutationLemmas.thy
	--- a/thys/Completeness/PermutationLemmas.thy
	+++ b/thys/Completeness/PermutationLemmas.thy
	@@ -1,172 +1,160 @@
	section "Permutation Lemmas"

	theory PermutationLemmas
	imports "HOL-Library.Multiset"
	begin

	\<comment> \<open>following function is very close to that in multisets- now we can make the connection that x <~~> y iff the multiset of x is the same as that of y\<close>

	subsection "perm, count equivalence"

	-primrec count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
	-where
	- "count x [] = 0"
	-\| "count x (y#ys) = (if x=y then 1 else 0) + count x ys"
	-
	lemma count_eq:
	- \<open>count x xs = Multiset.count (mset xs) x\<close>
	- by (induction xs) simp_all
	-
	-lemma perm_count: "mset A = mset B \<Longrightarrow> (\<forall> x. count x A = count x B)"
	- by (simp add: count_eq)
	-
	-lemma count_0: "(\<forall>x. count x B = 0) = (B = [])"
	- by(induct B) auto
	+ \<open>count_list xs x = Multiset.count (mset xs) x\<close>
	+by (induction xs) simp_all

	-lemma count_Suc: "count a B = Suc m \<Longrightarrow> a : set B"
	- apply(induct B)
	- apply auto
	- apply(case_tac "a = aa")
	- apply auto
	- done
	+lemma perm_count: "mset A = mset B \<Longrightarrow> (\<forall> x. count_list A x = count_list B x)"
	+by (simp add: count_eq)

	-lemma count_append: "count a (xs@ys) = count a xs + count a ys"
	- by(induct xs) auto
	+lemma count_0: "(\<forall>x. count_list B x = 0) = (B = [])"
	+by (simp add: count_list_0_iff)

	-lemma count_perm: "!! B. (\<forall> x. count x A = count x B) \<Longrightarrow> mset A = mset B"
	- by (simp add: count_eq multiset_eq_iff)
	+lemma count_Suc: "count_list B a = Suc m \<Longrightarrow> a : set B"
	+by (metis Zero_not_Suc count_notin)

	-lemma perm_count_conv: "mset A = mset B \<longleftrightarrow> (\<forall> x. count x A = count x B)"
	- by (simp add: count_eq multiset_eq_iff)
	+lemma count_perm: "!! B. (\<forall> x. count_list A x = count_list B x) \<Longrightarrow> mset A = mset B"
	+by (simp add: count_eq multiset_eq_iff)
	+
	+lemma perm_count_conv: "mset A = mset B \<longleftrightarrow> (\<forall> x. count_list A x = count_list B x)"
	+by (simp add: count_eq multiset_eq_iff)


	subsection "Properties closed under Perm and Contr hold for x iff hold for remdups x"

	lemma remdups_append: "y : set ys --> remdups (ws@y#ys) = remdups (ws@ys)"
	apply (induct ws, simp)
	apply (case_tac "y = a", simp, simp)
	done

	lemma perm_contr': assumes perm[rule_format]: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
	and contr'[rule_format]: "! x xs. P(x#x#xs) = P (x#xs)"
	shows "! xs. length xs = n --> (P xs = P (remdups xs))"
	apply(induct n rule: nat_less_induct)
	proof (safe)
	fix xs :: "'a list"
	assume a[rule_format]: "\<forall>m<length xs. \<forall>ys. length ys = m \<longrightarrow> P ys = P (remdups ys)"
	show "P xs = P (remdups xs)"
	proof (cases "distinct xs")
	case True
	thus ?thesis by(simp add:distinct_remdups_id)
	next
	case False
	from not_distinct_decomp[OF this] obtain ws ys zs y where xs: "xs = ws@[y]@ys@[y]@zs" by force
	have "P xs = P (ws@[y]@ys@[y]@zs)" by (simp add: xs)
	also have "... = P ([y,y]@ws@ys@zs)"
	- apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
	+ apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp) done
	also have "... = P ([y]@ws@ys@zs)" apply simp apply(rule contr') done
	also have "... = P (ws@ys@[y]@zs)"
	- apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
	+ apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp) done
	also have "... = P (remdups (ws@ys@[y]@zs))"
	apply(rule a) by(auto simp: xs)
	also have "(remdups (ws@ys@[y]@zs)) = (remdups xs)"
	apply(simp add: xs remdups_append) done
	finally show "P xs = P (remdups xs)" .
	qed
	qed

	lemma perm_contr: assumes perm: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
	and contr': "! x xs. P(x#x#xs) = P (x#xs)"
	shows "(P xs = P (remdups xs))"
	apply(rule perm_contr'[OF perm contr', rule_format]) by force


	subsection "List properties closed under Perm, Weak and Contr are monotonic in the set of the list"

	definition
	rem :: "'a => 'a list => 'a list" where
	"rem x xs = filter (%y. y ~= x) xs"

	lemma rem: "x ~: set (rem x xs)"
	by(simp add: rem_def)

	lemma length_rem: "length (rem x xs) <= length xs"
	by(simp add: rem_def)

	lemma rem_notin: "x ~: set xs ==> rem x xs = xs"
	apply(simp add: rem_def)
	apply(rule filter_True)
	apply force
	done


	lemma perm_weak_filter': assumes perm[rule_format]: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
	and weak[rule_format]: "! x xs. P xs --> P (x#xs)"
	shows "! ys. P (ys@filter Q xs) --> P (ys@xs)"
	proof (rule allI, rule impI)
	fix ys
	define zs where \<open>zs = filter (Not \<circ> Q) xs\<close>
	assume \<open>P (ys @ filter Q xs)\<close>
	then have \<open>P (filter Q xs @ ys)\<close>
	apply (subst perm) defer apply assumption apply simp done
	then have \<open>P (zs @ filter Q xs @ ys)\<close>
	apply (induction zs)
	apply (simp_all add: weak)
	done
	with zs_def show \<open>P (ys @ xs)\<close>
	apply (subst perm) defer apply assumption apply simp done
	qed

	lemma perm_weak_filter: assumes perm: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
	and weak: "! x xs. P xs --> P (x#xs)"
	shows "P (filter Q xs) ==> P xs"
	using perm_weak_filter'[OF perm weak, rule_format, of "[]", simplified]
	by blast

	\<comment> \<open>right, now in a position to prove that in presence of perm, contr and weak, set x leq set y and x : ded implies y : ded\<close>

	lemma perm_weak_contr_mono:
	assumes perm: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
	and contr: "! x xs. P (x#x#xs) --> P (x#xs)"
	and weak: "! x xs. P xs --> P (x#xs)"
	and xy: "set x <= set y"
	and Px : "P x"
	shows "P y"
	proof -
	from contr weak have contr': "! x xs. P(x#x#xs) = P (x#xs)" by blast

	define y' where "y' = filter (% z. z : set x) y"
	from xy have "set x = set y'" apply(simp add: y'_def) apply blast done
	hence rxry': "mset (remdups x) = mset (remdups y')"
	using set_eq_iff_mset_remdups_eq by auto

	from Px perm_contr[OF perm contr'] have Prx: "P (remdups x)" by simp
	with rxry' have "P (remdups y')" apply (subst perm) defer apply assumption apply simp done

	with perm_contr[OF perm contr'] have "P y'" by simp
	thus "P y"
	apply(simp add: y'_def)
	apply(rule perm_weak_filter[OF perm weak]) .
	qed

	(* No, not used
	subsection "Following used in Soundness"

	primrec multiset_of_list :: "'a list \<Rightarrow> 'a multiset"
	where
	"multiset_of_list [] = {#}"
	\| "multiset_of_list (x#xs) = {#x#} + multiset_of_list xs"

	lemma count_count[symmetric]: "count x A = Multiset.count (multiset_of_list A) x"
	by (induct A) simp_all

	lemma perm_multiset: "A <~~> B = (multiset_of_list A = multiset_of_list B)"
	apply(simp add: perm_count_conv)
	apply(simp add: multiset_eq_iff)
	apply(simp add: count_count)
	done

	lemma set_of_multiset_of_list: "set_of (multiset_of_list A) = set A"
	by (induct A) auto
	*)
	end
	diff --git a/thys/Completeness/Sequents.thy b/thys/Completeness/Sequents.thy
	--- a/thys/Completeness/Sequents.thy
	+++ b/thys/Completeness/Sequents.thy
	@@ -1,310 +1,310 @@
	section "Sequents"

	theory Sequents
	imports Formula
	begin

	type_synonym sequent = "formula list"

	definition
	evalS :: "[model,vbl => object,formula list] => bool" where
	"evalS M phi fs \<longleftrightarrow> (? f : set fs . evalF M phi f = True)"

	lemma evalS_nil[simp]: "evalS M phi [] = False"
	by(simp add: evalS_def)

	lemma evalS_cons[simp]: "evalS M phi (A # Gamma) = (evalF M phi A \| evalS M phi Gamma)"
	by(simp add: evalS_def)

	lemma evalS_append: "evalS M phi (Gamma @ Delta) = (evalS M phi Gamma \| evalS M phi Delta)"
	by(force simp add: evalS_def)

	lemma evalS_equiv[rule_format]: "(equalOn (freeVarsFL Gamma) f g) --> (evalS M f Gamma = evalS M g Gamma)"
	apply (induct Gamma, simp, rule)
	apply(simp add: freeVarsFL_cons)
	apply(drule_tac equalOn_UnD)
	apply(blast dest: evalF_equiv)
	done


	definition
	modelAssigns :: "[model] => (vbl => object) set" where
	"modelAssigns M = { phi . range phi <= objects M }"

	lemma modelAssignsI: "range f <= objects M \<Longrightarrow> f : modelAssigns M"
	by(simp add: modelAssigns_def)

	lemma modelAssignsD: "f : modelAssigns M \<Longrightarrow> range f <= objects M"
	by(simp add: modelAssigns_def)

	definition
	validS :: "formula list => bool" where
	"validS fs \<longleftrightarrow> (! M . ! phi : modelAssigns M . evalS M phi fs = True)"


	subsection "Rules"

	type_synonym rule = "sequent * (sequent set)"

	definition
	concR :: "rule => sequent" where
	"concR = (%(conc,prems). conc)"

	definition
	premsR :: "rule => sequent set" where
	"premsR = (%(conc,prems). prems)"

	definition
	mapRule :: "(formula => formula) => rule => rule" where
	"mapRule = (%f (conc,prems) . (map f conc,(map f) ` prems))"

	lemma mapRuleI: "[\| A = map f a; B = (map f) ` b \|] ==> (A,B) = mapRule f (a,b)"
	by(simp add: mapRule_def)
	\<comment> \<open>FIXME tjr would like symmetric\<close>


	subsection "Deductions"

	(FIXME. I don't see why plain Pow_mono is rejected.)
	lemmas Powp_mono [mono] = Pow_mono [to_pred pred_subset_eq]

	inductive_set
	deductions :: "rule set => formula list set"
	for rules :: "rule set"
	(******
	* Given a set of rules,
	* 1. Given a rule conc/prem(i) in rules,
	* and the prem(i) are deductions from rules,
	* then conc is a deduction from rules.
	* 2. can derive permutation of any deducible formula list.
	* (supposed to be multisets not lists).
	******)
	where
	inferI: "[\| (conc,prems) : rules;
	prems : Pow(deductions(rules))
	\|] ==> conc : deductions(rules)"
	(*
	perms "[\| permutation conc' conc;
	conc' : deductions(rules)
	\|] ==> conc : deductions(rules)"
	*)

	lemma mono_deductions: "[\| A <= B \|] ==> deductions(A) <= deductions(B)"
	apply(best intro: deductions.inferI elim: deductions.induct) done

	(lemmas deductionsMono = mono_deductions)

	(*
	-- "tjr following should be subsetD?"
	lemmas deductionSubsetI = mono_deductions[THEN subsetD]
	thm deductionSubsetI
	*)

	(******
	* (f : formula -> formula) extended structurally over rules, deductions etc...
	* (((If f maps rules into themselves then can consider mapping derivation trees.)))
	* (((Is the asm necessary - think not?)))
	* The mapped deductions from the rules are same as
	* the deductions from the mapped rules.
	*
	* WHY:
	*
	* map f `` deductions rules <= deductions (mapRule f `` rules) (this thm)
	* <= deductions rules (closed)
	*
	* If rules are closed under f then so are deductions.
	* Can take f = (subst u v) and have application to exercise #1.
	*
	* Q: maybe also make f dual mapping, (what about quantifier side conditions...?).
	******)

	(*
	lemma map_deductions: "map f ` deductions rules <= deductions (mapRule f ` rules)"
	apply(rule subsetI)
	apply (erule_tac imageE, simp)
	apply(erule deductions.induct)
	apply(blast intro: deductions.inferI mapRuleI)
	done

	lemma deductionsCloseRules: "! (conc,prems) : S . prems <= deductions R --> conc : deductions R ==> deductions (R Un S) = deductions R"
	apply(rule equalityI)
	prefer 2
	apply(rule mono_deductions) apply blast
	apply(rule subsetI)
	apply (erule_tac deductions.induct, simp) apply(erule conjE) apply(thin_tac "prems \<subseteq> deductions (R \<union> S)")
	apply(erule disjE)
	apply(rule inferI) apply assumption apply force
	apply blast
	done
	*)


	subsection "Basic Rule sets"

	definition
	"Axioms = { z. ? p vs. z = ([FAtom Pos p vs,FAtom Neg p vs],{}) }"
	definition
	"Conjs = { z. ? A0 A1 Delta Gamma. z = (FConj Pos A0 A1#Gamma @ Delta,{A0#Gamma,A1#Delta}) }"
	definition
	"Disjs = { z. ? A0 A1 Gamma. z = (FConj Neg A0 A1#Gamma,{A0#A1#Gamma}) }"
	definition
	"Alls = { z. ? A x Gamma. z = (FAll Pos A#Gamma,{instanceF x A#Gamma}) & x ~: freeVarsFL (FAll Pos A#Gamma) }"
	definition
	"Exs = { z. ? A x Gamma. z = (FAll Neg A#Gamma,{instanceF x A#Gamma})}"
	definition
	"Weaks = { z. ? A Gamma. z = (A#Gamma,{Gamma})}"
	definition
	"Contrs = { z. ? A Gamma. z = (A#Gamma,{A#A#Gamma})}"
	definition
	"Cuts = { z. ? C Delta Gamma. z = (Gamma @ Delta,{C#Gamma,FNot C#Delta})}"
	definition
	"Perms = { z. ? Gamma Gamma' . z = (Gamma,{Gamma'}) & mset Gamma = mset Gamma'}"
	definition
	"DAxioms = { z. ? p vs. z = ([FAtom Neg p vs,FAtom Pos p vs],{}) }"


	lemma AxiomI: "[\| Axioms <= A \|] ==> [FAtom Pos p vs,FAtom Neg p vs] : deductions(A)"
	apply(rule deductions.inferI)
	apply(auto simp add: Axioms_def) done

	lemma DAxiomsI: "[\| DAxioms <= A \|] ==> [FAtom Neg p vs,FAtom Pos p vs] : deductions(A)"
	apply(rule deductions.inferI)
	apply(auto simp add: DAxioms_def) done

	lemma DisjI: "[\| A0#A1#Gamma : deductions(A); Disjs <= A \|] ==> (FConj Neg A0 A1#Gamma) : deductions(A)"
	apply(rule deductions.inferI)
	apply(auto simp add: Disjs_def) done

	lemma ConjI: "[\| (A0#Gamma) : deductions(A); (A1#Delta) : deductions(A); Conjs <= A \|] ==> FConj Pos A0 A1#Gamma @ Delta : deductions(A)"
	apply(rule_tac prems="{A0#Gamma,A1#Delta}" in deductions.inferI)
	apply(auto simp add: Conjs_def) apply force done

	lemma AllI: "[\| instanceF w A#Gamma : deductions(R); w ~: freeVarsFL (FAll Pos A#Gamma); Alls <= R \|] ==> (FAll Pos A#Gamma) : deductions(R)"
	apply(rule_tac prems="{instanceF w A#Gamma}" in deductions.inferI)
	apply(auto simp add: Alls_def) done

	lemma ExI: "[\| instanceF w A#Gamma : deductions(R); Exs <= R \|] ==> (FAll Neg A#Gamma) : deductions(R)"
	apply(rule_tac prems = "{instanceF w A#Gamma}" in deductions.inferI)
	apply(auto simp add: Exs_def) done

	lemma WeakI: "[\| Gamma : deductions R; Weaks <= R \|] ==> A#Gamma : deductions(R)"
	apply(rule_tac prems="{Gamma}" in deductions.inferI)
	apply(auto simp add: Weaks_def) done

	lemma ContrI: "[\| A#A#Gamma : deductions R; Contrs <= R \|] ==> A#Gamma : deductions(R)"
	apply(rule_tac prems="{A#A#Gamma}" in deductions.inferI)
	apply(auto simp add: Contrs_def) done

	lemma PermI: "[\| Gamma' : deductions R; mset Gamma = mset Gamma'; Perms <= R \|] ==> Gamma : deductions(R)"
	apply(rule_tac prems="{Gamma'}" in deductions.inferI)
	apply(auto simp add: Perms_def) done


	subsection "Derived Rules"

	lemma WeakI1: "[\| Gamma : deductions(A); Weaks <= A \|] ==> (Delta @ Gamma) : deductions(A)"
	apply (induct Delta, simp)
	apply(auto intro: WeakI) done

	lemma WeakI2: "[\| Gamma : deductions(A); Perms <= A; Weaks <= A \|] ==> (Gamma @ Delta) : deductions(A)"
	apply (auto intro: PermI [of \<open>Delta @ Gamma\<close>] WeakI1)
	done

	lemma SATAxiomI: "[\| Axioms <= A; Weaks <= A; Perms <= A; forms = [FAtom Pos n vs,FAtom Neg n vs] @ Gamma \|] ==> forms : deductions(A)"
	apply(simp only:)
	apply(blast intro: WeakI2 AxiomI)
	done

	lemma DisjI1: "[\| (A1#Gamma) : deductions(A); Disjs <= A; Weaks <= A \|] ==> FConj Neg A0 A1#Gamma : deductions(A)"
	apply(blast intro: DisjI WeakI)
	done

	lemma DisjI2: "!!A. [\| (A0#Gamma) : deductions(A); Disjs <= A; Weaks <= A; Perms <= A \|] ==> FConj Neg A0 A1#Gamma : deductions(A)"
	apply(rule DisjI)
	apply(rule PermI [of \<open>A1 # A0 # Gamma\<close>])
	apply simp_all
	apply(rule WeakI)
	.

	\<comment> \<open>FIXME the following 4 lemmas could all be proved for the standard rule sets using monotonicity as below\<close>
	\<comment> \<open>we keep proofs as in original, but they are slightly ugly, and do not state what is intuitively happening\<close>
	lemma perm_tmp4: "Perms \<subseteq> R \<Longrightarrow> A @ (a # list) @ (a # list) : deductions R \<Longrightarrow> (a # a # A) @ list @ list : deductions R"
	apply (rule PermI, auto)
	done

	lemma weaken_append[rule_format]: "Contrs <= R ==> Perms <= R ==> !A. A @ Gamma @ Gamma : deductions(R) --> A @ Gamma : deductions(R)"
	apply (induct_tac Gamma, simp, rule) apply rule
	apply(drule_tac x="a#a#A" in spec)
	apply(erule_tac impE)
	apply(rule perm_tmp4) apply(assumption, assumption)
	apply(thin_tac "A @ (a # list) @ a # list \<in> deductions R")
	apply simp
	apply(frule_tac ContrI) apply assumption
	apply(thin_tac "a # a # A @ list \<in> deductions R")
	apply(rule PermI) apply assumption
	- apply(simp add: perm_count_conv count_append)
	+ apply(simp add: perm_count_conv)
	by assumption
	\<comment> \<open>FIXME horrible\<close>

	lemma ListWeakI: "Perms <= R ==> Contrs <= R ==> x # Gamma @ Gamma : deductions(R) ==> x # Gamma : deductions(R)"
	by(rule weaken_append[of R "[x]" Gamma, simplified])

	lemma ConjI': "[\| (A0#Gamma) : deductions(A); (A1#Gamma) : deductions(A); Contrs <= A; Conjs <= A; Perms <= A \|] ==> FConj Pos A0 A1#Gamma : deductions(A)"
	apply(rule ListWeakI, assumption, assumption)
	apply(rule ConjI) .



	subsection "Standard Rule Sets For Predicate Calculus"

	definition
	PC :: "rule set" where
	"PC = Union {Perms,Axioms,Conjs,Disjs,Alls,Exs,Weaks,Contrs,Cuts}"

	definition
	CutFreePC :: "rule set" where
	"CutFreePC = Union {Perms,Axioms,Conjs,Disjs,Alls,Exs,Weaks,Contrs}"

	lemma rulesInPCs: "Axioms <= PC" "Axioms <= CutFreePC"
	"Conjs <= PC" "Conjs <= CutFreePC"
	"Disjs <= PC" "Disjs <= CutFreePC"
	"Alls <= PC" "Alls <= CutFreePC"
	"Exs <= PC" "Exs <= CutFreePC"
	"Weaks <= PC" "Weaks <= CutFreePC"
	"Contrs <= PC" "Contrs <= CutFreePC"
	"Perms <= PC" "Perms <= CutFreePC"
	"Cuts <= PC"
	"CutFreePC <= PC"
	by(auto simp: PC_def CutFreePC_def)


	subsection "Monotonicity for CutFreePC deductions"

	\<comment> \<open>these lemmas can be used to replace complicated permutation reasoning above\<close>
	\<comment> \<open>essentially if x is a deduction, and set x subset set y, then y is a deduction\<close>

	definition
	inDed :: "formula list => bool" where
	"inDed xs \<longleftrightarrow> xs : deductions CutFreePC"

	lemma perm: "! xs ys. mset xs = mset ys --> (inDed xs = inDed ys)"
	by (metis PermI inDed_def rulesInPCs(16))

	lemma contr: "! x xs. inDed (x#x#xs) --> inDed (x#xs)"
	apply(simp add: inDed_def)
	apply(blast intro!: ContrI rulesInPCs)
	done

	lemma weak: "! x xs. inDed xs --> inDed (x#xs)"
	apply(simp add: inDed_def)
	apply(blast intro!: WeakI rulesInPCs)
	done

	lemma inDed_mono'[simplified inDed_def]: "set x <= set y ==> inDed x ==> inDed y"
	using perm_weak_contr_mono[OF perm contr weak] .

	lemma inDed_mono[simplified inDed_def]: "inDed x ==> set x <= set y ==> inDed y"
	using perm_weak_contr_mono[OF perm contr weak] .


	end
	diff --git a/thys/Epistemic_Logic/Epistemic_Logic.thy b/thys/Epistemic_Logic/Epistemic_Logic.thy
	--- a/thys/Epistemic_Logic/Epistemic_Logic.thy
	+++ b/thys/Epistemic_Logic/Epistemic_Logic.thy
	@@ -1,1411 +1,1412 @@
	(*
	File: Epistemic_Logic.thy
	Author: Asta Halkjær From

	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).
	The extensions of system K (T, KB, K4, S4, S5) and their completeness proofs
	are based on the textbook "Modal Logic" by Blackburn, de Rijke and Venema
	(Cambridge University Press 2001).
	*)

	theory Epistemic_Logic imports "HOL-Library.Countable" begin

	section \<open>Syntax\<close>

	type_synonym id = string

	datatype 'i fm
	- = FF ("\<^bold>\<bottom>")
	+ = FF (\<open>\<^bold>\<bottom>\<close>)
	\| Pro id
	- \| Dis \<open>'i fm\<close> \<open>'i fm\<close> (infixr "\<^bold>\<or>" 30)
	- \| Con \<open>'i fm\<close> \<open>'i fm\<close> (infixr "\<^bold>\<and>" 35)
	- \| Imp \<open>'i fm\<close> \<open>'i fm\<close> (infixr "\<^bold>\<longrightarrow>" 25)
	+ \| Dis \<open>'i fm\<close> \<open>'i fm\<close> (infixr \<open>\<^bold>\<or>\<close> 60)
	+ \| Con \<open>'i fm\<close> \<open>'i fm\<close> (infixr \<open>\<^bold>\<and>\<close> 65)
	+ \| Imp \<open>'i fm\<close> \<open>'i fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)
	\| K 'i \<open>'i fm\<close>

	-abbreviation TT ("\<^bold>\<top>") where
	+abbreviation TT (\<open>\<^bold>\<top>\<close>) where
	\<open>TT \<equiv> \<^bold>\<bottom> \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>

	-abbreviation Neg ("\<^bold>\<not> _" [40] 40) where
	+abbreviation Neg (\<open>\<^bold>\<not> _\<close> [70] 70) where
	\<open>Neg p \<equiv> p \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>

	abbreviation \<open>L i p \<equiv> \<^bold>\<not> K i (\<^bold>\<not> p)\<close>

	section \<open>Semantics\<close>

	-datatype ('i, 'w) kripke =
	- Kripke (\<W>: \<open>'w set\<close>) (\<pi>: \<open>'w \<Rightarrow> id \<Rightarrow> bool\<close>) (\<K>: \<open>'i \<Rightarrow> 'w \<Rightarrow> 'w set\<close>)
	+record ('i, 'w) frame =
	+ \<W> :: \<open>'w set\<close>
	+ \<K> :: \<open>'i \<Rightarrow> 'w \<Rightarrow> 'w set\<close>

	-primrec semantics :: \<open>('i, 'w) kripke \<Rightarrow> 'w \<Rightarrow> 'i fm \<Rightarrow> bool\<close>
	- ("_, _ \<Turnstile> _" [50, 50] 50) where
	- \<open>(M, w \<Turnstile> \<^bold>\<bottom>) = False\<close>
	-\| \<open>(M, w \<Turnstile> Pro x) = \<pi> M w x\<close>
	-\| \<open>(M, w \<Turnstile> (p \<^bold>\<or> q)) = ((M, w \<Turnstile> p) \<or> (M, w \<Turnstile> q))\<close>
	-\| \<open>(M, w \<Turnstile> (p \<^bold>\<and> q)) = ((M, w \<Turnstile> p) \<and> (M, w \<Turnstile> q))\<close>
	-\| \<open>(M, w \<Turnstile> (p \<^bold>\<longrightarrow> q)) = ((M, w \<Turnstile> p) \<longrightarrow> (M, w \<Turnstile> q))\<close>
	-\| \<open>(M, w \<Turnstile> K i p) = (\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p)\<close>
	+record ('i, 'w) kripke =
	+ \<open>('i, 'w) frame\<close> +
	+ \<pi> :: \<open>'w \<Rightarrow> id \<Rightarrow> bool\<close>
	+
	+primrec semantics :: \<open>('i, 'w) kripke \<Rightarrow> 'w \<Rightarrow> 'i fm \<Rightarrow> bool\<close> (\<open>_, _ \<Turnstile> _\<close> [50, 50, 50] 50) where
	+ \<open>M, w \<Turnstile> \<^bold>\<bottom> \<longleftrightarrow> False\<close>
	+\| \<open>M, w \<Turnstile> Pro x \<longleftrightarrow> \<pi> M w x\<close>
	+\| \<open>M, w \<Turnstile> p \<^bold>\<or> q \<longleftrightarrow> M, w \<Turnstile> p \<or> M, w \<Turnstile> q\<close>
	+\| \<open>M, w \<Turnstile> p \<^bold>\<and> q \<longleftrightarrow> M, w \<Turnstile> p \<and> M, w \<Turnstile> q\<close>
	+\| \<open>M, w \<Turnstile> p \<^bold>\<longrightarrow> q \<longleftrightarrow> M, w \<Turnstile> p \<longrightarrow> M, w \<Turnstile> q\<close>
	+\| \<open>M, w \<Turnstile> K i p \<longleftrightarrow> (\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p)\<close>
	+
	+abbreviation validStar :: \<open>(('i, 'w) kripke \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> 'i fm \<Rightarrow> bool\<close>
	+ (\<open>_; _ \<TTurnstile>\<star> _\<close> [50, 50, 50] 50) where
	+ \<open>P; G \<TTurnstile>\<star> p \<equiv> \<forall>M. P M \<longrightarrow>
	+ (\<forall>w \<in> \<W> M. (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p)\<close>

	section \<open>S5 Axioms\<close>

	-definition reflexive :: \<open>('i, 'w) kripke \<Rightarrow> bool\<close> where
	+definition reflexive :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
	\<open>reflexive M \<equiv> \<forall>i. \<forall>w \<in> \<W> M. w \<in> \<K> M i w\<close>
	-
	-definition symmetric :: \<open>('i, 'w) kripke \<Rightarrow> bool\<close> where
	+
	+definition symmetric :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
	\<open>symmetric M \<equiv> \<forall>i. \<forall>v \<in> \<W> M. \<forall>w \<in> \<W> M. v \<in> \<K> M i w \<longleftrightarrow> w \<in> \<K> M i v\<close>

	-definition transitive :: \<open>('i, 'w) kripke \<Rightarrow> bool\<close> where
	+definition transitive :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
	\<open>transitive M \<equiv> \<forall>i. \<forall>u \<in> \<W> M. \<forall>v \<in> \<W> M. \<forall>w \<in> \<W> M.
	w \<in> \<K> M i v \<and> u \<in> \<K> M i w \<longrightarrow> u \<in> \<K> M i v\<close>

	-abbreviation equivalence :: \<open>('i, 'w) kripke \<Rightarrow> bool\<close> where
	+abbreviation refltrans :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
	+ \<open>refltrans M \<equiv> reflexive M \<and> transitive M\<close>
	+
	+abbreviation equivalence :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
	\<open>equivalence M \<equiv> reflexive M \<and> symmetric M \<and> transitive M\<close>

	-lemma Imp_intro [intro]: \<open>(M, w \<Turnstile> p \<Longrightarrow> M, w \<Turnstile> q) \<Longrightarrow> M, w \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	+definition Euclidean :: \<open>('i, 'w, 'c) frame_scheme \<Rightarrow> bool\<close> where
	+ \<open>Euclidean M \<equiv> \<forall>i. \<forall>u \<in> \<W> M. \<forall>v \<in> \<W> M. \<forall>w \<in> \<W> M.
	+ v \<in> \<K> M i u \<longrightarrow> w \<in> \<K> M i u \<longrightarrow> w \<in> \<K> M i v\<close>
	+
	+lemma Imp_intro [intro]: \<open>(M, w \<Turnstile> p \<Longrightarrow> M, w \<Turnstile> q) \<Longrightarrow> M, w \<Turnstile> p \<^bold>\<longrightarrow> q\<close>
	by simp

	-theorem distribution: \<open>M, w \<Turnstile> (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q)\<close>
	+theorem distribution: \<open>M, w \<Turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q\<close>
	proof
	- assume \<open>M, w \<Turnstile> (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q))\<close>
	+ assume \<open>M, w \<Turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q)\<close>
	then have \<open>M, w \<Turnstile> K i p\<close> \<open>M, w \<Turnstile> K i (p \<^bold>\<longrightarrow> q)\<close>
	by simp_all
	- then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p\<close> \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	+ then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p\<close> \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p \<^bold>\<longrightarrow> q\<close>
	by simp_all
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> q\<close>
	by simp
	then show \<open>M, w \<Turnstile> K i q\<close>
	by simp
	qed

	theorem generalization:
	- assumes valid: \<open>\<forall>(M :: ('i, 'w) kripke) w. M, w \<Turnstile> p\<close>
	- shows \<open>(M :: ('i, 'w) kripke), w \<Turnstile> K i p\<close>
	+ fixes M :: \<open>('i, 'w) kripke\<close>
	+ assumes \<open>\<forall>(M :: ('i, 'w) kripke). \<forall>w \<in> \<W> M. M, w \<Turnstile> p\<close> \<open>w \<in> \<W> M\<close>
	+ shows \<open>M, w \<Turnstile> K i p\<close>
	proof -
	- have \<open>\<forall>w' \<in> \<K> M i w. M, w' \<Turnstile> p\<close>
	- using valid by blast
	+ have \<open>\<forall>w' \<in> \<W> M \<inter> \<K> M i w. M, w' \<Turnstile> p\<close>
	+ using assms by blast
	then show \<open>M, w \<Turnstile> K i p\<close>
	by simp
	qed

	theorem truth:
	assumes \<open>reflexive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>M, w \<Turnstile> (K i p \<^bold>\<longrightarrow> p)\<close>
	+ shows \<open>M, w \<Turnstile> K i p \<^bold>\<longrightarrow> p\<close>
	proof
	assume \<open>M, w \<Turnstile> K i p\<close>
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p\<close>
	by simp
	moreover have \<open>w \<in> \<K> M i w\<close>
	using \<open>reflexive M\<close> \<open>w \<in> \<W> M\<close> unfolding reflexive_def by blast
	ultimately show \<open>M, w \<Turnstile> p\<close>
	using \<open>w \<in> \<W> M\<close> by simp
	qed

	theorem pos_introspection:
	assumes \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>M, w \<Turnstile> (K i p \<^bold>\<longrightarrow> K i (K i p))\<close>
	+ shows \<open>M, w \<Turnstile> K i p \<^bold>\<longrightarrow> K i (K i p)\<close>
	proof
	assume \<open>M, w \<Turnstile> K i p\<close>
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> p\<close>
	by simp
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. \<forall>u \<in> \<W> M \<inter> \<K> M i v. M, u \<Turnstile> p\<close>
	using \<open>transitive M\<close> \<open>w \<in> \<W> M\<close> unfolding transitive_def by blast
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> K i p\<close>
	by simp
	then show \<open>M, w \<Turnstile> K i (K i p)\<close>
	by simp
	qed

	theorem neg_introspection:
	assumes \<open>symmetric M\<close> \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>M, w \<Turnstile> (\<^bold>\<not> K i p \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i p))\<close>
	+ shows \<open>M, w \<Turnstile> \<^bold>\<not> K i p \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i p)\<close>
	proof
	assume \<open>M, w \<Turnstile> \<^bold>\<not> (K i p)\<close>
	then obtain u where \<open>u \<in> \<K> M i w\<close> \<open>\<not> (M, u \<Turnstile> p)\<close> \<open>u \<in> \<W> M\<close>
	by auto
	moreover have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. u \<in> \<W> M \<inter> \<K> M i v\<close>
	using \<open>u \<in> \<K> M i w\<close> \<open>symmetric M\<close> \<open>transitive M\<close> \<open>u \<in> \<W> M\<close> \<open>w \<in> \<W> M\<close>
	unfolding symmetric_def transitive_def by blast
	ultimately have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> \<^bold>\<not> K i p\<close>
	by auto
	then show \<open>M, w \<Turnstile> K i (\<^bold>\<not> K i p)\<close>
	by simp
	qed

	section \<open>Normal Modal Logic\<close>

	primrec eval :: \<open>(id \<Rightarrow> bool) \<Rightarrow> ('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm \<Rightarrow> bool\<close> where
	\<open>eval _ _ \<^bold>\<bottom> = False\<close>
	\| \<open>eval g _ (Pro x) = g x\<close>
	\| \<open>eval g h (p \<^bold>\<or> q) = (eval g h p \<or> eval g h q)\<close>
	\| \<open>eval g h (p \<^bold>\<and> q) = (eval g h p \<and> eval g h q)\<close>
	\| \<open>eval g h (p \<^bold>\<longrightarrow> q) = (eval g h p \<longrightarrow> eval g h q)\<close>
	\| \<open>eval _ h (K i p) = h (K i p)\<close>

	abbreviation \<open>tautology p \<equiv> \<forall>g h. eval g h p\<close>

	-inductive AK :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm \<Rightarrow> bool\<close> ("_ \<turnstile> _" [50, 50] 50)
	+inductive AK :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm \<Rightarrow> bool\<close> (\<open>_ \<turnstile> _\<close> [50, 50] 50)
	for A :: \<open>'i fm \<Rightarrow> bool\<close> where
	A1: \<open>tautology p \<Longrightarrow> A \<turnstile> p\<close>
	- \| A2: \<open>A \<turnstile> (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q)\<close>
	+ \| A2: \<open>A \<turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q\<close>
	\| Ax: \<open>A p \<Longrightarrow> A \<turnstile> p\<close>
	- \| R1: \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> (p \<^bold>\<longrightarrow> q) \<Longrightarrow> A \<turnstile> q\<close>
	+ \| R1: \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> A \<turnstile> q\<close>
	\| R2: \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> K i p\<close>

	+primrec imply :: \<open>'i fm list \<Rightarrow> 'i fm \<Rightarrow> 'i fm\<close> (infixr \<open>\<^bold>\<leadsto>\<close> 56) where
	+ \<open>([] \<^bold>\<leadsto> q) = q\<close>
	+\| \<open>(p # ps \<^bold>\<leadsto> q) = (p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q)\<close>
	+
	+abbreviation AK_assms (\<open>_; _ \<turnstile> _\<close> [50, 50, 50] 50) where
	+ \<open>A; G \<turnstile> p \<equiv> \<exists>qs. set qs \<subseteq> G \<and> (A \<turnstile> qs \<^bold>\<leadsto> p)\<close>
	+
	section \<open>Soundness\<close>

	-lemma eval_semantics: \<open>eval (pi w) (\<lambda>q. Kripke W pi r, w \<Turnstile> q) p = (Kripke W pi r, w \<Turnstile> p)\<close>
	+lemma eval_semantics:
	+ \<open>eval (pi w) (\<lambda>q. \<lparr>\<W> = W, \<K> = r, \<pi> = pi\<rparr>, w \<Turnstile> q) p = (\<lparr>\<W> = W, \<K> = r, \<pi> = pi\<rparr>, w \<Turnstile> p)\<close>
	by (induct p) simp_all

	lemma tautology:
	assumes \<open>tautology p\<close>
	shows \<open>M, w \<Turnstile> p\<close>
	proof -
	- from assms have \<open>eval (g w) (\<lambda>q. Kripke W g r, w \<Turnstile> q) p\<close> for W g r
	+ from assms have \<open>eval (g w) (\<lambda>q. \<lparr>\<W> = W, \<K> = r, \<pi> = g\<rparr>, w \<Turnstile> q) p\<close> for W g r
	by simp
	- then have \<open>Kripke W g r, w \<Turnstile> p\<close> for W g r
	+ then have \<open>\<lparr>\<W> = W, \<K> = r, \<pi> = g\<rparr>, w \<Turnstile> p\<close> for W g r
	using eval_semantics by fast
	then show \<open>M, w \<Turnstile> p\<close>
	- by (metis kripke.collapse)
	+ by (metis kripke.cases)
	qed

	theorem soundness:
	- fixes M :: \<open>('i, 'w) kripke\<close>
	- assumes \<open>\<And>(M :: ('i, 'w) kripke) w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	+ assumes \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	shows \<open>A \<turnstile> p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	by (induct p arbitrary: w rule: AK.induct) (auto simp: assms tautology)

	section \<open>Derived rules\<close>

	-lemma K_A2': \<open>A \<turnstile> (K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q)\<close>
	+lemma K_A2': \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q\<close>
	proof -
	- have \<open>A \<turnstile> (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q)\<close>
	+ have \<open>A \<turnstile> K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q\<close>
	using A2 by fast
	- moreover have \<open>A \<turnstile> ((P \<^bold>\<and> Q \<^bold>\<longrightarrow> R) \<^bold>\<longrightarrow> (Q \<^bold>\<longrightarrow> P \<^bold>\<longrightarrow> R))\<close> for P Q R
	+ moreover have \<open>A \<turnstile> (P \<^bold>\<and> Q \<^bold>\<longrightarrow> R) \<^bold>\<longrightarrow> (Q \<^bold>\<longrightarrow> P \<^bold>\<longrightarrow> R)\<close> for P Q R
	by (simp add: A1)
	ultimately show ?thesis
	using R1 by fast
	qed

	lemma K_map:
	- assumes \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	- shows \<open>A \<turnstile> (K i p \<^bold>\<longrightarrow> K i q)\<close>
	+ assumes \<open>A \<turnstile> p \<^bold>\<longrightarrow> q\<close>
	+ shows \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i q\<close>
	proof -
	- note \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	+ note \<open>A \<turnstile> p \<^bold>\<longrightarrow> q\<close>
	then have \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q)\<close>
	using R2 by fast
	- moreover have \<open>A \<turnstile> (K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q)\<close>
	+ moreover have \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q\<close>
	using K_A2' by fast
	ultimately show ?thesis
	using R1 by fast
	qed

	lemma K_LK: \<open>A \<turnstile> (L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> \<^bold>\<not> K i p)\<close>
	proof -
	have \<open>A \<turnstile> (p \<^bold>\<longrightarrow> \<^bold>\<not> \<^bold>\<not> p)\<close>
	by (simp add: A1)
	moreover have \<open>A \<turnstile> ((P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> (\<^bold>\<not> Q \<^bold>\<longrightarrow> \<^bold>\<not> P))\<close> for P Q
	using A1 by force
	ultimately show ?thesis
	using K_map R1 by fast
	qed

	-primrec imply :: \<open>'i fm list \<Rightarrow> 'i fm \<Rightarrow> 'i fm\<close> where
	- \<open>imply [] q = q\<close>
	-\| \<open>imply (p # ps) q = (p \<^bold>\<longrightarrow> imply ps q)\<close>
	-
	-lemma K_imply_head: \<open>A \<turnstile> imply (p # ps) p\<close>
	+lemma K_imply_head: \<open>A \<turnstile> (p # ps \<^bold>\<leadsto> p)\<close>
	proof -
	- have \<open>tautology (imply (p # ps) p)\<close>
	+ have \<open>tautology (p # ps \<^bold>\<leadsto> p)\<close>
	by (induct ps) simp_all
	then show ?thesis
	using A1 by blast
	qed

	lemma K_imply_Cons:
	- assumes \<open>A \<turnstile> imply ps q\<close>
	- shows \<open>A \<turnstile> imply (p # ps) q\<close>
	+ assumes \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close>
	+ shows \<open>A \<turnstile> p # ps \<^bold>\<leadsto> q\<close>
	proof -
	- have \<open>A \<turnstile> (imply ps q \<^bold>\<longrightarrow> imply (p # ps) q)\<close>
	+ have \<open>A \<turnstile> (ps \<^bold>\<leadsto> q \<^bold>\<longrightarrow> p # ps \<^bold>\<leadsto> q)\<close>
	by (simp add: A1)
	with R1 assms show ?thesis .
	qed

	lemma K_right_mp:
	- assumes \<open>A \<turnstile> imply ps p\<close> \<open>A \<turnstile> imply ps (p \<^bold>\<longrightarrow> q)\<close>
	- shows \<open>A \<turnstile> imply ps q\<close>
	+ assumes \<open>A \<turnstile> ps \<^bold>\<leadsto> p\<close> \<open>A \<turnstile> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q)\<close>
	+ shows \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close>
	proof -
	- have \<open>tautology (imply ps p \<^bold>\<longrightarrow> imply ps (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> imply ps q)\<close>
	+ have \<open>tautology (ps \<^bold>\<leadsto> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q)\<close>
	by (induct ps) simp_all
	- with A1 have \<open>A \<turnstile> (imply ps p \<^bold>\<longrightarrow> imply ps (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> imply ps q)\<close> .
	+ with A1 have \<open>A \<turnstile> ps \<^bold>\<leadsto> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q\<close> .
	then show ?thesis
	using assms R1 by blast
	qed

	lemma tautology_imply_superset:
	assumes \<open>set ps \<subseteq> set qs\<close>
	- shows \<open>tautology (imply ps r \<^bold>\<longrightarrow> imply qs r)\<close>
	+ shows \<open>tautology (ps \<^bold>\<leadsto> r \<^bold>\<longrightarrow> qs \<^bold>\<leadsto> r)\<close>
	proof (rule ccontr)
	- assume \<open>\<not> tautology (imply ps r \<^bold>\<longrightarrow> imply qs r)\<close>
	- then obtain g h where \<open>\<not> eval g h (imply ps r \<^bold>\<longrightarrow> imply qs r)\<close>
	+ assume \<open>\<not> tautology (ps \<^bold>\<leadsto> r \<^bold>\<longrightarrow> qs \<^bold>\<leadsto> r)\<close>
	+ then obtain g h where \<open>\<not> eval g h (ps \<^bold>\<leadsto> r \<^bold>\<longrightarrow> qs \<^bold>\<leadsto> r)\<close>
	by blast
	- then have \<open>eval g h (imply ps r)\<close> \<open>\<not> eval g h (imply qs r)\<close>
	+ then have \<open>eval g h (ps \<^bold>\<leadsto> r)\<close> \<open>\<not> eval g h (qs \<^bold>\<leadsto> r)\<close>
	by simp_all
	then consider (np) \<open>\<exists>p \<in> set ps. \<not> eval g h p\<close> \| (r) \<open>\<forall>p \<in> set ps. eval g h p\<close> \<open>eval g h r\<close>
	by (induct ps) auto
	then show False
	proof cases
	case np
	then have \<open>\<exists>p \<in> set qs. \<not> eval g h p\<close>
	using \<open>set ps \<subseteq> set qs\<close> by blast
	- then have \<open>eval g h (imply qs r)\<close>
	+ then have \<open>eval g h (qs \<^bold>\<leadsto> r)\<close>
	by (induct qs) simp_all
	then show ?thesis
	- using \<open>\<not> eval g h (imply qs r)\<close> by blast
	+ using \<open>\<not> eval g h (qs \<^bold>\<leadsto> r)\<close> by blast
	next
	case r
	- then have \<open>eval g h (imply qs r)\<close>
	+ then have \<open>eval g h (qs \<^bold>\<leadsto> r)\<close>
	by (induct qs) simp_all
	then show ?thesis
	- using \<open>\<not> eval g h (imply qs r)\<close> by blast
	+ using \<open>\<not> eval g h (qs \<^bold>\<leadsto> r)\<close> by blast
	qed
	qed

	lemma K_imply_weaken:
	- assumes \<open>A \<turnstile> imply ps q\<close> \<open>set ps \<subseteq> set ps'\<close>
	- shows \<open>A \<turnstile> imply ps' q\<close>
	+ assumes \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close> \<open>set ps \<subseteq> set ps'\<close>
	+ shows \<open>A \<turnstile> ps' \<^bold>\<leadsto> q\<close>
	proof -
	- have \<open>tautology (imply ps q \<^bold>\<longrightarrow> imply ps' q)\<close>
	+ have \<open>tautology (ps \<^bold>\<leadsto> q \<^bold>\<longrightarrow> ps' \<^bold>\<leadsto> q)\<close>
	using \<open>set ps \<subseteq> set ps'\<close> tautology_imply_superset by blast
	- then have \<open>A \<turnstile> (imply ps q \<^bold>\<longrightarrow> imply ps' q)\<close>
	+ then have \<open>A \<turnstile> ps \<^bold>\<leadsto> q \<^bold>\<longrightarrow> ps' \<^bold>\<leadsto> q\<close>
	using A1 by blast
	then show ?thesis
	- using \<open>A \<turnstile> imply ps q\<close> R1 by blast
	+ using \<open>A \<turnstile> ps \<^bold>\<leadsto> q\<close> R1 by blast
	qed

	-lemma imply_append: \<open>imply (ps @ ps') q = imply ps (imply ps' q)\<close>
	+lemma imply_append: \<open>(ps @ ps' \<^bold>\<leadsto> q) = (ps \<^bold>\<leadsto> ps' \<^bold>\<leadsto> q)\<close>
	by (induct ps) simp_all

	lemma K_ImpI:
	- assumes \<open>A \<turnstile> imply (p # G) q\<close>
	- shows \<open>A \<turnstile> imply G (p \<^bold>\<longrightarrow> q)\<close>
	+ assumes \<open>A \<turnstile> p # G \<^bold>\<leadsto> q\<close>
	+ shows \<open>A \<turnstile> G \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q)\<close>
	proof -
	have \<open>set (p # G) \<subseteq> set (G @ [p])\<close>
	by simp
	- then have \<open>A \<turnstile> imply (G @ [p]) q\<close>
	+ then have \<open>A \<turnstile> G @ [p] \<^bold>\<leadsto> q\<close>
	using assms K_imply_weaken by blast
	- then have \<open>A \<turnstile> imply G (imply [p] q)\<close>
	+ then have \<open>A \<turnstile> G \<^bold>\<leadsto> [p] \<^bold>\<leadsto> q\<close>
	using imply_append by metis
	then show ?thesis
	by simp
	qed

	lemma K_Boole:
	- assumes \<open>A \<turnstile> imply ((\<^bold>\<not> p) # G) \<^bold>\<bottom>\<close>
	- shows \<open>A \<turnstile> imply G p\<close>
	+ assumes \<open>A \<turnstile> (\<^bold>\<not> p) # G \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	+ shows \<open>A \<turnstile> G \<^bold>\<leadsto> p\<close>
	proof -
	- have \<open>A \<turnstile> imply G (\<^bold>\<not> \<^bold>\<not> p)\<close>
	+ have \<open>A \<turnstile> G \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p\<close>
	using assms K_ImpI by blast
	- moreover have \<open>tautology (imply G (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> imply G p)\<close>
	+ moreover have \<open>tautology (G \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p)\<close>
	by (induct G) simp_all
	- then have \<open>A \<turnstile> (imply G (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> imply G p)\<close>
	+ then have \<open>A \<turnstile> (G \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p)\<close>
	using A1 by blast
	ultimately show ?thesis
	using R1 by blast
	qed

	lemma K_DisE:
	- assumes \<open>A \<turnstile> imply (p # G) r\<close> \<open>A \<turnstile> imply (q # G) r\<close> \<open>A \<turnstile> imply G (p \<^bold>\<or> q)\<close>
	- shows \<open>A \<turnstile> imply G r\<close>
	+ assumes \<open>A \<turnstile> p # G \<^bold>\<leadsto> r\<close> \<open>A \<turnstile> q # G \<^bold>\<leadsto> r\<close> \<open>A \<turnstile> G \<^bold>\<leadsto> p \<^bold>\<or> q\<close>
	+ shows \<open>A \<turnstile> G \<^bold>\<leadsto> r\<close>
	proof -
	- have \<open>tautology (imply (p # G) r \<^bold>\<longrightarrow> imply (q # G) r \<^bold>\<longrightarrow> imply G (p \<^bold>\<or> q) \<^bold>\<longrightarrow> imply G r)\<close>
	+ have \<open>tautology (p # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> q # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p \<^bold>\<or> q \<^bold>\<longrightarrow> G \<^bold>\<leadsto> r)\<close>
	by (induct G) auto
	- then have \<open>A \<turnstile> (imply (p # G) r \<^bold>\<longrightarrow> imply (q # G) r \<^bold>\<longrightarrow> imply G (p \<^bold>\<or> q) \<^bold>\<longrightarrow> imply G r)\<close>
	+ then have \<open>A \<turnstile> p # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> q # G \<^bold>\<leadsto> r \<^bold>\<longrightarrow> G \<^bold>\<leadsto> p \<^bold>\<or> q \<^bold>\<longrightarrow> G \<^bold>\<leadsto> r\<close>
	using A1 by blast
	then show ?thesis
	using assms R1 by blast
	qed

	-lemma K_mp: \<open>A \<turnstile> imply (p # (p \<^bold>\<longrightarrow> q) # G) q\<close>
	+lemma K_mp: \<open>A \<turnstile> p # (p \<^bold>\<longrightarrow> q) # G \<^bold>\<leadsto> q\<close>
	by (meson K_imply_head K_imply_weaken K_right_mp set_subset_Cons)

	lemma K_swap:
	- assumes \<open>A \<turnstile> imply (p # q # G) r\<close>
	- shows \<open>A \<turnstile> imply (q # p # G) r\<close>
	+ assumes \<open>A \<turnstile> p # q # G \<^bold>\<leadsto> r\<close>
	+ shows \<open>A \<turnstile> q # p # G \<^bold>\<leadsto> r\<close>
	using assms K_ImpI by (metis imply.simps(1-2))

	lemma K_DisL:
	- assumes \<open>A \<turnstile> imply (p # ps) q\<close> \<open>A \<turnstile> imply (p' # ps) q\<close>
	- shows \<open>A \<turnstile> imply ((p \<^bold>\<or> p') # ps) q\<close>
	+ assumes \<open>A \<turnstile> p # ps \<^bold>\<leadsto> q\<close> \<open>A \<turnstile> p' # ps \<^bold>\<leadsto> q\<close>
	+ shows \<open>A \<turnstile> (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> q\<close>
	proof -
	- have \<open>A \<turnstile> imply (p # (p \<^bold>\<or> p') # ps) q\<close> \<open>A \<turnstile> imply (p' # (p \<^bold>\<or> p') # ps) q\<close>
	+ have \<open>A \<turnstile> p # (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> q\<close> \<open>A \<turnstile> p' # (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> q\<close>
	using assms K_swap K_imply_Cons by blast+
	- moreover have \<open>A \<turnstile> imply ((p \<^bold>\<or> p') # ps) (p \<^bold>\<or> p')\<close>
	+ moreover have \<open>A \<turnstile> (p \<^bold>\<or> p') # ps \<^bold>\<leadsto> p \<^bold>\<or> p'\<close>
	using K_imply_head by blast
	ultimately show ?thesis
	using K_DisE by blast
	qed

	lemma K_distrib_K_imp:
	- assumes \<open>A \<turnstile> K i (imply G q)\<close>
	- shows \<open>A \<turnstile> imply (map (K i) G) (K i q)\<close>
	+ assumes \<open>A \<turnstile> K i (G \<^bold>\<leadsto> q)\<close>
	+ shows \<open>A \<turnstile> map (K i) G \<^bold>\<leadsto> K i q\<close>
	proof -
	- have \<open>A \<turnstile> (K i (imply G q) \<^bold>\<longrightarrow> imply (map (K i) G) (K i q))\<close>
	+ have \<open>A \<turnstile> (K i (G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q)\<close>
	proof (induct G)
	case Nil
	then show ?case
	by (simp add: A1)
	next
	case (Cons a G)
	- have \<open>A \<turnstile> (K i a \<^bold>\<and> K i (imply (a # G) q) \<^bold>\<longrightarrow> K i (imply G q))\<close>
	+ have \<open>A \<turnstile> K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i (G \<^bold>\<leadsto> q)\<close>
	by (simp add: A2)
	moreover have
	- \<open>A \<turnstile> ((K i a \<^bold>\<and> K i (imply (a # G) q) \<^bold>\<longrightarrow> K i (imply G q)) \<^bold>\<longrightarrow>
	- (K i (imply G q) \<^bold>\<longrightarrow> imply (map (K i) G) (K i q)) \<^bold>\<longrightarrow>
	- (K i a \<^bold>\<and> K i (imply (a # G) q) \<^bold>\<longrightarrow> imply (map (K i) G) (K i q)))\<close>
	+ \<open>A \<turnstile> ((K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i (G \<^bold>\<leadsto> q)) \<^bold>\<longrightarrow>
	+ (K i (G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q) \<^bold>\<longrightarrow>
	+ (K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q))\<close>
	by (simp add: A1)
	- ultimately have \<open>A \<turnstile> (K i a \<^bold>\<and> K i (imply (a # G) q) \<^bold>\<longrightarrow> imply (map (K i) G) (K i q))\<close>
	+ ultimately have \<open>A \<turnstile> K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q\<close>
	using Cons R1 by blast
	moreover have
	- \<open>A \<turnstile> ((K i a \<^bold>\<and> K i (imply (a # G) q) \<^bold>\<longrightarrow> imply (map (K i) G) (K i q)) \<^bold>\<longrightarrow>
	- (K i (imply (a # G) q) \<^bold>\<longrightarrow> K i a \<^bold>\<longrightarrow> imply (map (K i) G) (K i q)))\<close>
	+ \<open>A \<turnstile> ((K i a \<^bold>\<and> K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q) \<^bold>\<longrightarrow>
	+ (K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i a \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q))\<close>
	by (simp add: A1)
	- ultimately have \<open>A \<turnstile> (K i (imply (a # G) q) \<^bold>\<longrightarrow> K i a \<^bold>\<longrightarrow> imply (map (K i) G) (K i q))\<close>
	+ ultimately have \<open>A \<turnstile> (K i (a # G \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> K i a \<^bold>\<longrightarrow> map (K i) G \<^bold>\<leadsto> K i q)\<close>
	using R1 by blast
	then show ?case
	by simp
	qed
	then show ?thesis
	using assms R1 by blast
	qed

	+lemma K_trans: \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r\<close>
	+ by (auto intro: A1)
	+
	+lemma K_L_dual: \<open>A \<turnstile> \<^bold>\<not> L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i p\<close>
	+proof -
	+ have \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i p\<close> \<open>A \<turnstile> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> p\<close>
	+ by (auto intro: A1)
	+ then have \<open>A \<turnstile> K i (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> K i p\<close>
	+ by (auto intro: K_map)
	+ moreover have \<open>A \<turnstile> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> (\<^bold>\<not> \<^bold>\<not> P \<^bold>\<longrightarrow> Q)\<close> for P Q
	+ by (auto intro: A1)
	+ ultimately show \<open>A \<turnstile> \<^bold>\<not> \<^bold>\<not> K i (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> K i p\<close>
	+ by (auto intro: R1)
	+qed
	+
	+section \<open>Strong Soundness\<close>
	+
	+corollary soundness_imply:
	+ assumes \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	+ shows \<open>A \<turnstile> ps \<^bold>\<leadsto> p \<Longrightarrow> P; set ps \<TTurnstile>\<star> p\<close>
	+proof (induct ps arbitrary: p)
	+ case Nil
	+ then show ?case
	+ using soundness[of A P p] assms by simp
	+next
	+ case (Cons a ps)
	+ then show ?case
	+ using K_ImpI by fastforce
	+qed
	+
	+theorem strong_soundness:
	+ assumes \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	+ shows \<open>A; G \<turnstile> p \<Longrightarrow> P; G \<TTurnstile>\<star> p\<close>
	+proof safe
	+ fix qs w and M :: \<open>('a, 'b) kripke\<close>
	+ assume \<open>A \<turnstile> qs \<^bold>\<leadsto> p\<close>
	+ moreover assume \<open>set qs \<subseteq> G\<close> \<open>\<forall>q \<in> G. M, w \<Turnstile> q\<close>
	+ then have \<open>\<forall>q \<in> set qs. M, w \<Turnstile> q\<close>
	+ using \<open>set qs \<subseteq> G\<close> by blast
	+ moreover assume \<open>P M\<close> \<open>w \<in> \<W> M\<close>
	+ ultimately show \<open>M, w \<Turnstile> p\<close>
	+ using soundness_imply[of A P qs p] assms by blast
	+qed
	+
	section \<open>Completeness\<close>

	subsection \<open>Consistent sets\<close>

	definition consistent :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> bool\<close> where
	- \<open>consistent A S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> A \<turnstile> imply S' \<^bold>\<bottom>\<close>
	+ \<open>consistent A S \<equiv> \<not> (A; S \<turnstile> \<^bold>\<bottom>)\<close>

	lemma inconsistent_subset:
	assumes \<open>consistent A V\<close> \<open>\<not> consistent A ({p} \<union> V)\<close>
	- obtains V' where \<open>set V' \<subseteq> V\<close> \<open>A \<turnstile> imply (p # V') \<^bold>\<bottom>\<close>
	+ obtains V' where \<open>set V' \<subseteq> V\<close> \<open>A \<turnstile> p # V' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	proof -
	- obtain V' where V': \<open>set V' \<subseteq> ({p} \<union> V)\<close> \<open>p \<in> set V'\<close> \<open>A \<turnstile> imply V' \<^bold>\<bottom>\<close>
	+ obtain V' where V': \<open>set V' \<subseteq> ({p} \<union> V)\<close> \<open>p \<in> set V'\<close> \<open>A \<turnstile> V' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using assms unfolding consistent_def by blast
	- then have *: \<open>A \<turnstile> imply (p # V') \<^bold>\<bottom>\<close>
	+ then have *: \<open>A \<turnstile> p # V' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using K_imply_Cons by blast

	let ?S = \<open>removeAll p V'\<close>
	have \<open>set (p # V') \<subseteq> set (p # ?S)\<close>
	by auto
	- then have \<open>A \<turnstile> imply (p # ?S) \<^bold>\<bottom>\<close>
	+ then have \<open>A \<turnstile> p # ?S \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using * K_imply_weaken by blast
	moreover have \<open>set ?S \<subseteq> V\<close>
	using V'(1) by (metis Diff_subset_conv set_removeAll)
	ultimately show ?thesis
	using that by blast
	qed

	-lemma consistent_deriv:
	- assumes \<open>consistent A V\<close> \<open>A \<turnstile> p\<close>
	- shows \<open>consistent A ({p} \<union> V)\<close>
	- using assms by (metis R1 consistent_def imply.simps(2) inconsistent_subset)
	-
	lemma consistent_consequent:
	- assumes \<open>consistent A V\<close> \<open>p \<in> V\<close> \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	+ assumes \<open>consistent A V\<close> \<open>p \<in> V\<close> \<open>A \<turnstile> p \<^bold>\<longrightarrow> q\<close>
	shows \<open>consistent A ({q} \<union> V)\<close>
	proof -
	- have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> A \<turnstile> imply (p # V') \<^bold>\<bottom>\<close>
	+ have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> p # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
	using \<open>consistent A V\<close> \<open>p \<in> V\<close> unfolding consistent_def
	by (metis insert_subset list.simps(15))
	- then have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> A \<turnstile> imply (q # V') \<^bold>\<bottom>\<close>
	+ then have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> q # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
	using \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q)\<close> K_imply_head K_right_mp by (metis imply.simps(1-2))
	then show ?thesis
	using \<open>consistent A V\<close> inconsistent_subset by metis
	qed

	lemma consistent_consequent':
	assumes \<open>consistent A V\<close> \<open>p \<in> V\<close> \<open>tautology (p \<^bold>\<longrightarrow> q)\<close>
	shows \<open>consistent A ({q} \<union> V)\<close>
	using assms consistent_consequent A1 by blast

	lemma consistent_disjuncts:
	assumes \<open>consistent A V\<close> \<open>(p \<^bold>\<or> q) \<in> V\<close>
	shows \<open>consistent A ({p} \<union> V) \<or> consistent A ({q} \<union> V)\<close>
	proof (rule ccontr)
	assume \<open>\<not> ?thesis\<close>
	then have \<open>\<not> consistent A ({p} \<union> V)\<close> \<open>\<not> consistent A ({q} \<union> V)\<close>
	by blast+

	then obtain S' T' where
	- S': \<open>set S' \<subseteq> V\<close> \<open>A \<turnstile> imply (p # S') \<^bold>\<bottom>\<close> and
	- T': \<open>set T' \<subseteq> V\<close> \<open>A \<turnstile> imply (q # T') \<^bold>\<bottom>\<close>
	+ S': \<open>set S' \<subseteq> V\<close> \<open>A \<turnstile> p # S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close> and
	+ T': \<open>set T' \<subseteq> V\<close> \<open>A \<turnstile> q # T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using \<open>consistent A V\<close> inconsistent_subset by metis

	- from S' have p: \<open>A \<turnstile> imply (p # S' @ T') \<^bold>\<bottom>\<close>
	+ from S' have p: \<open>A \<turnstile> p # S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	by (metis K_imply_weaken Un_upper1 append_Cons set_append)
	- moreover from T' have q: \<open>A \<turnstile> imply (q # S' @ T') \<^bold>\<bottom>\<close>
	+ moreover from T' have q: \<open>A \<turnstile> q # S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	by (metis K_imply_head K_right_mp R1 imply.simps(2) imply_append)
	- ultimately have \<open>A \<turnstile> imply ((p \<^bold>\<or> q) # S' @ T') \<^bold>\<bottom>\<close>
	+ ultimately have \<open>A \<turnstile> (p \<^bold>\<or> q) # S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using K_DisL by blast
	- then have \<open>A \<turnstile> imply (S' @ T') \<^bold>\<bottom>\<close>
	+ then have \<open>A \<turnstile> S' @ T' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using S'(1) T'(1) p q \<open>consistent A V\<close> \<open>(p \<^bold>\<or> q) \<in> V\<close> unfolding consistent_def
	by (metis Un_subset_iff insert_subset list.simps(15) set_append)
	moreover have \<open>set (S' @ T') \<subseteq> V\<close>
	by (simp add: S'(1) T'(1))
	ultimately show False
	using \<open>consistent A V\<close> unfolding consistent_def by blast
	qed

	lemma exists_finite_inconsistent:
	assumes \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> V)\<close>
	obtains W where \<open>{\<^bold>\<not> p} \<union> W \<subseteq> {\<^bold>\<not> p} \<union> V\<close> \<open>(\<^bold>\<not> p) \<notin> W\<close> \<open>finite W\<close> \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> W)\<close>
	proof -
	- obtain W' where W': \<open>set W' \<subseteq> {\<^bold>\<not> p} \<union> V\<close> \<open>A \<turnstile> imply W' \<^bold>\<bottom>\<close>
	+ obtain W' where W': \<open>set W' \<subseteq> {\<^bold>\<not> p} \<union> V\<close> \<open>A \<turnstile> W' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using assms unfolding consistent_def by blast
	let ?S = \<open>removeAll (\<^bold>\<not> p) W'\<close>
	have \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> set ?S)\<close>
	unfolding consistent_def using W'(2) by auto
	moreover have \<open>finite (set ?S)\<close>
	by blast
	moreover have \<open>{\<^bold>\<not> p} \<union> set ?S \<subseteq> {\<^bold>\<not> p} \<union> V\<close>
	using W'(1) by auto
	moreover have \<open>(\<^bold>\<not> p) \<notin> set ?S\<close>
	by simp
	ultimately show ?thesis
	by (meson that)
	qed

	lemma inconsistent_imply:
	assumes \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> set G)\<close>
	- shows \<open>A \<turnstile> imply G p\<close>
	+ shows \<open>A \<turnstile> G \<^bold>\<leadsto> p\<close>
	using assms K_Boole K_imply_weaken unfolding consistent_def
	by (metis insert_is_Un list.simps(15))

	subsection \<open>Maximal consistent sets\<close>

	definition maximal :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> bool\<close> where
	\<open>maximal A S \<equiv> \<forall>p. p \<notin> S \<longrightarrow> \<not> consistent A ({p} \<union> S)\<close>

	theorem deriv_in_maximal:
	assumes \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>A \<turnstile> p\<close>
	shows \<open>p \<in> V\<close>
	using assms R1 inconsistent_subset unfolding consistent_def maximal_def
	by (metis imply.simps(2))

	theorem exactly_one_in_maximal:
	assumes \<open>consistent A V\<close> \<open>maximal A V\<close>
	shows \<open>p \<in> V \<longleftrightarrow> (\<^bold>\<not> p) \<notin> V\<close>
	proof
	assume \<open>p \<in> V\<close>
	then show \<open>(\<^bold>\<not> p) \<notin> V\<close>
	using assms K_mp unfolding consistent_def maximal_def
	by (metis empty_subsetI insert_subset list.set(1) list.simps(15))
	next
	assume \<open>(\<^bold>\<not> p) \<notin> V\<close>
	have \<open>A \<turnstile> (p \<^bold>\<or> \<^bold>\<not> p)\<close>
	by (simp add: A1)
	then have \<open>(p \<^bold>\<or> \<^bold>\<not> p) \<in> V\<close>
	using assms deriv_in_maximal by blast
	then have \<open>consistent A ({p} \<union> V) \<or> consistent A ({\<^bold>\<not> p} \<union> V)\<close>
	using assms consistent_disjuncts by blast
	then show \<open>p \<in> V\<close>
	using \<open>maximal A V\<close> \<open>(\<^bold>\<not> p) \<notin> V\<close> unfolding maximal_def by blast
	qed

	theorem consequent_in_maximal:
	assumes \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>p \<in> V\<close> \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close>
	shows \<open>q \<in> V\<close>
	proof -
	- have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> A \<turnstile> imply (p # (p \<^bold>\<longrightarrow> q) # V') \<^bold>\<bottom>\<close>
	+ have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> p # (p \<^bold>\<longrightarrow> q) # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
	using \<open>consistent A V\<close> \<open>p \<in> V\<close> \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close> unfolding consistent_def
	by (metis insert_subset list.simps(15))
	- then have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> A \<turnstile> imply (q # V') \<^bold>\<bottom>\<close>
	+ then have \<open>\<forall>V'. set V' \<subseteq> V \<longrightarrow> \<not> (A \<turnstile> q # V' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
	by (meson K_mp K_ImpI K_imply_weaken K_right_mp set_subset_Cons)
	then have \<open>consistent A ({q} \<union> V)\<close>
	using \<open>consistent A V\<close> inconsistent_subset by metis
	then show ?thesis
	using \<open>maximal A V\<close> unfolding maximal_def by fast
	qed

	theorem ax_in_maximal:
	assumes \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>A p\<close>
	shows \<open>p \<in> V\<close>
	using assms deriv_in_maximal Ax by blast

	theorem mcs_properties:
	assumes \<open>consistent A V\<close> and \<open>maximal A V\<close>
	shows \<open>A \<turnstile> p \<Longrightarrow> p \<in> V\<close>
	and \<open>p \<in> V \<longleftrightarrow> (\<^bold>\<not> p) \<notin> V\<close>
	and \<open>p \<in> V \<Longrightarrow> (p \<^bold>\<longrightarrow> q) \<in> V \<Longrightarrow> q \<in> V\<close>
	using assms deriv_in_maximal exactly_one_in_maximal consequent_in_maximal by blast+

	subsection \<open>Lindenbaum extension\<close>

	instantiation fm :: (countable) countable begin
	instance by countable_datatype
	end

	primrec extend :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> (nat \<Rightarrow> 'i fm) \<Rightarrow> nat \<Rightarrow> 'i fm set\<close> where
	- \<open>extend A S f 0 = S\<close> \|
	- \<open>extend A S f (Suc n) =
	+ \<open>extend A S f 0 = S\<close>
	+\| \<open>extend A S f (Suc n) =
	(if consistent A ({f n} \<union> extend A S f n)
	then {f n} \<union> extend A S f n
	else extend A S f n)\<close>

	definition Extend :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> (nat \<Rightarrow> 'i fm) \<Rightarrow> 'i fm set\<close> where
	\<open>Extend A S f \<equiv> \<Union>n. extend A S f n\<close>

	lemma Extend_subset: \<open>S \<subseteq> Extend A S f\<close>
	unfolding Extend_def using Union_upper extend.simps(1) range_eqI
	by metis

	lemma extend_bound: \<open>(\<Union>n \<le> m. extend A S f n) = extend A S f m\<close>
	by (induct m) (simp_all add: atMost_Suc)

	lemma consistent_extend: \<open>consistent A S \<Longrightarrow> consistent A (extend A S f n)\<close>
	by (induct n) simp_all

	lemma UN_finite_bound:
	assumes \<open>finite A\<close> \<open>A \<subseteq> (\<Union>n. f n)\<close>
	shows \<open>\<exists>m :: nat. A \<subseteq> (\<Union>n \<le> m. f n)\<close>
	using assms
	proof (induct rule: finite_induct)
	case (insert x A)
	then obtain m where \<open>A \<subseteq> (\<Union>n \<le> m. f n)\<close>
	by fast
	then have \<open>A \<subseteq> (\<Union>n \<le> (m + k). f n)\<close> for k
	by fastforce
	moreover obtain m' where \<open>x \<in> f m'\<close>
	using insert(4) by blast
	ultimately have \<open>{x} \<union> A \<subseteq> (\<Union>n \<le> m + m'. f n)\<close>
	by auto
	then show ?case
	by blast
	qed simp

	lemma consistent_Extend:
	assumes \<open>consistent A S\<close>
	shows \<open>consistent A (Extend A S f)\<close>
	unfolding Extend_def
	proof (rule ccontr)
	assume \<open>\<not> consistent A (\<Union>n. extend A S f n)\<close>
	- then obtain S' where \<open>A \<turnstile> imply S' \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> (\<Union>n. extend A S f n)\<close>
	+ then obtain S' where \<open>A \<turnstile> S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> (\<Union>n. extend A S f n)\<close>
	unfolding consistent_def by blast
	then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend A S f n)\<close>
	using UN_finite_bound by (metis List.finite_set)
	then have \<open>set S' \<subseteq> extend A S f m\<close>
	using extend_bound by blast
	moreover have \<open>consistent A (extend A S f m)\<close>
	using assms consistent_extend by blast
	ultimately show False
	- unfolding consistent_def using \<open>A \<turnstile> imply S' \<^bold>\<bottom>\<close> by blast
	+ unfolding consistent_def using \<open>A \<turnstile> S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close> by blast
	qed

	lemma maximal_Extend:
	assumes \<open>surj f\<close>
	shows \<open>maximal A (Extend A S f)\<close>
	proof (rule ccontr)
	assume \<open>\<not> maximal A (Extend A S f)\<close>
	then obtain p where \<open>p \<notin> Extend A S f\<close> \<open>consistent A ({p} \<union> Extend A S f)\<close>
	unfolding maximal_def using assms consistent_Extend by blast
	obtain k where n: \<open>f k = p\<close>
	using \<open>surj f\<close> unfolding surj_def by metis
	then have \<open>p \<notin> extend A S f (Suc k)\<close>
	using \<open>p \<notin> Extend A S f\<close> unfolding Extend_def by blast
	then have \<open>\<not> consistent A ({p} \<union> extend A S f k)\<close>
	using n by fastforce
	moreover have \<open>{p} \<union> extend A S f k \<subseteq> {p} \<union> Extend A S f\<close>
	unfolding Extend_def by blast
	ultimately have \<open>\<not> consistent A ({p} \<union> Extend A S f)\<close>
	unfolding consistent_def by fastforce
	then show False
	using \<open>consistent A ({p} \<union> Extend A S f)\<close> by blast
	qed

	lemma maximal_extension:
	fixes V :: \<open>('i :: countable) fm set\<close>
	assumes \<open>consistent A V\<close>
	obtains W where \<open>V \<subseteq> W\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
	proof -
	let ?W = \<open>Extend A V from_nat\<close>
	have \<open>V \<subseteq> ?W\<close>
	using Extend_subset by blast
	moreover have \<open>consistent A ?W\<close>
	using assms consistent_Extend by blast
	moreover have \<open>maximal A ?W\<close>
	using assms maximal_Extend surj_from_nat by blast
	ultimately show ?thesis
	using that by blast
	qed

	subsection \<open>Canonical model\<close>

	abbreviation pi :: \<open>'i fm set \<Rightarrow> id \<Rightarrow> bool\<close> where
	\<open>pi V x \<equiv> Pro x \<in> V\<close>

	abbreviation known :: \<open>'i fm set \<Rightarrow> 'i \<Rightarrow> 'i fm set\<close> where
	\<open>known V i \<equiv> {p. K i p \<in> V}\<close>

	abbreviation reach :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i \<Rightarrow> 'i fm set \<Rightarrow> 'i fm set set\<close> where
	\<open>reach A i V \<equiv> {W. known V i \<subseteq> W}\<close>

	abbreviation mcss :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> 'i fm set set\<close> where
	\<open>mcss A \<equiv> {W. consistent A W \<and> maximal A W}\<close>

	+abbreviation canonical :: \<open>('i fm \<Rightarrow> bool) \<Rightarrow> ('i, 'i fm set) kripke\<close> where
	+ \<open>canonical A \<equiv> \<lparr>\<W> = mcss A, \<K> = reach A, \<pi> = pi\<rparr>\<close>
	+
	lemma truth_lemma:
	- fixes A and p :: \<open>('i :: countable) fm\<close>
	- defines \<open>M \<equiv> Kripke (mcss A) pi (reach A)\<close>
	+ fixes p :: \<open>('i :: countable) fm\<close>
	assumes \<open>consistent A V\<close> and \<open>maximal A V\<close>
	- shows \<open>(p \<in> V \<longleftrightarrow> M, V \<Turnstile> p) \<and> ((\<^bold>\<not> p) \<in> V \<longleftrightarrow> M, V \<Turnstile> \<^bold>\<not> p)\<close>
	- using assms unfolding M_def
	+ shows \<open>p \<in> V \<longleftrightarrow> canonical A, V \<Turnstile> p\<close>
	+ using assms
	proof (induct p arbitrary: V)
	case FF
	then show ?case
	- proof (intro conjI impI iffI)
	+ proof safe
	assume \<open>\<^bold>\<bottom> \<in> V\<close>
	then have False
	using \<open>consistent A V\<close> K_imply_head unfolding consistent_def
	by (metis bot.extremum insert_subset list.set(1) list.simps(15))
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<bottom>\<close> ..
	+ then show \<open>canonical A, V \<Turnstile> \<^bold>\<bottom>\<close> ..
	next
	- assume \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> \<^bold>\<bottom>\<close>
	- then show \<open>(\<^bold>\<not> \<^bold>\<bottom>) \<in> V\<close>
	- using \<open>consistent A V\<close> \<open>maximal A V\<close> unfolding maximal_def
	- by (meson K_Boole inconsistent_subset consistent_def)
	- qed simp_all
	+ assume \<open>canonical A, V \<Turnstile> \<^bold>\<bottom>\<close>
	+ then show \<open>\<^bold>\<bottom> \<in> V\<close>
	+ by simp
	+ qed
	next
	case (Pro x)
	then show ?case
	- proof (intro conjI impI iffI)
	- assume \<open>(\<^bold>\<not> Pro x) \<in> V\<close>
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> Pro x\<close>
	- using \<open>consistent A V\<close> \<open>maximal A V\<close> exactly_one_in_maximal by auto
	- next
	- assume \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> Pro x\<close>
	- then show \<open>(\<^bold>\<not> Pro x) \<in> V\<close>
	- using \<open>consistent A V\<close> \<open>maximal A V\<close> exactly_one_in_maximal by auto
	- qed (simp_all add: \<open>maximal A V\<close> maximal_def)
	+ by simp
	next
	case (Dis p q)
	- have \<open>(p \<^bold>\<or> q) \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> (p \<^bold>\<or> q)\<close>
	- proof
	+ then show ?case
	+ proof safe
	assume \<open>(p \<^bold>\<or> q) \<in> V\<close>
	then have \<open>consistent A ({p} \<union> V) \<or> consistent A ({q} \<union> V)\<close>
	using \<open>consistent A V\<close> consistent_disjuncts by blast
	then have \<open>p \<in> V \<or> q \<in> V\<close>
	using \<open>maximal A V\<close> unfolding maximal_def by fast
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> (p \<^bold>\<or> q)\<close>
	+ then show \<open>canonical A, V \<Turnstile> (p \<^bold>\<or> q)\<close>
	using Dis by simp
	+ next
	+ assume \<open>canonical A, V \<Turnstile> (p \<^bold>\<or> q)\<close>
	+ then consider \<open>canonical A, V \<Turnstile> p\<close> \| \<open>canonical A, V \<Turnstile> q\<close>
	+ by auto
	+ then have \<open>p \<in> V \<or> q \<in> V\<close>
	+ using Dis by auto
	+ moreover have \<open>A \<turnstile> p \<^bold>\<longrightarrow> p \<^bold>\<or> q\<close> \<open>A \<turnstile> q \<^bold>\<longrightarrow> p \<^bold>\<or> q\<close>
	+ by (auto simp: A1)
	+ ultimately show \<open>(p \<^bold>\<or> q) \<in> V\<close>
	+ using Dis.prems deriv_in_maximal consequent_in_maximal by blast
	qed
	- moreover have \<open>(\<^bold>\<not> (p \<^bold>\<or> q)) \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> (p \<^bold>\<or> q)\<close>
	- proof
	- assume \<open>(\<^bold>\<not> (p \<^bold>\<or> q)) \<in> V\<close>
	- then have \<open>consistent A ({\<^bold>\<not> q} \<union> V)\<close> \<open>consistent A ({\<^bold>\<not> p} \<union> V)\<close>
	- using \<open>consistent A V\<close> consistent_consequent' by fastforce+
	- then have \<open>(\<^bold>\<not> p) \<in> V\<close> \<open>(\<^bold>\<not> q) \<in> V\<close>
	- using \<open>maximal A V\<close> unfolding maximal_def by fast+
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> (p \<^bold>\<or> q)\<close>
	- using Dis by simp
	- qed
	- ultimately show ?case
	- using exactly_one_in_maximal Dis by auto
	next
	case (Con p q)
	- have \<open>(p \<^bold>\<and> q) \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> (p \<^bold>\<and> q)\<close>
	- proof
	+ then show ?case
	+ proof safe
	assume \<open>(p \<^bold>\<and> q) \<in> V\<close>
	then have \<open>consistent A ({p} \<union> V)\<close> \<open>consistent A ({q} \<union> V)\<close>
	using \<open>consistent A V\<close> consistent_consequent' by fastforce+
	then have \<open>p \<in> V\<close> \<open>q \<in> V\<close>
	using \<open>maximal A V\<close> unfolding maximal_def by fast+
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> (p \<^bold>\<and> q)\<close>
	+ then show \<open>canonical A, V \<Turnstile> (p \<^bold>\<and> q)\<close>
	using Con by simp
	+ next
	+ assume \<open>canonical A, V \<Turnstile> (p \<^bold>\<and> q)\<close>
	+ then have \<open>canonical A, V \<Turnstile> p\<close> \<open>canonical A, V \<Turnstile> q\<close>
	+ by auto
	+ then have \<open>p \<in> V\<close> \<open>q \<in> V\<close>
	+ using Con by auto
	+ moreover have \<open>A \<turnstile> p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p \<^bold>\<and> q\<close>
	+ by (auto simp: A1)
	+ ultimately show \<open>(p \<^bold>\<and> q) \<in> V\<close>
	+ using Con.prems deriv_in_maximal consequent_in_maximal by blast
	qed
	- moreover have \<open>(\<^bold>\<not> (p \<^bold>\<and> q)) \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> (p \<^bold>\<and> q)\<close>
	- proof
	- assume \<open>(\<^bold>\<not> (p \<^bold>\<and> q)) \<in> V\<close>
	- then have \<open>consistent A ({\<^bold>\<not> p \<^bold>\<or> \<^bold>\<not> q} \<union> V)\<close>
	- using \<open>consistent A V\<close> consistent_consequent' by fastforce
	- then have \<open>consistent A ({\<^bold>\<not> p} \<union> V) \<or> consistent A ({\<^bold>\<not> q} \<union> V)\<close>
	- using \<open>consistent A V\<close> \<open>maximal A V\<close> consistent_disjuncts unfolding maximal_def by blast
	- then have \<open>(\<^bold>\<not> p) \<in> V \<or> (\<^bold>\<not> q) \<in> V\<close>
	- using \<open>maximal A V\<close> unfolding maximal_def by fast
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> (p \<^bold>\<and> q)\<close>
	- using Con by simp
	- qed
	- ultimately show ?case
	- using exactly_one_in_maximal Con by auto
	next
	case (Imp p q)
	- have \<open>(p \<^bold>\<longrightarrow> q) \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	- proof
	+ then show ?case
	+ proof safe
	assume \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close>
	then have \<open>consistent A ({\<^bold>\<not> p \<^bold>\<or> q} \<union> V)\<close>
	using \<open>consistent A V\<close> consistent_consequent' by fastforce
	then have \<open>consistent A ({\<^bold>\<not> p} \<union> V) \<or> consistent A ({q} \<union> V)\<close>
	using \<open>consistent A V\<close> \<open>maximal A V\<close> consistent_disjuncts unfolding maximal_def by blast
	then have \<open>(\<^bold>\<not> p) \<in> V \<or> q \<in> V\<close>
	using \<open>maximal A V\<close> unfolding maximal_def by fast
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	+ then have \<open>p \<notin> V \<or> q \<in> V\<close>
	+ using Imp.prems exactly_one_in_maximal by blast
	+ then show \<open>canonical A, V \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	using Imp by simp
	+ next
	+ assume \<open>canonical A, V \<Turnstile> (p \<^bold>\<longrightarrow> q)\<close>
	+ then consider \<open>\<not> canonical A, V \<Turnstile> p\<close> \| \<open>canonical A, V \<Turnstile> q\<close>
	+ by auto
	+ then have \<open>p \<notin> V \<or> q \<in> V\<close>
	+ using Imp by auto
	+ then have \<open>(\<^bold>\<not> p) \<in> V \<or> q \<in> V\<close>
	+ using Imp.prems exactly_one_in_maximal by blast
	+ moreover have \<open>A \<turnstile> \<^bold>\<not> p \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close> \<open>A \<turnstile> q \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close>
	+ by (auto simp: A1)
	+ ultimately show \<open>(p \<^bold>\<longrightarrow> q) \<in> V\<close>
	+ using Imp.prems deriv_in_maximal consequent_in_maximal by blast
	qed
	- moreover have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> (p \<^bold>\<longrightarrow> q)\<close>
	- proof
	- assume \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) \<in> V\<close>
	- then have \<open>consistent A ({p} \<union> V)\<close> \<open>consistent A ({\<^bold>\<not> q} \<union> V)\<close>
	- using \<open>consistent A V\<close> consistent_consequent' by fastforce+
	- then have \<open>p \<in> V\<close> \<open>(\<^bold>\<not> q) \<in> V\<close>
	- using \<open>maximal A V\<close> unfolding maximal_def by fast+
	- then show \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> (p \<^bold>\<longrightarrow> q)\<close>
	- using Imp by simp
	- qed
	- ultimately show ?case
	- using exactly_one_in_maximal Imp \<open>consistent A V\<close> by auto
	next
	case (K i p)
	- then have \<open>K i p \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> K i p\<close>
	- by auto
	- moreover have \<open>(Kripke (mcss A) pi (reach A), V \<Turnstile> K i p) \<longrightarrow> K i p \<in> V\<close>
	- proof (intro allI impI)
	- assume \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> K i p\<close>
	+ then show ?case
	+ proof safe
	+ assume \<open>K i p \<in> V\<close>
	+ then show \<open>canonical A, V \<Turnstile> K i p\<close>
	+ using K.hyps by auto
	+ next
	+ assume \<open>canonical A, V \<Turnstile> K i p\<close>

	have \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> known V i)\<close>
	proof
	assume \<open>consistent A ({\<^bold>\<not> p} \<union> known V i)\<close>
	then obtain W where W: \<open>{\<^bold>\<not> p} \<union> known V i \<subseteq> W\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
	using \<open>consistent A V\<close> maximal_extension by blast
	- then have \<open>Kripke (mcss A) pi (reach A), W \<Turnstile> \<^bold>\<not> p\<close>
	- using K \<open>consistent A V\<close> by blast
	+ then have \<open>canonical A, W \<Turnstile> \<^bold>\<not> p\<close>
	+ using K \<open>consistent A V\<close> exactly_one_in_maximal by auto
	moreover have \<open>W \<in> reach A i V\<close> \<open>W \<in> mcss A\<close>
	using W by simp_all
	- ultimately have \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> K i p\<close>
	+ ultimately have \<open>canonical A, V \<Turnstile> \<^bold>\<not> K i p\<close>
	by auto
	then show False
	- using \<open>Kripke (mcss A) pi (reach A), V \<Turnstile> K i p\<close> by auto
	+ using \<open>canonical A, V \<Turnstile> K i p\<close> by auto
	qed

	then obtain W where W:
	\<open>{\<^bold>\<not> p} \<union> W \<subseteq> {\<^bold>\<not> p} \<union> known V i\<close> \<open>(\<^bold>\<not> p) \<notin> W\<close> \<open>finite W\<close> \<open>\<not> consistent A ({\<^bold>\<not> p} \<union> W)\<close>
	using exists_finite_inconsistent by metis

	obtain L where L: \<open>set L = W\<close>
	using \<open>finite W\<close> finite_list by blast

	- then have \<open>A \<turnstile> imply L p\<close>
	+ then have \<open>A \<turnstile> L \<^bold>\<leadsto> p\<close>
	using W(4) inconsistent_imply by blast
	- then have \<open>A \<turnstile> K i (imply L p)\<close>
	+ then have \<open>A \<turnstile> K i (L \<^bold>\<leadsto> p)\<close>
	using R2 by fast
	- then have \<open>A \<turnstile> imply (map (K i) L) (K i p)\<close>
	+ then have \<open>A \<turnstile> map (K i) L \<^bold>\<leadsto> K i p\<close>
	using K_distrib_K_imp by fast
	- then have \<open>imply (map (K i) L) (K i p) \<in> V\<close>
	+ then have \<open>(map (K i) L \<^bold>\<leadsto> K i p) \<in> V\<close>
	using deriv_in_maximal K.prems(1, 2) by blast
	then show \<open>K i p \<in> V\<close>
	using L W(1-2)
	proof (induct L arbitrary: W)
	case (Cons a L)
	then have \<open>K i a \<in> V\<close>
	by auto
	- then have \<open>imply (map (K i) L) (K i p) \<in> V\<close>
	+ then have \<open>(map (K i) L \<^bold>\<leadsto> K i p) \<in> V\<close>
	using Cons(2) \<open>consistent A V\<close> \<open>maximal A V\<close> consequent_in_maximal by auto
	then show ?case
	using Cons by auto
	qed simp
	qed
	- moreover have \<open>(Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> K i p) \<longrightarrow> (\<^bold>\<not> K i p) \<in> V\<close>
	- using \<open>consistent A V\<close> \<open>maximal A V\<close> exactly_one_in_maximal calculation(1)
	- by (metis (no_types, lifting) semantics.simps(1, 5))
	- moreover have \<open>(\<^bold>\<not> K i p) \<in> V \<longrightarrow> Kripke (mcss A) pi (reach A), V \<Turnstile> \<^bold>\<not> K i p\<close>
	- using \<open>consistent A V\<close> \<open>maximal A V\<close> calculation(2) exactly_one_in_maximal by auto
	- ultimately show ?case
	- by blast
	qed

	lemma canonical_model:
	assumes \<open>consistent A S\<close> and \<open>p \<in> S\<close>
	- defines \<open>V \<equiv> Extend A S from_nat\<close> and \<open>M \<equiv> Kripke (mcss A) pi (reach A)\<close>
	+ defines \<open>V \<equiv> Extend A S from_nat\<close> and \<open>M \<equiv> canonical A\<close>
	shows \<open>M, V \<Turnstile> p\<close> and \<open>consistent A V\<close> and \<open>maximal A V\<close>
	proof -
	have \<open>consistent A V\<close>
	using \<open>consistent A S\<close> unfolding V_def using consistent_Extend by blast
	have \<open>maximal A V\<close>
	unfolding V_def using maximal_Extend surj_from_nat by blast
	-
	{ fix x
	assume \<open>x \<in> S\<close>
	then have \<open>x \<in> V\<close>
	unfolding V_def using Extend_subset by blast
	then have \<open>M, V \<Turnstile> x\<close>
	unfolding M_def using truth_lemma \<open>consistent A V\<close> \<open>maximal A V\<close> by blast }
	then show \<open>M, V \<Turnstile> p\<close>
	using \<open>p \<in> S\<close> by blast+
	show \<open>consistent A V\<close> \<open>maximal A V\<close>
	by fact+
	qed

	subsection \<open>Completeness\<close>

	-lemma imply_completeness:
	- assumes valid: \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M.
	- (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (A \<turnstile> imply qs p)\<close>
	+abbreviation valid :: \<open>(('i :: countable, 'i fm set) kripke \<Rightarrow> bool) \<Rightarrow> 'i fm set \<Rightarrow> 'i fm \<Rightarrow> bool\<close>
	+ (\<open>_; _ \<TTurnstile> _\<close> [50, 50, 50] 50)
	+ where \<open>P; G \<TTurnstile> p \<equiv> P; G \<TTurnstile>\<star> p\<close>
	+
	+theorem strong_completeness:
	+ assumes \<open>P; G \<TTurnstile> p\<close> and \<open>P (canonical A)\<close>
	+ shows \<open>A; G \<turnstile> p\<close>
	proof (rule ccontr)
	- assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> A \<turnstile> imply qs p\<close>
	- then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> A \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
	+ assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> (A \<turnstile> qs \<^bold>\<leadsto> p)\<close>
	+ then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> (A \<turnstile> (\<^bold>\<not> p) # qs \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
	using K_Boole by blast

	let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
	let ?V = \<open>Extend A ?S from_nat\<close>
	- let ?M = \<open>Kripke (mcss A) pi (reach A)\<close>
	+ let ?M = \<open>canonical A\<close>

	have \<open>consistent A ?S\<close>
	using * by (metis K_imply_Cons consistent_def inconsistent_subset)
	then have \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close>
	using canonical_model by fastforce+
	moreover have \<open>?V \<in> mcss A\<close>
	using \<open>consistent A ?S\<close> consistent_Extend maximal_Extend surj_from_nat by blast
	ultimately have \<open>?M, ?V \<Turnstile> p\<close>
	- using valid by simp
	+ using assms by simp
	then show False
	using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
	qed

	-theorem completeness:
	- assumes \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M. M, w \<Turnstile> p\<close>
	+corollary completeness:
	+ assumes \<open>P; {} \<TTurnstile> p\<close> and \<open>P (canonical A)\<close>
	shows \<open>A \<turnstile> p\<close>
	- using assms imply_completeness[where G=\<open>{}\<close>] by auto
	+ using assms strong_completeness[where G=\<open>{}\<close>] by simp
	+
	+corollary completeness\<^sub>A:
	+ assumes \<open>(\<lambda>_. True); {} \<TTurnstile> p\<close>
	+ shows \<open>A \<turnstile> p\<close>
	+ using assms completeness by blast

	section \<open>System K\<close>

	-abbreviation SystemK :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>K _" [50] 50) where
	- \<open>\<turnstile>\<^sub>K p \<equiv> (\<lambda>_. False) \<turnstile> p\<close>
	-
	-lemma soundness\<^sub>K: \<open>\<turnstile>\<^sub>K p \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	- using soundness by metis
	-
	-abbreviation \<open>valid\<^sub>K p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M. M, w \<Turnstile> p\<close>
	+abbreviation SystemK (\<open>_ \<turnstile>\<^sub>K _\<close> [50] 50) where
	+ \<open>G \<turnstile>\<^sub>K p \<equiv> (\<lambda>_. False); G \<turnstile> p\<close>

	-theorem main\<^sub>K: \<open>valid\<^sub>K p \<longleftrightarrow> \<turnstile>\<^sub>K p\<close>
	-proof
	- assume \<open>valid\<^sub>K p\<close>
	- with completeness show \<open>\<turnstile>\<^sub>K p\<close>
	- by blast
	-next
	- assume \<open>\<turnstile>\<^sub>K p\<close>
	- with soundness\<^sub>K show \<open>valid\<^sub>K p\<close>
	- by fast
	-qed
	+lemma strong_soundness\<^sub>K: \<open>G \<turnstile>\<^sub>K p \<Longrightarrow> P; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness[of \<open>\<lambda>_. False\<close> \<open>\<lambda>_. True\<close>] by fast

	-corollary
	- assumes \<open>valid\<^sub>K p\<close> and \<open>w \<in> \<W> M\<close>
	- shows \<open>M, w \<Turnstile> p\<close>
	-proof -
	- have \<open>\<turnstile>\<^sub>K p\<close>
	- using assms(1) unfolding main\<^sub>K .
	- with soundness\<^sub>K assms(2) show \<open>M, w \<Turnstile> p\<close> by fast
	-qed
	+abbreviation validK (\<open>_ \<TTurnstile>\<^sub>K _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>K p \<equiv> (\<lambda>_. True); G \<TTurnstile> p\<close>
	+
	+lemma strong_completeness\<^sub>K: \<open>G \<TTurnstile>\<^sub>K p \<Longrightarrow> G \<turnstile>\<^sub>K p\<close>
	+ using strong_completeness[of \<open>\<lambda>_. True\<close>] by blast
	+
	+theorem main\<^sub>K: \<open>G \<TTurnstile>\<^sub>K p \<longleftrightarrow> G \<turnstile>\<^sub>K p\<close>
	+ using strong_soundness\<^sub>K[of G p] strong_completeness\<^sub>K[of G p] by fast
	+
	+corollary \<open>G \<TTurnstile>\<^sub>K p \<Longrightarrow> (\<lambda>_. True); G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness\<^sub>K[of G p] strong_completeness\<^sub>K[of G p] by fast

	section \<open>System T\<close>

	text \<open>Also known as System M\<close>

	inductive AxT :: \<open>'i fm \<Rightarrow> bool\<close> where
	\<open>AxT (K i p \<^bold>\<longrightarrow> p)\<close>

	-abbreviation SystemT :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>T _" [50] 50) where
	- \<open>\<turnstile>\<^sub>T p \<equiv> AxT \<turnstile> p\<close>
	+abbreviation SystemT (\<open>_ \<turnstile>\<^sub>T _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>T p \<equiv> AxT; G \<turnstile> p\<close>

	lemma soundness_AxT: \<open>AxT p \<Longrightarrow> reflexive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	by (induct p rule: AxT.induct) (meson truth)

	-lemma soundness\<^sub>T: \<open>\<turnstile>\<^sub>T p \<Longrightarrow> reflexive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	- using soundness soundness_AxT .
	+lemma strong_soundness\<^sub>T: \<open>G \<turnstile>\<^sub>T p \<Longrightarrow> reflexive; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness soundness_AxT .

	lemma AxT_reflexive:
	- assumes \<open>\<forall>p. AxT p \<longrightarrow> A p\<close> and \<open>consistent A V\<close> and \<open>maximal A V\<close>
	+ assumes \<open>AxT \<le> A\<close> and \<open>consistent A V\<close> and \<open>maximal A V\<close>
	shows \<open>V \<in> reach A i V\<close>
	proof -
	have \<open>(K i p \<^bold>\<longrightarrow> p) \<in> V\<close> for p
	- using assms ax_in_maximal AxT.intros by metis
	+ using assms ax_in_maximal AxT.intros by fast
	then have \<open>p \<in> V\<close> if \<open>K i p \<in> V\<close> for p
	using that assms consequent_in_maximal by blast
	then show ?thesis
	using assms by blast
	qed

	-lemma mcs\<^sub>T_reflexive:
	- assumes \<open>\<forall>p. AxT p \<longrightarrow> A p\<close>
	- shows \<open>reflexive (Kripke (mcss A) pi (reach A))\<close>
	+lemma reflexive\<^sub>T:
	+ assumes \<open>AxT \<le> A\<close>
	+ shows \<open>reflexive (canonical A)\<close>
	unfolding reflexive_def
	proof safe
	fix i V
	- assume \<open>V \<in> \<W> (Kripke (mcss A) pi (reach A))\<close>
	+ assume \<open>V \<in> \<W> (canonical A)\<close>
	then have \<open>consistent A V\<close> \<open>maximal A V\<close>
	by simp_all
	with AxT_reflexive assms have \<open>V \<in> reach A i V\<close> .
	- then show \<open>V \<in> \<K> (Kripke (mcss A) pi (reach A)) i V\<close>
	+ then show \<open>V \<in> \<K> (canonical A) i V\<close>
	by simp
	qed

	-lemma imply_completeness_T:
	- assumes valid: \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M.
	- reflexive M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (AxT \<turnstile> imply qs p)\<close>
	-proof (rule ccontr)
	- assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> AxT \<turnstile> imply qs p\<close>
	- then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> AxT \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
	- using K_Boole by blast
	-
	- let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
	- let ?V = \<open>Extend AxT ?S from_nat\<close>
	- let ?M = \<open>Kripke (mcss AxT) pi (reach AxT)\<close>
	+abbreviation validT (\<open>_ \<TTurnstile>\<^sub>T _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>T p \<equiv> reflexive; G \<TTurnstile> p\<close>

	- have \<open>consistent AxT ?S\<close>
	- using * by (metis K_imply_Cons consistent_def inconsistent_subset)
	- then have \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close> \<open>consistent AxT ?V\<close> \<open>maximal AxT ?V\<close>
	- using canonical_model unfolding list_all_def by fastforce+
	- moreover have \<open>reflexive ?M\<close>
	- using mcs\<^sub>T_reflexive by fast
	- ultimately have \<open>?M, ?V \<Turnstile> p\<close>
	- using valid by auto
	- then show False
	- using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
	-qed
	+lemma strong_completeness\<^sub>T: \<open>G \<TTurnstile>\<^sub>T p \<Longrightarrow> G \<turnstile>\<^sub>T p\<close>
	+ using strong_completeness reflexive\<^sub>T by blast

	-lemma completeness\<^sub>T:
	- assumes \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M. reflexive M \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<turnstile>\<^sub>T p\<close>
	- using assms imply_completeness_T[where G=\<open>{}\<close>] by auto
	-
	-abbreviation \<open>valid\<^sub>T p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M. reflexive M \<longrightarrow> M, w \<Turnstile> p\<close>
	+theorem main\<^sub>T: \<open>G \<TTurnstile>\<^sub>T p \<longleftrightarrow> G \<turnstile>\<^sub>T p\<close>
	+ using strong_soundness\<^sub>T[of G p] strong_completeness\<^sub>T[of G p] by fast

	-theorem main\<^sub>T: \<open>valid\<^sub>T p \<longleftrightarrow> \<turnstile>\<^sub>T p\<close>
	- using soundness\<^sub>T completeness\<^sub>T by fast
	-
	-corollary
	- assumes \<open>reflexive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>T p \<longrightarrow> M, w \<Turnstile> p\<close>
	- using assms soundness\<^sub>T completeness\<^sub>T by fast
	+corollary \<open>G \<TTurnstile>\<^sub>T p \<longrightarrow> reflexive; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness\<^sub>T[of G p] strong_completeness\<^sub>T[of G p] by fast

	section \<open>System KB\<close>

	inductive AxB :: \<open>'i fm \<Rightarrow> bool\<close> where
	\<open>AxB (p \<^bold>\<longrightarrow> K i (L i p))\<close>

	-abbreviation SystemKB :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>K\<^sub>B _" [50] 50) where
	- \<open>\<turnstile>\<^sub>K\<^sub>B p \<equiv> AxB \<turnstile> p\<close>
	+abbreviation SystemKB (\<open>_ \<turnstile>\<^sub>K\<^sub>B _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>K\<^sub>B p \<equiv> AxB; G \<turnstile> p\<close>

	lemma soundness_AxB: \<open>AxB p \<Longrightarrow> symmetric M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	unfolding symmetric_def by (induct p rule: AxB.induct) auto

	-lemma soundness\<^sub>K\<^sub>B: \<open>\<turnstile>\<^sub>K\<^sub>B p \<Longrightarrow> symmetric M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	- using soundness soundness_AxB .
	+lemma strong_soundness\<^sub>K\<^sub>B: \<open>G \<turnstile>\<^sub>K\<^sub>B p \<Longrightarrow> symmetric; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness soundness_AxB .

	lemma AxB_symmetric':
	- assumes \<open>\<forall>p. AxB p \<longrightarrow> A p\<close> \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
	+ assumes \<open>AxB \<le> A\<close> \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
	and \<open>W \<in> reach A i V\<close>
	shows \<open>V \<in> reach A i W\<close>
	proof -
	have \<open>\<forall>p. K i p \<in> W \<longrightarrow> p \<in> V\<close>
	- proof (intro allI impI, rule ccontr)
	+ proof (safe, rule ccontr)
	fix p
	assume \<open>K i p \<in> W\<close> \<open>p \<notin> V\<close>
	then have \<open>(\<^bold>\<not> p) \<in> V\<close>
	using assms(2-3) exactly_one_in_maximal by fast
	then have \<open>K i (L i (\<^bold>\<not> p)) \<in> V\<close>
	using assms(1-3) ax_in_maximal AxB.intros consequent_in_maximal by fast
	then have \<open>L i (\<^bold>\<not> p) \<in> W\<close>
	using \<open>W \<in> reach A i V\<close> by fast
	then have \<open>(\<^bold>\<not> K i p) \<in> W\<close>
	using assms(4-5) by (meson K_LK consistent_consequent maximal_def)
	then show False
	using \<open>K i p \<in> W\<close> assms(4-5) exactly_one_in_maximal by fast
	qed
	then have \<open>known W i \<subseteq> V\<close>
	by blast
	then show ?thesis
	using assms(2-3) by simp
	qed

	-lemma AxB_symmetric:
	- assumes \<open>\<forall>p. AxB p \<longrightarrow> A p\<close> \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
	- shows \<open>W \<in> reach A i V \<longleftrightarrow> V \<in> reach A i W\<close>
	- using assms AxB_symmetric'[where V=V and W=W] AxB_symmetric'[where V=W and W=V]
	- by (intro iffI) blast+
	-
	-lemma mcs\<^sub>K\<^sub>B_symmetric:
	- assumes \<open>\<forall>p. AxB p \<longrightarrow> A p\<close>
	- shows \<open>symmetric (Kripke (mcss A) pi (reach A))\<close>
	+lemma symmetric\<^sub>K\<^sub>B:
	+ assumes \<open>AxB \<le> A\<close>
	+ shows \<open>symmetric (canonical A)\<close>
	unfolding symmetric_def
	proof (intro allI ballI)
	fix i V W
	- assume \<open>V \<in> \<W> (Kripke (mcss A) pi (reach A))\<close> \<open>W \<in> \<W> (Kripke (mcss A) pi (reach A))\<close>
	+ assume \<open>V \<in> \<W> (canonical A)\<close> \<open>W \<in> \<W> (canonical A)\<close>
	then have \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A W\<close> \<open>maximal A W\<close>
	by simp_all
	- with AxB_symmetric assms have \<open>W \<in> reach A i V \<longleftrightarrow> V \<in> reach A i W\<close> .
	- then show
	- \<open>(W \<in> \<K> (Kripke (mcss A) pi (reach A)) i V) = (V \<in> \<K> (Kripke (mcss A) pi (reach A)) i W)\<close>
	+ with AxB_symmetric' assms have \<open>W \<in> reach A i V \<longleftrightarrow> V \<in> reach A i W\<close>
	+ by metis
	+ then show \<open>(W \<in> \<K> (canonical A) i V) = (V \<in> \<K> (canonical A) i W)\<close>
	by simp
	qed

	-lemma imply_completeness_KB:
	- assumes valid: \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M.
	- symmetric M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (AxB \<turnstile> imply qs p)\<close>
	-proof (rule ccontr)
	- assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> AxB \<turnstile> imply qs p\<close>
	- then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> AxB \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
	- using K_Boole by blast
	-
	- let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
	- let ?V = \<open>Extend AxB ?S from_nat\<close>
	- let ?M = \<open>Kripke (mcss AxB) pi (reach AxB)\<close>
	+abbreviation validKB (\<open>_ \<TTurnstile>\<^sub>K\<^sub>B _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<equiv> symmetric; G \<TTurnstile> p\<close>

	- have \<open>consistent AxB ?S\<close>
	- using * by (metis K_imply_Cons consistent_def inconsistent_subset)
	- then have \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close> \<open>consistent AxB ?V\<close> \<open>maximal AxB ?V\<close>
	- using canonical_model unfolding list_all_def by fastforce+
	- moreover have \<open>symmetric ?M\<close>
	- using mcs\<^sub>K\<^sub>B_symmetric by fast
	- ultimately have \<open>?M, ?V \<Turnstile> p\<close>
	- using valid by auto
	- then show False
	- using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
	-qed
	+lemma strong_completeness\<^sub>K\<^sub>B: \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<Longrightarrow> G \<turnstile>\<^sub>K\<^sub>B p\<close>
	+ using strong_completeness symmetric\<^sub>K\<^sub>B by blast

	-lemma completeness\<^sub>K\<^sub>B:
	- assumes \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M. symmetric M \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<turnstile>\<^sub>K\<^sub>B p\<close>
	- using assms imply_completeness_KB[where G=\<open>{}\<close>] by auto
	-
	-abbreviation \<open>valid\<^sub>K\<^sub>B p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M. symmetric M \<longrightarrow> M, w \<Turnstile> p\<close>
	+theorem main\<^sub>K\<^sub>B: \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<longleftrightarrow> G \<turnstile>\<^sub>K\<^sub>B p\<close>
	+ using strong_soundness\<^sub>K\<^sub>B[of G p] strong_completeness\<^sub>K\<^sub>B[of G p] by fast

	-theorem main\<^sub>K\<^sub>B: \<open>valid\<^sub>K\<^sub>B p \<longleftrightarrow> \<turnstile>\<^sub>K\<^sub>B p\<close>
	- using soundness\<^sub>K\<^sub>B completeness\<^sub>K\<^sub>B by fast
	-
	-corollary
	- assumes \<open>symmetric M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>K\<^sub>B p \<longrightarrow> M, w \<Turnstile> p\<close>
	- using assms soundness\<^sub>K\<^sub>B completeness\<^sub>K\<^sub>B by fast
	+corollary \<open>G \<TTurnstile>\<^sub>K\<^sub>B p \<longrightarrow> symmetric; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness\<^sub>K\<^sub>B[of G p] strong_completeness\<^sub>K\<^sub>B[of G p] by fast

	section \<open>System K4\<close>

	inductive Ax4 :: \<open>'i fm \<Rightarrow> bool\<close> where
	\<open>Ax4 (K i p \<^bold>\<longrightarrow> K i (K i p))\<close>

	-abbreviation SystemK4 :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>K\<^sub>4 _" [50] 50) where
	- \<open>\<turnstile>\<^sub>K\<^sub>4 p \<equiv> Ax4 \<turnstile> p\<close>
	+abbreviation SystemK4 (\<open>_ \<turnstile>\<^sub>K\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>K\<^sub>4 p \<equiv> Ax4; G \<turnstile> p\<close>

	lemma soundness_Ax4: \<open>Ax4 p \<Longrightarrow> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	by (induct p rule: Ax4.induct) (meson pos_introspection)

	-lemma soundness\<^sub>K\<^sub>4: \<open>\<turnstile>\<^sub>K\<^sub>4 p \<Longrightarrow> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	- using soundness soundness_Ax4 .
	+lemma strong_soundness\<^sub>K\<^sub>4: \<open>G \<turnstile>\<^sub>K\<^sub>4 p \<Longrightarrow> transitive; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness soundness_Ax4 .

	lemma Ax4_transitive:
	- assumes \<open>\<forall>p. Ax4 p \<longrightarrow> A p\<close> \<open>consistent A V\<close> \<open>maximal A V\<close>
	+ assumes \<open>Ax4 \<le> A\<close> \<open>consistent A V\<close> \<open>maximal A V\<close>
	and \<open>W \<in> reach A i V\<close> \<open>U \<in> reach A i W\<close>
	shows \<open>U \<in> reach A i V\<close>
	proof -
	have \<open>(K i p \<^bold>\<longrightarrow> K i (K i p)) \<in> V\<close> for p
	- using assms(1-3) ax_in_maximal Ax4.intros by metis
	+ using assms(1-3) ax_in_maximal Ax4.intros by fast
	then have \<open>K i (K i p) \<in> V\<close> if \<open>K i p \<in> V\<close> for p
	using that assms(2-3) consequent_in_maximal by blast
	then show ?thesis
	using assms(4-5) by blast
	qed

	-lemma mcs\<^sub>K\<^sub>4_transitive:
	- assumes \<open>\<forall>p. Ax4 p \<longrightarrow> A p\<close>
	- shows \<open>transitive (Kripke (mcss A) pi (reach A))\<close>
	+lemma transitive\<^sub>K\<^sub>4:
	+ assumes \<open>Ax4 \<le> A\<close>
	+ shows \<open>transitive (canonical A)\<close>
	unfolding transitive_def
	proof safe
	fix i U V W
	- assume \<open>V \<in> \<W> (Kripke (mcss A) pi (reach A))\<close>
	+ assume \<open>V \<in> \<W> (canonical A)\<close>
	then have \<open>consistent A V\<close> \<open>maximal A V\<close>
	by simp_all
	moreover assume
	- \<open>W \<in> \<K> (Kripke (mcss A) pi (reach A)) i V\<close>
	- \<open>U \<in> \<K> (Kripke (mcss A) pi (reach A)) i W\<close>
	+ \<open>W \<in> \<K> (canonical A) i V\<close>
	+ \<open>U \<in> \<K> (canonical A) i W\<close>
	ultimately have \<open>U \<in> reach A i V\<close>
	- using Ax4_transitive[where V=V and W=W and U=U] assms by simp
	- then show \<open>U \<in> \<K> (Kripke (mcss A) pi (reach A)) i V\<close>
	+ using Ax4_transitive assms by simp
	+ then show \<open>U \<in> \<K> (canonical A) i V\<close>
	by simp
	qed

	-lemma imply_completeness_K4:
	- assumes valid: \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M.
	- transitive M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (Ax4 \<turnstile> imply qs p)\<close>
	-proof (rule ccontr)
	- assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> Ax4 \<turnstile> imply qs p\<close>
	- then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> Ax4 \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
	- using K_Boole by blast
	+abbreviation validK4 (\<open>_ \<TTurnstile>\<^sub>K\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<equiv> transitive; G \<TTurnstile> p\<close>

	- let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
	- let ?V = \<open>Extend Ax4 ?S from_nat\<close>
	- let ?M = \<open>Kripke (mcss Ax4) pi (reach Ax4)\<close>
	+lemma strong_completeness\<^sub>K\<^sub>4: \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<Longrightarrow> G \<turnstile>\<^sub>K\<^sub>4 p\<close>
	+ using strong_completeness transitive\<^sub>K\<^sub>4 by blast

	- have \<open>consistent Ax4 ?S\<close>
	- using * by (metis K_imply_Cons consistent_def inconsistent_subset)
	- then have \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close> \<open>consistent Ax4 ?V\<close> \<open>maximal Ax4 ?V\<close>
	- using canonical_model unfolding list_all_def by fastforce+
	- moreover have \<open>transitive ?M\<close>
	- using mcs\<^sub>K\<^sub>4_transitive by fast
	- ultimately have \<open>?M, ?V \<Turnstile> p\<close>
	- using valid by auto
	- then show False
	- using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
	+theorem main\<^sub>K\<^sub>4: \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<longleftrightarrow> G \<turnstile>\<^sub>K\<^sub>4 p\<close>
	+ using strong_soundness\<^sub>K\<^sub>4[of G p] strong_completeness\<^sub>K\<^sub>4[of G p] by fast
	+
	+corollary \<open>G \<TTurnstile>\<^sub>K\<^sub>4 p \<longrightarrow> transitive; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness\<^sub>K\<^sub>4[of G p] strong_completeness\<^sub>K\<^sub>4[of G p] by fast
	+
	+section \<open>System K5\<close>
	+
	+inductive Ax5 :: \<open>'i fm \<Rightarrow> bool\<close> where
	+ \<open>Ax5 (L i p \<^bold>\<longrightarrow> K i (L i p))\<close>
	+
	+abbreviation SystemK5 (\<open>_ \<turnstile>\<^sub>K\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>K\<^sub>5 p \<equiv> Ax5; G \<turnstile> p\<close>
	+
	+lemma soundness_Ax5: \<open>Ax5 p \<Longrightarrow> Euclidean M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	+ by (induct p rule: Ax5.induct) (unfold Euclidean_def semantics.simps, blast)
	+
	+lemma strong_soundness\<^sub>K\<^sub>5: \<open>G \<turnstile>\<^sub>K\<^sub>5 p \<Longrightarrow> Euclidean; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness soundness_Ax5 .
	+
	+lemma Ax5_Euclidean:
	+ assumes \<open>Ax5 \<le> A\<close>
	+ \<open>consistent A U\<close> \<open>maximal A U\<close>
	+ \<open>consistent A V\<close> \<open>maximal A V\<close>
	+ \<open>consistent A W\<close> \<open>maximal A W\<close>
	+ and \<open>V \<in> reach A i U\<close> \<open>W \<in> reach A i U\<close>
	+ shows \<open>W \<in> reach A i V\<close>
	+ using assms
	+proof -
	+ { fix p
	+ assume \<open>K i p \<in> V\<close> \<open>p \<notin> W\<close>
	+ then have \<open>(\<^bold>\<not> p) \<in> W\<close>
	+ using assms(6-7) exactly_one_in_maximal by fast
	+ then have \<open>L i (\<^bold>\<not> p) \<in> U\<close>
	+ using assms(2-3, 6-7, 9) exactly_one_in_maximal by blast
	+ then have \<open>K i (L i (\<^bold>\<not> p)) \<in> U\<close>
	+ using assms(1-3) ax_in_maximal Ax5.intros consequent_in_maximal by fast
	+ then have \<open>L i (\<^bold>\<not> p) \<in> V\<close>
	+ using assms(8) by blast
	+ then have \<open>\<^bold>\<not> K i p \<in> V\<close>
	+ using assms(4-5) K_LK consequent_in_maximal deriv_in_maximal by fast
	+ then have False
	+ using assms(4-5) \<open>K i p \<in> V\<close> exactly_one_in_maximal by fast
	+ }
	+ then show ?thesis
	+ by blast
	qed

	-lemma completeness\<^sub>K\<^sub>4:
	- assumes \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M. transitive M \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<turnstile>\<^sub>K\<^sub>4 p\<close>
	- using assms imply_completeness_K4[where G=\<open>{}\<close>] by auto
	-
	-abbreviation \<open>valid\<^sub>K\<^sub>4 p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M. transitive M \<longrightarrow> M, w \<Turnstile> p\<close>
	+lemma Euclidean\<^sub>K\<^sub>5:
	+ assumes \<open>Ax5 \<le> A\<close>
	+ shows \<open>Euclidean (canonical A)\<close>
	+ unfolding Euclidean_def
	+proof safe
	+ fix i U V W
	+ assume \<open>U \<in> \<W> (canonical A)\<close> \<open>V \<in> \<W> (canonical A)\<close> \<open>W \<in> \<W> (canonical A)\<close>
	+ then have
	+ \<open>consistent A U\<close> \<open>maximal A U\<close>
	+ \<open>consistent A V\<close> \<open>maximal A V\<close>
	+ \<open>consistent A W\<close> \<open>maximal A W\<close>
	+ by simp_all
	+ moreover assume
	+ \<open>V \<in> \<K> (canonical A) i U\<close>
	+ \<open>W \<in> \<K> (canonical A) i U\<close>
	+ ultimately have \<open>W \<in> reach A i V\<close>
	+ using Ax5_Euclidean assms by simp
	+ then show \<open>W \<in> \<K> (canonical A) i V\<close>
	+ by simp
	+qed

	-theorem main\<^sub>K\<^sub>4: \<open>valid\<^sub>K\<^sub>4 p \<longleftrightarrow> \<turnstile>\<^sub>K\<^sub>4 p\<close>
	- using soundness\<^sub>K\<^sub>4 completeness\<^sub>K\<^sub>4 by fast
	+abbreviation validK5 (\<open>_ \<TTurnstile>\<^sub>K\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<equiv> Euclidean; G \<TTurnstile> p\<close>

	-corollary
	- assumes \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>K\<^sub>4 p \<longrightarrow> M, w \<Turnstile> p\<close>
	- using assms soundness\<^sub>K\<^sub>4 completeness\<^sub>K\<^sub>4 by fast
	+lemma strong_completeness\<^sub>K\<^sub>5: \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<Longrightarrow> G \<turnstile>\<^sub>K\<^sub>5 p\<close>
	+ using strong_completeness Euclidean\<^sub>K\<^sub>5 by blast
	+
	+theorem main\<^sub>K\<^sub>5: \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>K\<^sub>5 p\<close>
	+ using strong_soundness\<^sub>K\<^sub>5[of G p] strong_completeness\<^sub>K\<^sub>5[of G p] by fast
	+
	+corollary \<open>G \<TTurnstile>\<^sub>K\<^sub>5 p \<longrightarrow> Euclidean; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness\<^sub>K\<^sub>5[of G p] strong_completeness\<^sub>K\<^sub>5[of G p] by fast

	section \<open>System S4\<close>

	abbreviation Or :: \<open>('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool\<close> (infixl \<open>\<oplus>\<close> 65) where
	- \<open>A \<oplus> A' \<equiv> \<lambda>x. A x \<or> A' x\<close>
	+ \<open>(A \<oplus> A') p \<equiv> A p \<or> A' p\<close>

	-abbreviation SystemS4 :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>S\<^sub>4 _" [50] 50) where
	- \<open>\<turnstile>\<^sub>S\<^sub>4 p \<equiv> AxT \<oplus> Ax4 \<turnstile> p\<close>
	+abbreviation SystemS4 (\<open>_ \<turnstile>\<^sub>S\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>S\<^sub>4 p \<equiv> AxT \<oplus> Ax4; G \<turnstile> p\<close>

	lemma soundness_AxT4: \<open>(AxT \<oplus> Ax4) p \<Longrightarrow> reflexive M \<and> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	using soundness_AxT soundness_Ax4 by fast

	-lemma soundness\<^sub>S\<^sub>4: \<open>\<turnstile>\<^sub>S\<^sub>4 p \<Longrightarrow> reflexive M \<and> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	- using soundness soundness_AxT4 .
	-
	-lemma imply_completeness_S4:
	- assumes valid: \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M.
	- reflexive M \<longrightarrow> transitive M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (AxT \<oplus> Ax4 \<turnstile> imply qs p)\<close>
	-proof (rule ccontr)
	- assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> AxT \<oplus> Ax4 \<turnstile> imply qs p\<close>
	- then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> AxT \<oplus> Ax4 \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
	- using K_Boole by blast
	-
	- let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
	- let ?V = \<open>Extend (AxT \<oplus> Ax4) ?S from_nat\<close>
	- let ?M = \<open>Kripke (mcss (AxT \<oplus> Ax4)) pi (reach (AxT \<oplus> Ax4))\<close>
	+lemma strong_soundness\<^sub>S\<^sub>4: \<open>G \<turnstile>\<^sub>S\<^sub>4 p \<Longrightarrow> refltrans; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness soundness_AxT4 .

	- have \<open>consistent (AxT \<oplus> Ax4) ?S\<close>
	- using * by (metis (no_types, lifting) K_imply_Cons consistent_def inconsistent_subset)
	- then have
	- \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close>
	- \<open>consistent (AxT \<oplus> Ax4) ?V\<close> \<open>maximal (AxT \<oplus> Ax4) ?V\<close>
	- using canonical_model unfolding list_all_def by fastforce+
	- moreover have \<open>reflexive ?M\<close> \<open>transitive ?M\<close>
	- by (simp_all add: mcs\<^sub>T_reflexive mcs\<^sub>K\<^sub>4_transitive)
	- ultimately have \<open>?M, ?V \<Turnstile> p\<close>
	- using valid by auto
	- then show False
	- using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
	-qed
	+abbreviation validS4 (\<open>_ \<TTurnstile>\<^sub>S\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<equiv> refltrans; G \<TTurnstile> p\<close>

	-lemma completeness\<^sub>S\<^sub>4:
	- assumes \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M.
	- reflexive M \<longrightarrow> transitive M \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<turnstile>\<^sub>S\<^sub>4 p\<close>
	- using assms imply_completeness_S4[where G=\<open>{}\<close>] by auto
	+lemma strong_completeness\<^sub>S\<^sub>4: \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<Longrightarrow> G \<turnstile>\<^sub>S\<^sub>4 p\<close>
	+ using strong_completeness[of refltrans] reflexive\<^sub>T[of \<open>AxT \<oplus> Ax4\<close>] transitive\<^sub>K\<^sub>4[of \<open>AxT \<oplus> Ax4\<close>]
	+ by blast

	-abbreviation \<open>valid\<^sub>S\<^sub>4 p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M.
	- reflexive M \<longrightarrow> transitive M \<longrightarrow> M, w \<Turnstile> p\<close>
	+theorem main\<^sub>S\<^sub>4: \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>4 p\<close>
	+ using strong_soundness\<^sub>S\<^sub>4[of G p] strong_completeness\<^sub>S\<^sub>4[of G p] by fast

	-theorem main\<^sub>S\<^sub>4: \<open>valid\<^sub>S\<^sub>4 p \<longleftrightarrow> \<turnstile>\<^sub>S\<^sub>4 p\<close>
	- using soundness\<^sub>S\<^sub>4 completeness\<^sub>S\<^sub>4 by fast
	-
	-corollary
	- assumes \<open>reflexive M\<close> \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>S\<^sub>4 p \<longrightarrow> M, w \<Turnstile> p\<close>
	- using assms soundness\<^sub>S\<^sub>4 completeness\<^sub>S\<^sub>4 by fast
	+corollary \<open>G \<TTurnstile>\<^sub>S\<^sub>4 p \<longrightarrow> refltrans; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness\<^sub>S\<^sub>4[of G p] strong_completeness\<^sub>S\<^sub>4[of G p] by fast

	section \<open>System S5\<close>

	-abbreviation SystemS5 :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>S\<^sub>5 _" [50] 50) where
	- \<open>\<turnstile>\<^sub>S\<^sub>5 p \<equiv> AxT \<oplus> AxB \<oplus> Ax4 \<turnstile> p\<close>
	+subsection \<open>T + B + 4\<close>
	+
	+abbreviation SystemS5 (\<open>_ \<turnstile>\<^sub>S\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>S\<^sub>5 p \<equiv> AxT \<oplus> AxB \<oplus> Ax4; G \<turnstile> p\<close>

	abbreviation AxTB4 :: \<open>'i fm \<Rightarrow> bool\<close> where
	\<open>AxTB4 \<equiv> AxT \<oplus> AxB \<oplus> Ax4\<close>

	lemma soundness_AxTB4: \<open>AxTB4 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	using soundness_AxT soundness_AxB soundness_Ax4 by fast

	-lemma soundness\<^sub>S\<^sub>5: \<open>\<turnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	- using soundness soundness_AxTB4 .
	-
	-lemma imply_completeness_S5:
	- assumes valid: \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M.
	- equivalence M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (AxTB4 \<turnstile> imply qs p)\<close>
	-proof (rule ccontr)
	- assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> AxTB4 \<turnstile> imply qs p\<close>
	- then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> AxTB4 \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
	- using K_Boole by blast
	-
	- let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
	- let ?V = \<open>Extend AxTB4 ?S from_nat\<close>
	- let ?M = \<open>Kripke (mcss AxTB4) pi (reach AxTB4)\<close>
	-
	- have \<open>consistent AxTB4 ?S\<close>
	- using * by (metis (no_types, lifting) K_imply_Cons consistent_def inconsistent_subset)
	- then have
	- \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close>
	- \<open>consistent AxTB4 ?V\<close> \<open>maximal AxTB4 ?V\<close>
	- using canonical_model unfolding list_all_def by fastforce+
	- moreover have \<open>equivalence ?M\<close>
	- by (simp add: mcs\<^sub>T_reflexive mcs\<^sub>K\<^sub>B_symmetric mcs\<^sub>K\<^sub>4_transitive)
	- ultimately have \<open>?M, ?V \<Turnstile> p\<close>
	- using valid by auto
	- then show False
	- using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
	-qed
	+lemma strong_soundness\<^sub>S\<^sub>5: \<open>G \<turnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> equivalence; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness soundness_AxTB4 .

	-lemma completeness\<^sub>S\<^sub>5:
	- assumes \<open>\<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M. equivalence M \<longrightarrow> M, w \<Turnstile> p\<close>
	- shows \<open>\<turnstile>\<^sub>S\<^sub>5 p\<close>
	- using assms imply_completeness_S5[where G=\<open>{}\<close>] by auto
	-
	-abbreviation \<open>valid\<^sub>S\<^sub>5 p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M. equivalence M \<longrightarrow> M, w \<Turnstile> p\<close>
	-
	-theorem main\<^sub>S\<^sub>5: \<open>valid\<^sub>S\<^sub>5 p \<longleftrightarrow> \<turnstile>\<^sub>S\<^sub>5 p\<close>
	- using soundness\<^sub>S\<^sub>5 completeness\<^sub>S\<^sub>5 by fast
	-
	-corollary
	- assumes \<open>equivalence M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>S\<^sub>5 p \<longrightarrow> M, w \<Turnstile> p\<close>
	- using assms soundness\<^sub>S\<^sub>5 completeness\<^sub>S\<^sub>5 by fast
	-
	-subsection \<open>Traditional formulation\<close>
	+abbreviation validS5 (\<open>_ \<TTurnstile>\<^sub>S\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<equiv> equivalence; G \<TTurnstile> p\<close>

	-inductive SystemS5' :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>S\<^sub>5'' _" [50] 50) where
	- A1': \<open>tautology p \<Longrightarrow> \<turnstile>\<^sub>S\<^sub>5' p\<close>
	-\| A2': \<open>\<turnstile>\<^sub>S\<^sub>5' (K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q)\<close>
	-\| AT': \<open>\<turnstile>\<^sub>S\<^sub>5' (K i p \<^bold>\<longrightarrow> p)\<close>
	-\| A5': \<open>\<turnstile>\<^sub>S\<^sub>5' (\<^bold>\<not> K i p \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i p))\<close>
	-\| R1': \<open>\<turnstile>\<^sub>S\<^sub>5' p \<Longrightarrow> \<turnstile>\<^sub>S\<^sub>5' (p \<^bold>\<longrightarrow> q) \<Longrightarrow> \<turnstile>\<^sub>S\<^sub>5' q\<close>
	-\| R2': \<open>\<turnstile>\<^sub>S\<^sub>5' p \<Longrightarrow> \<turnstile>\<^sub>S\<^sub>5' K i p\<close>
	+lemma strong_completeness\<^sub>S\<^sub>5: \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> G \<turnstile>\<^sub>S\<^sub>5 p\<close>
	+ using strong_completeness[of equivalence]
	+ reflexive\<^sub>T[of AxTB4] symmetric\<^sub>K\<^sub>B[of AxTB4] transitive\<^sub>K\<^sub>4[of AxTB4]
	+ by blast

	-lemma S5'_trans: \<open>\<turnstile>\<^sub>S\<^sub>5' ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r)\<close>
	- by (simp add: A1')
	+theorem main\<^sub>S\<^sub>5: \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>5 p\<close>
	+ using strong_soundness\<^sub>S\<^sub>5[of G p] strong_completeness\<^sub>S\<^sub>5[of G p] by fast

	-lemma S5'_L: \<open>\<turnstile>\<^sub>S\<^sub>5' (p \<^bold>\<longrightarrow> L i p)\<close>
	+corollary \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<longrightarrow> equivalence; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness\<^sub>S\<^sub>5[of G p] strong_completeness\<^sub>S\<^sub>5[of G p] by fast
	+
	+subsection \<open>T + 5\<close>
	+
	+abbreviation SystemS5' (\<open>_ \<turnstile>\<^sub>S\<^sub>5'' _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>S\<^sub>5' p \<equiv> AxT \<oplus> Ax5; G \<turnstile> p\<close>
	+
	+abbreviation AxT5 :: \<open>'i fm \<Rightarrow> bool\<close> where
	+ \<open>AxT5 \<equiv> AxT \<oplus> Ax5\<close>
	+
	+lemma symm_trans_Euclid: \<open>symmetric M \<Longrightarrow> transitive M \<Longrightarrow> Euclidean M\<close>
	+ unfolding symmetric_def transitive_def Euclidean_def by blast
	+
	+lemma soundness_AxT5: \<open>AxT5 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
	+ using soundness_AxT[of p M w] soundness_Ax5[of p M w] symm_trans_Euclid by blast
	+
	+lemma strong_soundness\<^sub>S\<^sub>5': \<open>G \<turnstile>\<^sub>S\<^sub>5' p \<Longrightarrow> equivalence; G \<TTurnstile>\<star> p\<close>
	+ using strong_soundness soundness_AxT5 .
	+
	+lemma refl_Euclid_equiv: \<open>reflexive M \<Longrightarrow> Euclidean M \<Longrightarrow> equivalence M\<close>
	+ unfolding reflexive_def symmetric_def transitive_def Euclidean_def by metis
	+
	+lemma strong_completeness\<^sub>S\<^sub>5': \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> G \<turnstile>\<^sub>S\<^sub>5' p\<close>
	+ using strong_completeness[of equivalence]
	+ reflexive\<^sub>T[of AxT5] Euclidean\<^sub>K\<^sub>5[of AxT5] refl_Euclid_equiv by blast
	+
	+theorem main\<^sub>S\<^sub>5': \<open>G \<TTurnstile>\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>5' p\<close>
	+ using strong_soundness\<^sub>S\<^sub>5'[of G p] strong_completeness\<^sub>S\<^sub>5'[of G p] by fast
	+
	+subsection \<open>Equivalence between systems\<close>
	+
	+subsubsection \<open>Axiom 5 from B and 4\<close>
	+
	+lemma K4_L:
	+ assumes \<open>Ax4 \<le> A\<close>
	+ shows \<open>A \<turnstile> L i (L i p) \<^bold>\<longrightarrow> L i p\<close>
	proof -
	- have \<open>\<turnstile>\<^sub>S\<^sub>5' (K i (\<^bold>\<not> p) \<^bold>\<longrightarrow> \<^bold>\<not> p)\<close>
	- using AT' by fast
	- moreover have \<open>\<turnstile>\<^sub>S\<^sub>5' ((P \<^bold>\<longrightarrow> \<^bold>\<not> Q) \<^bold>\<longrightarrow> Q \<^bold>\<longrightarrow> \<^bold>\<not> P)\<close> for P Q :: \<open>'i fm\<close>
	- using A1' by force
	- ultimately show ?thesis
	- using R1' by blast
	+ have \<open>A \<turnstile> K i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i (K i (\<^bold>\<not> p))\<close>
	+ using assms by (auto intro: Ax Ax4.intros)
	+ then show ?thesis
	+ by (meson K_LK K_trans R1)
	qed

	-lemma S5'_B: \<open>\<turnstile>\<^sub>S\<^sub>5' (p \<^bold>\<longrightarrow> K i (L i p))\<close>
	- using A5' S5'_L R1' S5'_trans by metis
	-
	-lemma S5'_KL: \<open>\<turnstile>\<^sub>S\<^sub>5' (K i p \<^bold>\<longrightarrow> L i p)\<close>
	- by (meson AT' R1' S5'_L S5'_trans)
	-
	-lemma S5'_map_K:
	- assumes \<open>\<turnstile>\<^sub>S\<^sub>5' (p \<^bold>\<longrightarrow> q)\<close>
	- shows \<open>\<turnstile>\<^sub>S\<^sub>5' (K i p \<^bold>\<longrightarrow> K i q)\<close>
	+lemma KB4_5:
	+ assumes \<open>AxB \<le> A\<close> \<open>Ax4 \<le> A\<close>
	+ shows \<open>A \<turnstile> L i p \<^bold>\<longrightarrow> K i (L i p)\<close>
	proof -
	- note \<open>\<turnstile>\<^sub>S\<^sub>5' (p \<^bold>\<longrightarrow> q)\<close>
	- then have \<open>\<turnstile>\<^sub>S\<^sub>5' K i (p \<^bold>\<longrightarrow> q)\<close>
	- using R2' by fast
	- moreover have \<open>\<turnstile>\<^sub>S\<^sub>5' (K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q)\<close>
	- using A2' by fast
	+ have \<open>A \<turnstile> L i p \<^bold>\<longrightarrow> K i (L i (L i p))\<close>
	+ using assms by (auto intro: Ax AxB.intros)
	+ moreover have \<open>A \<turnstile> L i (L i p) \<^bold>\<longrightarrow> L i p\<close>
	+ using assms by (auto intro: K4_L)
	+ then have \<open>A \<turnstile> K i (L i (L i p)) \<^bold>\<longrightarrow> K i (L i p)\<close>
	+ using K_map by fast
	ultimately show ?thesis
	- using R1' by fast
	-qed
	-
	-lemma S5'_map_L:
	- assumes \<open>\<turnstile>\<^sub>S\<^sub>5' (p \<^bold>\<longrightarrow> q)\<close>
	- shows \<open>\<turnstile>\<^sub>S\<^sub>5' (L i p \<^bold>\<longrightarrow> L i q)\<close>
	- using assms by (metis R1' S5'_map_K S5'_trans)
	-
	-lemma S5'_L_dual: \<open>\<turnstile>\<^sub>S\<^sub>5' (\<^bold>\<not> L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i p)\<close>
	-proof -
	- have \<open>\<turnstile>\<^sub>S\<^sub>5' (K i p \<^bold>\<longrightarrow> K i p)\<close> \<open>\<turnstile>\<^sub>S\<^sub>5' (\<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> p)\<close>
	- by (simp_all add: A1')
	- then have \<open>\<turnstile>\<^sub>S\<^sub>5' (K i (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> K i p)\<close>
	- by (simp add: S5'_map_K)
	- moreover have \<open>\<turnstile>\<^sub>S\<^sub>5' ((P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> (\<^bold>\<not> \<^bold>\<not> P \<^bold>\<longrightarrow> Q))\<close> for P Q :: \<open>'i fm\<close>
	- by (simp add: A1')
	- ultimately show \<open>\<turnstile>\<^sub>S\<^sub>5' (\<^bold>\<not> \<^bold>\<not> K i (\<^bold>\<not> \<^bold>\<not> p) \<^bold>\<longrightarrow> K i p)\<close>
	- using R1' by blast
	+ using K_trans R1 by metis
	qed

	-lemma S5'_4: \<open>\<turnstile>\<^sub>S\<^sub>5' (K i p \<^bold>\<longrightarrow> K i (K i p))\<close>
	+subsubsection \<open>Axioms B and 4 from T and 5\<close>
	+
	+lemma T_L:
	+ assumes \<open>AxT \<le> A\<close>
	+ shows \<open>A \<turnstile> p \<^bold>\<longrightarrow> L i p\<close>
	proof -
	- have \<open>\<turnstile>\<^sub>S\<^sub>5' (L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i (L i (\<^bold>\<not> p)))\<close>
	- using A5' by fast
	- moreover have \<open>\<turnstile>\<^sub>S\<^sub>5' ((P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> \<^bold>\<not> Q \<^bold>\<longrightarrow> \<^bold>\<not> P)\<close> for P Q :: \<open>'i fm\<close>
	- using A1' by force
	- ultimately have \<open>\<turnstile>\<^sub>S\<^sub>5' (\<^bold>\<not> K i (L i (\<^bold>\<not> p)) \<^bold>\<longrightarrow> \<^bold>\<not> L i (\<^bold>\<not> p))\<close>
	- using R1' by fast
	- then have \<open>\<turnstile>\<^sub>S\<^sub>5' (L i (K i (\<^bold>\<not> \<^bold>\<not> p)) \<^bold>\<longrightarrow> \<^bold>\<not> L i (\<^bold>\<not> p))\<close>
	- by blast
	- moreover have \<open>\<turnstile>\<^sub>S\<^sub>5' (p \<^bold>\<longrightarrow> \<^bold>\<not> \<^bold>\<not> p)\<close>
	- by (simp add: A1')
	- ultimately have \<open>\<turnstile>\<^sub>S\<^sub>5' (L i (K i p) \<^bold>\<longrightarrow> \<^bold>\<not> L i (\<^bold>\<not> p))\<close>
	- by (metis (no_types, opaque_lifting) R1' S5'_map_K S5'_trans)
	- then have \<open>\<turnstile>\<^sub>S\<^sub>5' (L i (K i p) \<^bold>\<longrightarrow> K i p)\<close>
	- by (meson S5'_L_dual R1' S5'_trans)
	- then show ?thesis
	- by (metis A2' R1' R2' S5'_B S5'_trans)
	+ have \<open>A \<turnstile> K i (\<^bold>\<not> p) \<^bold>\<longrightarrow> \<^bold>\<not> p\<close>
	+ using assms by (auto intro: Ax AxT.intros)
	+ moreover have \<open>A \<turnstile> (P \<^bold>\<longrightarrow> \<^bold>\<not> Q) \<^bold>\<longrightarrow> Q \<^bold>\<longrightarrow> \<^bold>\<not> P\<close> for P Q
	+ by (auto intro: A1)
	+ ultimately show ?thesis
	+ by (auto intro: R1)
	qed

	-lemma S5_S5': \<open>\<turnstile>\<^sub>S\<^sub>5 p \<Longrightarrow> \<turnstile>\<^sub>S\<^sub>5' p\<close>
	+lemma S5'_B:
	+ assumes \<open>AxT \<le> A\<close> \<open>Ax5 \<le> A\<close>
	+ shows \<open>A \<turnstile> p \<^bold>\<longrightarrow> K i (L i p)\<close>
	+proof -
	+ have \<open>A \<turnstile> L i p \<^bold>\<longrightarrow> K i (L i p)\<close>
	+ using assms(2) by (auto intro: Ax Ax5.intros)
	+ moreover have \<open>A \<turnstile> p \<^bold>\<longrightarrow> L i p\<close>
	+ using assms(1) by (auto intro: T_L)
	+ ultimately show ?thesis
	+ using K_trans R1 by metis
	+qed
	+
	+lemma K5_L:
	+ assumes \<open>Ax5 \<le> A\<close>
	+ shows \<open>A \<turnstile> L i (K i p) \<^bold>\<longrightarrow> K i p\<close>
	+proof -
	+ have \<open>A \<turnstile> L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i (L i (\<^bold>\<not> p))\<close>
	+ using assms by (auto intro: Ax Ax5.intros)
	+ then have \<open>A \<turnstile> L i (\<^bold>\<not> p) \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i p)\<close>
	+ using K_LK by (metis K_map K_trans R1)
	+ moreover have \<open>A \<turnstile> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> \<^bold>\<not> Q \<^bold>\<longrightarrow> \<^bold>\<not> P\<close> for P Q
	+ by (auto intro: A1)
	+ ultimately have \<open>A \<turnstile> \<^bold>\<not> K i (\<^bold>\<not> K i p) \<^bold>\<longrightarrow> \<^bold>\<not> L i (\<^bold>\<not> p)\<close>
	+ using R1 by blast
	+ then have \<open>A \<turnstile> \<^bold>\<not> K i (\<^bold>\<not> K i p) \<^bold>\<longrightarrow> K i p\<close>
	+ using K_L_dual R1 K_trans by metis
	+ then show ?thesis
	+ by blast
	+qed
	+
	+lemma S5'_4:
	+ assumes \<open>AxT \<le> A\<close> \<open>Ax5 \<le> A\<close>
	+ shows \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i (K i p)\<close>
	+proof -
	+ have \<open>A \<turnstile> L i (K i p) \<^bold>\<longrightarrow> K i (L i (K i p))\<close>
	+ using assms(2) by (auto intro: Ax Ax5.intros)
	+ moreover have \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> L i (K i p)\<close>
	+ using assms(1) by (auto intro: T_L)
	+ ultimately have \<open>A \<turnstile> K i p \<^bold>\<longrightarrow> K i (L i (K i p))\<close>
	+ using K_trans R1 by metis
	+ moreover have \<open>A \<turnstile> L i (K i p) \<^bold>\<longrightarrow> K i p\<close>
	+ using assms(2) K5_L by metis
	+ then have \<open>A \<turnstile> K i (L i (K i p)) \<^bold>\<longrightarrow> K i (K i p)\<close>
	+ using K_map by fast
	+ ultimately show ?thesis
	+ using R1 K_trans by metis
	+qed
	+
	+lemma S5_S5': \<open>AxTB4 \<turnstile> p \<Longrightarrow> AxT5 \<turnstile> p\<close>
	proof (induct p rule: AK.induct)
	- case (A2 i p q)
	- have \<open>\<turnstile>\<^sub>S\<^sub>5' (K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i p \<^bold>\<longrightarrow> K i q)\<close>
	- using A2' .
	- moreover have \<open>\<turnstile>\<^sub>S\<^sub>5' ((P \<^bold>\<longrightarrow> Q \<^bold>\<longrightarrow> R) \<^bold>\<longrightarrow> (Q \<^bold>\<and> P \<^bold>\<longrightarrow> R))\<close> for P Q R :: \<open>'i fm\<close>
	- by (simp add: A1')
	- ultimately show ?case
	- using R1' by blast
	-next
	case (Ax p)
	- then show ?case
	- using AT' S5'_B S5'_4
	- by (metis Ax4.cases AxB.cases AxT.cases)
	-qed (meson SystemS5'.intros)+
	+ moreover have \<open>AxT5 \<turnstile> p\<close> if \<open>AxT p\<close>
	+ using that AK.Ax by metis
	+ moreover have \<open>AxT5 \<turnstile> p\<close> if \<open>AxB p\<close>
	+ using that S5'_B by (metis (no_types, lifting) AxB.cases predicate1I)
	+ moreover have \<open>AxT5 \<turnstile> p\<close> if \<open>Ax4 p\<close>
	+ using that S5'_4 by (metis (no_types, lifting) Ax4.cases predicate1I)
	+ ultimately show ?case
	+ by blast
	+qed (auto intro: AK.intros)

	-lemma S5'_S5:
	- fixes p :: \<open>('i :: countable) fm\<close>
	- shows \<open>\<turnstile>\<^sub>S\<^sub>5' p \<Longrightarrow> \<turnstile>\<^sub>S\<^sub>5 p\<close>
	-proof (induct p rule: SystemS5'.induct)
	- case (AT' i p)
	- then show ?case
	- by (simp add: Ax AxT.intros)
	-next
	- case (A5' i p)
	- then show ?case
	- using completeness\<^sub>S\<^sub>5 neg_introspection by fast
	-qed (meson AK.intros K_A2')+
	+lemma S5'_S5: \<open>AxT5 \<turnstile> p \<Longrightarrow> AxTB4 \<turnstile> p\<close>
	+proof (induct p rule: AK.induct)
	+ case (Ax p)
	+ moreover have \<open>AxTB4 \<turnstile> p\<close> if \<open>AxT p\<close>
	+ using that AK.Ax by metis
	+ moreover have \<open>AxTB4 \<turnstile> p\<close> if \<open>Ax5 p\<close>
	+ using that KB4_5 by (metis (no_types, lifting) Ax5.cases predicate1I)
	+ ultimately show ?case
	+ by blast
	+qed (auto intro: AK.intros)

	-theorem main\<^sub>S\<^sub>5': \<open>valid\<^sub>S\<^sub>5 p \<longleftrightarrow> \<turnstile>\<^sub>S\<^sub>5' p\<close>
	- using main\<^sub>S\<^sub>5 S5_S5' S5'_S5 by blast
	+corollary S5_S5'_assms: \<open>G \<turnstile>\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>S\<^sub>5' p\<close>
	+ using S5_S5' S5'_S5 by blast

	section \<open>Acknowledgements\<close>

	text \<open>
	The formalization is inspired by Berghofer's formalization of Henkin-style completeness.

	\<^item> Stefan Berghofer:
	First-Order Logic According to Fitting.
	\<^url>\<open>https://www.isa-afp.org/entries/FOL-Fitting.shtml\<close>
	\<close>

	end
	diff --git a/thys/Equivalence_Relation_Enumeration/Equivalence_Relation_Enumeration.thy b/thys/Equivalence_Relation_Enumeration/Equivalence_Relation_Enumeration.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Equivalence_Relation_Enumeration/Equivalence_Relation_Enumeration.thy
	@@ -0,0 +1,591 @@
	+section \<open>Introduction\<close>
	+
	+theory Equivalence_Relation_Enumeration
	+ imports "HOL-Library.Sublist" "HOL-Library.Disjoint_Sets"
	+ "Card_Equiv_Relations.Card_Equiv_Relations"
	+begin
	+
	+text \<open>As mentioned in the abstract the enumeration algorithm relies on the bijection between
	+restricted growth functions (RGFs) of length @{term "n"} and the equivalence relations on
	+@{term "{..<n}"}, where the bijection is the operation that forms the equivalence kernels of an RGF.
	+The method is being dicussed, for example, by~\cite{hutchinson1963, milne1977} or
	+\cite[\textsection 1.5]{white1986}.
	+
	+An enumeration algorithm for RGFs is less convoluted than one for equivalence relations or
	+partitions and the representation has the advantage that checking whether a pair of elements are
	+equivalent can be done by performing two list lookup operations.
	+
	+After a few preliminary results in the following section, Section~\ref{sec:enum_rgf} introduces the
	+enumeration algorithm for RGFs and shows that the function enumerates all of them (for the given
	+length) without repetition. Section~\ref{sec:bij_kernel} shows that the operation of forming the
	+equivalence kernel is a bijection and concludes with the correctness of the entire algorithm. In
	+Section~\ref{sec:app} an interesting application is being discussed, where the enumeration of
	+partitions is applied within a proof. Section~\ref{sec:add} contains a few additional results,
	+such as the fact that the length of the enumerated list is a Bell number. The latter result relies
	+on the formalization of the cardinality of equivalence relations by
	+Bulwahn~\cite{Card_Equiv_Relations-AFP}.\<close>
	+
	+section \<open>Preliminary Results\<close>
	+
	+text \<open>This section contains a few preliminary results used in the proofs below.\<close>
	+
	+lemma length_filter:"length (filter p xs) = sum_list (map (\<lambda>x. of_bool ( p x)) xs)"
	+ by (induct xs, simp_all)
	+
	+lemma count_list_expand:"count_list xs x = length (filter ((=) x) xs)"
	+ by (induct xs, simp_all)
	+
	+text \<open>An induction schema (similar to @{thm [source] list_induct2} and @{thm [source] rev_induct})
	+for two lists of equal length, where induction step is shown appending elements at the end.\<close>
	+
	+lemma list_induct_2_rev[consumes 1, case_names Nil Cons]:
	+ assumes "length x = length y"
	+ assumes "P [] []"
	+ assumes "\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (xs@[x]) (ys@[y])"
	+ shows "P x y"
	+ using assms(1)
	+proof (induct "length x" arbitrary: x y)
	+ case 0
	+ then show ?case using assms(2) by simp
	+next
	+ case (Suc n)
	+ obtain x1 x2 where a:"x = x1@[x2]" and c:"length x1 = n"
	+ by (metis Suc(2) append_butlast_last_id length_append_singleton
	+ length_greater_0_conv nat.inject zero_less_Suc)
	+
	+ obtain y1 y2 where b:"y = y1@[y2]" and d:"length y1 = n"
	+ by (metis Suc(2,3) append_butlast_last_id length_append_singleton
	+ length_greater_0_conv nat.inject zero_less_Suc)
	+
	+ have "P x1 y1" using c d Suc by simp
	+ hence "P (x1@[x2]) (y1@[y2])" using assms(3) c d by simp
	+ thus ?case using a b by simp
	+qed
	+
	+text \<open>If all but one value of a sum is zero then it can be evaluated on the remaining point:\<close>
	+
	+lemma sum_collapse:
	+ fixes f :: "'a \<Rightarrow> 'b::{comm_monoid_add}"
	+ assumes "finite A"
	+ assumes "z \<in> A"
	+ assumes "\<And>y. y \<in> A \<Longrightarrow> y \<noteq> z \<Longrightarrow> f y = 0"
	+ shows "sum f A = f z"
	+ using sum.union_disjoint[where A="A-{z}" and B="{z}" and g="f"]
	+ by (simp add: assms sum.insert_if)
	+
	+text \<open>Number of occurrences of elements in lists is preserved under injective maps.\<close>
	+
	+lemma count_list_inj_map:
	+ assumes "inj_on f (set x)"
	+ assumes "y \<in> set x"
	+ shows "count_list (map f x) (f y) = count_list x y"
	+ using assms by (induction x, simp_all, fastforce)
	+
	+text \<open>A relation cannot be an equivalence relation on two distinct sets.\<close>
	+
	+lemma equiv_on_unique:
	+ assumes "equiv A p"
	+ assumes "equiv B p"
	+ shows "A = B"
	+ by (meson assms equalityI equiv_class_eq_iff subsetI)
	+
	+text \<open>The restriction of an equivalence relation is itself an equivalence relation.\<close>
	+
	+lemma equiv_subset:
	+ assumes "B \<subseteq> A"
	+ assumes "equiv A p"
	+ shows "equiv B (Restr p B)"
	+proof -
	+ have "refl_on B (Restr p B)" using assms by (simp add:refl_on_def equiv_def, blast)
	+ moreover have "sym (Restr p B)" using assms by (simp add:sym_def equiv_def)
	+ moreover have "trans (Restr p B)"
	+ using assms by (simp add:trans_def equiv_def, blast)
	+ ultimately show ?thesis by (simp add:equiv_def)
	+qed
	+
	+section \<open>Enumerating Restricted Growth Functions\label{sec:enum_rgf}\<close>
	+
	+fun rgf_limit :: "nat list \<Rightarrow> nat"
	+ where
	+ "rgf_limit [] = 0" \|
	+ "rgf_limit (x#xs) = max (x+1) (rgf_limit xs)"
	+
	+lemma rgf_limit_snoc: "rgf_limit (x@[y]) = max (y+1) (rgf_limit x)"
	+ by (induction x, simp_all)
	+
	+lemma rgf_limit_ge: "y \<in> set xs \<Longrightarrow> y < rgf_limit xs"
	+ by (induction xs, simp_all, metis lessI max_less_iff_conj not_less_eq)
	+
	+definition rgf :: "nat list \<Rightarrow> bool"
	+ where "rgf x = (\<forall>ys y. prefix (ys@[y]) x \<longrightarrow> y \<le> rgf_limit ys)"
	+
	+text \<open>The function @{term "rgf_limit"} returns the smallest natural number larger than all list
	+elements, it is the largest allowed value following @{term "xs"} for restricted growth functions.
	+The definition @{term "rgf"} is the predicate capturing the notion.\<close>
	+
	+fun enum_rgfs :: "nat \<Rightarrow> (nat list) list"
	+ where
	+ "enum_rgfs 0 = [[]]" \|
	+ "enum_rgfs (Suc n) = [(x@[y]). x \<leftarrow> enum_rgfs n, y \<leftarrow> [0..<rgf_limit x+1]]"
	+
	+text \<open>The function @{term "enum_rgfs n"} returns all RGFs of length @{term "n"} without repetition.
	+The fact is verified in the three lemmas at the end of this section.\<close>
	+
	+lemma rgf_snoc:
	+ "rgf (xs@[x]) \<longleftrightarrow> rgf xs \<and> x < rgf_limit xs + 1"
	+ unfolding rgf_def by (rule order_antisym, (simp add:less_Suc_eq_le)+)
	+
	+lemma rgf_imp_initial_segment:
	+ "rgf xs \<Longrightarrow> set xs = {..<rgf_limit xs}"
	+proof (induction xs rule:rev_induct)
	+ case Nil
	+ then show ?case by simp
	+next
	+ case (snoc x xs)
	+ have c:"rgf xs" using snoc(2) rgf_snoc by simp
	+ hence a:"set xs = {..<rgf_limit xs}" using snoc(1) by simp
	+ have b: "x \<le> rgf_limit xs" using snoc(2) rgf_snoc c by simp
	+ have "set (xs@[x]) = insert x {..<rgf_limit xs}"
	+ using a by simp
	+ also have "... = {..<max (x+1) (rgf_limit xs)}" using b
	+ by (cases "x < rgf_limit xs", simp add:insert_absorb, simp add:lessThan_Suc)
	+ also have "... = {..<rgf_limit (xs@[x])}"
	+ using rgf_limit_snoc by simp
	+ finally show ?case by simp
	+qed
	+
	+lemma enum_rgfs_returns_rgfs:
	+ assumes "x \<in> set (enum_rgfs n)"
	+ shows "rgf x"
	+ using assms
	+proof (induction n arbitrary: x)
	+ case 0
	+ then show ?case by (simp add:rgf_def)
	+next
	+ case (Suc n)
	+ obtain x1 x2 where
	+ x_def:"x = x1@[x2]" "x2 < rgf_limit x1 + 1" "x1 \<in> set (enum_rgfs n)"
	+ using Suc by (simp add:image_iff, force)
	+ have a:"rgf x1" using Suc x_def by blast
	+ thus ?case using x_def by (simp add:rgf_snoc)
	+qed
	+
	+lemma enum_rgfs_len:
	+ assumes "x \<in> set (enum_rgfs n)"
	+ shows "length x = n"
	+ using assms by (induction n arbitrary: x, simp_all, fastforce)
	+
	+lemma equiv_rels_enum:
	+ assumes "rgf x"
	+ shows "count_list (enum_rgfs (length x)) x = 1"
	+ using assms
	+proof (induction x rule:rev_induct)
	+ case Nil
	+ then show ?case by simp
	+next
	+ case (snoc x xs)
	+ have b:"rgf xs" using snoc(2) rgf_def by simp
	+ hence "x < rgf_limit xs + 1" using rgf_snoc snoc by blast
	+ hence a:"card ({0..<rgf_limit xs + 1} \<inter> {x}) = 1" by force
	+ have "1 = count_list (enum_rgfs (length xs)) xs" using snoc b by simp
	+ also have "... = (\<Sum>r1\<leftarrow>enum_rgfs (length xs). of_bool (xs = r1) *
	+ card ({0..<rgf_limit xs + 1} \<inter> {x}))"
	+ using a by (simp add:length_concat filter_concat count_list_expand length_filter)
	+ also have "... = (\<Sum>r1\<leftarrow>enum_rgfs (length xs). of_bool (xs = r1) *
	+ card ({0..<rgf_limit r1 + 1} \<inter> {x}))"
	+ by (metis (mono_tags, opaque_lifting) mult_eq_0_iff of_bool_eq_0_iff)
	+ also have "... = (\<Sum>r1\<leftarrow>enum_rgfs (length xs). of_bool (xs = r1) *
	+ (\<Sum>r2\<leftarrow>[0..<rgf_limit r1 + 1]. of_bool (x = r2)))"
	+ by (simp add:interv_sum_list_conv_sum_set_nat del:One_nat_def)
	+ also have "... = length (filter ((=) (xs@[x])) (enum_rgfs (length (xs@[x]))))"
	+ by (simp add:length_concat filter_concat length_filter comp_def
	+ of_bool_conj sum_list_const_mult del:upt_Suc)
	+ also have "... = count_list (enum_rgfs (length (xs@[x]))) (xs@[x])"
	+ by (simp add:count_list_expand length_filter del:enum_rgfs.simps)
	+ finally show ?case by presburger
	+qed
	+
	+section \<open>Enumerating Equivalence Relations\label{sec:bij_kernel}\<close>
	+
	+text \<open>The following definition returns the equivalence relation induced by a list, for example, by
	+a restricted growth function.\<close>
	+
	+definition kernel_of :: "'a list \<Rightarrow> nat rel"
	+ where "kernel_of xs = {(i,j). i < length xs \<and> j < length xs \<and> xs ! i = xs ! j}"
	+
	+text \<open>Using that the enumeration function for equivalence relations on @{term "{..<n}"} is
	+straight-forward to define:\<close>
	+
	+definition equiv_rels where "equiv_rels n = map kernel_of (enum_rgfs n)"
	+
	+text \<open>The following lemma shows that the image of
	+@{term "kernel_of"} is indeed an equivalence relation:\<close>
	+
	+lemma kernel_of_equiv: "equiv {..<length xs} (kernel_of xs)"
	+proof -
	+ have "kernel_of xs \<subseteq> {..<length xs} \<times> {..<length xs}"
	+ by (rule subsetI, simp add:kernel_of_def mem_Times_iff case_prod_beta)
	+ thus ?thesis by (simp add:equiv_def refl_on_def sym_def trans_def kernel_of_def)
	+qed
	+
	+lemma kernel_of_eq_len:
	+ assumes "kernel_of x = kernel_of y"
	+ shows "length x = length y"
	+proof -
	+ have "{..<length x} = {..<length y}"
	+ by (metis kernel_of_equiv equiv_on_unique assms)
	+ thus ?thesis by simp
	+qed
	+
	+lemma kernel_of_eq:
	+ "(kernel_of x = kernel_of y) \<longleftrightarrow>
	+ (length x = length y \<and> (\<forall>j < length x. \<forall>i < j. (x ! i = x ! j) = (y ! i = y ! j)))"
	+proof (cases "length x = length y")
	+ case True
	+ have "(kernel_of x = kernel_of y) \<longleftrightarrow>
	+ (\<forall>j < length x. \<forall>i < length x. (x ! i = x ! j) = (y ! i = y ! j))"
	+ unfolding set_eq_iff kernel_of_def using True by (simp, blast)
	+ also have "... \<longleftrightarrow> (\<forall>j < length x. \<forall>i < j. (x ! i = x ! j) = (y ! i = y ! j))"
	+ by (metis (no_types, lifting) linorder_cases order.strict_trans)
	+ finally show ?thesis using True by simp
	+next
	+ case False
	+ then show ?thesis using kernel_of_eq_len by blast
	+qed
	+
	+lemma kernel_of_snoc:
	+ "kernel_of (xs) = Restr (kernel_of (xs@[x])) {..<length xs}"
	+ by (simp add:kernel_of_def nth_append set_eq_iff)
	+
	+lemma kernel_of_inj_on_rgfs_aux:
	+ assumes "length x = length y"
	+ assumes "rgf x"
	+ assumes "rgf y"
	+ assumes "kernel_of x = kernel_of y"
	+ shows "x = y"
	+ using assms
	+proof (induct x y rule: list_induct_2_rev)
	+ case Nil
	+ then show ?case by simp
	+next
	+ case (Cons x xs y ys)
	+ have a:"kernel_of xs = kernel_of ys"
	+ using Cons(1,5) kernel_of_snoc by metis
	+ have d:"rgf xs" "rgf ys" using Cons rgf_def by auto
	+ hence b:"xs = ys" using Cons(2) a by auto
	+ have "\<And>i. i < length xs \<Longrightarrow> (xs ! i = x) = (ys ! i = y)"
	+ proof -
	+ fix i
	+ assume i_l:"i < length xs"
	+ have "(xs ! i = x) \<longleftrightarrow> (i,length xs) \<in> kernel_of (xs@[x])" using i_l
	+ by (simp add:kernel_of_def less_Suc_eq nth_append)
	+ also have "... \<longleftrightarrow> (i,length xs) \<in> kernel_of (ys@[y])"
	+ using Cons(5) by simp
	+ also have "... \<longleftrightarrow> (ys ! i= y)" using i_l Cons(1)
	+ by (simp add:kernel_of_def less_Suc_eq nth_append)
	+ finally show "(xs ! i = x) = (ys ! i = y)" by simp
	+ qed
	+ hence c:"(x \<in> set xs \<longrightarrow> x = y) \<and> (x \<notin> set xs \<longrightarrow> y \<notin> set ys)"
	+ by (metis b in_set_conv_nth)
	+ have x_bound:"x < rgf_limit xs + 1"
	+ using Cons(3) rgf_snoc d by simp
	+ have y_bound:"y < rgf_limit ys + 1"
	+ using Cons(4) rgf_snoc d by simp
	+ have "x = y" using b c d rgf_imp_initial_segment Cons x_bound y_bound
	+ apply (cases "x < rgf_limit xs", simp)
	+ by (cases "y < rgf_limit ys", simp+)
	+ then show ?case using b by simp
	+qed
	+
	+lemma kernel_of_inj_on_rgfs:
	+ "inj_on kernel_of {x. rgf x}"
	+ by (rule inj_onI, simp, metis kernel_of_eq_len kernel_of_inj_on_rgfs_aux)
	+
	+text \<open>Applying an injective map to a list preserves the induced relation:\<close>
	+
	+lemma kernel_of_under_inj_map:
	+ assumes "inj_on f (set x)"
	+ shows "kernel_of x = kernel_of (map f x)"
	+proof -
	+ have "\<And>i j. i < length x \<Longrightarrow> j < length x
	+ \<Longrightarrow> (map f x) ! i = (map f x) ! j \<Longrightarrow> x ! i = x ! j"
	+ using assms by (simp add: inj_on_eq_iff)
	+ thus ?thesis unfolding kernel_of_def by fastforce
	+qed
	+
	+lemma all_rels_are_kernels:
	+ assumes "equiv {..<n} p"
	+ shows "\<exists>(x :: nat set list). kernel_of x = p \<and> length x = n"
	+proof -
	+ define r where "r = map (\<lambda>k. p``{k}) [0..<n]"
	+
	+ have "\<And> u v. (u,v) \<in> kernel_of r \<longleftrightarrow> (u,v) \<in> p"
	+ proof -
	+ fix u v :: nat
	+ have "(u,v) \<in> kernel_of r \<longleftrightarrow> ((u,v) \<in> {..<n}\<times>{..<n} \<and> p``{u} = p``{v})"
	+ unfolding kernel_of_def r_def by auto
	+ also have "... \<longleftrightarrow> (u,v) \<in> p" by (metis assms equiv_class_eq_iff mem_Sigma_iff)
	+ finally show "(u,v) \<in> kernel_of r \<longleftrightarrow> (u,v) \<in> p" by simp
	+ qed
	+ hence "kernel_of r = p" by auto
	+ moreover have "length r = n" using r_def by simp
	+ ultimately show ?thesis by auto
	+qed
	+
	+text \<open>For any list there is always an injective map on its set, such that its image is an RGF.\<close>
	+
	+lemma map_list_to_rgf:
	+ "\<exists>f. inj_on f (set x) \<and> rgf (map f x)"
	+proof (induction "length x" arbitrary: x)
	+ case 0
	+ then show ?case by (simp add:rgf_def)
	+next
	+ case (Suc n)
	+ obtain x1 x2 where x_def: "x = x1@[x2]" and l_x1: "length x1 = n"
	+ by (metis append_butlast_last_id length_append_singleton Suc(2)
	+ length_greater_0_conv nat.inject zero_less_Suc)
	+ obtain f where inj_f: "inj_on f (set x1)" and pc_f: "rgf (map f x1)"
	+ using Suc(1) l_x1 by blast
	+ show ?case
	+ proof (cases "x2 \<in> set x1")
	+ case True
	+ have a:"set x = set x1" using x_def True by auto
	+ hence b:"inj_on f (set x)" using inj_f by auto
	+
	+ have "f x2 < rgf_limit (map f x1)" using rgf_limit_ge True by auto
	+ hence "rgf (map f x)"
	+ by (simp add:x_def rgf_snoc pc_f)
	+ then show ?thesis using b by blast
	+ next
	+ case False
	+ define f' where "f' = (\<lambda>y. if y \<in> set x1 then f y else rgf_limit (map f x1))"
	+ have "inj_on f' (set x1)" using f'_def inj_f by (simp add: inj_on_def)
	+ moreover have "rgf_limit (map f x1) \<notin> set (map f x1)"
	+ using rgf_limit_ge by blast
	+ hence "f' x2 \<notin> f' ` set x1" using False by (simp add:f'_def)
	+ ultimately have "inj_on f' (insert x2 (set x1))" using False by simp
	+ hence a:"inj_on f' (set x)" using False x_def by simp
	+
	+ have b:"map f x1 = map f' x1" using f'_def by simp
	+
	+ have c:"f' x2 < Suc (rgf_limit (map f x1))" by (simp add:f'_def False)
	+ have "rgf (map f' x)" by (simp add:x_def b[symmetric] rgf_snoc pc_f c)
	+ then show ?thesis using a by blast
	+ qed
	+qed
	+
	+text \<open>For any relation there is a corresponding RGF:\<close>
	+
	+lemma rgf_exists:
	+ assumes "equiv {..<n} r"
	+ shows "\<exists>x. rgf x \<and> length x = n \<and> kernel_of x = r"
	+proof -
	+ obtain y :: "nat set list" where a:"kernel_of y = r" "length y = n"
	+ using all_rels_are_kernels assms by blast
	+ then obtain f where b:"inj_on f (set y)" "rgf (map f y)"
	+ using map_list_to_rgf by blast
	+ have "kernel_of (map f y) = r"
	+ using kernel_of_under_inj_map a b by blast
	+ moreover have "length (map f y) = n" using a by simp
	+ ultimately show ?thesis
	+ using b by blast
	+qed
	+
	+text \<open>These are the main result of this entry: The function @{term "equiv_rels n"} enumerates the
	+equivalence relations on @{term "{..<n}"} without repetition.\<close>
	+
	+theorem equiv_rels_set:
	+ assumes "x \<in> set (equiv_rels n)"
	+ shows "equiv {..<n} x"
	+ using assms equiv_rels_def kernel_of_equiv enum_rgfs_len by auto
	+
	+theorem equiv_rels:
	+ assumes "equiv {..<n} r"
	+ shows "count_list (equiv_rels n) r = 1"
	+proof -
	+ obtain y where y_def: "rgf y" "length y = n" "kernel_of y = r"
	+ using rgf_exists assms by blast
	+
	+ have a: "\<And>x. x \<in> set (enum_rgfs n) \<Longrightarrow> (kernel_of y = kernel_of x) = (y=x)"
	+ using enum_rgfs_returns_rgfs y_def(1,2) enum_rgfs_len inj_onD[OF kernel_of_inj_on_rgfs]
	+ by auto
	+
	+ have "count_list (equiv_rels n) r =
	+ length (filter (\<lambda>x. r = kernel_of x) (enum_rgfs n))"
	+ by (simp add:equiv_rels_def count_list_expand length_filter comp_def)
	+ also have "... = length (filter (\<lambda>x. kernel_of y = kernel_of x) (enum_rgfs n))"
	+ using y_def(3) by simp
	+ also have "... = length (filter (\<lambda>x. y = x) (enum_rgfs n))"
	+ using a by (simp cong:filter_cong)
	+ also have "... = count_list (enum_rgfs n) y"
	+ by (simp add:count_list_expand length_filter)
	+ also have "... = 1"
	+ using equiv_rels_enum y_def(1,2) by auto
	+ finally show ?thesis by simp
	+qed
	+
	+text \<open>A corollary of the previous theorem is that the sum of the indicator function for a relation
	+over @{term "equiv_rels n"} is always one.\<close>
	+
	+corollary equiv_rels_2:
	+ assumes "n = length xs"
	+ shows "(\<Sum>x\<leftarrow>equiv_rels n. of_bool (kernel_of xs = x)) = (1 :: 'a :: {semiring_1})"
	+proof -
	+ have "length (filter (\<lambda>x. kernel_of xs = x) (equiv_rels (length xs))) = 1"
	+ using equiv_rels[OF kernel_of_equiv[where xs="xs"]] assms by (simp add:count_list_expand)
	+ thus ?thesis
	+ using assms by (simp add:of_bool_def sum_list_map_filter'[symmetric] sum_list_triv)
	+qed
	+
	+section \<open>Example Application\label{sec:app}\<close>
	+
	+text \<open>In this section, I wanted to discuss an interesting application within the context of
	+a proof in Isabelle. This is motivated by a real-world example \cite[\textsection 2.2]{alon1999},
	+where a function in a 4-times iterated sum could only be reduced by splitting it according to the
	+equivalence relation formed by the indices. The notepad below illustrates how this can be done
	+(in the case of 3 index variables).\<close>
	+
	+notepad
	+begin \<^marker>\<open>tag visible\<close>
	+ fix f :: "nat \<times> nat \<times> nat \<Rightarrow> nat"
	+ fix I :: "nat set"
	+ assume a:"finite I"
	+
	+ text \<open>To be able to break down such a sum by partitions let us introduce the function $P$
	+ which is defined to be sum of an indicator function over all possible equivalence relations
	+ its argument can form:\<close>
	+
	+ define P :: "nat list \<Rightarrow> nat"
	+ where "P = (\<lambda>xs. (\<Sum>x \<leftarrow> equiv_rels (length xs). of_bool (kernel_of xs = x) ))"
	+
	+ text \<open>Note that its value is always one, hence we can introduce it in an algebraic equation easily:\<close>
	+
	+ have P_one: "\<And>xs. P xs = 1"
	+ by (simp add: P_def equiv_rels_2)
	+
	+ note unfold_equiv_rels = P_def equiv_rels_def numeral_eq_Suc kernel_of_eq
	+ neq_commute All_less_Suc comp_def
	+
	+ define r where "r = (\<Sum>i \<in> I. (\<Sum>j \<in> I. (\<Sum>k \<in> I. f (i,j,k))))"
	+
	+ text \<open>As a first step, we just introduce the factor @{term "P [i,j,k]"}.\<close>
	+
	+ have "r = (\<Sum>i \<in> I. (\<Sum>j \<in> I. (\<Sum>k \<in> I. f (i,j,k) * P [i,j,k])))"
	+ by (simp add:P_one r_def cong:sum.cong)
	+
	+ text \<open>By expanding the definition of P and distributing, the sum can be expanded into 5 sums
	+ each representing a distinct equivalence relation formed by the indices.\<close>
	+
	+ also have "... =
	+ (\<Sum>i\<in>I. f (i, i, i)) +
	+ (\<Sum>i\<in>I. \<Sum>j\<in>I. f (i, i, j) * of_bool (i \<noteq> j)) +
	+ (\<Sum>i\<in>I. \<Sum>j\<in>I. f (i, j, i) * of_bool (i \<noteq> j)) +
	+ (\<Sum>i\<in>I. \<Sum>j\<in>I. f (i, j, j) * of_bool (i \<noteq> j)) +
	+ (\<Sum>i\<in>I. \<Sum>j\<in>I. \<Sum>k\<in>I. f (i, j, k) * of_bool (j \<noteq> k \<and> i \<noteq> k \<and> i \<noteq> j))"
	+ (is "_ = ?rhs")
	+ by (simp add:unfold_equiv_rels sum.distrib distrib_left sum_collapse[OF a])
	+ finally have "r = ?rhs" by simp
	+end
	+
	+section \<open>Additional Results\label{sec:add}\<close>
	+
	+text \<open>If two lists induce the same equivalence relation, then there is a bijection between the sets
	+that preserves the multiplicities of its elements.\<close>
	+
	+lemma kernel_of_eq_imp_bij:
	+ assumes "kernel_of x = kernel_of y"
	+ shows "\<exists>f. bij_betw f (set x) (set y) \<and>
	+ (\<forall>z \<in> set x. count_list x z = count_list y (f z))"
	+proof -
	+ obtain x' where x'_def: "inj_on x' (set x)" "rgf (map x' x)"
	+ using map_list_to_rgf by blast
	+ obtain y' where y'_def: "inj_on y' (set y)" "rgf (map y' y)"
	+ using map_list_to_rgf by blast
	+
	+ have "kernel_of (map x' x) = kernel_of (map y' y)"
	+ using assms x'_def(1) y'_def(1)
	+ by (simp add: kernel_of_under_inj_map[symmetric])
	+ hence b:"map x' x = map y' y"
	+ using inj_onD[OF kernel_of_inj_on_rgfs] x'_def(2) y'_def(2) length_map by simp
	+ hence f: "x' ` set x = y' ` set y"
	+ by (metis list.set_map)
	+ define f where "f = the_inv_into (set y) y' \<circ> x'"
	+ have g:"\<And>z. z \<in> set x \<Longrightarrow> count_list x z = count_list y (f z)"
	+ proof -
	+ fix z
	+ assume a:"z \<in> set x"
	+ have e: "x' z \<in> y' ` set y"
	+ by (metis a b imageI image_set)
	+ have c: "the_inv_into (set y) y' (x' z) \<in> set y"
	+ using e the_inv_into_into[OF y'_def(1)] by simp
	+ have d: "(y' (the_inv_into (set y) y' (x' z))) = x' z"
	+ using e f_the_inv_into_f y'_def(1) by force
	+
	+ have "count_list x z = count_list (map x' x) (x' z)"
	+ using a x'_def by (simp add: count_list_inj_map)
	+ also have "... = count_list (map y' y) (x' z)"
	+ by (simp add:b)
	+ also have "... = count_list (map y' y) (y' (the_inv_into (set y) y' (x' z)))"
	+ by (simp add:d)
	+ also have "... = count_list y (the_inv_into (set y) y' (x' z))"
	+ using c count_list_inj_map[OF y'_def(1)] by simp
	+ also have "... = count_list y (f z)" by (simp add:f_def)
	+ finally show "count_list x z = count_list y (f z)" by simp
	+ qed
	+
	+ have "bij_betw x' (set x) (x' ` set x)"
	+ using x'_def(1) bij_betw_imageI by auto
	+ moreover have "bij_betw (the_inv_into (set y) y') (y' ` set y) (set y)"
	+ using bij_betw_the_inv_into[OF bij_betw_imageI] y'_def(1) by auto
	+ hence "bij_betw (the_inv_into (set y) y') (x' ` set x) (set y)"
	+ using f by simp
	+ ultimately have "bij_betw f (set x) (set y)"
	+ using bij_betw_trans f_def by blast
	+ thus ?thesis using g by blast
	+qed
	+
	+text \<open>As expected the length of @{term "equiv_rels n"} is the $n$-th Bell number.\<close>
	+
	+lemma len_equiv_rels: "length (equiv_rels n) = Bell n"
	+proof -
	+ have a:"finite {p. equiv {..<n} p}"
	+ by (simp add: finite_equiv)
	+ have b: "set (equiv_rels n) \<subseteq> {p. equiv {..<n} p}"
	+ using equiv_rels_set by blast
	+ have "length (equiv_rels n) =
	+ (\<Sum>x \<in> {p. equiv {..<n} p}. count_list (equiv_rels n) x)"
	+ using a b by (simp add:sum_count_set)
	+ also have "... = card {p. equiv {..<n} p}"
	+ by (simp add: equiv_rels)
	+ also have "... = Bell (card {..<n})"
	+ using card_equiv_rel_eq_Bell by blast
	+ also have "... = Bell n" by simp
	+ finally show ?thesis by simp
	+qed
	+
	+text \<open>Instead of forming an equivalence relation from a list, it is also possible to induce a
	+partition from it:\<close>
	+
	+definition induced_par :: "'a list \<Rightarrow> nat set set" where
	+ "induced_par xs = (\<lambda>k. {i. i < length xs \<and> xs ! i = k}) ` (set xs)"
	+
	+text \<open>The following lemma verifies the commutative diagram, i.e.,
	+@{term "induced_par xs"} is the same partition as the quotient of @{term "{..<length xs}"} over
	+the corresponding equivalence relation.\<close>
	+
	+lemma quotient_of_kernel_is_induced_par:
	+ "{..<length xs} // (kernel_of xs) = (induced_par xs)"
	+proof (rule set_eqI)
	+ fix x
	+ have "x \<in> {..<length xs} // (kernel_of xs) \<longleftrightarrow>
	+ (\<exists>i < length xs. x = {j. j < length xs \<and> xs ! i = xs ! j})"
	+ unfolding quotient_def kernel_of_def by blast
	+ also have "... \<longleftrightarrow> (\<exists>y \<in> set xs. x = {j. j < length xs \<and> y = xs ! j})"
	+ unfolding in_set_conv_nth Bex_def by (rule order_antisym, force+)
	+ also have "... \<longleftrightarrow> (x \<in> induced_par xs)"
	+ unfolding induced_par_def by auto
	+ finally show "x \<in> {..<length xs} // (kernel_of xs) \<longleftrightarrow> (x \<in> induced_par xs)"
	+ by simp
	+qed
	+
	+end
	diff --git a/thys/Equivalence_Relation_Enumeration/ROOT b/thys/Equivalence_Relation_Enumeration/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Equivalence_Relation_Enumeration/ROOT
	@@ -0,0 +1,11 @@
	+chapter AFP
	+
	+session Equivalence_Relation_Enumeration (AFP) = "HOL-Library" +
	+ options [timeout = 600]
	+ sessions
	+ Card_Equiv_Relations
	+ theories
	+ Equivalence_Relation_Enumeration
	+ document_files
	+ "root.tex"
	+ "root.bib"
	diff --git a/thys/Equivalence_Relation_Enumeration/document/root.bib b/thys/Equivalence_Relation_Enumeration/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Equivalence_Relation_Enumeration/document/root.bib
	@@ -0,0 +1,58 @@
	+@article{milne1977,
	+ title = {Restricted growth functions and incidence relations of the lattice of partitions of an n-set},
	+ journal = {Advances in Mathematics},
	+ volume = {26},
	+ number = {3},
	+ pages = {290--305},
	+ year = {1977},
	+ author = {Stephen Milne},
	+}
	+
	+@book{white1986,
	+ title={Constructive Combinatorics},
	+ author={Stanton, Dennis and White, Dennis},
	+ year={1986},
	+ publisher={Springer},
	+}
	+
	+@article{hutchinson1963,
	+ author = {Hutchinson, George},
	+ title = {Partioning Algorithms for Finite Sets},
	+ year = {1963},
	+ _issue_date = {Oct. 1963},
	+ _publisher = {Association for Computing Machinery},
	+ _address = {New York, NY, USA},
	+ volume = {6},
	+ number = {10},
	+ _issn = {0001-0782},
	+ _url = {https://doi.org/10.1145/367651.367661},
	+ _doi = {10.1145/367651.367661},
	+ journal = {Commun. ACM},
	+ month = oct,
	+ pages = {613–-614},
	+ _numpages = {2},
	+}
	+
	+@article{Card_Equiv_Relations-AFP,
	+ author = {Lukas Bulwahn},
	+ title = {Cardinality of Equivalence Relations},
	+ journal = {Archive of Formal Proofs},
	+ month = may,
	+ year = 2016,
	+ note = {\url{https://isa-afp.org/entries/Card_Equiv_Relations.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+
	+@article{alon1999,
	+ title = {The Space Complexity of Approximating the Frequency Moments},
	+ journal = {Journal of Computer and System Sciences},
	+ volume = {58},
	+ number = {1},
	+ pages = {137-147},
	+ year = {1999},
	+ issn = {0022-0000},
	+ _doi = {https://doi.org/10.1006/jcss.1997.1545},
	+ _url = {https://www.sciencedirect.com/science/article/pii/S0022000097915452},
	+ author = {Noga Alon and Yossi Matias and Mario Szegedy},
	+}
	diff --git a/thys/Equivalence_Relation_Enumeration/document/root.tex b/thys/Equivalence_Relation_Enumeration/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Equivalence_Relation_Enumeration/document/root.tex
	@@ -0,0 +1,72 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+
	+% further packages required for unusual symbols (see also
	+% isabellesym.sty), use only when needed
	+
	+%\usepackage{amssymb}
	+ %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
	+ %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
	+ %\<triangleq>, \<yen>, \<lozenge>
	+
	+%\usepackage{eurosym}
	+ %for \<euro>
	+
	+%\usepackage[only,bigsqcap,bigparallel,fatsemi,interleave,sslash]{stmaryrd}
	+ %for \<Sqinter>, \<Parallel>, \<Zsemi>, \<Parallel>, \<sslash>
	+
	+%\usepackage{eufrak}
	+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
	+
	+%\usepackage{textcomp}
	+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	+ %\<currency>
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+% for uniform font size
	+%\renewcommand{\isastyle}{\isastyleminor}
	+
	+
	+\begin{document}
	+
	+\title{Enumeration of Equivalence Relations}
	+\author{Emin Karayel}
	+\maketitle
	+\begin{abstract}
	+This entry contains a formalization of an algorithm enumerating all equivalence relations on an
	+initial segment of the natural numbers. The approach follows the method described by Stanton and
	+White~\cite[\textsection 1.5]{white1986} using restricted growth functions.
	+
	+The algorithm internally enumerates restricted growth functions (as lists), whose equivalence
	+kernels then form the equivalence relations. This has the advantage that the representation is
	+compact and lookup of the relation reduces to a list lookup operation.
	+
	+The algorithm can also be used within a proof and an example application is included,
	+where a sequence of variables is split by the possible partitions they can form.
	+\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/Eval_FO/Ailamazyan.thy b/thys/Eval_FO/Ailamazyan.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/Ailamazyan.thy
	@@ -0,0 +1,5597 @@
	+theory Ailamazyan
	+ imports Eval_FO Cluster Mapping_Code
	+begin
	+
	+fun SP :: "('a, 'b) fo_fmla \<Rightarrow> nat set" where
	+ "SP (Eqa (Var n) (Var n')) = (if n \<noteq> n' then {n, n'} else {})"
	+\| "SP (Neg \<phi>) = SP \<phi>"
	+\| "SP (Conj \<phi> \<psi>) = SP \<phi> \<union> SP \<psi>"
	+\| "SP (Disj \<phi> \<psi>) = SP \<phi> \<union> SP \<psi>"
	+\| "SP (Exists n \<phi>) = SP \<phi> - {n}"
	+\| "SP (Forall n \<phi>) = SP \<phi> - {n}"
	+\| "SP _ = {}"
	+
	+lemma SP_fv: "SP \<phi> \<subseteq> fv_fo_fmla \<phi>"
	+ by (induction \<phi> rule: SP.induct) auto
	+
	+lemma finite_SP: "finite (SP \<phi>)"
	+ using SP_fv finite_fv_fo_fmla finite_subset by fastforce
	+
	+fun SP_list_rec :: "('a, 'b) fo_fmla \<Rightarrow> nat list" where
	+ "SP_list_rec (Eqa (Var n) (Var n')) = (if n \<noteq> n' then [n, n'] else [])"
	+\| "SP_list_rec (Neg \<phi>) = SP_list_rec \<phi>"
	+\| "SP_list_rec (Conj \<phi> \<psi>) = SP_list_rec \<phi> @ SP_list_rec \<psi>"
	+\| "SP_list_rec (Disj \<phi> \<psi>) = SP_list_rec \<phi> @ SP_list_rec \<psi>"
	+\| "SP_list_rec (Exists n \<phi>) = filter (\<lambda>m. n \<noteq> m) (SP_list_rec \<phi>)"
	+\| "SP_list_rec (Forall n \<phi>) = filter (\<lambda>m. n \<noteq> m) (SP_list_rec \<phi>)"
	+\| "SP_list_rec _ = []"
	+
	+definition SP_list :: "('a, 'b) fo_fmla \<Rightarrow> nat list" where
	+ "SP_list \<phi> = remdups_adj (sort (SP_list_rec \<phi>))"
	+
	+lemma SP_list_set: "set (SP_list \<phi>) = SP \<phi>"
	+ unfolding SP_list_def
	+ by (induction \<phi> rule: SP.induct) (auto simp: fv_fo_terms_set_list)
	+
	+lemma sorted_distinct_SP_list: "sorted_distinct (SP_list \<phi>)"
	+ unfolding SP_list_def
	+ by (auto intro: distinct_remdups_adj_sort)
	+
	+fun d :: "('a, 'b) fo_fmla \<Rightarrow> nat" where
	+ "d (Eqa (Var n) (Var n')) = (if n \<noteq> n' then 2 else 1)"
	+\| "d (Neg \<phi>) = d \<phi>"
	+\| "d (Conj \<phi> \<psi>) = max (d \<phi>) (max (d \<psi>) (card (SP (Conj \<phi> \<psi>))))"
	+\| "d (Disj \<phi> \<psi>) = max (d \<phi>) (max (d \<psi>) (card (SP (Disj \<phi> \<psi>))))"
	+\| "d (Exists n \<phi>) = d \<phi>"
	+\| "d (Forall n \<phi>) = d \<phi>"
	+\| "d _ = 1"
	+
	+lemma d_pos: "1 \<le> d \<phi>"
	+ by (induction \<phi> rule: d.induct) auto
	+
	+lemma card_SP_d: "card (SP \<phi>) \<le> d \<phi>"
	+ using dual_order.trans
	+ by (induction \<phi> rule: SP.induct) (fastforce simp: card_Diff1_le finite_SP)+
	+
	+fun eval_eterm :: "('a + 'c) val \<Rightarrow> 'a fo_term \<Rightarrow> 'a + 'c" (infix "\<cdot>e" 60) where
	+ "eval_eterm \<sigma> (Const c) = Inl c"
	+\| "eval_eterm \<sigma> (Var n) = \<sigma> n"
	+
	+definition eval_eterms :: "('a + 'c) val \<Rightarrow> ('a fo_term) list \<Rightarrow>
	+ ('a + 'c) list" (infix "\<odot>e" 60) where
	+ "eval_eterms \<sigma> ts = map (eval_eterm \<sigma>) ts"
	+
	+lemma eval_eterm_cong: "(\<And>n. n \<in> fv_fo_term_set t \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
	+ eval_eterm \<sigma> t = eval_eterm \<sigma>' t"
	+ by (cases t) auto
	+
	+lemma eval_eterms_fv_fo_terms_set: "\<sigma> \<odot>e ts = \<sigma>' \<odot>e ts \<Longrightarrow> n \<in> fv_fo_terms_set ts \<Longrightarrow> \<sigma> n = \<sigma>' n"
	+proof (induction ts)
	+ case (Cons t ts)
	+ then show ?case
	+ by (cases t) (auto simp: eval_eterms_def fv_fo_terms_set_def)
	+qed (auto simp: eval_eterms_def fv_fo_terms_set_def)
	+
	+lemma eval_eterms_cong: "(\<And>n. n \<in> fv_fo_terms_set ts \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
	+ eval_eterms \<sigma> ts = eval_eterms \<sigma>' ts"
	+ by (auto simp: eval_eterms_def fv_fo_terms_set_def intro: eval_eterm_cong)
	+
	+lemma eval_terms_eterms: "map Inl (\<sigma> \<odot> ts) = (Inl \<circ> \<sigma>) \<odot>e ts"
	+proof (induction ts)
	+ case (Cons t ts)
	+ then show ?case
	+ by (cases t) (auto simp: eval_terms_def eval_eterms_def)
	+qed (auto simp: eval_terms_def eval_eterms_def)
	+
	+fun ad_equiv_pair :: "'a set \<Rightarrow> ('a + 'c) \<times> ('a + 'c) \<Rightarrow> bool" where
	+ "ad_equiv_pair X (a, a') \<longleftrightarrow> (a \<in> Inl ` X \<longrightarrow> a = a') \<and> (a' \<in> Inl ` X \<longrightarrow> a = a')"
	+
	+fun sp_equiv_pair :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
	+ "sp_equiv_pair (a, b) (a', b') \<longleftrightarrow> (a = a' \<longleftrightarrow> b = b')"
	+
	+definition ad_equiv_list :: "'a set \<Rightarrow> ('a + 'c) list \<Rightarrow> ('a + 'c) list \<Rightarrow> bool" where
	+ "ad_equiv_list X xs ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>x \<in> set (zip xs ys). ad_equiv_pair X x)"
	+
	+definition sp_equiv_list :: "('a + 'c) list \<Rightarrow> ('a + 'c) list \<Rightarrow> bool" where
	+ "sp_equiv_list xs ys \<longleftrightarrow> length xs = length ys \<and> pairwise sp_equiv_pair (set (zip xs ys))"
	+
	+definition ad_agr_list :: "'a set \<Rightarrow> ('a + 'c) list \<Rightarrow> ('a + 'c) list \<Rightarrow> bool" where
	+ "ad_agr_list X xs ys \<longleftrightarrow> length xs = length ys \<and> ad_equiv_list X xs ys \<and> sp_equiv_list xs ys"
	+
	+lemma ad_equiv_pair_refl[simp]: "ad_equiv_pair X (a, a)"
	+ by auto
	+
	+declare ad_equiv_pair.simps[simp del]
	+
	+lemma ad_equiv_pair_comm: "ad_equiv_pair X (a, a') \<longleftrightarrow> ad_equiv_pair X (a', a)"
	+ by (auto simp: ad_equiv_pair.simps)
	+
	+lemma ad_equiv_pair_mono: "X \<subseteq> Y \<Longrightarrow> ad_equiv_pair Y (a, a') \<Longrightarrow> ad_equiv_pair X (a, a')"
	+ unfolding ad_equiv_pair.simps
	+ by fastforce
	+
	+lemma sp_equiv_pair_comm: "sp_equiv_pair x y \<longleftrightarrow> sp_equiv_pair y x"
	+ by (cases x; cases y) auto
	+
	+definition sp_equiv :: "('a + 'c) val \<Rightarrow> ('a + 'c) val \<Rightarrow> nat set \<Rightarrow> bool" where
	+ "sp_equiv \<sigma> \<tau> I \<longleftrightarrow> pairwise sp_equiv_pair ((\<lambda>n. (\<sigma> n, \<tau> n)) ` I)"
	+
	+lemma sp_equiv_mono: "I \<subseteq> J \<Longrightarrow> sp_equiv \<sigma> \<tau> J \<Longrightarrow> sp_equiv \<sigma> \<tau> I"
	+ by (auto simp: sp_equiv_def pairwise_def)
	+
	+definition ad_agr_sets :: "nat set \<Rightarrow> nat set \<Rightarrow> 'a set \<Rightarrow> ('a + 'c) val \<Rightarrow>
	+ ('a + 'c) val \<Rightarrow> bool" where
	+ "ad_agr_sets FV S X \<sigma> \<tau> \<longleftrightarrow> (\<forall>i \<in> FV. ad_equiv_pair X (\<sigma> i, \<tau> i)) \<and> sp_equiv \<sigma> \<tau> S"
	+
	+lemma ad_agr_sets_comm: "ad_agr_sets FV S X \<sigma> \<tau> \<Longrightarrow> ad_agr_sets FV S X \<tau> \<sigma>"
	+ unfolding ad_agr_sets_def sp_equiv_def pairwise_def
	+ by (subst ad_equiv_pair_comm) auto
	+
	+lemma ad_agr_sets_mono: "X \<subseteq> Y \<Longrightarrow> ad_agr_sets FV S Y \<sigma> \<tau> \<Longrightarrow> ad_agr_sets FV S X \<sigma> \<tau>"
	+ using ad_equiv_pair_mono
	+ by (fastforce simp: ad_agr_sets_def)
	+
	+lemma ad_agr_sets_mono': "S \<subseteq> S' \<Longrightarrow> ad_agr_sets FV S' X \<sigma> \<tau> \<Longrightarrow> ad_agr_sets FV S X \<sigma> \<tau>"
	+ by (auto simp: ad_agr_sets_def sp_equiv_def pairwise_def)
	+
	+lemma ad_equiv_list_comm: "ad_equiv_list X xs ys \<Longrightarrow> ad_equiv_list X ys xs"
	+ by (auto simp: ad_equiv_list_def) (smt (verit, del_insts) ad_equiv_pair_comm in_set_zip prod.sel(1) prod.sel(2))
	+
	+lemma ad_equiv_list_mono: "X \<subseteq> Y \<Longrightarrow> ad_equiv_list Y xs ys \<Longrightarrow> ad_equiv_list X xs ys"
	+ using ad_equiv_pair_mono
	+ by (fastforce simp: ad_equiv_list_def)
	+
	+lemma ad_equiv_list_trans:
	+ assumes "ad_equiv_list X xs ys" "ad_equiv_list X ys zs"
	+ shows "ad_equiv_list X xs zs"
	+proof -
	+ have lens: "length xs = length ys" "length xs = length zs" "length ys = length zs"
	+ using assms
	+ by (auto simp: ad_equiv_list_def)
	+ have "\<And>x z. (x, z) \<in> set (zip xs zs) \<Longrightarrow> ad_equiv_pair X (x, z)"
	+ proof -
	+ fix x z
	+ assume "(x, z) \<in> set (zip xs zs)"
	+ then obtain i where i_def: "i < length xs" "xs ! i = x" "zs ! i = z"
	+ by (auto simp: set_zip)
	+ define y where "y = ys ! i"
	+ have "ad_equiv_pair X (x, y)" "ad_equiv_pair X (y, z)"
	+ using assms lens i_def
	+ by (fastforce simp: set_zip y_def ad_equiv_list_def)+
	+ then show "ad_equiv_pair X (x, z)"
	+ unfolding ad_equiv_pair.simps
	+ by blast
	+ qed
	+ then show ?thesis
	+ using assms
	+ by (auto simp: ad_equiv_list_def)
	+qed
	+
	+lemma ad_equiv_list_link: "(\<forall>i \<in> set ns. ad_equiv_pair X (\<sigma> i, \<tau> i)) \<longleftrightarrow>
	+ ad_equiv_list X (map \<sigma> ns) (map \<tau> ns)"
	+ by (auto simp: ad_equiv_list_def set_zip) (metis in_set_conv_nth nth_map)
	+
	+lemma set_zip_comm: "(x, y) \<in> set (zip xs ys) \<Longrightarrow> (y, x) \<in> set (zip ys xs)"
	+ by (metis in_set_zip prod.sel(1) prod.sel(2))
	+
	+lemma set_zip_map: "set (zip (map \<sigma> ns) (map \<tau> ns)) = (\<lambda>n. (\<sigma> n, \<tau> n)) ` set ns"
	+ by (induction ns) auto
	+
	+lemma sp_equiv_list_comm: "sp_equiv_list xs ys \<Longrightarrow> sp_equiv_list ys xs"
	+ unfolding sp_equiv_list_def
	+ using set_zip_comm
	+ by (auto simp: pairwise_def) force+
	+
	+lemma sp_equiv_list_trans:
	+ assumes "sp_equiv_list xs ys" "sp_equiv_list ys zs"
	+ shows "sp_equiv_list xs zs"
	+proof -
	+ have lens: "length xs = length ys" "length xs = length zs" "length ys = length zs"
	+ using assms
	+ by (auto simp: sp_equiv_list_def)
	+ have "pairwise sp_equiv_pair (set (zip xs zs))"
	+ proof (rule pairwiseI)
	+ fix xz xz'
	+ assume "xz \<in> set (zip xs zs)" "xz' \<in> set (zip xs zs)"
	+ then obtain x z i x' z' i' where xz_def: "i < length xs" "xs ! i = x" "zs ! i = z"
	+ "xz = (x, z)" "i' < length xs" "xs ! i' = x'" "zs ! i' = z'" "xz' = (x', z')"
	+ by (auto simp: set_zip)
	+ define y where "y = ys ! i"
	+ define y' where "y' = ys ! i'"
	+ have "sp_equiv_pair (x, y) (x', y')" "sp_equiv_pair (y, z) (y', z')"
	+ using assms lens xz_def
	+ by (auto simp: sp_equiv_list_def pairwise_def y_def y'_def set_zip) metis+
	+ then show "sp_equiv_pair xz xz'"
	+ by (auto simp: xz_def)
	+ qed
	+ then show ?thesis
	+ using assms
	+ by (auto simp: sp_equiv_list_def)
	+qed
	+
	+lemma sp_equiv_list_link: "sp_equiv_list (map \<sigma> ns) (map \<tau> ns) \<longleftrightarrow> sp_equiv \<sigma> \<tau> (set ns)"
	+ apply (auto simp: sp_equiv_list_def sp_equiv_def pairwise_def set_zip in_set_conv_nth)
	+ apply (metis nth_map)
	+ apply (metis nth_map)
	+ apply fastforce+
	+ done
	+
	+lemma ad_agr_list_comm: "ad_agr_list X xs ys \<Longrightarrow> ad_agr_list X ys xs"
	+ using ad_equiv_list_comm sp_equiv_list_comm
	+ by (fastforce simp: ad_agr_list_def)
	+
	+lemma ad_agr_list_mono: "X \<subseteq> Y \<Longrightarrow> ad_agr_list Y ys xs \<Longrightarrow> ad_agr_list X ys xs"
	+ using ad_equiv_list_mono
	+ by (force simp: ad_agr_list_def)
	+
	+lemma ad_agr_list_rev_mono:
	+ assumes "Y \<subseteq> X" "ad_agr_list Y ys xs" "Inl -` set xs \<subseteq> Y" "Inl -` set ys \<subseteq> Y"
	+ shows "ad_agr_list X ys xs"
	+proof -
	+ have "(a, b) \<in> set (zip ys xs) \<Longrightarrow> ad_equiv_pair Y (a, b) \<Longrightarrow> ad_equiv_pair X (a, b)" for a b
	+ using assms
	+ apply (cases a; cases b)
	+ apply (auto simp: ad_agr_list_def ad_equiv_list_def vimage_def set_zip)
	+ unfolding ad_equiv_pair.simps
	+ apply (metis Collect_mem_eq Collect_mono_iff imageI nth_mem)
	+ apply (metis Collect_mem_eq Collect_mono_iff imageI nth_mem)
	+ apply (metis Collect_mem_eq Collect_mono_iff imageI nth_mem)
	+ apply (metis Inl_Inr_False image_iff)
	+ done
	+ then show ?thesis
	+ using assms
	+ by (fastforce simp: ad_agr_list_def ad_equiv_list_def)
	+qed
	+
	+lemma ad_agr_list_trans: "ad_agr_list X xs ys \<Longrightarrow> ad_agr_list X ys zs \<Longrightarrow> ad_agr_list X xs zs"
	+ using ad_equiv_list_trans sp_equiv_list_trans
	+ by (force simp: ad_agr_list_def)
	+
	+lemma ad_agr_list_refl: "ad_agr_list X xs xs"
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def set_zip ad_equiv_pair.simps
	+ sp_equiv_list_def pairwise_def)
	+
	+lemma ad_agr_list_set: "ad_agr_list X xs ys \<Longrightarrow> y \<in> X \<Longrightarrow> Inl y \<in> set ys \<Longrightarrow> Inl y \<in> set xs"
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def set_zip in_set_conv_nth)
	+ (metis ad_equiv_pair.simps image_eqI)
	+
	+lemma ad_agr_list_length: "ad_agr_list X xs ys \<Longrightarrow> length xs = length ys"
	+ by (auto simp: ad_agr_list_def)
	+
	+lemma ad_agr_list_eq: "set ys \<subseteq> AD \<Longrightarrow> ad_agr_list AD (map Inl xs) (map Inl ys) \<Longrightarrow> xs = ys"
	+ by (fastforce simp: ad_agr_list_def ad_equiv_list_def set_zip ad_equiv_pair.simps
	+ intro!: nth_equalityI)
	+
	+lemma sp_equiv_list_subset:
	+ assumes "set ms \<subseteq> set ns" "sp_equiv_list (map \<sigma> ns) (map \<sigma>' ns)"
	+ shows "sp_equiv_list (map \<sigma> ms) (map \<sigma>' ms)"
	+ unfolding sp_equiv_list_def length_map pairwise_def
	+proof (rule conjI, rule refl, (rule ballI)+, rule impI)
	+ fix x y
	+ assume "x \<in> set (zip (map \<sigma> ms) (map \<sigma>' ms))" "y \<in> set (zip (map \<sigma> ms) (map \<sigma>' ms))" "x \<noteq> y"
	+ then have "x \<in> set (zip (map \<sigma> ns) (map \<sigma>' ns))" "y \<in> set (zip (map \<sigma> ns) (map \<sigma>' ns))" "x \<noteq> y"
	+ using assms(1)
	+ by (auto simp: set_zip) (metis in_set_conv_nth nth_map subset_iff)+
	+ then show "sp_equiv_pair x y"
	+ using assms(2)
	+ by (auto simp: sp_equiv_list_def pairwise_def)
	+qed
	+
	+lemma ad_agr_list_subset: "set ms \<subseteq> set ns \<Longrightarrow> ad_agr_list X (map \<sigma> ns) (map \<sigma>' ns) \<Longrightarrow>
	+ ad_agr_list X (map \<sigma> ms) (map \<sigma>' ms)"
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def sp_equiv_list_subset set_zip)
	+ (metis (no_types, lifting) in_set_conv_nth nth_map subset_iff)
	+
	+lemma ad_agr_list_link: "ad_agr_sets (set ns) (set ns) AD \<sigma> \<tau> \<longleftrightarrow>
	+ ad_agr_list AD (map \<sigma> ns) (map \<tau> ns)"
	+ unfolding ad_agr_sets_def ad_agr_list_def
	+ using ad_equiv_list_link sp_equiv_list_link
	+ by fastforce
	+
	+definition ad_agr :: "('a, 'b) fo_fmla \<Rightarrow> 'a set \<Rightarrow> ('a + 'c) val \<Rightarrow> ('a + 'c) val \<Rightarrow> bool" where
	+ "ad_agr \<phi> X \<sigma> \<tau> \<longleftrightarrow> ad_agr_sets (fv_fo_fmla \<phi>) (SP \<phi>) X \<sigma> \<tau>"
	+
	+lemma ad_agr_sets_restrict:
	+ "ad_agr_sets (set (fv_fo_fmla_list \<phi>)) (set (fv_fo_fmla_list \<phi>)) AD \<sigma> \<tau> \<Longrightarrow> ad_agr \<phi> AD \<sigma> \<tau>"
	+ using sp_equiv_mono SP_fv
	+ unfolding fv_fo_fmla_list_set
	+ by (auto simp: ad_agr_sets_def ad_agr_def) blast
	+
	+lemma finite_Inl: "finite X \<Longrightarrow> finite (Inl -` X)"
	+ using finite_vimageI[of X Inl]
	+ by (auto simp: vimage_def)
	+
	+lemma ex_out:
	+ assumes "finite X"
	+ shows "\<exists>k. k \<notin> X \<and> k < Suc (card X)"
	+ using card_mono[OF assms, of "{..<Suc (card X)}"]
	+ by auto
	+
	+lemma extend_\<tau>:
	+ assumes "ad_agr_sets (FV - {n}) (S - {n}) X \<sigma> \<tau>" "S \<subseteq> FV" "finite S" "\<tau> ` (FV - {n}) \<subseteq> Z"
	+ "Inl ` X \<union> Inr ` {..<max 1 (card (Inr -` \<tau> ` (S - {n})) + (if n \<in> S then 1 else 0))} \<subseteq> Z"
	+ shows "\<exists>k \<in> Z. ad_agr_sets FV S X (\<sigma>(n := x)) (\<tau>(n := k))"
	+proof (cases "n \<in> S")
	+ case True
	+ note n_in_S = True
	+ show ?thesis
	+ proof (cases "x \<in> Inl ` X")
	+ case True
	+ show ?thesis
	+ using assms n_in_S True
	+ apply (auto simp: ad_agr_sets_def sp_equiv_def pairwise_def intro!: bexI[of _ "x"])
	+ unfolding ad_equiv_pair.simps
	+ apply (metis True insert_Diff insert_iff subsetD)+
	+ done
	+ next
	+ case False
	+ note \<sigma>_n_not_Inl = False
	+ show ?thesis
	+ proof (cases "\<exists>m \<in> S - {n}. x = \<sigma> m")
	+ case True
	+ obtain m where m_def: "m \<in> S - {n}" "x = \<sigma> m"
	+ using True
	+ by auto
	+ have \<tau>_m_in: "\<tau> m \<in> Z"
	+ using assms m_def
	+ by auto
	+ show ?thesis
	+ using assms n_in_S \<sigma>_n_not_Inl True m_def
	+ by (auto simp: ad_agr_sets_def sp_equiv_def pairwise_def intro!: bexI[of _ "\<tau> m"])
	+ next
	+ case False
	+ have out: "x \<notin> \<sigma> ` (S - {n})"
	+ using False
	+ by auto
	+ have fin: "finite (Inr -` \<tau> ` (S - {n}))"
	+ using assms(3)
	+ by (simp add: finite_vimageI)
	+ obtain k where k_def: "Inr k \<notin> \<tau> ` (S - {n})" "k < Suc (card (Inr -` \<tau> ` (S - {n})))"
	+ using ex_out[OF fin] True
	+ by auto
	+ show ?thesis
	+ using assms n_in_S \<sigma>_n_not_Inl out k_def assms(5)
	+ apply (auto simp: ad_agr_sets_def sp_equiv_def pairwise_def intro!: bexI[of _ "Inr k"])
	+ unfolding ad_equiv_pair.simps
	+ apply fastforce
	+ apply (metis image_eqI insertE insert_Diff)
	+ done
	+ qed
	+ qed
	+next
	+ case False
	+ show ?thesis
	+ proof (cases "x \<in> Inl ` X")
	+ case x_in: True
	+ then show ?thesis
	+ using assms False
	+ by (auto simp: ad_agr_sets_def sp_equiv_def pairwise_def intro!: bexI[of _ "x"])
	+ next
	+ case x_out: False
	+ then show ?thesis
	+ using assms False
	+ apply (auto simp: ad_agr_sets_def sp_equiv_def pairwise_def intro!: bexI[of _ "Inr 0"])
	+ unfolding ad_equiv_pair.simps
	+ apply fastforce
	+ done
	+ qed
	+qed
	+
	+lemma esat_Pred:
	+ assumes "ad_agr_sets FV S (\<Union>(set ` X)) \<sigma> \<tau>" "fv_fo_terms_set ts \<subseteq> FV" "\<sigma> \<odot>e ts \<in> map Inl ` X"
	+ "t \<in> set ts"
	+ shows "\<sigma> \<cdot>e t = \<tau> \<cdot>e t"
	+proof (cases t)
	+ case (Var n)
	+ obtain vs where vs_def: "\<sigma> \<odot>e ts = map Inl vs" "vs \<in> X"
	+ using assms(3)
	+ by auto
	+ have "\<sigma> n \<in> set (\<sigma> \<odot>e ts)"
	+ using assms(4)
	+ by (force simp: eval_eterms_def Var)
	+ then have "\<sigma> n \<in> Inl ` \<Union> (set ` X)"
	+ using vs_def(2)
	+ unfolding vs_def(1)
	+ by auto
	+ moreover have "n \<in> FV"
	+ using assms(2,4)
	+ by (fastforce simp: Var fv_fo_terms_set_def)
	+ ultimately show ?thesis
	+ using assms(1)
	+ unfolding ad_equiv_pair.simps ad_agr_sets_def Var
	+ by fastforce
	+qed auto
	+
	+lemma sp_equiv_list_fv:
	+ assumes "(\<And>i. i \<in> fv_fo_terms_set ts \<Longrightarrow> ad_equiv_pair X (\<sigma> i, \<tau> i))"
	+ "\<Union>(set_fo_term ` set ts) \<subseteq> X" "sp_equiv \<sigma> \<tau> (fv_fo_terms_set ts)"
	+ shows "sp_equiv_list (map ((\<cdot>e) \<sigma>) ts) (map ((\<cdot>e) \<tau>) ts)"
	+ using assms
	+proof (induction ts)
	+ case (Cons t ts)
	+ have ind: "sp_equiv_list (map ((\<cdot>e) \<sigma>) ts) (map ((\<cdot>e) \<tau>) ts)"
	+ using Cons
	+ by (auto simp: fv_fo_terms_set_def sp_equiv_def pairwise_def)
	+ show ?case
	+ proof (cases t)
	+ case (Const c)
	+ have c_X: "c \<in> X"
	+ using Cons(3)
	+ by (auto simp: Const)
	+ have fv_t: "fv_fo_term_set t = {}"
	+ by (auto simp: Const)
	+ have "t' \<in> set ts \<Longrightarrow> sp_equiv_pair (\<sigma> \<cdot>e t, \<tau> \<cdot>e t) (\<sigma> \<cdot>e t', \<tau> \<cdot>e t')" for t'
	+ using c_X Const Cons(2)
	+ apply (cases t')
	+ apply (auto simp: fv_fo_terms_set_def)
	+ unfolding ad_equiv_pair.simps
	+ by (metis Cons(2) ad_equiv_pair.simps fv_fo_terms_setI image_insert insert_iff list.set(2)
	+ mk_disjoint_insert)+
	+ then show "sp_equiv_list (map ((\<cdot>e) \<sigma>) (t # ts)) (map ((\<cdot>e) \<tau>) (t # ts))"
	+ using ind pairwise_insert[of sp_equiv_pair "(\<sigma> \<cdot>e t, \<tau> \<cdot>e t)"]
	+ unfolding sp_equiv_list_def set_zip_map
	+ by (auto simp: sp_equiv_pair_comm fv_fo_terms_set_def fv_t)
	+ next
	+ case (Var n)
	+ have ad_n: "ad_equiv_pair X (\<sigma> n, \<tau> n)"
	+ using Cons(2)
	+ by (auto simp: fv_fo_terms_set_def Var)
	+ have sp_equiv_Var: "\<And>n'. Var n' \<in> set ts \<Longrightarrow> sp_equiv_pair (\<sigma> n, \<tau> n) (\<sigma> n', \<tau> n')"
	+ using Cons(4)
	+ by (auto simp: sp_equiv_def pairwise_def fv_fo_terms_set_def Var)
	+ have "t' \<in> set ts \<Longrightarrow> sp_equiv_pair (\<sigma> \<cdot>e t, \<tau> \<cdot>e t) (\<sigma> \<cdot>e t', \<tau> \<cdot>e t')" for t'
	+ using Cons(2,3) sp_equiv_Var
	+ apply (cases t')
	+ apply (auto simp: Var)
	+ apply (metis SUP_le_iff ad_equiv_pair.simps ad_n fo_term.set_intros imageI subset_eq)
	+ apply (metis SUP_le_iff ad_equiv_pair.simps ad_n fo_term.set_intros imageI subset_eq)
	+ done
	+ then show ?thesis
	+ using ind pairwise_insert[of sp_equiv_pair "(\<sigma> \<cdot>e t, \<tau> \<cdot>e t)" "(\<lambda>n. (\<sigma> \<cdot>e n, \<tau> \<cdot>e n)) ` set ts"]
	+ unfolding sp_equiv_list_def set_zip_map
	+ by (auto simp: sp_equiv_pair_comm)
	+ qed
	+qed (auto simp: sp_equiv_def sp_equiv_list_def fv_fo_terms_set_def)
	+
	+lemma esat_Pred_inf:
	+ assumes "fv_fo_terms_set ts \<subseteq> FV" "fv_fo_terms_set ts \<subseteq> S"
	+ "ad_agr_sets FV S AD \<sigma> \<tau>" "ad_agr_list AD (\<sigma> \<odot>e ts) vs"
	+ "\<Union>(set_fo_term ` set ts) \<subseteq> AD"
	+ shows "ad_agr_list AD (\<tau> \<odot>e ts) vs"
	+proof -
	+ have sp: "sp_equiv \<sigma> \<tau> (fv_fo_terms_set ts)"
	+ using assms(2,3) sp_equiv_mono
	+ unfolding ad_agr_sets_def
	+ by auto
	+ have "(\<And>i. i \<in> fv_fo_terms_set ts \<Longrightarrow> ad_equiv_pair AD (\<sigma> i, \<tau> i))"
	+ using assms(1,3)
	+ by (auto simp: ad_agr_sets_def)
	+ then have "sp_equiv_list (map ((\<cdot>e) \<sigma>) ts) (map ((\<cdot>e) \<tau>) ts)"
	+ using sp_equiv_list_fv[OF _ assms(5) sp]
	+ by auto
	+ moreover have "t \<in> set ts \<Longrightarrow> \<forall>i\<in>fv_fo_terms_set ts. ad_equiv_pair AD (\<sigma> i, \<tau> i) \<Longrightarrow> sp_equiv \<sigma> \<tau> S \<Longrightarrow> ad_equiv_pair AD (\<sigma> \<cdot>e t, \<tau> \<cdot>e t)" for t
	+ by (cases t) (auto simp: ad_equiv_pair.simps intro!: fv_fo_terms_setI)
	+ ultimately have ad_agr_list:
	+ "ad_agr_list AD (\<sigma> \<odot>e ts) (\<tau> \<odot>e ts)"
	+ unfolding eval_eterms_def ad_agr_list_def ad_equiv_list_link[symmetric]
	+ using assms(1,3)
	+ by (auto simp: ad_agr_sets_def)
	+ show ?thesis
	+ by (rule ad_agr_list_comm[OF ad_agr_list_trans[OF ad_agr_list_comm[OF assms(4)] ad_agr_list]])
	+qed
	+
	+type_synonym ('a, 'c) fo_t = "'a set \<times> nat \<times> ('a + 'c) table"
	+
	+fun esat :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> ('a + nat) val \<Rightarrow> ('a + nat) set \<Rightarrow> bool" where
	+ "esat (Pred r ts) I \<sigma> X \<longleftrightarrow> \<sigma> \<odot>e ts \<in> map Inl ` I (r, length ts)"
	+\| "esat (Bool b) I \<sigma> X \<longleftrightarrow> b"
	+\| "esat (Eqa t t') I \<sigma> X \<longleftrightarrow> \<sigma> \<cdot>e t = \<sigma> \<cdot>e t'"
	+\| "esat (Neg \<phi>) I \<sigma> X \<longleftrightarrow> \<not>esat \<phi> I \<sigma> X"
	+\| "esat (Conj \<phi> \<psi>) I \<sigma> X \<longleftrightarrow> esat \<phi> I \<sigma> X \<and> esat \<psi> I \<sigma> X"
	+\| "esat (Disj \<phi> \<psi>) I \<sigma> X \<longleftrightarrow> esat \<phi> I \<sigma> X \<or> esat \<psi> I \<sigma> X"
	+\| "esat (Exists n \<phi>) I \<sigma> X \<longleftrightarrow> (\<exists>x \<in> X. esat \<phi> I (\<sigma>(n := x)) X)"
	+\| "esat (Forall n \<phi>) I \<sigma> X \<longleftrightarrow> (\<forall>x \<in> X. esat \<phi> I (\<sigma>(n := x)) X)"
	+
	+fun sz_fmla :: "('a, 'b) fo_fmla \<Rightarrow> nat" where
	+ "sz_fmla (Neg \<phi>) = Suc (sz_fmla \<phi>)"
	+\| "sz_fmla (Conj \<phi> \<psi>) = Suc (sz_fmla \<phi> + sz_fmla \<psi>)"
	+\| "sz_fmla (Disj \<phi> \<psi>) = Suc (sz_fmla \<phi> + sz_fmla \<psi>)"
	+\| "sz_fmla (Exists n \<phi>) = Suc (sz_fmla \<phi>)"
	+\| "sz_fmla (Forall n \<phi>) = Suc (Suc (Suc (Suc (sz_fmla \<phi>))))"
	+\| "sz_fmla _ = 0"
	+
	+lemma sz_fmla_induct[case_names Pred Bool Eqa Neg Conj Disj Exists Forall]:
	+ "(\<And>r ts. P (Pred r ts)) \<Longrightarrow> (\<And>b. P (Bool b)) \<Longrightarrow>
	+ (\<And>t t'. P (Eqa t t')) \<Longrightarrow> (\<And>\<phi>. P \<phi> \<Longrightarrow> P (Neg \<phi>)) \<Longrightarrow>
	+ (\<And>\<phi> \<psi>. P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (Conj \<phi> \<psi>)) \<Longrightarrow> (\<And>\<phi> \<psi>. P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (Disj \<phi> \<psi>)) \<Longrightarrow>
	+ (\<And>n \<phi>. P \<phi> \<Longrightarrow> P (Exists n \<phi>)) \<Longrightarrow> (\<And>n \<phi>. P (Exists n (Neg \<phi>)) \<Longrightarrow> P (Forall n \<phi>)) \<Longrightarrow> P \<phi>"
	+proof (induction "sz_fmla \<phi>" arbitrary: \<phi> rule: nat_less_induct)
	+ case 1
	+ have IH: "\<And>\<psi>. sz_fmla \<psi> < sz_fmla \<phi> \<Longrightarrow> P \<psi>"
	+ using 1
	+ by auto
	+ then show ?case
	+ using 1(2,3,4,5,6,7,8,9)
	+ by (cases \<phi>) auto
	+qed
	+
	+lemma esat_fv_cong: "(\<And>n. n \<in> fv_fo_fmla \<phi> \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow> esat \<phi> I \<sigma> X \<longleftrightarrow> esat \<phi> I \<sigma>' X"
	+proof (induction \<phi> arbitrary: \<sigma> \<sigma>' rule: sz_fmla_induct)
	+ case (Pred r ts)
	+ then show ?case
	+ by (auto simp: eval_eterms_def fv_fo_terms_set_def)
	+ (smt comp_apply eval_eterm_cong fv_fo_term_set_cong image_insert insertCI map_eq_conv
	+ mk_disjoint_insert)+
	+next
	+ case (Eqa t t')
	+ then show ?case
	+ by (cases t; cases t') auto
	+next
	+ case (Neg \<phi>)
	+ show ?case
	+ using Neg(1)[of \<sigma> \<sigma>'] Neg(2) by auto
	+next
	+ case (Conj \<phi>1 \<phi>2)
	+ show ?case
	+ using Conj(1,2)[of \<sigma> \<sigma>'] Conj(3) by auto
	+next
	+ case (Disj \<phi>1 \<phi>2)
	+ show ?case
	+ using Disj(1,2)[of \<sigma> \<sigma>'] Disj(3) by auto
	+next
	+ case (Exists n \<phi>)
	+ show ?case
	+ proof (rule iffI)
	+ assume "esat (Exists n \<phi>) I \<sigma> X"
	+ then obtain x where x_def: "x \<in> X" "esat \<phi> I (\<sigma>(n := x)) X"
	+ by auto
	+ from x_def(2) have "esat \<phi> I (\<sigma>'(n := x)) X"
	+ using Exists(1)[of "\<sigma>(n := x)" "\<sigma>'(n := x)"] Exists(2) by fastforce
	+ with x_def(1) show "esat (Exists n \<phi>) I \<sigma>' X"
	+ by auto
	+ next
	+ assume "esat (Exists n \<phi>) I \<sigma>' X"
	+ then obtain x where x_def: "x \<in> X" "esat \<phi> I (\<sigma>'(n := x)) X"
	+ by auto
	+ from x_def(2) have "esat \<phi> I (\<sigma>(n := x)) X"
	+ using Exists(1)[of "\<sigma>(n := x)" "\<sigma>'(n := x)"] Exists(2) by fastforce
	+ with x_def(1) show "esat (Exists n \<phi>) I \<sigma> X"
	+ by auto
	+ qed
	+next
	+ case (Forall n \<phi>)
	+ then show ?case
	+ by auto
	+qed auto
	+
	+fun ad_terms :: "('a fo_term) list \<Rightarrow> 'a set" where
	+ "ad_terms ts = \<Union>(set (map set_fo_term ts))"
	+
	+fun act_edom :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 'a set" where
	+ "act_edom (Pred r ts) I = ad_terms ts \<union> \<Union>(set ` I (r, length ts))"
	+\| "act_edom (Bool b) I = {}"
	+\| "act_edom (Eqa t t') I = set_fo_term t \<union> set_fo_term t'"
	+\| "act_edom (Neg \<phi>) I = act_edom \<phi> I"
	+\| "act_edom (Conj \<phi> \<psi>) I = act_edom \<phi> I \<union> act_edom \<psi> I"
	+\| "act_edom (Disj \<phi> \<psi>) I = act_edom \<phi> I \<union> act_edom \<psi> I"
	+\| "act_edom (Exists n \<phi>) I = act_edom \<phi> I"
	+\| "act_edom (Forall n \<phi>) I = act_edom \<phi> I"
	+
	+lemma finite_act_edom: "wf_fo_intp \<phi> I \<Longrightarrow> finite (act_edom \<phi> I)"
	+ using finite_Inl
	+ by (induction \<phi> I rule: wf_fo_intp.induct)
	+ (auto simp: finite_set_fo_term vimage_def)
	+
	+fun fo_adom :: "('a, 'c) fo_t \<Rightarrow> 'a set" where
	+ "fo_adom (AD, n, X) = AD"
	+
	+theorem main: "ad_agr \<phi> AD \<sigma> \<tau> \<Longrightarrow> act_edom \<phi> I \<subseteq> AD \<Longrightarrow>
	+ Inl ` AD \<union> Inr ` {..<d \<phi>} \<subseteq> X \<Longrightarrow> \<tau> ` fv_fo_fmla \<phi> \<subseteq> X \<Longrightarrow>
	+ esat \<phi> I \<sigma> UNIV \<longleftrightarrow> esat \<phi> I \<tau> X"
	+proof (induction \<phi> arbitrary: \<sigma> \<tau> rule: sz_fmla_induct)
	+ case (Pred r ts)
	+ have fv_sub: "fv_fo_terms_set ts \<subseteq> fv_fo_fmla (Pred r ts)"
	+ by auto
	+ have sub_AD: "\<Union>(set ` I (r, length ts)) \<subseteq> AD"
	+ using Pred(2)
	+ by auto
	+ show ?case
	+ unfolding esat.simps
	+ proof (rule iffI)
	+ assume assm: "\<sigma> \<odot>e ts \<in> map Inl ` I (r, length ts)"
	+ have "\<sigma> \<odot>e ts = \<tau> \<odot>e ts"
	+ using esat_Pred[OF ad_agr_sets_mono[OF sub_AD Pred(1)[unfolded ad_agr_def]]
	+ fv_sub assm]
	+ by (auto simp: eval_eterms_def)
	+ with assm show "\<tau> \<odot>e ts \<in> map Inl ` I (r, length ts)"
	+ by auto
	+ next
	+ assume assm: "\<tau> \<odot>e ts \<in> map Inl ` I (r, length ts)"
	+ have "\<tau> \<odot>e ts = \<sigma> \<odot>e ts"
	+ using esat_Pred[OF ad_agr_sets_comm[OF ad_agr_sets_mono[OF
	+ sub_AD Pred(1)[unfolded ad_agr_def]]] fv_sub assm]
	+ by (auto simp: eval_eterms_def)
	+ with assm show "\<sigma> \<odot>e ts \<in> map Inl ` I (r, length ts)"
	+ by auto
	+ qed
	+next
	+ case (Eqa x1 x2)
	+ show ?case
	+ proof (cases x1; cases x2)
	+ fix c c'
	+ assume "x1 = Const c" "x2 = Const c'"
	+ with Eqa show ?thesis
	+ by auto
	+ next
	+ fix c m'
	+ assume assms: "x1 = Const c" "x2 = Var m'"
	+ with Eqa(1,2) have "\<sigma> m' = Inl c \<longleftrightarrow> \<tau> m' = Inl c"
	+ apply (auto simp: ad_agr_def ad_agr_sets_def)
	+ unfolding ad_equiv_pair.simps
	+ by fastforce+
	+ with assms show ?thesis
	+ by fastforce
	+ next
	+ fix m c'
	+ assume assms: "x1 = Var m" "x2 = Const c'"
	+ with Eqa(1,2) have "\<sigma> m = Inl c' \<longleftrightarrow> \<tau> m = Inl c'"
	+ apply (auto simp: ad_agr_def ad_agr_sets_def)
	+ unfolding ad_equiv_pair.simps
	+ by fastforce+
	+ with assms show ?thesis
	+ by auto
	+ next
	+ fix m m'
	+ assume assms: "x1 = Var m" "x2 = Var m'"
	+ with Eqa(1,2) have "\<sigma> m = \<sigma> m' \<longleftrightarrow> \<tau> m = \<tau> m'"
	+ by (auto simp: ad_agr_def ad_agr_sets_def sp_equiv_def pairwise_def split: if_splits)
	+ with assms show ?thesis
	+ by auto
	+ qed
	+next
	+ case (Neg \<phi>)
	+ from Neg(2) have "ad_agr \<phi> AD \<sigma> \<tau>"
	+ by (auto simp: ad_agr_def)
	+ with Neg show ?case
	+ by auto
	+next
	+ case (Conj \<phi>1 \<phi>2)
	+ have aux: "ad_agr \<phi>1 AD \<sigma> \<tau>" "ad_agr \<phi>2 AD \<sigma> \<tau>"
	+ "Inl ` AD \<union> Inr ` {..<d \<phi>1} \<subseteq> X" "Inl ` AD \<union> Inr ` {..<d \<phi>2} \<subseteq> X"
	+ "\<tau> ` fv_fo_fmla \<phi>1 \<subseteq> X" "\<tau> ` fv_fo_fmla \<phi>2 \<subseteq> X"
	+ using Conj(3,5,6)
	+ by (auto simp: ad_agr_def ad_agr_sets_def sp_equiv_def pairwise_def)
	+ show ?case
	+ using Conj(1)[OF aux(1) _ aux(3) aux(5)] Conj(2)[OF aux(2) _ aux(4) aux(6)] Conj(4)
	+ by auto
	+next
	+ case (Disj \<phi>1 \<phi>2)
	+ have aux: "ad_agr \<phi>1 AD \<sigma> \<tau>" "ad_agr \<phi>2 AD \<sigma> \<tau>"
	+ "Inl ` AD \<union> Inr ` {..<d \<phi>1} \<subseteq> X" "Inl ` AD \<union> Inr ` {..<d \<phi>2} \<subseteq> X"
	+ "\<tau> ` fv_fo_fmla \<phi>1 \<subseteq> X" "\<tau> ` fv_fo_fmla \<phi>2 \<subseteq> X"
	+ using Disj(3,5,6)
	+ by (auto simp: ad_agr_def ad_agr_sets_def sp_equiv_def pairwise_def)
	+ show ?case
	+ using Disj(1)[OF aux(1) _ aux(3) aux(5)] Disj(2)[OF aux(2) _ aux(4) aux(6)] Disj(4)
	+ by auto
	+next
	+ case (Exists m \<phi>)
	+ show ?case
	+ proof (rule iffI)
	+ assume "esat (Exists m \<phi>) I \<sigma> UNIV"
	+ then obtain x where assm: "esat \<phi> I (\<sigma>(m := x)) UNIV"
	+ by auto
	+ have "m \<in> SP \<phi> \<Longrightarrow> Suc (card (Inr -` \<tau> ` (SP \<phi> - {m}))) \<le> card (SP \<phi>)"
	+ by (metis Diff_insert_absorb card_image card_le_Suc_iff finite_Diff finite_SP
	+ image_vimage_subset inj_Inr mk_disjoint_insert surj_card_le)
	+ moreover have "card (Inr -` \<tau> ` SP \<phi>) \<le> card (SP \<phi>)"
	+ by (metis card_image finite_SP image_vimage_subset inj_Inr surj_card_le)
	+ ultimately have "max 1 (card (Inr -` \<tau> ` (SP \<phi> - {m})) + (if m \<in> SP \<phi> then 1 else 0)) \<le> d \<phi>"
	+ using d_pos card_SP_d[of \<phi>]
	+ by auto
	+ then have "\<exists>x' \<in> X. ad_agr \<phi> AD (\<sigma>(m := x)) (\<tau>(m := x'))"
	+ using extend_\<tau>[OF Exists(2)[unfolded ad_agr_def fv_fo_fmla.simps SP.simps]
	+ SP_fv[of \<phi>] finite_SP Exists(5)[unfolded fv_fo_fmla.simps]]
	+ Exists(4)
	+ by (force simp: ad_agr_def)
	+ then obtain x' where x'_def: "x' \<in> X" "ad_agr \<phi> AD (\<sigma>(m := x)) (\<tau>(m := x'))"
	+ by auto
	+ from Exists(5) have "\<tau>(m := x') ` fv_fo_fmla \<phi> \<subseteq> X"
	+ using x'_def(1) by fastforce
	+ then have "esat \<phi> I (\<tau>(m := x')) X"
	+ using Exists x'_def(1,2) assm
	+ by fastforce
	+ with x'_def show "esat (Exists m \<phi>) I \<tau> X"
	+ by auto
	+ next
	+ assume "esat (Exists m \<phi>) I \<tau> X"
	+ then obtain z where assm: "z \<in> X" "esat \<phi> I (\<tau>(m := z)) X"
	+ by auto
	+ have ad_agr: "ad_agr_sets (fv_fo_fmla \<phi> - {m}) (SP \<phi> - {m}) AD \<tau> \<sigma>"
	+ using Exists(2)[unfolded ad_agr_def fv_fo_fmla.simps SP.simps]
	+ by (rule ad_agr_sets_comm)
	+ have "\<exists>x. ad_agr \<phi> AD (\<sigma>(m := x)) (\<tau>(m := z))"
	+ using extend_\<tau>[OF ad_agr SP_fv[of \<phi>] finite_SP subset_UNIV subset_UNIV] ad_agr_sets_comm
	+ unfolding ad_agr_def
	+ by fastforce
	+ then obtain x where x_def: "ad_agr \<phi> AD (\<sigma>(m := x)) (\<tau>(m := z))"
	+ by auto
	+ have "\<tau>(m := z) ` fv_fo_fmla (Exists m \<phi>) \<subseteq> X"
	+ using Exists
	+ by fastforce
	+ with x_def have "esat \<phi> I (\<sigma>(m := x)) UNIV"
	+ using Exists assm
	+ by fastforce
	+ then show "esat (Exists m \<phi>) I \<sigma> UNIV"
	+ by auto
	+ qed
	+next
	+ case (Forall n \<phi>)
	+ have unfold: "act_edom (Forall n \<phi>) I = act_edom (Exists n (Neg \<phi>)) I"
	+ "Inl ` AD \<union> Inr ` {..<d (Forall n \<phi>)} = Inl ` AD \<union> Inr ` {..<d (Exists n (Neg \<phi>))}"
	+ "fv_fo_fmla (Forall n \<phi>) = fv_fo_fmla (Exists n (Neg \<phi>))"
	+ by auto
	+ have pred: "ad_agr (Exists n (Neg \<phi>)) AD \<sigma> \<tau>"
	+ using Forall(2)
	+ by (auto simp: ad_agr_def)
	+ show ?case
	+ using Forall(1)[OF pred Forall(3,4,5)[unfolded unfold]]
	+ by auto
	+qed auto
	+
	+lemma main_cor_inf:
	+ assumes "ad_agr \<phi> AD \<sigma> \<tau>" "act_edom \<phi> I \<subseteq> AD" "d \<phi> \<le> n"
	+ "\<tau> ` fv_fo_fmla \<phi> \<subseteq> Inl ` AD \<union> Inr ` {..<n}"
	+ shows "esat \<phi> I \<sigma> UNIV \<longleftrightarrow> esat \<phi> I \<tau> (Inl ` AD \<union> Inr ` {..<n})"
	+proof -
	+ show ?thesis
	+ using main[OF assms(1,2) _ assms(4)] assms(3)
	+ by fastforce
	+qed
	+
	+lemma esat_UNIV_cong:
	+ fixes \<sigma> :: "nat \<Rightarrow> 'a + nat"
	+ assumes "ad_agr \<phi> AD \<sigma> \<tau>" "act_edom \<phi> I \<subseteq> AD"
	+ shows "esat \<phi> I \<sigma> UNIV \<longleftrightarrow> esat \<phi> I \<tau> UNIV"
	+proof -
	+ show ?thesis
	+ using main[OF assms(1,2) subset_UNIV subset_UNIV]
	+ by auto
	+qed
	+
	+lemma esat_UNIV_ad_agr_list:
	+ fixes \<sigma> :: "nat \<Rightarrow> 'a + nat"
	+ assumes "ad_agr_list AD (map \<sigma> (fv_fo_fmla_list \<phi>)) (map \<tau> (fv_fo_fmla_list \<phi>))"
	+ "act_edom \<phi> I \<subseteq> AD"
	+ shows "esat \<phi> I \<sigma> UNIV \<longleftrightarrow> esat \<phi> I \<tau> UNIV"
	+ using esat_UNIV_cong[OF iffD2[OF ad_agr_def, OF ad_agr_sets_mono'[OF SP_fv],
	+ OF iffD2[OF ad_agr_list_link, OF assms(1), unfolded fv_fo_fmla_list_set]] assms(2)] .
	+
	+fun fo_rep :: "('a, 'c) fo_t \<Rightarrow> 'a table" where
	+ "fo_rep (AD, n, X) = {ts. \<exists>ts' \<in> X. ad_agr_list AD (map Inl ts) ts'}"
	+
	+lemma sat_esat_conv:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes fin: "wf_fo_intp \<phi> I"
	+ shows "sat \<phi> I \<sigma> \<longleftrightarrow> esat \<phi> I (Inl \<circ> \<sigma> :: nat \<Rightarrow> 'a + nat) UNIV"
	+ using assms
	+proof (induction \<phi> arbitrary: I \<sigma> rule: sz_fmla_induct)
	+ case (Pred r ts)
	+ show ?case
	+ unfolding sat.simps esat.simps comp_def[symmetric] eval_terms_eterms[symmetric]
	+ by auto
	+next
	+ case (Eqa t t')
	+ show ?case
	+ by (cases t; cases t') auto
	+next
	+ case (Exists n \<phi>)
	+ show ?case
	+ proof (rule iffI)
	+ assume "sat (Exists n \<phi>) I \<sigma>"
	+ then obtain x where x_def: "esat \<phi> I (Inl \<circ> \<sigma>(n := x)) UNIV"
	+ using Exists
	+ by fastforce
	+ have Inl_unfold: "Inl \<circ> \<sigma>(n := x) = (Inl \<circ> \<sigma>)(n := Inl x)"
	+ by auto
	+ show "esat (Exists n \<phi>) I (Inl \<circ> \<sigma>) UNIV"
	+ using x_def
	+ unfolding Inl_unfold
	+ by auto
	+ next
	+ assume "esat (Exists n \<phi>) I (Inl \<circ> \<sigma>) UNIV"
	+ then obtain x where x_def: "esat \<phi> I ((Inl \<circ> \<sigma>)(n := x)) UNIV"
	+ by auto
	+ show "sat (Exists n \<phi>) I \<sigma>"
	+ proof (cases x)
	+ case (Inl a)
	+ have Inl_unfold: "(Inl \<circ> \<sigma>)(n := x) = Inl \<circ> \<sigma>(n := a)"
	+ by (auto simp: Inl)
	+ show ?thesis
	+ using x_def[unfolded Inl_unfold] Exists
	+ by fastforce
	+ next
	+ case (Inr b)
	+ obtain c where c_def: "c \<notin> act_edom \<phi> I \<union> \<sigma> ` fv_fo_fmla \<phi>"
	+ using arb_element finite_act_edom[OF Exists(2), simplified] finite_fv_fo_fmla
	+ by (metis finite_Un finite_imageI)
	+ have wf_local: "wf_fo_intp \<phi> I"
	+ using Exists(2)
	+ by auto
	+ have "(a, a') \<in> set (zip (map (\<lambda>x. if x = n then Inr b else (Inl \<circ> \<sigma>) x) (fv_fo_fmla_list \<phi>))
	+ (map (\<lambda>a. Inl (if a = n then c else \<sigma> a)) (fv_fo_fmla_list \<phi>))) \<Longrightarrow>
	+ ad_equiv_pair (act_edom \<phi> I) (a, a')" for a a'
	+ using c_def
	+ by (cases a; cases a') (auto simp: set_zip ad_equiv_pair.simps split: if_splits)
	+ then have "sat \<phi> I (\<sigma>(n := c))"
	+ using c_def[folded fv_fo_fmla_list_set]
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def fun_upd_def sp_equiv_list_def pairwise_def set_zip split: if_splits
	+ intro!: Exists(1)[OF wf_local, THEN iffD2, OF esat_UNIV_ad_agr_list[OF _ subset_refl, THEN iffD1, OF _ x_def[unfolded Inr]]])
	+ then show ?thesis
	+ by auto
	+ qed
	+ qed
	+next
	+ case (Forall n \<phi>)
	+ show ?case
	+ using Forall(1)[of I \<sigma>] Forall(2)
	+ by auto
	+qed auto
	+
	+lemma sat_ad_agr_list:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ and J :: "(('a, nat) fo_t, 'b) fo_intp"
	+ assumes "wf_fo_intp \<phi> I"
	+ "ad_agr_list AD (map (Inl \<circ> \<sigma> :: nat \<Rightarrow> 'a + nat) (fv_fo_fmla_list \<phi>))
	+ (map (Inl \<circ> \<tau>) (fv_fo_fmla_list \<phi>))" "act_edom \<phi> I \<subseteq> AD"
	+ shows "sat \<phi> I \<sigma> \<longleftrightarrow> sat \<phi> I \<tau>"
	+ using esat_UNIV_ad_agr_list[OF assms(2,3)] sat_esat_conv[OF assms(1)]
	+ by auto
	+
	+definition nfv :: "('a, 'b) fo_fmla \<Rightarrow> nat" where
	+ "nfv \<phi> = length (fv_fo_fmla_list \<phi>)"
	+
	+lemma nfv_card: "nfv \<phi> = card (fv_fo_fmla \<phi>)"
	+proof -
	+ have "distinct (fv_fo_fmla_list \<phi>)"
	+ using sorted_distinct_fv_list
	+ by auto
	+ then have "length (fv_fo_fmla_list \<phi>) = card (set (fv_fo_fmla_list \<phi>))"
	+ using distinct_card by fastforce
	+ then show ?thesis
	+ unfolding fv_fo_fmla_list_set by (auto simp: nfv_def)
	+qed
	+
	+fun rremdups :: "'a list \<Rightarrow> 'a list" where
	+ "rremdups [] = []"
	+\| "rremdups (x # xs) = x # rremdups (filter ((\<noteq>) x) xs)"
	+
	+lemma filter_rremdups_filter: "filter P (rremdups (filter Q xs)) =
	+ rremdups (filter (\<lambda>x. P x \<and> Q x) xs)"
	+ apply (induction xs arbitrary: Q)
	+ apply auto
	+ by metis
	+
	+lemma filter_rremdups: "filter P (rremdups xs) = rremdups (filter P xs)"
	+ using filter_rremdups_filter[where Q="\<lambda>_. True"]
	+ by auto
	+
	+lemma filter_take: "\<exists>j. filter P (take i xs) = take j (filter P xs)"
	+ apply (induction xs arbitrary: i)
	+ apply (auto)
	+ apply (metis filter.simps(1) filter.simps(2) take_Cons' take_Suc_Cons)
	+ apply (metis filter.simps(2) take0 take_Cons')
	+ done
	+
	+lemma rremdups_take: "\<exists>j. rremdups (take i xs) = take j (rremdups xs)"
	+proof (induction xs arbitrary: i)
	+ case (Cons x xs)
	+ show ?case
	+ proof (cases i)
	+ case (Suc n)
	+ obtain j where j_def: "rremdups (take n xs) = take j (rremdups xs)"
	+ using Cons by auto
	+ obtain j' where j'_def: "filter ((\<noteq>) x) (take j (rremdups xs)) =
	+ take j' (filter ((\<noteq>) x) (rremdups xs))"
	+ using filter_take
	+ by blast
	+ show ?thesis
	+ by (auto simp: Suc filter_rremdups[symmetric] j_def j'_def intro: exI[of _ "Suc j'"])
	+ qed (auto simp add: take_Cons')
	+qed auto
	+
	+lemma rremdups_app: "rremdups (xs @ [x]) = rremdups xs @ (if x \<in> set xs then [] else [x])"
	+ apply (induction xs)
	+ apply auto
	+ apply (smt filter.simps(1) filter.simps(2) filter_append filter_rremdups)+
	+ done
	+
	+lemma rremdups_set: "set (rremdups xs) = set xs"
	+ by (induction xs) (auto simp: filter_rremdups[symmetric])
	+
	+lemma distinct_rremdups: "distinct (rremdups xs)"
	+proof (induction "length xs" arbitrary: xs rule: nat_less_induct)
	+ case 1
	+ then have IH: "\<And>m ys. length (ys :: 'a list) < length xs \<Longrightarrow> distinct (rremdups ys)"
	+ by auto
	+ show ?case
	+ proof (cases xs)
	+ case (Cons z zs)
	+ show ?thesis
	+ using IH
	+ by (auto simp: Cons rremdups_set le_imp_less_Suc)
	+ qed auto
	+qed
	+
	+lemma length_rremdups: "length (rremdups xs) = card (set xs)"
	+ using distinct_card[OF distinct_rremdups]
	+ by (subst eq_commute) (auto simp: rremdups_set)
	+
	+lemma set_map_filter_sum: "set (List.map_filter (case_sum Map.empty Some) xs) = Inr -` set xs"
	+ by (induction xs) (auto simp: List.map_filter_simps split: sum.splits)
	+
	+definition nats :: "nat list \<Rightarrow> bool" where
	+ "nats ns = (ns = [0..<length ns])"
	+
	+definition fo_nmlzd :: "'a set \<Rightarrow> ('a + nat) list \<Rightarrow> bool" where
	+ "fo_nmlzd AD xs \<longleftrightarrow> Inl -` set xs \<subseteq> AD \<and>
	+ (let ns = List.map_filter (case_sum Map.empty Some) xs in nats (rremdups ns))"
	+
	+lemma fo_nmlzd_all_AD:
	+ assumes "set xs \<subseteq> Inl ` AD"
	+ shows "fo_nmlzd AD xs"
	+proof -
	+ have "List.map_filter (case_sum Map.empty Some) xs = []"
	+ using assms
	+ by (induction xs) (auto simp: List.map_filter_simps)
	+ then show ?thesis
	+ using assms
	+ by (auto simp: fo_nmlzd_def nats_def Let_def)
	+qed
	+
	+lemma card_Inr_vimage_le_length: "card (Inr -` set xs) \<le> length xs"
	+proof -
	+ have "card (Inr -` set xs) \<le> card (set xs)"
	+ by (meson List.finite_set card_inj_on_le image_vimage_subset inj_Inr)
	+ moreover have "\<dots> \<le> length xs"
	+ by (rule card_length)
	+ finally show ?thesis .
	+qed
	+
	+lemma fo_nmlzd_set:
	+ assumes "fo_nmlzd AD xs"
	+ shows "set xs = set xs \<inter> Inl ` AD \<union> Inr ` {..<min (length xs) (card (Inr -` set xs))}"
	+proof -
	+ have "Inl -` set xs \<subseteq> AD"
	+ using assms
	+ by (auto simp: fo_nmlzd_def)
	+ moreover have "Inr -` set xs = {..<card (Inr -` set xs)}"
	+ using assms
	+ by (auto simp: Let_def fo_nmlzd_def nats_def length_rremdups set_map_filter_sum rremdups_set
	+ dest!: arg_cong[of _ _ set])
	+ ultimately have "set xs = set xs \<inter> Inl ` AD \<union> Inr ` {..<card (Inr -` set xs)}"
	+ by auto (metis (no_types, lifting) UNIV_I UNIV_sum UnE image_iff subset_iff vimageI)
	+ then show ?thesis
	+ using card_Inr_vimage_le_length[of xs]
	+ by (metis min.absorb2)
	+qed
	+
	+lemma map_filter_take: "\<exists>j. List.map_filter f (take i xs) = take j (List.map_filter f xs)"
	+ apply (induction xs arbitrary: i)
	+ apply (auto simp: List.map_filter_simps split: option.splits)
	+ apply (metis map_filter_simps(1) option.case(1) take0 take_Cons')
	+ apply (metis map_filter_simps(1) map_filter_simps(2) option.case(2) take_Cons' take_Suc_Cons)
	+ done
	+
	+lemma fo_nmlzd_take: assumes "fo_nmlzd AD xs"
	+ shows "fo_nmlzd AD (take i xs)"
	+proof -
	+ have aux: "rremdups zs = [0..<length (rremdups zs)] \<Longrightarrow> rremdups (take j zs) =
	+ [0..<length (rremdups (take j zs))]" for j zs
	+ using rremdups_take[of j zs]
	+ by (auto simp add: min_def) (metis add_0 linorder_le_cases take_upt)
	+ show ?thesis
	+ using assms map_filter_take[of "case_sum Map.empty Some" i xs] set_take_subset
	+ using aux[where ?zs="List.map_filter (case_sum Map.empty Some) xs"]
	+ by (fastforce simp: fo_nmlzd_def vimage_def nats_def Let_def)
	+qed
	+
	+lemma map_filter_app: "List.map_filter f (xs @ [x]) = List.map_filter f xs @
	+ (case f x of Some y \<Rightarrow> [y] \| _ \<Rightarrow> [])"
	+ by (induction xs) (auto simp: List.map_filter_simps split: option.splits)
	+
	+lemma fo_nmlzd_app_Inr: "Inr n \<notin> set xs \<Longrightarrow> Inr n' \<notin> set xs \<Longrightarrow> fo_nmlzd AD (xs @ [Inr n]) \<Longrightarrow>
	+ fo_nmlzd AD (xs @ [Inr n']) \<Longrightarrow> n = n'"
	+ by (auto simp: List.map_filter_simps fo_nmlzd_def nats_def Let_def map_filter_app
	+ rremdups_app set_map_filter_sum)
	+
	+fun all_tuples :: "'c set \<Rightarrow> nat \<Rightarrow> 'c table" where
	+ "all_tuples xs 0 = {[]}"
	+\| "all_tuples xs (Suc n) = \<Union>((\<lambda>as. (\<lambda>x. x # as) ` xs) ` (all_tuples xs n))"
	+
	+definition nall_tuples :: "'a set \<Rightarrow> nat \<Rightarrow> ('a + nat) table" where
	+ "nall_tuples AD n = {zs \<in> all_tuples (Inl ` AD \<union> Inr ` {..<n}) n. fo_nmlzd AD zs}"
	+
	+lemma all_tuples_finite: "finite xs \<Longrightarrow> finite (all_tuples xs n)"
	+ by (induction xs n rule: all_tuples.induct) auto
	+
	+lemma nall_tuples_finite: "finite AD \<Longrightarrow> finite (nall_tuples AD n)"
	+ by (auto simp: nall_tuples_def all_tuples_finite)
	+
	+lemma all_tuplesI: "length vs = n \<Longrightarrow> set vs \<subseteq> xs \<Longrightarrow> vs \<in> all_tuples xs n"
	+proof (induction xs n arbitrary: vs rule: all_tuples.induct)
	+ case (2 xs n)
	+ then obtain w ws where "vs = w # ws" "length ws = n" "set ws \<subseteq> xs" "w \<in> xs"
	+ by (metis Suc_length_conv contra_subsetD list.set_intros(1) order_trans set_subset_Cons)
	+ with 2(1) show ?case
	+ by auto
	+qed auto
	+
	+lemma nall_tuplesI: "length vs = n \<Longrightarrow> fo_nmlzd AD vs \<Longrightarrow> vs \<in> nall_tuples AD n"
	+ using fo_nmlzd_set[of AD vs]
	+ by (auto simp: nall_tuples_def intro!: all_tuplesI)
	+
	+lemma all_tuplesD: "vs \<in> all_tuples xs n \<Longrightarrow> length vs = n \<and> set vs \<subseteq> xs"
	+ by (induction xs n arbitrary: vs rule: all_tuples.induct) auto+
	+
	+lemma all_tuples_setD: "vs \<in> all_tuples xs n \<Longrightarrow> set vs \<subseteq> xs"
	+ by (auto dest: all_tuplesD)
	+
	+lemma nall_tuplesD: "vs \<in> nall_tuples AD n \<Longrightarrow>
	+ length vs = n \<and> set vs \<subseteq> Inl ` AD \<union> Inr ` {..<n} \<and> fo_nmlzd AD vs"
	+ by (auto simp: nall_tuples_def dest: all_tuplesD)
	+
	+lemma all_tuples_set: "all_tuples xs n = {ys. length ys = n \<and> set ys \<subseteq> xs}"
	+proof (induction xs n rule: all_tuples.induct)
	+ case (2 xs n)
	+ show ?case
	+ proof (rule subset_antisym; rule subsetI)
	+ fix ys
	+ assume "ys \<in> all_tuples xs (Suc n)"
	+ then show "ys \<in> {ys. length ys = Suc n \<and> set ys \<subseteq> xs}"
	+ using 2 by auto
	+ next
	+ fix ys
	+ assume "ys \<in> {ys. length ys = Suc n \<and> set ys \<subseteq> xs}"
	+ then have assm: "length ys = Suc n" "set ys \<subseteq> xs"
	+ by auto
	+ then obtain z zs where zs_def: "ys = z # zs" "z \<in> xs" "length zs = n" "set zs \<subseteq> xs"
	+ by (cases ys) auto
	+ with 2 have "zs \<in> all_tuples xs n"
	+ by auto
	+ with zs_def(1,2) show "ys \<in> all_tuples xs (Suc n)"
	+ by auto
	+ qed
	+qed auto
	+
	+lemma nall_tuples_set: "nall_tuples AD n = {ys. length ys = n \<and> fo_nmlzd AD ys}"
	+ using fo_nmlzd_set[of AD] card_Inr_vimage_le_length
	+ by (auto simp: nall_tuples_def all_tuples_set) (smt UnE nall_tuplesD nall_tuplesI subsetD)
	+
	+fun pos :: "'a \<Rightarrow> 'a list \<Rightarrow> nat option" where
	+ "pos a [] = None"
	+\| "pos a (x # xs) =
	+ (if a = x then Some 0 else (case pos a xs of Some n \<Rightarrow> Some (Suc n) \| _ \<Rightarrow> None))"
	+
	+lemma pos_set: "pos a xs = Some i \<Longrightarrow> a \<in> set xs"
	+ by (induction a xs arbitrary: i rule: pos.induct) (auto split: if_splits option.splits)
	+
	+lemma pos_length: "pos a xs = Some i \<Longrightarrow> i < length xs"
	+ by (induction a xs arbitrary: i rule: pos.induct) (auto split: if_splits option.splits)
	+
	+lemma pos_sound: "pos a xs = Some i \<Longrightarrow> i < length xs \<and> xs ! i = a"
	+ by (induction a xs arbitrary: i rule: pos.induct) (auto split: if_splits option.splits)
	+
	+lemma pos_complete: "pos a xs = None \<Longrightarrow> a \<notin> set xs"
	+ by (induction a xs rule: pos.induct) (auto split: if_splits option.splits)
	+
	+fun rem_nth :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
	+ "rem_nth _ [] = []"
	+\| "rem_nth 0 (x # xs) = xs"
	+\| "rem_nth (Suc n) (x # xs) = x # rem_nth n xs"
	+
	+lemma rem_nth_length: "i < length xs \<Longrightarrow> length (rem_nth i xs) = length xs - 1"
	+ by (induction i xs rule: rem_nth.induct) auto
	+
	+lemma rem_nth_take_drop: "i < length xs \<Longrightarrow> rem_nth i xs = take i xs @ drop (Suc i) xs"
	+ by (induction i xs rule: rem_nth.induct) auto
	+
	+lemma rem_nth_sound: "distinct xs \<Longrightarrow> pos n xs = Some i \<Longrightarrow>
	+ rem_nth i (map \<sigma> xs) = map \<sigma> (filter ((\<noteq>) n) xs)"
	+ apply (induction xs arbitrary: i)
	+ apply (auto simp: pos_set split: option.splits)
	+ by (metis (mono_tags, lifting) filter_True)
	+
	+fun add_nth :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
	+ "add_nth 0 a xs = a # xs"
	+\| "add_nth (Suc n) a zs = (case zs of x # xs \<Rightarrow> x # add_nth n a xs)"
	+
	+lemma add_nth_length: "i \<le> length zs \<Longrightarrow> length (add_nth i z zs) = Suc (length zs)"
	+ by (induction i z zs rule: add_nth.induct) (auto split: list.splits)
	+
	+lemma add_nth_take_drop: "i \<le> length zs \<Longrightarrow> add_nth i v zs = take i zs @ v # drop i zs"
	+ by (induction i v zs rule: add_nth.induct) (auto split: list.splits)
	+
	+lemma add_nth_rem_nth_map: "distinct xs \<Longrightarrow> pos n xs = Some i \<Longrightarrow>
	+ add_nth i a (rem_nth i (map \<sigma> xs)) = map (\<sigma>(n := a)) xs"
	+ by (induction xs arbitrary: i) (auto simp: pos_set split: option.splits)
	+
	+lemma add_nth_rem_nth_self: "i < length xs \<Longrightarrow> add_nth i (xs ! i) (rem_nth i xs) = xs"
	+ by (induction i xs rule: rem_nth.induct) auto
	+
	+lemma rem_nth_add_nth: "i \<le> length zs \<Longrightarrow> rem_nth i (add_nth i z zs) = zs"
	+ by (induction i z zs rule: add_nth.induct) (auto split: list.splits)
	+
	+fun merge :: "(nat \<times> 'a) list \<Rightarrow> (nat \<times> 'a) list \<Rightarrow> (nat \<times> 'a) list" where
	+ "merge [] mys = mys"
	+\| "merge nxs [] = nxs"
	+\| "merge ((n, x) # nxs) ((m, y) # mys) =
	+ (if n \<le> m then (n, x) # merge nxs ((m, y) # mys)
	+ else (m, y) # merge ((n, x) # nxs) mys)"
	+
	+lemma merge_Nil2[simp]: "merge nxs [] = nxs"
	+ by (cases nxs) auto
	+
	+lemma merge_length: "length (merge nxs mys) = length (map fst nxs @ map fst mys)"
	+ by (induction nxs mys rule: merge.induct) auto
	+
	+lemma insort_aux_le: "\<forall>x\<in>set nxs. n \<le> fst x \<Longrightarrow> \<forall>x\<in>set mys. m \<le> fst x \<Longrightarrow> n \<le> m \<Longrightarrow>
	+ insort n (sort (map fst nxs @ m # map fst mys)) = n # sort (map fst nxs @ m # map fst mys)"
	+ by (induction nxs) (auto simp: insort_is_Cons insort_left_comm)
	+
	+lemma insort_aux_gt: "\<forall>x\<in>set nxs. n \<le> fst x \<Longrightarrow> \<forall>x\<in>set mys. m \<le> fst x \<Longrightarrow> \<not> n \<le> m \<Longrightarrow>
	+ insort n (sort (map fst nxs @ m # map fst mys)) =
	+ m # insort n (sort (map fst nxs @ map fst mys))"
	+ apply (induction nxs)
	+ apply (auto simp: insort_is_Cons)
	+ by (metis dual_order.trans insort_key.simps(2) insort_left_comm)
	+
	+lemma map_fst_merge: "sorted_distinct (map fst nxs) \<Longrightarrow> sorted_distinct (map fst mys) \<Longrightarrow>
	+ map fst (merge nxs mys) = sort (map fst nxs @ map fst mys)"
	+ by (induction nxs mys rule: merge.induct)
	+ (auto simp add: sorted_sort_id insort_is_Cons insort_aux_le insort_aux_gt)
	+
	+lemma merge_map': "sorted_distinct (map fst nxs) \<Longrightarrow> sorted_distinct (map fst mys) \<Longrightarrow>
	+ fst ` set nxs \<inter> fst ` set mys = {} \<Longrightarrow>
	+ map snd nxs = map \<sigma> (map fst nxs) \<Longrightarrow> map snd mys = map \<sigma> (map fst mys) \<Longrightarrow>
	+ map snd (merge nxs mys) = map \<sigma> (sort (map fst nxs @ map fst mys))"
	+ by (induction nxs mys rule: merge.induct)
	+ (auto simp: sorted_sort_id insort_is_Cons insort_aux_le insort_aux_gt)
	+
	+lemma merge_map: "sorted_distinct ns \<Longrightarrow> sorted_distinct ms \<Longrightarrow> set ns \<inter> set ms = {} \<Longrightarrow>
	+ map snd (merge (zip ns (map \<sigma> ns)) (zip ms (map \<sigma> ms))) = map \<sigma> (sort (ns @ ms))"
	+ using merge_map'[of "zip ns (map \<sigma> ns)" "zip ms (map \<sigma> ms)" \<sigma>]
	+ by auto (metis length_map list.set_map map_fst_zip)
	+
	+fun fo_nmlz_rec :: "nat \<Rightarrow> ('a + nat \<rightharpoonup> nat) \<Rightarrow> 'a set \<Rightarrow>
	+ ('a + nat) list \<Rightarrow> ('a + nat) list" where
	+ "fo_nmlz_rec i m AD [] = []"
	+\| "fo_nmlz_rec i m AD (Inl x # xs) = (if x \<in> AD then Inl x # fo_nmlz_rec i m AD xs else
	+ (case m (Inl x) of None \<Rightarrow> Inr i # fo_nmlz_rec (Suc i) (m(Inl x \<mapsto> i)) AD xs
	+ \| Some j \<Rightarrow> Inr j # fo_nmlz_rec i m AD xs))"
	+\| "fo_nmlz_rec i m AD (Inr n # xs) = (case m (Inr n) of None \<Rightarrow>
	+ Inr i # fo_nmlz_rec (Suc i) (m(Inr n \<mapsto> i)) AD xs
	+ \| Some j \<Rightarrow> Inr j # fo_nmlz_rec i m AD xs)"
	+
	+lemma fo_nmlz_rec_sound: "ran m \<subseteq> {..<i} \<Longrightarrow> filter ((\<le>) i) (rremdups
	+ (List.map_filter (case_sum Map.empty Some) (fo_nmlz_rec i m AD xs))) = ns \<Longrightarrow>
	+ ns = [i..<i + length ns]"
	+proof (induction i m AD xs arbitrary: ns rule: fo_nmlz_rec.induct)
	+ case (2 i m AD x xs)
	+ then show ?case
	+ proof (cases "x \<in> AD")
	+ case False
	+ show ?thesis
	+ proof (cases "m (Inl x)")
	+ case None
	+ have pred: "ran (m(Inl x \<mapsto> i)) \<subseteq> {..<Suc i}"
	+ using 2(4) None
	+ by (auto simp: inj_on_def dom_def ran_def)
	+ have "ns = i # filter ((\<le>) (Suc i)) (rremdups
	+ (List.map_filter (case_sum Map.empty Some) (fo_nmlz_rec (Suc i) (m(Inl x \<mapsto> i)) AD xs)))"
	+ using 2(5) False None
	+ by (auto simp: List.map_filter_simps filter_rremdups)
	+ (metis Suc_leD antisym not_less_eq_eq)
	+ then show ?thesis
	+ by (auto simp: 2(2)[OF False None pred, OF refl])
	+ (smt Suc_le_eq Suc_pred le_add1 le_zero_eq less_add_same_cancel1 not_less_eq_eq
	+ upt_Suc_append upt_rec)
	+ next
	+ case (Some j)
	+ then have j_lt_i: "j < i"
	+ using 2(4)
	+ by (auto simp: ran_def)
	+ have ns_def: "ns = filter ((\<le>) i) (rremdups
	+ (List.map_filter (case_sum Map.empty Some) (fo_nmlz_rec i m AD xs)))"
	+ using 2(5) False Some j_lt_i
	+ by (auto simp: List.map_filter_simps filter_rremdups) (metis leD)
	+ show ?thesis
	+ by (rule 2(3)[OF False Some 2(4) ns_def[symmetric]])
	+ qed
	+ qed (auto simp: List.map_filter_simps split: option.splits)
	+next
	+ case (3 i m AD n xs)
	+ show ?case
	+ proof (cases "m (Inr n)")
	+ case None
	+ have pred: "ran (m(Inr n \<mapsto> i)) \<subseteq> {..<Suc i}"
	+ using 3(3) None
	+ by (auto simp: inj_on_def dom_def ran_def)
	+ have "ns = i # filter ((\<le>) (Suc i)) (rremdups
	+ (List.map_filter (case_sum Map.empty Some) (fo_nmlz_rec (Suc i) (m(Inr n \<mapsto> i)) AD xs)))"
	+ using 3(4) None
	+ by (auto simp: List.map_filter_simps filter_rremdups) (metis Suc_leD antisym not_less_eq_eq)
	+ then show ?thesis
	+ by (auto simp add: 3(1)[OF None pred, OF refl])
	+ (smt Suc_le_eq Suc_pred le_add1 le_zero_eq less_add_same_cancel1 not_less_eq_eq
	+ upt_Suc_append upt_rec)
	+ next
	+ case (Some j)
	+ then have j_lt_i: "j < i"
	+ using 3(3)
	+ by (auto simp: ran_def)
	+ have ns_def: "ns = filter ((\<le>) i) (rremdups
	+ (List.map_filter (case_sum Map.empty Some) (fo_nmlz_rec i m AD xs)))"
	+ using 3(4) Some j_lt_i
	+ by (auto simp: List.map_filter_simps filter_rremdups) (metis leD)
	+ show ?thesis
	+ by (rule 3(2)[OF Some 3(3) ns_def[symmetric]])
	+ qed
	+qed (auto simp: List.map_filter_simps)
	+
	+definition id_map :: "nat \<Rightarrow> ('a + nat \<rightharpoonup> nat)" where
	+ "id_map n = (\<lambda>x. case x of Inl x \<Rightarrow> None \| Inr x \<Rightarrow> if x < n then Some x else None)"
	+
	+lemma fo_nmlz_rec_idem: "Inl -` set ys \<subseteq> AD \<Longrightarrow>
	+ rremdups (List.map_filter (case_sum Map.empty Some) ys) = ns \<Longrightarrow>
	+ set (filter (\<lambda>n. n < i) ns) \<subseteq> {..<i} \<Longrightarrow> filter ((\<le>) i) ns = [i..<i + k] \<Longrightarrow>
	+ fo_nmlz_rec i (id_map i) AD ys = ys"
	+proof (induction ys arbitrary: i k ns)
	+ case (Cons y ys)
	+ show ?case
	+ proof (cases y)
	+ case (Inl a)
	+ show ?thesis
	+ using Cons(1)[OF _ _ Cons(4,5)] Cons(2,3)
	+ by (auto simp: Inl List.map_filter_simps)
	+ next
	+ case (Inr j)
	+ show ?thesis
	+ proof (cases "j < i")
	+ case False
	+ have j_i: "j = i"
	+ using False Cons(3,5)
	+ by (auto simp: Inr List.map_filter_simps filter_rremdups in_mono split: if_splits)
	+ (metis (no_types, lifting) upt_eq_Cons_conv)
	+ obtain kk where k_def: "k = Suc kk"
	+ using Cons(3,5)
	+ by (cases k) (auto simp: Inr List.map_filter_simps j_i)
	+ define ns' where "ns' = rremdups (List.map_filter (case_sum Map.empty Some) ys)"
	+ have id_map_None: "id_map i (Inr i) = None"
	+ by (auto simp: id_map_def)
	+ have id_map_upd: "id_map i(Inr i \<mapsto> i) = id_map (Suc i)"
	+ by (auto simp: id_map_def split: sum.splits)
	+ have "set (filter (\<lambda>n. n < Suc i) ns') \<subseteq> {..<Suc i}"
	+ using Cons(2,3)
	+ by auto
	+ moreover have "filter ((\<le>) (Suc i)) ns' = [Suc i..<i + k]"
	+ using Cons(3,5)
	+ by (auto simp: Inr List.map_filter_simps j_i filter_rremdups[symmetric] ns'_def[symmetric])
	+ (smt One_nat_def Suc_eq_plus1 Suc_le_eq add_diff_cancel_left' diff_is_0_eq'
	+ dual_order.order_iff_strict filter_cong n_not_Suc_n upt_eq_Cons_conv)
	+ moreover have "Inl -` set ys \<subseteq> AD"
	+ using Cons(2)
	+ by (auto simp: vimage_def)
	+ ultimately have "fo_nmlz_rec (Suc i) ((id_map i)(Inr i \<mapsto> i)) AD ys = ys"
	+ using Cons(1)[OF _ ns'_def[symmetric], of "Suc i" kk]
	+ by (auto simp: ns'_def k_def id_map_upd split: if_splits)
	+ then show ?thesis
	+ by (auto simp: Inr j_i id_map_None)
	+ next
	+ case True
	+ define ns' where "ns' = rremdups (List.map_filter (case_sum Map.empty Some) ys)"
	+ have "set (filter (\<lambda>y. y < i) ns') \<subseteq> set (filter (\<lambda>y. y < i) ns)"
	+ "filter ((\<le>) i) ns' = filter ((\<le>) i) ns"
	+ using Cons(3) True
	+ by (auto simp: Inr List.map_filter_simps filter_rremdups[symmetric] ns'_def[symmetric])
	+ (smt filter_cong leD)
	+ then have "fo_nmlz_rec i (id_map i) AD ys = ys"
	+ using Cons(1)[OF _ ns'_def[symmetric]] Cons(3,5) Cons(2)
	+ by (auto simp: vimage_def)
	+ then show ?thesis
	+ using True
	+ by (auto simp: Inr id_map_def)
	+ qed
	+ qed
	+qed (auto simp: List.map_filter_simps intro!: exI[of _ "[]"])
	+
	+lemma fo_nmlz_rec_length: "length (fo_nmlz_rec i m AD xs) = length xs"
	+ by (induction i m AD xs rule: fo_nmlz_rec.induct) (auto simp: fun_upd_def split: option.splits)
	+
	+lemma insert_Inr: "\<And>X. insert (Inr i) (X \<union> Inr ` {..<i}) = X \<union> Inr ` {..<Suc i}"
	+ by auto
	+
	+lemma fo_nmlz_rec_set: "ran m \<subseteq> {..<i} \<Longrightarrow> set (fo_nmlz_rec i m AD xs) \<union> Inr ` {..<i} =
	+ set xs \<inter> Inl ` AD \<union> Inr ` {..<i + card (set xs - Inl ` AD - dom m)}"
	+proof (induction i m AD xs rule: fo_nmlz_rec.induct)
	+ case (2 i m AD x xs)
	+ have fin: "finite (set (Inl x # xs) - Inl ` AD - dom m)"
	+ by auto
	+ show ?case
	+ using 2(1)[OF _ 2(4)]
	+ proof (cases "x \<in> AD")
	+ case True
	+ have "card (set (Inl x # xs) - Inl ` AD - dom m) = card (set xs - Inl ` AD - dom m)"
	+ using True
	+ by auto
	+ then show ?thesis
	+ using 2(1)[OF True 2(4)] True
	+ by auto
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "m (Inl x)")
	+ case None
	+ have pred: "ran (m(Inl x \<mapsto> i)) \<subseteq> {..<Suc i}"
	+ using 2(4) None
	+ by (auto simp: inj_on_def dom_def ran_def)
	+ have "set (Inl x # xs) - Inl ` AD - dom m =
	+ {Inl x} \<union> (set xs - Inl ` AD - dom (m(Inl x \<mapsto> i)))"
	+ using None False
	+ by (auto simp: dom_def)
	+ then have Suc: "Suc i + card (set xs - Inl ` AD - dom (m(Inl x \<mapsto> i))) =
	+ i + card (set (Inl x # xs) - Inl ` AD - dom m)"
	+ using None
	+ by auto
	+ show ?thesis
	+ using 2(2)[OF False None pred] False None
	+ unfolding Suc
	+ by (auto simp: fun_upd_def[symmetric] insert_Inr)
	+ next
	+ case (Some j)
	+ then have j_lt_i: "j < i"
	+ using 2(4)
	+ by (auto simp: ran_def)
	+ have "card (set (Inl x # xs) - Inl ` AD - dom m) = card (set xs - Inl ` AD - dom m)"
	+ by (auto simp: Some intro: arg_cong[of _ _ card])
	+ then show ?thesis
	+ using 2(3)[OF False Some 2(4)] False Some j_lt_i
	+ by auto
	+ qed
	+ qed
	+next
	+ case (3 i m AD k xs)
	+ then show ?case
	+ proof (cases "m (Inr k)")
	+ case None
	+ have preds: "ran (m(Inr k \<mapsto> i)) \<subseteq> {..<Suc i}"
	+ using 3(3)
	+ by (auto simp: ran_def)
	+ have "set (Inr k # xs) - Inl ` AD - dom m =
	+ {Inr k} \<union> (set xs - Inl ` AD - dom (m(Inr k \<mapsto> i)))"
	+ using None
	+ by (auto simp: dom_def)
	+ then have Suc: "Suc i + card (set xs - Inl ` AD - dom (m(Inr k \<mapsto> i))) =
	+ i + card (set (Inr k # xs) - Inl ` AD - dom m)"
	+ using None
	+ by auto
	+ show ?thesis
	+ using None 3(1)[OF None preds]
	+ unfolding Suc
	+ by (auto simp: fun_upd_def[symmetric] insert_Inr)
	+ next
	+ case (Some j)
	+ have fin: "finite (set (Inr k # xs) - Inl ` AD - dom m)"
	+ by auto
	+ have card_eq: "card (set xs - Inl ` AD - dom m) = card (set (Inr k # xs) - Inl ` AD - dom m)"
	+ by (auto simp: Some intro!: arg_cong[of _ _ card])
	+ have j_lt_i: "j < i"
	+ using 3(3) Some
	+ by (auto simp: ran_def)
	+ show ?thesis
	+ using 3(2)[OF Some 3(3)] j_lt_i
	+ unfolding card_eq
	+ by (auto simp: ran_def insert_Inr Some)
	+ qed
	+qed auto
	+
	+lemma fo_nmlz_rec_set_rev: "set (fo_nmlz_rec i m AD xs) \<subseteq> Inl ` AD \<Longrightarrow> set xs \<subseteq> Inl ` AD"
	+ by (induction i m AD xs rule: fo_nmlz_rec.induct) (auto split: if_splits option.splits)
	+
	+lemma fo_nmlz_rec_map: "inj_on m (dom m) \<Longrightarrow> ran m \<subseteq> {..<i} \<Longrightarrow> \<exists>m'. inj_on m' (dom m') \<and>
	+ (\<forall>n. m n \<noteq> None \<longrightarrow> m' n = m n) \<and> (\<forall>(x, y) \<in> set (zip xs (fo_nmlz_rec i m AD xs)).
	+ (case x of Inl x' \<Rightarrow> if x' \<in> AD then x = y else \<exists>j. m' (Inl x') = Some j \<and> y = Inr j
	+ \| Inr n \<Rightarrow> \<exists>j. m' (Inr n) = Some j \<and> y = Inr j))"
	+proof (induction i m AD xs rule: fo_nmlz_rec.induct)
	+ case (2 i m AD x xs)
	+ show ?case
	+ using 2(1)[OF _ 2(4,5)]
	+ proof (cases "x \<in> AD")
	+ case False
	+ show ?thesis
	+ proof (cases "m (Inl x)")
	+ case None
	+ have preds: "inj_on (m(Inl x \<mapsto> i)) (dom (m(Inl x \<mapsto> i)))" "ran (m(Inl x \<mapsto> i)) \<subseteq> {..<Suc i}"
	+ using 2(4,5)
	+ by (auto simp: inj_on_def ran_def)
	+ show ?thesis
	+ using 2(2)[OF False None preds] False None
	+ apply safe
	+ subgoal for m'
	+ by (auto simp: fun_upd_def split: sum.splits intro!: exI[of _ m'])
	+ done
	+ next
	+ case (Some j)
	+ show ?thesis
	+ using 2(3)[OF False Some 2(4,5)] False Some
	+ apply safe
	+ subgoal for m'
	+ by (auto split: sum.splits intro!: exI[of _ m'])
	+ done
	+ qed
	+ qed auto
	+next
	+ case (3 i m AD n xs)
	+ show ?case
	+ proof (cases "m (Inr n)")
	+ case None
	+ have preds: "inj_on (m(Inr n \<mapsto> i)) (dom (m(Inr n \<mapsto> i)))" "ran (m(Inr n \<mapsto> i)) \<subseteq> {..<Suc i}"
	+ using 3(3,4)
	+ by (auto simp: inj_on_def ran_def)
	+ show ?thesis
	+ using 3(1)[OF None preds] None
	+ apply safe
	+ subgoal for m'
	+ by (auto simp: fun_upd_def intro!: exI[of _ m'] split: sum.splits)
	+ done
	+ next
	+ case (Some j)
	+ show ?thesis
	+ using 3(2)[OF Some 3(3,4)] Some
	+ apply safe
	+ subgoal for m'
	+ by (auto simp: fun_upd_def intro!: exI[of _ m'] split: sum.splits)
	+ done
	+ qed
	+qed auto
	+
	+lemma ad_agr_map:
	+ assumes "length xs = length ys" "inj_on m (dom m)"
	+ "\<And>x y. (x, y) \<in> set (zip xs ys) \<Longrightarrow> (case x of Inl x' \<Rightarrow>
	+ if x' \<in> AD then x = y else m x = Some y \<and> (case y of Inl z \<Rightarrow> z \<notin> AD \| Inr _ \<Rightarrow> True)
	+ \| Inr n \<Rightarrow> m x = Some y \<and> (case y of Inl z \<Rightarrow> z \<notin> AD \| Inr _ \<Rightarrow> True))"
	+ shows "ad_agr_list AD xs ys"
	+proof -
	+ have "ad_equiv_pair AD (a, b)" if "(a, b) \<in> set (zip xs ys)" for a b
	+ unfolding ad_equiv_pair.simps
	+ using assms(3)[OF that]
	+ by (auto split: sum.splits if_splits)
	+ moreover have "False" if "(a, c) \<in> set (zip xs ys)" "(b, c) \<in> set (zip xs ys)" "a \<noteq> b" for a b c
	+ using assms(3)[OF that(1)] assms(3)[OF that(2)] assms(2) that(3)
	+ by (auto split: sum.splits if_splits) (metis domI inj_onD that(3))+
	+ moreover have "False" if "(a, b) \<in> set (zip xs ys)" "(a, c) \<in> set (zip xs ys)" "b \<noteq> c" for a b c
	+ using assms(3)[OF that(1)] assms(3)[OF that(2)] assms(2) that(3)
	+ by (auto split: sum.splits if_splits)
	+ ultimately show ?thesis
	+ using assms
	+ by (fastforce simp: ad_agr_list_def ad_equiv_list_def sp_equiv_list_def pairwise_def)
	+qed
	+
	+lemma fo_nmlz_rec_take: "take n (fo_nmlz_rec i m AD xs) = fo_nmlz_rec i m AD (take n xs)"
	+ by (induction i m AD xs arbitrary: n rule: fo_nmlz_rec.induct)
	+ (auto simp: take_Cons' split: option.splits)
	+
	+definition fo_nmlz :: "'a set \<Rightarrow> ('a + nat) list \<Rightarrow> ('a + nat) list" where
	+ "fo_nmlz = fo_nmlz_rec 0 Map.empty"
	+
	+lemma fo_nmlz_Nil[simp]: "fo_nmlz AD [] = []"
	+ by (auto simp: fo_nmlz_def)
	+
	+lemma fo_nmlz_Cons: "fo_nmlz AD [x] =
	+ (case x of Inl x \<Rightarrow> if x \<in> AD then [Inl x] else [Inr 0] \| _ \<Rightarrow> [Inr 0])"
	+ by (auto simp: fo_nmlz_def split: sum.splits)
	+
	+lemma fo_nmlz_Cons_Cons: "fo_nmlz AD [x, x] =
	+ (case x of Inl x \<Rightarrow> if x \<in> AD then [Inl x, Inl x] else [Inr 0, Inr 0] \| _ \<Rightarrow> [Inr 0, Inr 0])"
	+ by (auto simp: fo_nmlz_def split: sum.splits)
	+
	+lemma fo_nmlz_sound: "fo_nmlzd AD (fo_nmlz AD xs)"
	+ using fo_nmlz_rec_sound[of Map.empty 0] fo_nmlz_rec_set[of Map.empty 0 AD xs]
	+ by (auto simp: fo_nmlzd_def fo_nmlz_def nats_def Let_def)
	+
	+lemma fo_nmlz_length: "length (fo_nmlz AD xs) = length xs"
	+ using fo_nmlz_rec_length
	+ by (auto simp: fo_nmlz_def)
	+
	+lemma fo_nmlz_map: "\<exists>\<tau>. fo_nmlz AD (map \<sigma> ns) = map \<tau> ns"
	+proof -
	+ obtain m' where m'_def: "\<forall>(x, y)\<in>set (zip (map \<sigma> ns) (fo_nmlz AD (map \<sigma> ns))).
	+ case x of Inl x' \<Rightarrow> if x' \<in> AD then x = y else \<exists>j. m' (Inl x') = Some j \<and> y = Inr j
	+ \| Inr n \<Rightarrow> \<exists>j. m' (Inr n) = Some j \<and> y = Inr j"
	+ using fo_nmlz_rec_map[of Map.empty 0, of "map \<sigma> ns"]
	+ by (auto simp: fo_nmlz_def)
	+ define \<tau> where "\<tau> \<equiv> (\<lambda>n. case \<sigma> n of Inl x \<Rightarrow> if x \<in> AD then Inl x else Inr (the (m' (Inl x)))
	+ \| Inr j \<Rightarrow> Inr (the (m' (Inr j))))"
	+ have "fo_nmlz AD (map \<sigma> ns) = map \<tau> ns"
	+ proof (rule nth_equalityI)
	+ show "length (fo_nmlz AD (map \<sigma> ns)) = length (map \<tau> ns)"
	+ using fo_nmlz_length[of AD "map \<sigma> ns"]
	+ by auto
	+ fix i
	+ assume "i < length (fo_nmlz AD (map \<sigma> ns))"
	+ then show "fo_nmlz AD (map \<sigma> ns) ! i = map \<tau> ns ! i"
	+ using m'_def fo_nmlz_length[of AD "map \<sigma> ns"]
	+ apply (auto simp: set_zip \<tau>_def split: sum.splits)
	+ apply (metis nth_map)
	+ apply (metis nth_map option.sel)+
	+ done
	+ qed
	+ then show ?thesis
	+ by auto
	+qed
	+
	+lemma card_set_minus: "card (set xs - X) \<le> length xs"
	+ by (meson Diff_subset List.finite_set card_length card_mono order_trans)
	+
	+lemma fo_nmlz_set: "set (fo_nmlz AD xs) =
	+ set xs \<inter> Inl ` AD \<union> Inr ` {..<min (length xs) (card (set xs - Inl ` AD))}"
	+ using fo_nmlz_rec_set[of Map.empty 0 AD xs]
	+ by (auto simp add: fo_nmlz_def card_set_minus)
	+
	+lemma fo_nmlz_set_rev: "set (fo_nmlz AD xs) \<subseteq> Inl ` AD \<Longrightarrow> set xs \<subseteq> Inl ` AD"
	+ using fo_nmlz_rec_set_rev[of 0 Map.empty AD xs]
	+ by (auto simp: fo_nmlz_def)
	+
	+lemma inj_on_empty: "inj_on Map.empty (dom Map.empty)" and ran_empty_upto: "ran Map.empty \<subseteq> {..<0}"
	+ by auto
	+
	+lemma fo_nmlz_ad_agr: "ad_agr_list AD xs (fo_nmlz AD xs)"
	+ using fo_nmlz_rec_map[OF inj_on_empty ran_empty_upto, of xs AD]
	+ unfolding fo_nmlz_def
	+ apply safe
	+ subgoal for m'
	+ by (fastforce simp: inj_on_def dom_def split: sum.splits if_splits
	+ intro!: ad_agr_map[OF fo_nmlz_rec_length[symmetric], of "map_option Inr \<circ> m'"])
	+ done
	+
	+lemma fo_nmlzd_mono: "Inl -` set xs \<subseteq> AD \<Longrightarrow> fo_nmlzd AD' xs \<Longrightarrow> fo_nmlzd AD xs"
	+ by (auto simp: fo_nmlzd_def)
	+
	+lemma fo_nmlz_idem: "fo_nmlzd AD ys \<Longrightarrow> fo_nmlz AD ys = ys"
	+ using fo_nmlz_rec_idem[where ?i=0]
	+ by (auto simp: fo_nmlzd_def fo_nmlz_def id_map_def nats_def Let_def)
	+
	+lemma fo_nmlz_take: "take n (fo_nmlz AD xs) = fo_nmlz AD (take n xs)"
	+ using fo_nmlz_rec_take
	+ by (auto simp: fo_nmlz_def)
	+
	+fun nall_tuples_rec :: "'a set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a + nat) table" where
	+ "nall_tuples_rec AD i 0 = {[]}"
	+\| "nall_tuples_rec AD i (Suc n) = \<Union>((\<lambda>as. (\<lambda>x. x # as) ` (Inl ` AD \<union> Inr ` {..<i})) `
	+ nall_tuples_rec AD i n) \<union> (\<lambda>as. Inr i # as) ` nall_tuples_rec AD (Suc i) n"
	+
	+lemma nall_tuples_rec_Inl: "vs \<in> nall_tuples_rec AD i n \<Longrightarrow> Inl -` set vs \<subseteq> AD"
	+ by (induction AD i n arbitrary: vs rule: nall_tuples_rec.induct) (fastforce simp: vimage_def)+
	+
	+lemma nall_tuples_rec_length: "xs \<in> nall_tuples_rec AD i n \<Longrightarrow> length xs = n"
	+ by (induction AD i n arbitrary: xs rule: nall_tuples_rec.induct) auto
	+
	+lemma fun_upd_id_map: "id_map i(Inr i \<mapsto> i) = id_map (Suc i)"
	+ by (rule ext) (auto simp: id_map_def split: sum.splits)
	+
	+lemma id_mapD: "id_map j (Inr i) = None \<Longrightarrow> j \<le> i" "id_map j (Inr i) = Some x \<Longrightarrow> i < j \<and> i = x"
	+ by (auto simp: id_map_def split: if_splits)
	+
	+lemma nall_tuples_rec_fo_nmlz_rec_sound: "i \<le> j \<Longrightarrow> xs \<in> nall_tuples_rec AD i n \<Longrightarrow>
	+ fo_nmlz_rec j (id_map j) AD xs = xs"
	+ apply (induction n arbitrary: i j xs)
	+ apply (auto simp: fun_upd_id_map dest!: id_mapD split: option.splits)
	+ apply (meson dual_order.strict_trans2 id_mapD(1) not_Some_eq sup.strict_order_iff)
	+ using Suc_leI apply blast+
	+ done
	+
	+lemma nall_tuples_rec_fo_nmlz_rec_complete:
	+ assumes "fo_nmlz_rec j (id_map j) AD xs = xs"
	+ shows "xs \<in> nall_tuples_rec AD j (length xs)"
	+ using assms
	+proof (induction xs arbitrary: j)
	+ case (Cons x xs)
	+ show ?case
	+ proof (cases x)
	+ case (Inl a)
	+ have a_AD: "a \<in> AD"
	+ using Cons(2)
	+ by (auto simp: Inl split: if_splits option.splits)
	+ show ?thesis
	+ using Cons a_AD
	+ by (auto simp: Inl)
	+ next
	+ case (Inr b)
	+ have b_j: "b \<le> j"
	+ using Cons(2)
	+ by (auto simp: Inr split: option.splits dest: id_mapD)
	+ show ?thesis
	+ proof (cases "b = j")
	+ case True
	+ have preds: "fo_nmlz_rec (Suc j) (id_map (Suc j)) AD xs = xs"
	+ using Cons(2)
	+ by (auto simp: Inr True fun_upd_id_map dest: id_mapD split: option.splits)
	+ show ?thesis
	+ using Cons(1)[OF preds]
	+ by (auto simp: Inr True)
	+ next
	+ case False
	+ have b_lt_j: "b < j"
	+ using b_j False
	+ by auto
	+ have id_map: "id_map j (Inr b) = Some b"
	+ using b_lt_j
	+ by (auto simp: id_map_def)
	+ have preds: "fo_nmlz_rec j (id_map j) AD xs = xs"
	+ using Cons(2)
	+ by (auto simp: Inr id_map)
	+ show ?thesis
	+ using Cons(1)[OF preds] b_lt_j
	+ by (auto simp: Inr)
	+ qed
	+ qed
	+qed auto
	+
	+lemma nall_tuples_rec_fo_nmlz: "xs \<in> nall_tuples_rec AD 0 (length xs) \<longleftrightarrow> fo_nmlz AD xs = xs"
	+ using nall_tuples_rec_fo_nmlz_rec_sound[of 0 0 xs AD "length xs"]
	+ nall_tuples_rec_fo_nmlz_rec_complete[of 0 AD xs]
	+ by (auto simp: fo_nmlz_def id_map_def)
	+
	+lemma fo_nmlzd_code[code]: "fo_nmlzd AD xs \<longleftrightarrow> fo_nmlz AD xs = xs"
	+ using fo_nmlz_idem fo_nmlz_sound
	+ by metis
	+
	+lemma nall_tuples_code[code]: "nall_tuples AD n = nall_tuples_rec AD 0 n"
	+ unfolding nall_tuples_set
	+ using nall_tuples_rec_length trans[OF nall_tuples_rec_fo_nmlz fo_nmlzd_code[symmetric]]
	+ by fastforce
	+
	+lemma exists_map: "length xs = length ys \<Longrightarrow> distinct xs \<Longrightarrow> \<exists>f. ys = map f xs"
	+proof (induction xs ys rule: list_induct2)
	+ case (Cons x xs y ys)
	+ then obtain f where f_def: "ys = map f xs"
	+ by auto
	+ with Cons(3) have "y # ys = map (f(x := y)) (x # xs)"
	+ by auto
	+ then show ?case
	+ by metis
	+qed auto
	+
	+lemma exists_fo_nmlzd:
	+ assumes "length xs = length ys" "distinct xs" "fo_nmlzd AD ys"
	+ shows "\<exists>f. ys = fo_nmlz AD (map f xs)"
	+ using fo_nmlz_idem[OF assms(3)] exists_map[OF _ assms(2)] assms(1)
	+ by metis
	+
	+lemma list_induct2_rev[consumes 1]: "length xs = length ys \<Longrightarrow> (P [] []) \<Longrightarrow>
	+ (\<And>x y xs ys. P xs ys \<Longrightarrow> P (xs @ [x]) (ys @ [y])) \<Longrightarrow> P xs ys"
	+proof (induction "length xs" arbitrary: xs ys)
	+ case (Suc n)
	+ then show ?case
	+ by (cases xs rule: rev_cases; cases ys rule: rev_cases) auto
	+qed auto
	+
	+lemma ad_agr_list_fo_nmlzd:
	+ assumes "ad_agr_list AD vs vs'" "fo_nmlzd AD vs" "fo_nmlzd AD vs'"
	+ shows "vs = vs'"
	+ using ad_agr_list_length[OF assms(1)] assms
	+proof (induction vs vs' rule: list_induct2_rev)
	+ case (2 x y xs ys)
	+ have norms: "fo_nmlzd AD xs" "fo_nmlzd AD ys"
	+ using 2(3,4)
	+ by (auto simp: fo_nmlzd_def nats_def Let_def map_filter_app rremdups_app
	+ split: sum.splits if_splits)
	+ have ad_agr: "ad_agr_list AD xs ys"
	+ using 2(2)
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def sp_equiv_list_def pairwise_def)
	+ note xs_ys = 2(1)[OF ad_agr norms]
	+ have "x = y"
	+ proof (cases "isl x \<or> isl y")
	+ case True
	+ then have "isl x \<longrightarrow> projl x \<in> AD" "isl y \<longrightarrow> projl y \<in> AD"
	+ using 2(3,4)
	+ by (auto simp: fo_nmlzd_def)
	+ then show ?thesis
	+ using 2(2) True
	+ apply (auto simp: ad_agr_list_def ad_equiv_list_def isl_def)
	+ unfolding ad_equiv_pair.simps
	+ by blast+
	+ next
	+ case False
	+ then obtain x' y' where inr: "x = Inr x'" "y = Inr y'"
	+ by (cases x; cases y) auto
	+ show ?thesis
	+ using 2(2) xs_ys
	+ proof (cases "x \<in> set xs \<or> y \<in> set ys")
	+ case False
	+ then show ?thesis
	+ using fo_nmlzd_app_Inr 2(3,4)
	+ unfolding inr xs_ys
	+ by auto
	+ qed (auto simp: ad_agr_list_def sp_equiv_list_def pairwise_def set_zip in_set_conv_nth)
	+ qed
	+ then show ?case
	+ using xs_ys
	+ by auto
	+qed auto
	+
	+lemma fo_nmlz_eqI:
	+ assumes "ad_agr_list AD vs vs'"
	+ shows "fo_nmlz AD vs = fo_nmlz AD vs'"
	+ using ad_agr_list_fo_nmlzd[OF
	+ ad_agr_list_trans[OF ad_agr_list_trans[OF
	+ ad_agr_list_comm[OF fo_nmlz_ad_agr[of AD vs]] assms]
	+ fo_nmlz_ad_agr[of AD vs']] fo_nmlz_sound fo_nmlz_sound] .
	+
	+lemma fo_nmlz_eqD:
	+ assumes "fo_nmlz AD vs = fo_nmlz AD vs'"
	+ shows "ad_agr_list AD vs vs'"
	+ using ad_agr_list_trans[OF fo_nmlz_ad_agr[of AD vs, unfolded assms]
	+ ad_agr_list_comm[OF fo_nmlz_ad_agr[of AD vs']]] .
	+
	+lemma fo_nmlz_eq: "fo_nmlz AD vs = fo_nmlz AD vs' \<longleftrightarrow> ad_agr_list AD vs vs'"
	+ using fo_nmlz_eqI[where ?AD=AD] fo_nmlz_eqD[where ?AD=AD]
	+ by blast
	+
	+lemma fo_nmlz_mono:
	+ assumes "AD \<subseteq> AD'" "Inl -` set xs \<subseteq> AD"
	+ shows "fo_nmlz AD' xs = fo_nmlz AD xs"
	+proof -
	+ have "fo_nmlz AD (fo_nmlz AD' xs) = fo_nmlz AD' xs"
	+ apply (rule fo_nmlz_idem[OF fo_nmlzd_mono[OF _ fo_nmlz_sound]])
	+ using assms
	+ by (auto simp: fo_nmlz_set)
	+ moreover have "fo_nmlz AD xs = fo_nmlz AD (fo_nmlz AD' xs)"
	+ apply (rule fo_nmlz_eqI)
	+ apply (rule ad_agr_list_mono[OF assms(1)])
	+ apply (rule fo_nmlz_ad_agr)
	+ done
	+ ultimately show ?thesis
	+ by auto
	+qed
	+
	+definition proj_vals :: "'c val set \<Rightarrow> nat list \<Rightarrow> 'c table" where
	+ "proj_vals R ns = (\<lambda>\<tau>. map \<tau> ns) ` R"
	+
	+definition proj_fmla :: "('a, 'b) fo_fmla \<Rightarrow> 'c val set \<Rightarrow> 'c table" where
	+ "proj_fmla \<phi> R = proj_vals R (fv_fo_fmla_list \<phi>)"
	+
	+lemmas proj_fmla_map = proj_fmla_def[unfolded proj_vals_def]
	+
	+definition "extends_subst \<sigma> \<tau> = (\<forall>x. \<sigma> x \<noteq> None \<longrightarrow> \<sigma> x = \<tau> x)"
	+
	+definition ext_tuple :: "'a set \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow>
	+ ('a + nat) list \<Rightarrow> ('a + nat) list set" where
	+ "ext_tuple AD fv_sub fv_sub_comp as = (if fv_sub_comp = [] then {as}
	+ else (\<lambda>fs. map snd (merge (zip fv_sub as) (zip fv_sub_comp fs))) `
	+ (nall_tuples_rec AD (card (Inr -` set as)) (length fv_sub_comp)))"
	+
	+lemma ext_tuple_eq: "length fv_sub = length as \<Longrightarrow>
	+ ext_tuple AD fv_sub fv_sub_comp as =
	+ (\<lambda>fs. map snd (merge (zip fv_sub as) (zip fv_sub_comp fs))) `
	+ (nall_tuples_rec AD (card (Inr -` set as)) (length fv_sub_comp))"
	+ using fo_nmlz_idem[of AD as]
	+ by (auto simp: ext_tuple_def)
	+
	+lemma map_map_of: "length xs = length ys \<Longrightarrow> distinct xs \<Longrightarrow>
	+ ys = map (the \<circ> (map_of (zip xs ys))) xs"
	+ by (induction xs ys rule: list_induct2) (auto simp: fun_upd_comp)
	+
	+lemma id_map_empty: "id_map 0 = Map.empty"
	+ by (rule ext) (auto simp: id_map_def split: sum.splits)
	+
	+lemma fo_nmlz_rec_shift:
	+ fixes xs :: "('a + nat) list"
	+ shows "fo_nmlz_rec i (id_map i) AD xs = xs \<Longrightarrow>
	+ i' = card (Inr -` (Inr ` {..<i} \<union> set (take n xs))) \<Longrightarrow> n \<le> length xs \<Longrightarrow>
	+ fo_nmlz_rec i' (id_map i') AD (drop n xs) = drop n xs"
	+proof (induction i "id_map i :: 'a + nat \<rightharpoonup> nat" AD xs arbitrary: n rule: fo_nmlz_rec.induct)
	+ case (2 i AD x xs)
	+ have preds: "x \<in> AD" "fo_nmlz_rec i (id_map i) AD xs = xs"
	+ using 2(4)
	+ by (auto split: if_splits option.splits)
	+ show ?case
	+ using 2(4,5)
	+ proof (cases n)
	+ case (Suc k)
	+ have k_le: "k \<le> length xs"
	+ using 2(6)
	+ by (auto simp: Suc)
	+ have i'_def: "i' = card (Inr -` (Inr ` {..<i} \<union> set (take k xs)))"
	+ using 2(5)
	+ by (auto simp: Suc vimage_def)
	+ show ?thesis
	+ using 2(1)[OF preds i'_def k_le]
	+ by (auto simp: Suc)
	+ qed (auto simp: inj_vimage_image_eq)
	+next
	+ case (3 i AD j xs)
	+ show ?case
	+ using 3(3,4)
	+ proof (cases n)
	+ case (Suc k)
	+ have k_le: "k \<le> length xs"
	+ using 3(5)
	+ by (auto simp: Suc)
	+ have j_le_i: "j \<le> i"
	+ using 3(3)
	+ by (auto split: option.splits dest: id_mapD)
	+ show ?thesis
	+ proof (cases "j = i")
	+ case True
	+ have id_map: "id_map i (Inr j) = None" "id_map i(Inr j \<mapsto> i) = id_map (Suc i)"
	+ unfolding True fun_upd_id_map
	+ by (auto simp: id_map_def)
	+ have norm_xs: "fo_nmlz_rec (Suc i) (id_map (Suc i)) AD xs = xs"
	+ using 3(3)
	+ by (auto simp: id_map split: option.splits dest: id_mapD)
	+ have i'_def: "i' = card (Inr -` (Inr ` {..<Suc i} \<union> set (take k xs)))"
	+ using 3(4)
	+ by (auto simp: Suc True inj_vimage_image_eq)
	+ (metis Un_insert_left image_insert inj_Inr inj_vimage_image_eq lessThan_Suc vimage_Un)
	+ show ?thesis
	+ using 3(1)[OF id_map norm_xs i'_def k_le]
	+ by (auto simp: Suc)
	+ next
	+ case False
	+ have id_map: "id_map i (Inr j) = Some j"
	+ using j_le_i False
	+ by (auto simp: id_map_def)
	+ have norm_xs: "fo_nmlz_rec i (id_map i) AD xs = xs"
	+ using 3(3)
	+ by (auto simp: id_map)
	+ have i'_def: "i' = card (Inr -` (Inr ` {..<i} \<union> set (take k xs)))"
	+ using 3(4) j_le_i False
	+ by (auto simp: Suc inj_vimage_image_eq insert_absorb)
	+ show ?thesis
	+ using 3(2)[OF id_map norm_xs i'_def k_le]
	+ by (auto simp: Suc)
	+ qed
	+ qed (auto simp: inj_vimage_image_eq)
	+qed auto
	+
	+fun proj_tuple :: "nat list \<Rightarrow> (nat \<times> ('a + nat)) list \<Rightarrow> ('a + nat) list" where
	+ "proj_tuple [] mys = []"
	+\| "proj_tuple ns [] = []"
	+\| "proj_tuple (n # ns) ((m, y) # mys) =
	+ (if m < n then proj_tuple (n # ns) mys else
	+ if m = n then y # proj_tuple ns mys
	+ else proj_tuple ns ((m, y) # mys))"
	+
	+lemma proj_tuple_idle: "proj_tuple (map fst nxs) nxs = map snd nxs"
	+ by (induction nxs) auto
	+
	+lemma proj_tuple_merge: "sorted_distinct (map fst nxs) \<Longrightarrow> sorted_distinct (map fst mys) \<Longrightarrow>
	+ set (map fst nxs) \<inter> set (map fst mys) = {} \<Longrightarrow>
	+ proj_tuple (map fst nxs) (merge nxs mys) = map snd nxs"
	+ using proj_tuple_idle
	+ by (induction nxs mys rule: merge.induct) auto+
	+
	+lemma proj_tuple_map:
	+ assumes "sorted_distinct ns" "sorted_distinct ms" "set ns \<subseteq> set ms"
	+ shows "proj_tuple ns (zip ms (map \<sigma> ms)) = map \<sigma> ns"
	+proof -
	+ define ns' where "ns' = filter (\<lambda>n. n \<notin> set ns) ms"
	+ have sd_ns': "sorted_distinct ns'"
	+ using assms(2) sorted_filter[of id]
	+ by (auto simp: ns'_def)
	+ have disj: "set ns \<inter> set ns' = {}"
	+ by (auto simp: ns'_def)
	+ have ms_def: "ms = sort (ns @ ns')"
	+ apply (rule sorted_distinct_set_unique)
	+ using assms
	+ by (auto simp: ns'_def)
	+ have zip: "zip ms (map \<sigma> ms) = merge (zip ns (map \<sigma> ns)) (zip ns' (map \<sigma> ns'))"
	+ unfolding merge_map[OF assms(1) sd_ns' disj, folded ms_def, symmetric]
	+ using map_fst_merge assms(1)
	+ by (auto simp: ms_def) (smt length_map map_fst_merge map_fst_zip sd_ns' zip_map_fst_snd)
	+ show ?thesis
	+ unfolding zip
	+ using proj_tuple_merge
	+ by (smt assms(1) disj length_map map_fst_zip map_snd_zip sd_ns')
	+qed
	+
	+lemma proj_tuple_length:
	+ assumes "sorted_distinct ns" "sorted_distinct ms" "set ns \<subseteq> set ms" "length ms = length xs"
	+ shows "length (proj_tuple ns (zip ms xs)) = length ns"
	+proof -
	+ obtain \<sigma> where \<sigma>: "xs = map \<sigma> ms"
	+ using exists_map[OF assms(4)] assms(2)
	+ by auto
	+ show ?thesis
	+ unfolding \<sigma>
	+ by (auto simp: proj_tuple_map[OF assms(1-3)])
	+qed
	+
	+lemma ext_tuple_sound:
	+ assumes "sorted_distinct fv_sub" "sorted_distinct fv_sub_comp" "sorted_distinct fv_all"
	+ "set fv_sub \<inter> set fv_sub_comp = {}" "set fv_sub \<union> set fv_sub_comp = set fv_all"
	+ "ass = fo_nmlz AD ` proj_vals R fv_sub"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set fv_sub) (set fv_sub) AD \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> R \<longleftrightarrow> \<tau> \<in> R"
	+ "xs \<in> fo_nmlz AD ` \<Union>(ext_tuple AD fv_sub fv_sub_comp ` ass)"
	+ shows "fo_nmlz AD (proj_tuple fv_sub (zip fv_all xs)) \<in> ass"
	+ "xs \<in> fo_nmlz AD ` proj_vals R fv_all"
	+proof -
	+ have fv_all_sort: "fv_all = sort (fv_sub @ fv_sub_comp)"
	+ using assms(1,2,3,4,5)
	+ by (simp add: sorted_distinct_set_unique)
	+ have len_in_ass: "\<And>xs. xs \<in> ass \<Longrightarrow> xs = fo_nmlz AD xs \<and> length xs = length fv_sub"
	+ by (auto simp: assms(6) proj_vals_def fo_nmlz_length fo_nmlz_idem fo_nmlz_sound)
	+ obtain as fs where as_fs_def: "as \<in> ass"
	+ "fs \<in> nall_tuples_rec AD (card (Inr -` set as)) (length fv_sub_comp)"
	+ "xs = fo_nmlz AD (map snd (merge (zip fv_sub as) (zip fv_sub_comp fs)))"
	+ using fo_nmlz_sound len_in_ass assms(8)
	+ by (auto simp: ext_tuple_def split: if_splits)
	+ then have vs_norm: "fo_nmlzd AD xs"
	+ using fo_nmlz_sound
	+ by auto
	+ obtain \<sigma> where \<sigma>_def: "\<sigma> \<in> R" "as = fo_nmlz AD (map \<sigma> fv_sub)"
	+ using as_fs_def(1) assms(6)
	+ by (auto simp: proj_vals_def)
	+ then obtain \<tau> where \<tau>_def: "as = map \<tau> fv_sub" "ad_agr_list AD (map \<sigma> fv_sub) (map \<tau> fv_sub)"
	+ using fo_nmlz_map fo_nmlz_ad_agr
	+ by metis
	+ have \<tau>_R: "\<tau> \<in> R"
	+ using assms(7) ad_agr_list_link \<sigma>_def(1) \<tau>_def(2)
	+ by fastforce
	+ define \<sigma>' where "\<sigma>' \<equiv> \<lambda>n. if n \<in> set fv_sub_comp then the (map_of (zip fv_sub_comp fs) n)
	+ else \<tau> n"
	+ then have "\<forall>n \<in> set fv_sub. \<tau> n = \<sigma>' n"
	+ using assms(4) by auto
	+ then have \<sigma>'_S: "\<sigma>' \<in> R"
	+ using assms(7) \<tau>_R
	+ by (fastforce simp: ad_agr_sets_def sp_equiv_def pairwise_def ad_equiv_pair.simps)
	+ have length_as: "length as = length fv_sub"
	+ using as_fs_def(1) assms(6)
	+ by (auto simp: proj_vals_def fo_nmlz_length)
	+ have length_fs: "length fs = length fv_sub_comp"
	+ using as_fs_def(2)
	+ by (auto simp: nall_tuples_rec_length)
	+ have map_fv_sub: "map \<sigma>' fv_sub = map \<tau> fv_sub"
	+ using assms(4) \<tau>_def(2)
	+ by (auto simp: \<sigma>'_def)
	+ have fs_map_map_of: "fs = map (the \<circ> (map_of (zip fv_sub_comp fs))) fv_sub_comp"
	+ using map_map_of length_fs assms(2)
	+ by metis
	+ have fs_map: "fs = map \<sigma>' fv_sub_comp"
	+ using \<sigma>'_def length_fs by (subst fs_map_map_of) simp
	+ have vs_map_fv_all: "xs = fo_nmlz AD (map \<sigma>' fv_all)"
	+ unfolding as_fs_def(3) \<tau>_def(1) map_fv_sub[symmetric] fs_map fv_all_sort
	+ using merge_map[OF assms(1,2,4)]
	+ by metis
	+ show "xs \<in> fo_nmlz AD ` proj_vals R fv_all"
	+ using \<sigma>'_S vs_map_fv_all
	+ by (auto simp: proj_vals_def)
	+ obtain \<sigma>'' where \<sigma>''_def: "xs = map \<sigma>'' fv_all"
	+ using exists_map[of fv_all xs] fo_nmlz_map vs_map_fv_all
	+ by blast
	+ have proj: "proj_tuple fv_sub (zip fv_all xs) = map \<sigma>'' fv_sub"
	+ using proj_tuple_map assms(1,3,5)
	+ unfolding \<sigma>''_def
	+ by blast
	+ have \<sigma>''_\<sigma>': "fo_nmlz AD (map \<sigma>'' fv_sub) = as"
	+ using \<sigma>''_def vs_map_fv_all \<sigma>_def(2)
	+ by (metis \<tau>_def(2) ad_agr_list_subset assms(5) fo_nmlz_ad_agr fo_nmlz_eqI map_fv_sub sup_ge1)
	+ show "fo_nmlz AD (proj_tuple fv_sub (zip fv_all xs)) \<in> ass"
	+ unfolding proj \<sigma>''_\<sigma>' map_fv_sub
	+ by (rule as_fs_def(1))
	+qed
	+
	+lemma ext_tuple_complete:
	+ assumes "sorted_distinct fv_sub" "sorted_distinct fv_sub_comp" "sorted_distinct fv_all"
	+ "set fv_sub \<inter> set fv_sub_comp = {}" "set fv_sub \<union> set fv_sub_comp = set fv_all"
	+ "ass = fo_nmlz AD ` proj_vals R fv_sub"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set fv_sub) (set fv_sub) AD \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> R \<longleftrightarrow> \<tau> \<in> R"
	+ "xs = fo_nmlz AD (map \<sigma> fv_all)" "\<sigma> \<in> R"
	+ shows "xs \<in> fo_nmlz AD ` \<Union>(ext_tuple AD fv_sub fv_sub_comp ` ass)"
	+proof -
	+ have fv_all_sort: "fv_all = sort (fv_sub @ fv_sub_comp)"
	+ using assms(1,2,3,4,5)
	+ by (simp add: sorted_distinct_set_unique)
	+ note \<sigma>_def = assms(9,8)
	+ have vs_norm: "fo_nmlzd AD xs"
	+ using \<sigma>_def(2) fo_nmlz_sound
	+ by auto
	+ define fs where "fs = map \<sigma> fv_sub_comp"
	+ define as where "as = map \<sigma> fv_sub"
	+ define nos where "nos = fo_nmlz AD (as @ fs)"
	+ define as' where "as' = take (length fv_sub) nos"
	+ define fs' where "fs' = drop (length fv_sub) nos"
	+ have length_as': "length as' = length fv_sub"
	+ by (auto simp: as'_def nos_def as_def fo_nmlz_length)
	+ have length_fs': "length fs' = length fv_sub_comp"
	+ by (auto simp: fs'_def nos_def as_def fs_def fo_nmlz_length)
	+ have len_fv_sub_nos: "length fv_sub \<le> length nos"
	+ by (auto simp: nos_def fo_nmlz_length as_def)
	+ have norm_as': "fo_nmlzd AD as'"
	+ using fo_nmlzd_take[OF fo_nmlz_sound]
	+ by (auto simp: as'_def nos_def)
	+ have as'_norm_as: "as' = fo_nmlz AD as"
	+ by (auto simp: as'_def nos_def as_def fo_nmlz_take)
	+ have ad_agr_as': "ad_agr_list AD as as'"
	+ using fo_nmlz_ad_agr
	+ unfolding as'_norm_as .
	+ have nos_as'_fs': "nos = as' @ fs'"
	+ using length_as' length_fs'
	+ by (auto simp: as'_def fs'_def)
	+ obtain \<tau> where \<tau>_def: "as' = map \<tau> fv_sub" "fs' = map \<tau> fv_sub_comp"
	+ using exists_map[of "fv_sub @ fv_sub_comp" "as' @ fs'"] assms(1,2,4) length_as' length_fs'
	+ by auto
	+ have "length fv_sub + length fv_sub_comp \<le> length fv_all"
	+ using assms(1,2,3,4,5)
	+ by (metis distinct_append distinct_card eq_iff length_append set_append)
	+ then have nos_sub: "set nos \<subseteq> Inl ` AD \<union> Inr ` {..<length fv_all}"
	+ using fo_nmlz_set[of AD "as @ fs"]
	+ by (auto simp: nos_def as_def fs_def)
	+ have len_fs': "length fs' = length fv_sub_comp"
	+ by (auto simp: fs'_def nos_def fo_nmlz_length as_def fs_def)
	+ have norm_nos_idem: "fo_nmlz_rec 0 (id_map 0) AD nos = nos"
	+ using fo_nmlz_idem[of AD nos] fo_nmlz_sound
	+ by (auto simp: nos_def fo_nmlz_def id_map_empty)
	+ have fs'_all: "fs' \<in> nall_tuples_rec AD (card (Inr -` set as')) (length fv_sub_comp)"
	+ unfolding len_fs'[symmetric]
	+ by (rule nall_tuples_rec_fo_nmlz_rec_complete)
	+ (rule fo_nmlz_rec_shift[OF norm_nos_idem, simplified, OF refl len_fv_sub_nos,
	+ folded as'_def fs'_def])
	+ have "as' \<in> nall_tuples AD (length fv_sub)"
	+ using length_as'
	+ apply (rule nall_tuplesI)
	+ using norm_as' .
	+ then have as'_ass: "as' \<in> ass"
	+ using as'_norm_as \<sigma>_def(1) as_def
	+ unfolding assms(6)
	+ by (auto simp: proj_vals_def)
	+ have vs_norm: "xs = fo_nmlz AD (map snd (merge (zip fv_sub as) (zip fv_sub_comp fs)))"
	+ using assms(1,2,4) \<sigma>_def(2)
	+ by (auto simp: merge_map as_def fs_def fv_all_sort)
	+ have set_sort': "set (sort (fv_sub @ fv_sub_comp)) = set (fv_sub @ fv_sub_comp)"
	+ by auto
	+ have "xs = fo_nmlz AD (map snd (merge (zip fv_sub as') (zip fv_sub_comp fs')))"
	+ unfolding vs_norm as_def fs_def \<tau>_def
	+ merge_map[OF assms(1,2,4)]
	+ apply (rule fo_nmlz_eqI)
	+ apply (rule ad_agr_list_subset[OF equalityD1, OF set_sort'])
	+ using fo_nmlz_ad_agr[of AD "as @ fs", folded nos_def, unfolded nos_as'_fs']
	+ unfolding as_def fs_def \<tau>_def map_append[symmetric] .
	+ then show ?thesis
	+ using as'_ass fs'_all
	+ by (auto simp: ext_tuple_def length_as')
	+qed
	+
	+definition "ext_tuple_set AD ns ns' X = (if ns' = [] then X else fo_nmlz AD ` \<Union>(ext_tuple AD ns ns' ` X))"
	+
	+lemma ext_tuple_set_eq: "Ball X (fo_nmlzd AD) \<Longrightarrow> ext_tuple_set AD ns ns' X = fo_nmlz AD ` \<Union>(ext_tuple AD ns ns' ` X)"
	+ by (auto simp: ext_tuple_set_def ext_tuple_def fo_nmlzd_code)
	+
	+lemma ext_tuple_set_mono: "A \<subseteq> B \<Longrightarrow> ext_tuple_set AD ns ns' A \<subseteq> ext_tuple_set AD ns ns' B"
	+ by (auto simp: ext_tuple_set_def)
	+
	+lemma ext_tuple_correct:
	+ assumes "sorted_distinct fv_sub" "sorted_distinct fv_sub_comp" "sorted_distinct fv_all"
	+ "set fv_sub \<inter> set fv_sub_comp = {}" "set fv_sub \<union> set fv_sub_comp = set fv_all"
	+ "ass = fo_nmlz AD ` proj_vals R fv_sub"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set fv_sub) (set fv_sub) AD \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> R \<longleftrightarrow> \<tau> \<in> R"
	+ shows "ext_tuple_set AD fv_sub fv_sub_comp ass = fo_nmlz AD ` proj_vals R fv_all"
	+proof (rule set_eqI, rule iffI)
	+ fix xs
	+ assume xs_in: "xs \<in> ext_tuple_set AD fv_sub fv_sub_comp ass"
	+ show "xs \<in> fo_nmlz AD ` proj_vals R fv_all"
	+ using ext_tuple_sound(2)[OF assms] xs_in
	+ by (auto simp: ext_tuple_set_def ext_tuple_def assms(6) fo_nmlz_idem[OF fo_nmlz_sound] image_iff
	+ split: if_splits)
	+next
	+ fix xs
	+ assume "xs \<in> fo_nmlz AD ` proj_vals R fv_all"
	+ then obtain \<sigma> where \<sigma>_def: "xs = fo_nmlz AD (map \<sigma> fv_all)" "\<sigma> \<in> R"
	+ by (auto simp: proj_vals_def)
	+ show "xs \<in> ext_tuple_set AD fv_sub fv_sub_comp ass"
	+ using ext_tuple_complete[OF assms \<sigma>_def]
	+ by (auto simp: ext_tuple_set_def ext_tuple_def assms(6) fo_nmlz_idem[OF fo_nmlz_sound] image_iff
	+ split: if_splits)
	+qed
	+
	+lemma proj_tuple_sound:
	+ assumes "sorted_distinct fv_sub" "sorted_distinct fv_sub_comp" "sorted_distinct fv_all"
	+ "set fv_sub \<inter> set fv_sub_comp = {}" "set fv_sub \<union> set fv_sub_comp = set fv_all"
	+ "ass = fo_nmlz AD ` proj_vals R fv_sub"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set fv_sub) (set fv_sub) AD \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> R \<longleftrightarrow> \<tau> \<in> R"
	+ "fo_nmlz AD xs = xs" "length xs = length fv_all"
	+ "fo_nmlz AD (proj_tuple fv_sub (zip fv_all xs)) \<in> ass"
	+ shows "xs \<in> fo_nmlz AD ` \<Union>(ext_tuple AD fv_sub fv_sub_comp ` ass)"
	+proof -
	+ have fv_all_sort: "fv_all = sort (fv_sub @ fv_sub_comp)"
	+ using assms(1,2,3,4,5)
	+ by (simp add: sorted_distinct_set_unique)
	+ obtain \<sigma> where \<sigma>_def: "xs = map \<sigma> fv_all"
	+ using exists_map[of fv_all xs] assms(3,9)
	+ by auto
	+ have xs_norm: "xs = fo_nmlz AD (map \<sigma> fv_all)"
	+ using assms(8)
	+ by (auto simp: \<sigma>_def)
	+ have proj: "proj_tuple fv_sub (zip fv_all xs) = map \<sigma> fv_sub"
	+ unfolding \<sigma>_def
	+ apply (rule proj_tuple_map[OF assms(1,3)])
	+ using assms(5)
	+ by blast
	+ obtain \<tau> where \<tau>_def: "fo_nmlz AD (map \<sigma> fv_sub) = fo_nmlz AD (map \<tau> fv_sub)" "\<tau> \<in> R"
	+ using assms(10)
	+ by (auto simp: assms(6) proj proj_vals_def)
	+ have \<sigma>_R: "\<sigma> \<in> R"
	+ using assms(7) fo_nmlz_eqD[OF \<tau>_def(1)] \<tau>_def(2)
	+ unfolding ad_agr_list_link[symmetric]
	+ by auto
	+ show ?thesis
	+ by (rule ext_tuple_complete[OF assms(1,2,3,4,5,6,7) xs_norm \<sigma>_R]) assumption
	+qed
	+
	+lemma proj_tuple_correct:
	+ assumes "sorted_distinct fv_sub" "sorted_distinct fv_sub_comp" "sorted_distinct fv_all"
	+ "set fv_sub \<inter> set fv_sub_comp = {}" "set fv_sub \<union> set fv_sub_comp = set fv_all"
	+ "ass = fo_nmlz AD ` proj_vals R fv_sub"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set fv_sub) (set fv_sub) AD \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> R \<longleftrightarrow> \<tau> \<in> R"
	+ "fo_nmlz AD xs = xs" "length xs = length fv_all"
	+ shows "xs \<in> fo_nmlz AD ` \<Union>(ext_tuple AD fv_sub fv_sub_comp ` ass) \<longleftrightarrow>
	+ fo_nmlz AD (proj_tuple fv_sub (zip fv_all xs)) \<in> ass"
	+ using ext_tuple_sound(1)[OF assms(1,2,3,4,5,6,7)] proj_tuple_sound[OF assms]
	+ by blast
	+
	+fun unify_vals_terms :: "('a + 'c) list \<Rightarrow> ('a fo_term) list \<Rightarrow> (nat \<rightharpoonup> ('a + 'c)) \<Rightarrow>
	+ (nat \<rightharpoonup> ('a + 'c)) option" where
	+ "unify_vals_terms [] [] \<sigma> = Some \<sigma>"
	+\| "unify_vals_terms (v # vs) ((Const c') # ts) \<sigma> =
	+ (if v = Inl c' then unify_vals_terms vs ts \<sigma> else None)"
	+\| "unify_vals_terms (v # vs) ((Var n) # ts) \<sigma> =
	+ (case \<sigma> n of Some x \<Rightarrow> (if v = x then unify_vals_terms vs ts \<sigma> else None)
	+ \| None \<Rightarrow> unify_vals_terms vs ts (\<sigma>(n := Some v)))"
	+\| "unify_vals_terms _ _ _ = None"
	+
	+lemma unify_vals_terms_extends: "unify_vals_terms vs ts \<sigma> = Some \<sigma>' \<Longrightarrow> extends_subst \<sigma> \<sigma>'"
	+ unfolding extends_subst_def
	+ by (induction vs ts \<sigma> arbitrary: \<sigma>' rule: unify_vals_terms.induct)
	+ (force split: if_splits option.splits)+
	+
	+lemma unify_vals_terms_sound: "unify_vals_terms vs ts \<sigma> = Some \<sigma>' \<Longrightarrow> (the \<circ> \<sigma>') \<odot>e ts = vs"
	+ using unify_vals_terms_extends
	+ by (induction vs ts \<sigma> arbitrary: \<sigma>' rule: unify_vals_terms.induct)
	+ (force simp: eval_eterms_def extends_subst_def fv_fo_terms_set_def
	+ split: if_splits option.splits)+
	+
	+lemma unify_vals_terms_complete: "\<sigma>'' \<odot>e ts = vs \<Longrightarrow> (\<And>n. \<sigma> n \<noteq> None \<Longrightarrow> \<sigma> n = Some (\<sigma>'' n)) \<Longrightarrow>
	+ \<exists>\<sigma>'. unify_vals_terms vs ts \<sigma> = Some \<sigma>'"
	+ by (induction vs ts \<sigma> rule: unify_vals_terms.induct)
	+ (force simp: eval_eterms_def extends_subst_def split: if_splits option.splits)+
	+
	+definition eval_table :: "'a fo_term list \<Rightarrow> ('a + 'c) table \<Rightarrow> ('a + 'c) table" where
	+ "eval_table ts X = (let fvs = fv_fo_terms_list ts in
	+ \<Union>((\<lambda>vs. case unify_vals_terms vs ts Map.empty of Some \<sigma> \<Rightarrow>
	+ {map (the \<circ> \<sigma>) fvs} \| _ \<Rightarrow> {}) ` X))"
	+
	+lemma eval_table:
	+ fixes X :: "('a + 'c) table"
	+ shows "eval_table ts X = proj_vals {\<sigma>. \<sigma> \<odot>e ts \<in> X} (fv_fo_terms_list ts)"
	+proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> eval_table ts X"
	+ then obtain as \<sigma> where as_def: "as \<in> X" "unify_vals_terms as ts Map.empty = Some \<sigma>"
	+ "vs = map (the \<circ> \<sigma>) (fv_fo_terms_list ts)"
	+ by (auto simp: eval_table_def split: option.splits)
	+ have "(the \<circ> \<sigma>) \<odot>e ts \<in> X"
	+ using unify_vals_terms_sound[OF as_def(2)] as_def(1)
	+ by auto
	+ with as_def(3) show "vs \<in> proj_vals {\<sigma>. \<sigma> \<odot>e ts \<in> X} (fv_fo_terms_list ts)"
	+ by (fastforce simp: proj_vals_def)
	+next
	+ fix vs :: "('a + 'c) list"
	+ assume "vs \<in> proj_vals {\<sigma>. \<sigma> \<odot>e ts \<in> X} (fv_fo_terms_list ts)"
	+ then obtain \<sigma> where \<sigma>_def: "vs = map \<sigma> (fv_fo_terms_list ts)" "\<sigma> \<odot>e ts \<in> X"
	+ by (auto simp: proj_vals_def)
	+ obtain \<sigma>' where \<sigma>'_def: "unify_vals_terms (\<sigma> \<odot>e ts) ts Map.empty = Some \<sigma>'"
	+ using unify_vals_terms_complete[OF refl, of Map.empty \<sigma> ts]
	+ by auto
	+ have "(the \<circ> \<sigma>') \<odot>e ts = (\<sigma> \<odot>e ts)"
	+ using unify_vals_terms_sound[OF \<sigma>'_def(1)]
	+ by auto
	+ then have "vs = map (the \<circ> \<sigma>') (fv_fo_terms_list ts)"
	+ using fv_fo_terms_set_list eval_eterms_fv_fo_terms_set
	+ unfolding \<sigma>_def(1)
	+ by fastforce
	+ then show "vs \<in> eval_table ts X"
	+ using \<sigma>_def(2) \<sigma>'_def
	+ by (force simp: eval_table_def)
	+qed
	+
	+fun ad_agr_close_rec :: "nat \<Rightarrow> (nat \<rightharpoonup> 'a + nat) \<Rightarrow> 'a set \<Rightarrow>
	+ ('a + nat) list \<Rightarrow> ('a + nat) list set" where
	+ "ad_agr_close_rec i m AD [] = {[]}"
	+\| "ad_agr_close_rec i m AD (Inl x # xs) = (\<lambda>xs. Inl x # xs) ` ad_agr_close_rec i m AD xs"
	+\| "ad_agr_close_rec i m AD (Inr n # xs) = (case m n of None \<Rightarrow> \<Union>((\<lambda>x. (\<lambda>xs. Inl x # xs) `
	+ ad_agr_close_rec i (m(n := Some (Inl x))) (AD - {x}) xs) ` AD) \<union>
	+ (\<lambda>xs. Inr i # xs) ` ad_agr_close_rec (Suc i) (m(n := Some (Inr i))) AD xs
	+ \| Some v \<Rightarrow> (\<lambda>xs. v # xs) ` ad_agr_close_rec i m AD xs)"
	+
	+lemma ad_agr_close_rec_length: "ys \<in> ad_agr_close_rec i m AD xs \<Longrightarrow> length xs = length ys"
	+ by (induction i m AD xs arbitrary: ys rule: ad_agr_close_rec.induct) (auto split: option.splits)
	+
	+lemma ad_agr_close_rec_sound: "ys \<in> ad_agr_close_rec i m AD xs \<Longrightarrow>
	+ fo_nmlz_rec j (id_map j) X xs = xs \<Longrightarrow> X \<inter> AD = {} \<Longrightarrow> X \<inter> Y = {} \<Longrightarrow> Y \<inter> AD = {} \<Longrightarrow>
	+ inj_on m (dom m) \<Longrightarrow> dom m = {..<j} \<Longrightarrow> ran m \<subseteq> Inl ` Y \<union> Inr ` {..<i} \<Longrightarrow> i \<le> j \<Longrightarrow>
	+ fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) ys = ys \<and>
	+ (\<exists>m'. inj_on m' (dom m') \<and> (\<forall>n v. m n = Some v \<longrightarrow> m' (Inr n) = Some v) \<and>
	+ (\<forall>(x, y) \<in> set (zip xs ys). case x of Inl x' \<Rightarrow>
	+ if x' \<in> X then x = y else m' x = Some y \<and> (case y of Inl z \<Rightarrow> z \<notin> X \| Inr x \<Rightarrow> True)
	+ \| Inr n \<Rightarrow> m' x = Some y \<and> (case y of Inl z \<Rightarrow> z \<notin> X \| Inr x \<Rightarrow> True)))"
	+proof (induction i m AD xs arbitrary: Y j ys rule: ad_agr_close_rec.induct)
	+ case (1 i m AD)
	+ then show ?case
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def sp_equiv_list_def inj_on_def dom_def
	+ split: sum.splits intro!: exI[of _ "case_sum Map.empty m"])
	+next
	+ case (2 i m AD x xs)
	+ obtain zs where ys_def: "ys = Inl x # zs" "zs \<in> ad_agr_close_rec i m AD xs"
	+ using 2(2)
	+ by auto
	+ have preds: "fo_nmlz_rec j (id_map j) X xs = xs" "x \<in> X"
	+ using 2(3)
	+ by (auto split: if_splits option.splits)
	+ show ?case
	+ using 2(1)[OF ys_def(2) preds(1) 2(4,5,6,7,8,9,10)] preds(2)
	+ by (auto simp: ys_def(1))
	+next
	+ case (3 i m AD n xs)
	+ show ?case
	+ proof (cases "m n")
	+ case None
	+ obtain v zs where ys_def: "ys = v # zs"
	+ using 3(4)
	+ by (auto simp: None)
	+ have n_ge_j: "j \<le> n"
	+ using 3(9,10) None
	+ by (metis domIff leI lessThan_iff)
	+ show ?thesis
	+ proof (cases v)
	+ case (Inl x)
	+ have zs_def: "zs \<in> ad_agr_close_rec i (m(n \<mapsto> Inl x)) (AD - {x}) xs" "x \<in> AD"
	+ using 3(4)
	+ by (auto simp: None ys_def Inl)
	+ have preds: "fo_nmlz_rec (Suc j) (id_map (Suc j)) X xs = xs" "X \<inter> (AD - {x}) = {}"
	+ "X \<inter> (Y \<union> {x}) = {}" "(Y \<union> {x}) \<inter> (AD - {x}) = {}" "dom (m(n \<mapsto> Inl x)) = {..<Suc j}"
	+ "ran (m(n \<mapsto> Inl x)) \<subseteq> Inl ` (Y \<union> {x}) \<union> Inr ` {..<i}"
	+ "i \<le> Suc j" "n = j"
	+ using 3(5,6,7,8,10,11,12) n_ge_j zs_def(2)
	+ by (auto simp: fun_upd_id_map ran_def dest: id_mapD split: option.splits)
	+ have inj: "inj_on (m(n \<mapsto> Inl x)) (dom (m(n \<mapsto> Inl x)))"
	+ using 3(8,9,10,11,12) preds(8) zs_def(2)
	+ by (fastforce simp: inj_on_def dom_def ran_def)
	+ have sets_unfold: "X \<union> (Y \<union> {x}) \<union> (AD - {x}) = X \<union> Y \<union> AD"
	+ using zs_def(2)
	+ by auto
	+ note IH = 3(1)[OF None zs_def(2,1) preds(1,2,3,4) inj preds(5,6,7), unfolded sets_unfold]
	+ have norm_ys: "fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) ys = ys"
	+ using conjunct1[OF IH] zs_def(2)
	+ by (auto simp: ys_def(1) Inl split: option.splits)
	+ show ?thesis
	+ using norm_ys conjunct2[OF IH] None zs_def(2) 3(6)
	+ unfolding ys_def(1)
	+ apply safe
	+ subgoal for m'
	+ apply (auto simp: Inl dom_def intro!: exI[of _ m'] split: if_splits)
	+ apply (metis option.distinct(1))
	+ apply (fastforce split: prod.splits sum.splits)
	+ done
	+ done
	+ next
	+ case (Inr k)
	+ have zs_def: "zs \<in> ad_agr_close_rec (Suc i) (m(n \<mapsto> Inr i)) AD xs" "i = k"
	+ using 3(4)
	+ by (auto simp: None ys_def Inr)
	+ have preds: "fo_nmlz_rec (Suc n) (id_map (Suc n)) X xs = xs"
	+ "dom (m(n \<mapsto> Inr i)) = {..<Suc n}"
	+ "ran (m(n \<mapsto> Inr i)) \<subseteq> Inl ` Y \<union> Inr ` {..<Suc i}" "Suc i \<le> Suc n"
	+ using 3(5,10,11,12) n_ge_j
	+ by (auto simp: fun_upd_id_map ran_def dest: id_mapD split: option.splits)
	+ have inj: "inj_on (m(n \<mapsto> Inr i)) (dom (m(n \<mapsto> Inr i)))"
	+ using 3(9,11)
	+ by (auto simp: inj_on_def dom_def ran_def)
	+ note IH = 3(2)[OF None zs_def(1) preds(1) 3(6,7,8) inj preds(2,3,4)]
	+ have norm_ys: "fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) ys = ys"
	+ using conjunct1[OF IH] zs_def(2)
	+ by (auto simp: ys_def Inr fun_upd_id_map dest: id_mapD split: option.splits)
	+ show ?thesis
	+ using norm_ys conjunct2[OF IH] None
	+ unfolding ys_def(1) zs_def(2)
	+ apply safe
	+ subgoal for m'
	+ apply (auto simp: Inr dom_def intro!: exI[of _ m'] split: if_splits)
	+ apply (metis option.distinct(1))
	+ apply (fastforce split: prod.splits sum.splits)
	+ done
	+ done
	+ qed
	+ next
	+ case (Some v)
	+ obtain zs where ys_def: "ys = v # zs" "zs \<in> ad_agr_close_rec i m AD xs"
	+ using 3(4)
	+ by (auto simp: Some)
	+ have preds: "fo_nmlz_rec j (id_map j) X xs = xs" "n < j"
	+ using 3(5,8,10) Some
	+ by (auto simp: dom_def split: option.splits)
	+ note IH = 3(3)[OF Some ys_def(2) preds(1) 3(6,7,8,9,10,11,12)]
	+ have norm_ys: "fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) ys = ys"
	+ using conjunct1[OF IH] 3(11) Some
	+ by (auto simp: ys_def(1) ran_def id_map_def)
	+ have "case v of Inl z \<Rightarrow> z \<notin> X \| Inr x \<Rightarrow> True"
	+ using 3(7,11) Some
	+ by (auto simp: ran_def split: sum.splits)
	+ then show ?thesis
	+ using norm_ys conjunct2[OF IH] Some
	+ unfolding ys_def(1)
	+ apply safe
	+ subgoal for m'
	+ by (auto intro!: exI[of _ m'] split: sum.splits)
	+ done
	+ qed
	+qed
	+
	+lemma ad_agr_close_rec_complete:
	+ fixes xs :: "('a + nat) list"
	+ shows "fo_nmlz_rec j (id_map j) X xs = xs \<Longrightarrow>
	+ X \<inter> AD = {} \<Longrightarrow> X \<inter> Y = {} \<Longrightarrow> Y \<inter> AD = {} \<Longrightarrow>
	+ inj_on m (dom m) \<Longrightarrow> dom m = {..<j} \<Longrightarrow> ran m = Inl ` Y \<union> Inr ` {..<i} \<Longrightarrow> i \<le> j \<Longrightarrow>
	+ (\<And>n b. (Inr n, b) \<in> set (zip xs ys) \<Longrightarrow> case m n of Some v \<Rightarrow> v = b \| None \<Rightarrow> b \<notin> ran m) \<Longrightarrow>
	+ fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) ys = ys \<Longrightarrow> ad_agr_list X xs ys \<Longrightarrow>
	+ ys \<in> ad_agr_close_rec i m AD xs"
	+proof (induction j "id_map j :: 'a + nat \<Rightarrow> nat option" X xs arbitrary: m i ys AD Y
	+ rule: fo_nmlz_rec.induct)
	+ case (2 j X x xs)
	+ have x_X: "x \<in> X" "fo_nmlz_rec j (id_map j) X xs = xs"
	+ using 2(4)
	+ by (auto split: if_splits option.splits)
	+ obtain z zs where ys_def: "ys = Inl z # zs" "z = x"
	+ using 2(14) x_X(1)
	+ by (cases ys) (auto simp: ad_agr_list_def ad_equiv_list_def ad_equiv_pair.simps)
	+ have norm_zs: "fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) zs = zs"
	+ using 2(13) ys_def(2) x_X(1)
	+ by (auto simp: ys_def(1))
	+ have ad_agr: "ad_agr_list X xs zs"
	+ using 2(14)
	+ by (auto simp: ys_def ad_agr_list_def ad_equiv_list_def sp_equiv_list_def pairwise_def)
	+ show ?case
	+ using 2(1)[OF x_X 2(5,6,7,8,9,10,11) _ norm_zs ad_agr] 2(12)
	+ by (auto simp: ys_def)
	+next
	+ case (3 j X n xs)
	+ obtain z zs where ys_def: "ys = z # zs"
	+ using 3(13)
	+ apply (cases ys)
	+ apply (auto simp: ad_agr_list_def)
	+ done
	+ show ?case
	+ proof (cases "j \<le> n")
	+ case True
	+ then have n_j: "n = j"
	+ using 3(3)
	+ by (auto split: option.splits dest: id_mapD)
	+ have id_map: "id_map j (Inr n) = None" "id_map j(Inr n \<mapsto> j) = id_map (Suc j)"
	+ unfolding n_j fun_upd_id_map
	+ by (auto simp: id_map_def)
	+ have norm_xs: "fo_nmlz_rec (Suc j) (id_map (Suc j)) X xs = xs"
	+ using 3(3)
	+ by (auto simp: ys_def fun_upd_id_map id_map(1) split: option.splits)
	+ have None: "m n = None"
	+ using 3(8)
	+ by (auto simp: dom_def n_j)
	+ have z_out: "z \<notin> Inl ` Y \<union> Inr ` {..<i}"
	+ using 3(11) None
	+ by (force simp: ys_def 3(9))
	+ show ?thesis
	+ proof (cases z)
	+ case (Inl a)
	+ have a_in: "a \<in> AD"
	+ using 3(12,13) z_out
	+ by (auto simp: ys_def Inl ad_agr_list_def ad_equiv_list_def ad_equiv_pair.simps
	+ split: if_splits option.splits)
	+ have norm_zs: "fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) zs = zs"
	+ using 3(12) a_in
	+ by (auto simp: ys_def Inl)
	+ have preds: "X \<inter> (AD - {a}) = {}" "X \<inter> (Y \<union> {a}) = {}" "(Y \<union> {a}) \<inter> (AD - {a}) = {}"
	+ using 3(4,5,6) a_in
	+ by auto
	+ have inj: "inj_on (m(n := Some (Inl a))) (dom (m(n := Some (Inl a))))"
	+ using 3(6,7,9) None a_in
	+ by (auto simp: inj_on_def dom_def ran_def) blast+
	+ have preds': "dom (m(n \<mapsto> Inl a)) = {..<Suc j}"
	+ "ran (m(n \<mapsto> Inl a)) = Inl ` (Y \<union> {a}) \<union> Inr ` {..<i}" "i \<le> Suc j"
	+ using 3(6,8,9,10) None less_Suc_eq a_in
	+ apply (auto simp: n_j dom_def ran_def)
	+ apply (smt Un_iff image_eqI mem_Collect_eq option.simps(3))
	+ apply (smt 3(8) domIff image_subset_iff lessThan_iff mem_Collect_eq sup_ge2)
	+ done
	+ have a_unfold: "X \<union> (Y \<union> {a}) \<union> (AD - {a}) = X \<union> Y \<union> AD" "Y \<union> {a} \<union> (AD - {a}) = Y \<union> AD"
	+ using a_in
	+ by auto
	+ have ad_agr: "ad_agr_list X xs zs"
	+ using 3(13)
	+ by (auto simp: ys_def Inl ad_agr_list_def ad_equiv_list_def sp_equiv_list_def pairwise_def)
	+ have "zs \<in> ad_agr_close_rec i (m(n \<mapsto> Inl a)) (AD - {a}) xs"
	+ apply (rule 3(1)[OF id_map norm_xs preds inj preds' _ _ ad_agr])
	+ using 3(11,13) norm_zs
	+ unfolding 3(9) preds'(2) a_unfold
	+ apply (auto simp: None Inl ys_def ad_agr_list_def sp_equiv_list_def pairwise_def
	+ split: option.splits)
	+ apply (metis Un_iff image_eqI option.simps(4))
	+ apply (metis image_subset_iff lessThan_iff option.simps(4) sup_ge2)
	+ apply fastforce
	+ done
	+ then show ?thesis
	+ using a_in
	+ by (auto simp: ys_def Inl None)
	+ next
	+ case (Inr b)
	+ have i_b: "i = b"
	+ using 3(12) z_out
	+ by (auto simp: ys_def Inr split: option.splits dest: id_mapD)
	+ have norm_zs: "fo_nmlz_rec (Suc i) (id_map (Suc i)) (X \<union> Y \<union> AD) zs = zs"
	+ using 3(12)
	+ by (auto simp: ys_def Inr i_b fun_upd_id_map split: option.splits dest: id_mapD)
	+ have ad_agr: "ad_agr_list X xs zs"
	+ using 3(13)
	+ by (auto simp: ys_def ad_agr_list_def ad_equiv_list_def sp_equiv_list_def pairwise_def)
	+ define m' where "m' \<equiv> m(n := Some (Inr i))"
	+ have preds: "inj_on m' (dom m')" "dom m' = {..<Suc j}" "Suc i \<le> Suc j"
	+ using 3(7,8,9,10)
	+ by (auto simp: m'_def n_j inj_on_def dom_def ran_def image_iff)
	+ (metis 3(8) domI lessThan_iff less_SucI)
	+ have ran: "ran m' = Inl ` Y \<union> Inr ` {..<Suc i}"
	+ using 3(9) None
	+ by (auto simp: m'_def)
	+ have "zs \<in> ad_agr_close_rec (Suc i) m' AD xs"
	+ apply (rule 3(1)[OF id_map norm_xs 3(4,5,6) preds(1,2) ran preds(3) _ norm_zs ad_agr])
	+ using 3(11,13)
	+ unfolding 3(9) ys_def Inr i_b m'_def
	+ unfolding ran[unfolded m'_def i_b]
	+ apply (auto simp: ad_agr_list_def sp_equiv_list_def pairwise_def split: option.splits)
	+ apply (metis Un_upper1 image_subset_iff option.simps(4))
	+ apply (metis UnI1 image_eqI insert_iff lessThan_Suc lessThan_iff option.simps(4)
	+ sp_equiv_pair.simps sum.inject(2) sup_commute)
	+ apply fastforce
	+ done
	+ then show ?thesis
	+ by (auto simp: ys_def Inr None m'_def i_b)
	+ qed
	+ next
	+ case False
	+ have id_map: "id_map j (Inr n) = Some n"
	+ using False
	+ by (auto simp: id_map_def)
	+ have norm_xs: "fo_nmlz_rec j (id_map j) X xs = xs"
	+ using 3(3)
	+ by (auto simp: id_map)
	+ have Some: "m n = Some z"
	+ using False 3(11)[unfolded ys_def]
	+ by (metis (mono_tags) 3(8) domD insert_iff leI lessThan_iff list.simps(15)
	+ option.simps(5) zip_Cons_Cons)
	+ have z_in: "z \<in> Inl ` Y \<union> Inr ` {..<i}"
	+ using 3(9) Some
	+ by (auto simp: ran_def)
	+ have ad_agr: "ad_agr_list X xs zs"
	+ using 3(13)
	+ by (auto simp: ad_agr_list_def ys_def ad_equiv_list_def sp_equiv_list_def pairwise_def)
	+ show ?thesis
	+ proof (cases z)
	+ case (Inl a)
	+ have a_in: "a \<in> Y \<union> AD"
	+ using 3(12,13)
	+ by (auto simp: ys_def Inl ad_agr_list_def ad_equiv_list_def ad_equiv_pair.simps
	+ split: if_splits option.splits)
	+ have norm_zs: "fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) zs = zs"
	+ using 3(12) a_in
	+ by (auto simp: ys_def Inl)
	+ show ?thesis
	+ using 3(2)[OF id_map norm_xs 3(4,5,6,7,8,9,10) _ norm_zs ad_agr] 3(11) a_in
	+ by (auto simp: ys_def Inl Some split: option.splits)
	+ next
	+ case (Inr b)
	+ have b_lt: "b < i"
	+ using z_in
	+ by (auto simp: Inr)
	+ have norm_zs: "fo_nmlz_rec i (id_map i) (X \<union> Y \<union> AD) zs = zs"
	+ using 3(12) b_lt
	+ by (auto simp: ys_def Inr split: option.splits)
	+ show ?thesis
	+ using 3(2)[OF id_map norm_xs 3(4,5,6,7,8,9,10) _ norm_zs ad_agr] 3(11)
	+ by (auto simp: ys_def Inr Some)
	+ qed
	+ qed
	+qed (auto simp: ad_agr_list_def)
	+
	+definition ad_agr_close :: "'a set \<Rightarrow> ('a + nat) list \<Rightarrow> ('a + nat) list set" where
	+ "ad_agr_close AD xs = ad_agr_close_rec 0 Map.empty AD xs"
	+
	+lemma ad_agr_close_sound:
	+ assumes "ys \<in> ad_agr_close Y xs" "fo_nmlzd X xs" "X \<inter> Y = {}"
	+ shows "fo_nmlzd (X \<union> Y) ys \<and> ad_agr_list X xs ys"
	+ using ad_agr_close_rec_sound[OF assms(1)[unfolded ad_agr_close_def]
	+ fo_nmlz_idem[OF assms(2), unfolded fo_nmlz_def, folded id_map_empty] assms(3)
	+ Int_empty_right Int_empty_left]
	+ ad_agr_map[OF ad_agr_close_rec_length[OF assms(1)[unfolded ad_agr_close_def]], of _ X]
	+ fo_nmlzd_code[unfolded fo_nmlz_def, folded id_map_empty, of "X \<union> Y" ys]
	+ by (auto simp: fo_nmlz_def)
	+
	+lemma ad_agr_close_complete:
	+ assumes "X \<inter> Y = {}" "fo_nmlzd X xs" "fo_nmlzd (X \<union> Y) ys" "ad_agr_list X xs ys"
	+ shows "ys \<in> ad_agr_close Y xs"
	+ using ad_agr_close_rec_complete[OF fo_nmlz_idem[OF assms(2),
	+ unfolded fo_nmlz_def, folded id_map_empty] assms(1) Int_empty_right Int_empty_left _ _ _
	+ order.refl _ _ assms(4), of Map.empty]
	+ fo_nmlzd_code[unfolded fo_nmlz_def, folded id_map_empty, of "X \<union> Y" ys]
	+ assms(3)
	+ unfolding ad_agr_close_def
	+ by (auto simp: fo_nmlz_def)
	+
	+lemma ad_agr_close_empty: "fo_nmlzd X xs \<Longrightarrow> ad_agr_close {} xs = {xs}"
	+ using ad_agr_close_complete[where ?X=X and ?Y="{}" and ?xs=xs and ?ys=xs]
	+ ad_agr_close_sound[where ?X=X and ?Y="{}" and ?xs=xs] ad_agr_list_refl ad_agr_list_fo_nmlzd
	+ by fastforce
	+
	+lemma ad_agr_close_set_correct:
	+ assumes "AD' \<subseteq> AD" "sorted_distinct ns"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set ns) (set ns) AD' \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> R \<longleftrightarrow> \<tau> \<in> R"
	+ shows "\<Union>(ad_agr_close (AD - AD') ` fo_nmlz AD' ` proj_vals R ns) = fo_nmlz AD ` proj_vals R ns"
	+proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> \<Union>(ad_agr_close (AD - AD') ` fo_nmlz AD' ` proj_vals R ns)"
	+ then obtain \<sigma> where \<sigma>_def: "vs \<in> ad_agr_close (AD - AD') (fo_nmlz AD' (map \<sigma> ns))" "\<sigma> \<in> R"
	+ by (auto simp: proj_vals_def)
	+ have vs: "fo_nmlzd AD vs" "ad_agr_list AD' (fo_nmlz AD' (map \<sigma> ns)) vs"
	+ using ad_agr_close_sound[OF \<sigma>_def(1) fo_nmlz_sound] assms(1) Diff_partition
	+ by fastforce+
	+ obtain \<tau> where \<tau>_def: "vs = map \<tau> ns"
	+ using exists_map[of ns vs] assms(2) vs(2)
	+ by (auto simp: ad_agr_list_def fo_nmlz_length)
	+ show "vs \<in> fo_nmlz AD ` proj_vals R ns"
	+ apply (subst fo_nmlz_idem[OF vs(1), symmetric])
	+ using iffD1[OF assms(3) \<sigma>_def(2), OF iffD2[OF ad_agr_list_link ad_agr_list_trans[OF
	+ fo_nmlz_ad_agr[of AD' "map \<sigma> ns"] vs(2), unfolded \<tau>_def]]]
	+ unfolding \<tau>_def
	+ by (auto simp: proj_vals_def)
	+next
	+ fix vs
	+ assume "vs \<in> fo_nmlz AD ` proj_vals R ns"
	+ then obtain \<sigma> where \<sigma>_def: "vs = fo_nmlz AD (map \<sigma> ns)" "\<sigma> \<in> R"
	+ by (auto simp: proj_vals_def)
	+ define xs where "xs = fo_nmlz AD' vs"
	+ have preds: "AD' \<inter> (AD - AD') = {}" "fo_nmlzd AD' xs" "fo_nmlzd (AD' \<union> (AD - AD')) vs"
	+ using assms(1) fo_nmlz_sound Diff_partition
	+ by (fastforce simp: \<sigma>_def(1) xs_def)+
	+ obtain \<tau> where \<tau>_def: "vs = map \<tau> ns"
	+ using exists_map[of "ns" vs] assms(2) \<sigma>_def(1)
	+ by (auto simp: fo_nmlz_length)
	+ have "vs \<in> ad_agr_close (AD - AD') xs"
	+ using ad_agr_close_complete[OF preds] ad_agr_list_comm[OF fo_nmlz_ad_agr]
	+ by (auto simp: xs_def)
	+ then show "vs \<in> \<Union>(ad_agr_close (AD - AD') ` fo_nmlz AD' ` proj_vals R ns)"
	+ unfolding xs_def \<tau>_def
	+ using iffD1[OF assms(3) \<sigma>_def(2), OF ad_agr_sets_mono[OF assms(1) iffD2[OF ad_agr_list_link
	+ fo_nmlz_ad_agr[of AD "map \<sigma> ns", folded \<sigma>_def(1), unfolded \<tau>_def]]]]
	+ by (auto simp: proj_vals_def)
	+qed
	+
	+lemma ad_agr_close_correct:
	+ assumes "AD' \<subseteq> AD"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set (fv_fo_fmla_list \<phi>)) (set (fv_fo_fmla_list \<phi>)) AD' \<sigma> \<tau> \<Longrightarrow>
	+ \<sigma> \<in> R \<longleftrightarrow> \<tau> \<in> R"
	+ shows "\<Union>(ad_agr_close (AD - AD') ` fo_nmlz AD' ` proj_fmla \<phi> R) = fo_nmlz AD ` proj_fmla \<phi> R"
	+ using ad_agr_close_set_correct[OF _ sorted_distinct_fv_list, OF assms]
	+ by (auto simp: proj_fmla_def)
	+
	+definition "ad_agr_close_set AD X = (if Set.is_empty AD then X else \<Union>(ad_agr_close AD ` X))"
	+
	+lemma ad_agr_close_set_eq: "Ball X (fo_nmlzd AD') \<Longrightarrow> ad_agr_close_set AD X = \<Union>(ad_agr_close AD ` X)"
	+ by (force simp: ad_agr_close_set_def Set.is_empty_def ad_agr_close_empty)
	+
	+lemma Ball_fo_nmlzd: "Ball (fo_nmlz AD ` X) (fo_nmlzd AD)"
	+ by (auto simp: fo_nmlz_sound)
	+
	+lemmas ad_agr_close_set_nmlz_eq = ad_agr_close_set_eq[OF Ball_fo_nmlzd]
	+
	+definition eval_pred :: "('a fo_term) list \<Rightarrow> 'a table \<Rightarrow> ('a, 'c) fo_t" where
	+ "eval_pred ts X = (let AD = \<Union>(set (map set_fo_term ts)) \<union> \<Union>(set ` X) in
	+ (AD, length (fv_fo_terms_list ts), eval_table ts (map Inl ` X)))"
	+
	+definition eval_bool :: "bool \<Rightarrow> ('a, 'c) fo_t" where
	+ "eval_bool b = (if b then ({}, 0, {[]}) else ({}, 0, {}))"
	+
	+definition eval_eq :: "'a fo_term \<Rightarrow> 'a fo_term \<Rightarrow> ('a, nat) fo_t" where
	+ "eval_eq t t' = (case t of Var n \<Rightarrow>
	+ (case t' of Var n' \<Rightarrow>
	+ if n = n' then ({}, 1, {[Inr 0]})
	+ else ({}, 2, {[Inr 0, Inr 0]})
	+ \| Const c' \<Rightarrow> ({c'}, 1, {[Inl c']}))
	+ \| Const c \<Rightarrow>
	+ (case t' of Var n' \<Rightarrow> ({c}, 1, {[Inl c]})
	+ \| Const c' \<Rightarrow> if c = c' then ({c}, 0, {[]}) else ({c, c'}, 0, {})))"
	+
	+fun eval_neg :: "nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow> ('a, nat) fo_t" where
	+ "eval_neg ns (AD, _, X) = (AD, length ns, nall_tuples AD (length ns) - X)"
	+
	+definition "eval_conj_tuple AD ns\<phi> ns\<psi> xs ys =
	+ (let cxs = filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> isl x) (zip ns\<phi> xs);
	+ nxs = map fst (filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> \<not>isl x) (zip ns\<phi> xs));
	+ cys = filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> isl y) (zip ns\<psi> ys);
	+ nys = map fst (filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> \<not>isl y) (zip ns\<psi> ys)) in
	+ fo_nmlz AD ` ext_tuple {} (sort (ns\<phi> @ map fst cys)) nys (map snd (merge (zip ns\<phi> xs) cys)) \<inter>
	+ fo_nmlz AD ` ext_tuple {} (sort (ns\<psi> @ map fst cxs)) nxs (map snd (merge (zip ns\<psi> ys) cxs)))"
	+
	+definition "eval_conj_set AD ns\<phi> X\<phi> ns\<psi> X\<psi> = \<Union>((\<lambda>xs. \<Union>(eval_conj_tuple AD ns\<phi> ns\<psi> xs ` X\<psi>)) ` X\<phi>)"
	+
	+definition "idx_join AD ns ns\<phi> X\<phi> ns\<psi> X\<psi> =
	+ (let idx\<phi>' = cluster (Some \<circ> (\<lambda>xs. fo_nmlz AD (proj_tuple ns (zip ns\<phi> xs)))) X\<phi>;
	+ idx\<psi>' = cluster (Some \<circ> (\<lambda>ys. fo_nmlz AD (proj_tuple ns (zip ns\<psi> ys)))) X\<psi> in
	+ set_of_idx (mapping_join (\<lambda>X\<phi>'' X\<psi>''. eval_conj_set AD ns\<phi> X\<phi>'' ns\<psi> X\<psi>'') idx\<phi>' idx\<psi>'))"
	+
	+fun eval_conj :: "nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow> nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow>
	+ ('a, nat) fo_t" where
	+ "eval_conj ns\<phi> (AD\<phi>, _, X\<phi>) ns\<psi> (AD\<psi>, _, X\<psi>) = (let AD = AD\<phi> \<union> AD\<psi>; AD\<Delta>\<phi> = AD - AD\<phi>; AD\<Delta>\<psi> = AD - AD\<psi>; ns = filter (\<lambda>n. n \<in> set ns\<psi>) ns\<phi> in
	+ (AD, card (set ns\<phi> \<union> set ns\<psi>), idx_join AD ns ns\<phi> (ad_agr_close_set AD\<Delta>\<phi> X\<phi>) ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> X\<psi>)))"
	+
	+fun eval_ajoin :: "nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow> nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow>
	+ ('a, nat) fo_t" where
	+ "eval_ajoin ns\<phi> (AD\<phi>, _, X\<phi>) ns\<psi> (AD\<psi>, _, X\<psi>) = (let AD = AD\<phi> \<union> AD\<psi>; AD\<Delta>\<phi> = AD - AD\<phi>; AD\<Delta>\<psi> = AD - AD\<psi>;
	+ ns = filter (\<lambda>n. n \<in> set ns\<psi>) ns\<phi>; ns\<phi>' = filter (\<lambda>n. n \<notin> set ns\<phi>) ns\<psi>;
	+ idx\<phi> = cluster (Some \<circ> (\<lambda>xs. fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> xs)))) (ad_agr_close_set AD\<Delta>\<phi> X\<phi>);
	+ idx\<psi> = cluster (Some \<circ> (\<lambda>ys. fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<psi> ys)))) X\<psi> in
	+ (AD, card (set ns\<phi> \<union> set ns\<psi>), set_of_idx (Mapping.map_values (\<lambda>xs X. case Mapping.lookup idx\<psi> xs of Some Y \<Rightarrow>
	+ idx_join AD ns ns\<phi> X ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {xs} - Y)) \| _ \<Rightarrow> ext_tuple_set AD ns\<phi> ns\<phi>' X) idx\<phi>)))"
	+
	+fun eval_disj :: "nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow> nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow>
	+ ('a, nat) fo_t" where
	+ "eval_disj ns\<phi> (AD\<phi>, _, X\<phi>) ns\<psi> (AD\<psi>, _, X\<psi>) = (let AD = AD\<phi> \<union> AD\<psi>;
	+ ns\<phi>' = filter (\<lambda>n. n \<notin> set ns\<phi>) ns\<psi>;
	+ ns\<psi>' = filter (\<lambda>n. n \<notin> set ns\<psi>) ns\<phi>;
	+ AD\<Delta>\<phi> = AD - AD\<phi>; AD\<Delta>\<psi> = AD - AD\<psi> in
	+ (AD, card (set ns\<phi> \<union> set ns\<psi>),
	+ ext_tuple_set AD ns\<phi> ns\<phi>' (ad_agr_close_set AD\<Delta>\<phi> X\<phi>) \<union>
	+ ext_tuple_set AD ns\<psi> ns\<psi>' (ad_agr_close_set AD\<Delta>\<psi> X\<psi>)))"
	+
	+fun eval_exists :: "nat \<Rightarrow> nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow> ('a, nat) fo_t" where
	+ "eval_exists i ns (AD, _, X) = (case pos i ns of Some j \<Rightarrow>
	+ (AD, length ns - 1, fo_nmlz AD ` rem_nth j ` X)
	+ \| None \<Rightarrow> (AD, length ns, X))"
	+
	+fun eval_forall :: "nat \<Rightarrow> nat list \<Rightarrow> ('a, nat) fo_t \<Rightarrow> ('a, nat) fo_t" where
	+ "eval_forall i ns (AD, _, X) = (case pos i ns of Some j \<Rightarrow>
	+ let n = card AD in
	+ (AD, length ns - 1, Mapping.keys (Mapping.filter (\<lambda>t Z. n + card (Inr -` set t) + 1 \<le> card Z)
	+ (cluster (Some \<circ> (\<lambda>ts. fo_nmlz AD (rem_nth j ts))) X)))
	+ \| None \<Rightarrow> (AD, length ns, X))"
	+
	+lemma combine_map2: assumes "length ys = length xs" "length ys' = length xs'"
	+ "distinct xs" "distinct xs'" "set xs \<inter> set xs' = {}"
	+ shows "\<exists>f. ys = map f xs \<and> ys' = map f xs'"
	+proof -
	+ obtain f g where fg_def: "ys = map f xs" "ys' = map g xs'"
	+ using assms exists_map
	+ by metis
	+ show ?thesis
	+ using assms
	+ by (auto simp: fg_def intro!: exI[of _ "\<lambda>x. if x \<in> set xs then f x else g x"])
	+qed
	+
	+lemma combine_map3: assumes "length ys = length xs" "length ys' = length xs'" "length ys'' = length xs''"
	+ "distinct xs" "distinct xs'" "distinct xs''" "set xs \<inter> set xs' = {}" "set xs \<inter> set xs'' = {}" "set xs' \<inter> set xs'' = {}"
	+ shows "\<exists>f. ys = map f xs \<and> ys' = map f xs' \<and> ys'' = map f xs''"
	+proof -
	+ obtain f g h where fgh_def: "ys = map f xs" "ys' = map g xs'" "ys'' = map h xs''"
	+ using assms exists_map
	+ by metis
	+ show ?thesis
	+ using assms
	+ by (auto simp: fgh_def intro!: exI[of _ "\<lambda>x. if x \<in> set xs then f x else if x \<in> set xs' then g x else h x"])
	+qed
	+
	+lemma distinct_set_zip: "length nsx = length xs \<Longrightarrow> distinct nsx \<Longrightarrow>
	+ (a, b) \<in> set (zip nsx xs) \<Longrightarrow> (a, ba) \<in> set (zip nsx xs) \<Longrightarrow> b = ba"
	+ by (induction nsx xs rule: list_induct2) (auto dest: set_zip_leftD)
	+
	+lemma fo_nmlz_idem_isl:
	+ assumes "\<And>x. x \<in> set xs \<Longrightarrow> (case x of Inl z \<Rightarrow> z \<in> X \| _ \<Rightarrow> False)"
	+ shows "fo_nmlz X xs = xs"
	+proof -
	+ have F1: "Inl x \<in> set xs \<Longrightarrow> x \<in> X" for x
	+ using assms[of "Inl x"]
	+ by auto
	+ have F2: "List.map_filter (case_sum Map.empty Some) xs = []"
	+ using assms
	+ by (induction xs) (fastforce simp: List.map_filter_def split: sum.splits)+
	+ show ?thesis
	+ by (rule fo_nmlz_idem) (auto simp: fo_nmlzd_def nats_def F2 intro: F1)
	+qed
	+
	+lemma set_zip_mapI: "x \<in> set xs \<Longrightarrow> (f x, g x) \<in> set (zip (map f xs) (map g xs))"
	+ by (induction xs) auto
	+
	+lemma ad_agr_list_fo_nmlzd_isl:
	+ assumes "ad_agr_list X (map f xs) (map g xs)" "fo_nmlzd X (map f xs)" "x \<in> set xs" "isl (f x)"
	+ shows "f x = g x"
	+proof -
	+ have AD: "ad_equiv_pair X (f x, g x)"
	+ using assms(1) set_zip_mapI[OF assms(3)]
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def split: sum.splits)
	+ then show ?thesis
	+ using assms(2-)
	+ by (auto simp: fo_nmlzd_def) (metis AD ad_equiv_pair.simps ad_equiv_pair_mono image_eqI sum.collapse(1) vimageI)
	+qed
	+
	+lemma eval_conj_tuple_close_empty2:
	+ assumes "fo_nmlzd X xs" "fo_nmlzd Y ys"
	+ "length nsx = length xs" "length nsy = length ys"
	+ "sorted_distinct nsx" "sorted_distinct nsy"
	+ "sorted_distinct ns" "set ns \<subseteq> set nsx \<inter> set nsy"
	+ "fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsx xs)) \<noteq> fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsy ys)) \<or>
	+ (proj_tuple ns (zip nsx xs) \<noteq> proj_tuple ns (zip nsy ys) \<and>
	+ (\<forall>x \<in> set (proj_tuple ns (zip nsx xs)). isl x) \<and> (\<forall>y \<in> set (proj_tuple ns (zip nsy ys)). isl y))"
	+ "xs' \<in> ad_agr_close ((X \<union> Y) - X) xs" "ys' \<in> ad_agr_close ((X \<union> Y) - Y) ys"
	+ shows "eval_conj_tuple (X \<union> Y) nsx nsy xs' ys' = {}"
	+proof -
	+ define cxs where "cxs = filter (\<lambda>(n, x). n \<notin> set nsy \<and> isl x) (zip nsx xs')"
	+ define nxs where "nxs = map fst (filter (\<lambda>(n, x). n \<notin> set nsy \<and> \<not>isl x) (zip nsx xs'))"
	+ define cys where "cys = filter (\<lambda>(n, y). n \<notin> set nsx \<and> isl y) (zip nsy ys')"
	+ define nys where "nys = map fst (filter (\<lambda>(n, y). n \<notin> set nsx \<and> \<not>isl y) (zip nsy ys'))"
	+ define both where "both = sorted_list_of_set (set nsx \<union> set nsy)"
	+ have close: "fo_nmlzd (X \<union> Y) xs'" "ad_agr_list X xs xs'" "fo_nmlzd (X \<union> Y) ys'" "ad_agr_list Y ys ys'"
	+ using ad_agr_close_sound[OF assms(10) assms(1)] ad_agr_close_sound[OF assms(11) assms(2)]
	+ by (auto simp add: sup_left_commute)
	+ have close': "length xs' = length xs" "length ys' = length ys"
	+ using close
	+ by (auto simp: ad_agr_list_length)
	+ have len_sort: "length (sort (nsx @ map fst cys)) = length (map snd (merge (zip nsx xs') cys))"
	+ "length (sort (nsy @ map fst cxs)) = length (map snd (merge (zip nsy ys') cxs))"
	+ by (auto simp: merge_length assms(3,4) close')
	+ {
	+ fix zs
	+ assume "zs \<in> fo_nmlz (X \<union> Y) ` (\<lambda>fs. map snd (merge (zip (sort (nsx @ map fst cys)) (map snd (merge (zip nsx xs') cys))) (zip nys fs))) `
	+ nall_tuples_rec {} (card (Inr -` set (map snd (merge (zip nsx xs') cys)))) (length nys)"
	+ "zs \<in> fo_nmlz (X \<union> Y) ` (\<lambda>fs. map snd (merge (zip (sort (nsy @ map fst cxs)) (map snd (merge (zip nsy ys') cxs))) (zip nxs fs))) `
	+ nall_tuples_rec {} (card (Inr -` set (map snd (merge (zip nsy ys') cxs)))) (length nxs)"
	+ then obtain zxs zys where nall: "zxs \<in> nall_tuples_rec {} (card (Inr -` set (map snd (merge (zip nsx xs') cys)))) (length nys)"
	+ "zs = fo_nmlz (X \<union> Y) (map snd (merge (zip (sort (nsx @ map fst cys)) (map snd (merge (zip nsx xs') cys))) (zip nys zxs)))"
	+ "zys \<in> nall_tuples_rec {} (card (Inr -` set (map snd (merge (zip nsy ys') cxs)))) (length nxs)"
	+ "zs = fo_nmlz (X \<union> Y) (map snd (merge (zip (sort (nsy @ map fst cxs)) (map snd (merge (zip nsy ys') cxs))) (zip nxs zys)))"
	+ by auto
	+ have len_zs: "length zxs = length nys" "length zys = length nxs"
	+ using nall(1,3)
	+ by (auto dest: nall_tuples_rec_length)
	+ have aux: "sorted_distinct (map fst cxs)" "sorted_distinct nxs" "sorted_distinct nsy"
	+ "sorted_distinct (map fst cys)" "sorted_distinct nys" "sorted_distinct nsx"
	+ "set (map fst cxs) \<inter> set nsy = {}" "set (map fst cxs) \<inter> set nxs = {}" "set nsy \<inter> set nxs = {}"
	+ "set (map fst cys) \<inter> set nsx = {}" "set (map fst cys) \<inter> set nys = {}" "set nsx \<inter> set nys = {}"
	+ using assms(3,4,5,6) close' distinct_set_zip
	+ by (auto simp: cxs_def nxs_def cys_def nys_def sorted_filter distinct_map_fst_filter)
	+ (smt (z3) distinct_set_zip)+
	+ obtain xf where xf_def: "map snd cxs = map xf (map fst cxs)" "ys' = map xf nsy" "zys = map xf nxs"
	+ using combine_map3[where ?ys="map snd cxs" and ?xs="map fst cxs" and ?ys'=ys' and ?xs'=nsy and ?ys''=zys and ?xs''=nxs] assms(4) aux close'
	+ by (auto simp: len_zs)
	+ obtain ysf where ysf_def: "ys = map ysf nsy"
	+ using assms(4,6) exists_map
	+ by auto
	+ obtain xg where xg_def: "map snd cys = map xg (map fst cys)" "xs' = map xg nsx" "zxs = map xg nys"
	+ using combine_map3[where ?ys="map snd cys" and ?xs="map fst cys" and ?ys'=xs' and ?xs'=nsx and ?ys''=zxs and ?xs''=nys] assms(3) aux close'
	+ by (auto simp: len_zs)
	+ obtain xsf where xsf_def: "xs = map xsf nsx"
	+ using assms(3,5) exists_map
	+ by auto
	+ have set_cxs_nxs: "set (map fst cxs @ nxs) = set nsx - set nsy"
	+ using assms(3)
	+ unfolding cxs_def nxs_def close'[symmetric]
	+ by (induction nsx xs' rule: list_induct2) auto
	+ have set_cys_nys: "set (map fst cys @ nys) = set nsy - set nsx"
	+ using assms(4)
	+ unfolding cys_def nys_def close'[symmetric]
	+ by (induction nsy ys' rule: list_induct2) auto
	+ have sort_sort_both_xs: "sort (sort (nsy @ map fst cxs) @ nxs) = both"
	+ apply (rule sorted_distinct_set_unique)
	+ using assms(3,5,6) close' set_cxs_nxs
	+ by (auto simp: both_def nxs_def cxs_def intro: distinct_map_fst_filter)
	+ (metis (no_types, lifting) distinct_set_zip)
	+ have sort_sort_both_ys: "sort (sort (nsx @ map fst cys) @ nys) = both"
	+ apply (rule sorted_distinct_set_unique)
	+ using assms(4,5,6) close' set_cys_nys
	+ by (auto simp: both_def nys_def cys_def intro: distinct_map_fst_filter)
	+ (metis (no_types, lifting) distinct_set_zip)
	+ have "map snd (merge (zip nsy ys') cxs) = map xf (sort (nsy @ map fst cxs))"
	+ using merge_map[where ?\<sigma>=xf and ?ns=nsy and ?ms="map fst cxs"] assms(6) aux
	+ unfolding xf_def(1)[symmetric] xf_def(2)
	+ by (auto simp: zip_map_fst_snd)
	+ then have zs_xf: "zs = fo_nmlz (X \<union> Y) (map xf both)"
	+ using merge_map[where \<sigma>=xf and ?ns="sort (nsy @ map fst cxs)" and ?ms=nxs] aux
	+ by (fastforce simp: nall(4) xf_def(3) sort_sort_both_xs)
	+ have "map snd (merge (zip nsx xs') cys) = map xg (sort (nsx @ map fst cys))"
	+ using merge_map[where ?\<sigma>=xg and ?ns=nsx and ?ms="map fst cys"] assms(5) aux
	+ unfolding xg_def(1)[symmetric] xg_def(2)
	+ by (fastforce simp: zip_map_fst_snd)
	+ then have zs_xg: "zs = fo_nmlz (X \<union> Y) (map xg both)"
	+ using merge_map[where \<sigma>=xg and ?ns="sort (nsx @ map fst cys)" and ?ms=nys] aux
	+ by (fastforce simp: nall(2) xg_def(3) sort_sort_both_ys)
	+ have proj_map: "proj_tuple ns (zip nsx xs') = map xg ns" "proj_tuple ns (zip nsy ys') = map xf ns"
	+ "proj_tuple ns (zip nsx xs) = map xsf ns" "proj_tuple ns (zip nsy ys) = map ysf ns"
	+ unfolding xf_def(2) xg_def(2) xsf_def ysf_def
	+ using assms(5,6,7,8) proj_tuple_map
	+ by auto
	+ have "ad_agr_list (X \<union> Y) (map xg both) (map xf both)"
	+ using zs_xg zs_xf
	+ by (fastforce dest: fo_nmlz_eqD)
	+ then have "ad_agr_list (X \<union> Y) (proj_tuple ns (zip nsx xs')) (proj_tuple ns (zip nsy ys'))"
	+ using assms(8)
	+ unfolding proj_map
	+ by (fastforce simp: both_def intro: ad_agr_list_subset[rotated])
	+ then have fo_nmlz_Un: "fo_nmlz (X \<union> Y) (proj_tuple ns (zip nsx xs')) = fo_nmlz (X \<union> Y) (proj_tuple ns (zip nsy ys'))"
	+ by (auto intro: fo_nmlz_eqI)
	+ have "False"
	+ using assms(9)
	+ proof (rule disjE)
	+ assume c: "fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsx xs)) \<noteq> fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsy ys))"
	+ have fo_nmlz_Int: "fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsx xs')) = fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsy ys'))"
	+ using fo_nmlz_Un
	+ by (rule fo_nmlz_eqI[OF ad_agr_list_mono, rotated, OF fo_nmlz_eqD]) auto
	+ have proj_xs: "fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsx xs)) = fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsx xs'))"
	+ unfolding proj_map
	+ apply (rule fo_nmlz_eqI)
	+ apply (rule ad_agr_list_mono[OF Int_lower1])
	+ apply (rule ad_agr_list_subset[OF _ close(2)[unfolded xsf_def xg_def(2)]])
	+ using assms(8)
	+ apply (auto)
	+ done
	+ have proj_ys: "fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsy ys)) = fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsy ys'))"
	+ unfolding proj_map
	+ apply (rule fo_nmlz_eqI)
	+ apply (rule ad_agr_list_mono[OF Int_lower2])
	+ apply (rule ad_agr_list_subset[OF _ close(4)[unfolded ysf_def xf_def(2)]])
	+ using assms(8)
	+ apply (auto)
	+ done
	+ show "False"
	+ using c fo_nmlz_Int proj_xs proj_ys
	+ by auto
	+ next
	+ assume c: "proj_tuple ns (zip nsx xs) \<noteq> proj_tuple ns (zip nsy ys) \<and>
	+ (\<forall>x\<in>set (proj_tuple ns (zip nsx xs)). isl x) \<and> (\<forall>y\<in>set (proj_tuple ns (zip nsy ys)). isl y)"
	+ have "case x of Inl z \<Rightarrow> z \<in> X \<union> Y \| Inr b \<Rightarrow> False" if "x \<in> set (proj_tuple ns (zip nsx xs'))" for x
	+ using close(2) assms(1,8) c that ad_agr_list_fo_nmlzd_isl[where ?X=X and ?f=xsf and ?g=xg and ?xs=nsx]
	+ unfolding proj_map
	+ unfolding xsf_def xg_def(2)
	+ apply (auto simp: fo_nmlzd_def split: sum.splits)
	+ apply (metis image_eqI subsetD vimageI)
	+ apply (metis subsetD sum.disc(2))
	+ done
	+ then have E1: "fo_nmlz (X \<union> Y) (proj_tuple ns (zip nsx xs')) = proj_tuple ns (zip nsx xs')"
	+ by (rule fo_nmlz_idem_isl)
	+ have "case y of Inl z \<Rightarrow> z \<in> X \<union> Y \| Inr b \<Rightarrow> False" if "y \<in> set (proj_tuple ns (zip nsy ys'))" for y
	+ using close(4) assms(2,8) c that ad_agr_list_fo_nmlzd_isl[where ?X=Y and ?f=ysf and ?g=xf and ?xs=nsy]
	+ unfolding proj_map
	+ unfolding ysf_def xf_def(2)
	+ apply (auto simp: fo_nmlzd_def split: sum.splits)
	+ apply (metis image_eqI subsetD vimageI)
	+ apply (metis subsetD sum.disc(2))
	+ done
	+ then have E2: "fo_nmlz (X \<union> Y) (proj_tuple ns (zip nsy ys')) = proj_tuple ns (zip nsy ys')"
	+ by (rule fo_nmlz_idem_isl)
	+ have ad: "ad_agr_list X (map xsf ns) (map xg ns)"
	+ using assms(8) close(2)[unfolded xsf_def xg_def(2)] ad_agr_list_subset
	+ by blast
	+ have "\<forall>x\<in>set (proj_tuple ns (zip nsx xs)). isl x"
	+ using c
	+ by auto
	+ then have E3: "proj_tuple ns (zip nsx xs) = proj_tuple ns (zip nsx xs')"
	+ using assms(8)
	+ unfolding proj_map
	+ apply (induction ns)
	+ using ad_agr_list_fo_nmlzd_isl[OF close(2)[unfolded xsf_def xg_def(2)] assms(1)[unfolded xsf_def]]
	+ by auto
	+ have "\<forall>x\<in>set (proj_tuple ns (zip nsy ys)). isl x"
	+ using c
	+ by auto
	+ then have E4: "proj_tuple ns (zip nsy ys) = proj_tuple ns (zip nsy ys')"
	+ using assms(8)
	+ unfolding proj_map
	+ apply (induction ns)
	+ using ad_agr_list_fo_nmlzd_isl[OF close(4)[unfolded ysf_def xf_def(2)] assms(2)[unfolded ysf_def]]
	+ by auto
	+ show "False"
	+ using c fo_nmlz_Un
	+ unfolding E1 E2 E3 E4
	+ by auto
	+ qed
	+ }
	+ then show ?thesis
	+ by (auto simp: eval_conj_tuple_def Let_def cxs_def[symmetric] nxs_def[symmetric] cys_def[symmetric] nys_def[symmetric]
	+ ext_tuple_eq[OF len_sort(1)] ext_tuple_eq[OF len_sort(2)])
	+qed
	+
	+lemma eval_conj_tuple_close_empty:
	+ assumes "fo_nmlzd X xs" "fo_nmlzd Y ys"
	+ "length nsx = length xs" "length nsy = length ys"
	+ "sorted_distinct nsx" "sorted_distinct nsy"
	+ "ns = filter (\<lambda>n. n \<in> set nsy) nsx"
	+ "fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsx xs)) \<noteq> fo_nmlz (X \<inter> Y) (proj_tuple ns (zip nsy ys))"
	+ "xs' \<in> ad_agr_close ((X \<union> Y) - X) xs" "ys' \<in> ad_agr_close ((X \<union> Y) - Y) ys"
	+ shows "eval_conj_tuple (X \<union> Y) nsx nsy xs' ys' = {}"
	+proof -
	+ have aux: "sorted_distinct ns" "set ns \<subseteq> set nsx \<inter> set nsy"
	+ using assms(5) sorted_filter[of id]
	+ by (auto simp: assms(7))
	+ show ?thesis
	+ using eval_conj_tuple_close_empty2[OF assms(1-6) aux] assms(8-)
	+ by auto
	+qed
	+
	+lemma eval_conj_tuple_empty2:
	+ assumes "fo_nmlzd Z xs" "fo_nmlzd Z ys"
	+ "length nsx = length xs" "length nsy = length ys"
	+ "sorted_distinct nsx" "sorted_distinct nsy"
	+ "sorted_distinct ns" "set ns \<subseteq> set nsx \<inter> set nsy"
	+ "fo_nmlz Z (proj_tuple ns (zip nsx xs)) \<noteq> fo_nmlz Z (proj_tuple ns (zip nsy ys)) \<or>
	+ (proj_tuple ns (zip nsx xs) \<noteq> proj_tuple ns (zip nsy ys) \<and>
	+ (\<forall>x \<in> set (proj_tuple ns (zip nsx xs)). isl x) \<and> (\<forall>y \<in> set (proj_tuple ns (zip nsy ys)). isl y))"
	+ shows "eval_conj_tuple Z nsx nsy xs ys = {}"
	+ using eval_conj_tuple_close_empty2[OF assms(1-8)] assms(9) ad_agr_close_empty assms(1-2)
	+ by fastforce
	+
	+lemma eval_conj_tuple_empty:
	+ assumes "fo_nmlzd Z xs" "fo_nmlzd Z ys"
	+ "length nsx = length xs" "length nsy = length ys"
	+ "sorted_distinct nsx" "sorted_distinct nsy"
	+ "ns = filter (\<lambda>n. n \<in> set nsy) nsx"
	+ "fo_nmlz Z (proj_tuple ns (zip nsx xs)) \<noteq> fo_nmlz Z (proj_tuple ns (zip nsy ys))"
	+ shows "eval_conj_tuple Z nsx nsy xs ys = {}"
	+proof -
	+ have aux: "sorted_distinct ns" "set ns \<subseteq> set nsx \<inter> set nsy"
	+ using assms(5) sorted_filter[of id]
	+ by (auto simp: assms(7))
	+ show ?thesis
	+ using eval_conj_tuple_empty2[OF assms(1-6) aux] assms(8-)
	+ by auto
	+qed
	+
	+lemma nall_tuples_rec_filter:
	+ assumes "xs \<in> nall_tuples_rec AD n (length xs)" "ys = filter (\<lambda>x. \<not>isl x) xs"
	+ shows "ys \<in> nall_tuples_rec {} n (length ys)"
	+ using assms
	+proof (induction xs arbitrary: n ys)
	+ case (Cons x xs)
	+ then show ?case
	+ proof (cases x)
	+ case (Inr b)
	+ have b_le_i: "b \<le> n"
	+ using Cons(2)
	+ by (auto simp: Inr)
	+ obtain zs where ys_def: "ys = Inr b # zs" "zs = filter (\<lambda>x. \<not> isl x) xs"
	+ using Cons(3)
	+ by (auto simp: Inr)
	+ show ?thesis
	+ proof (cases "b < n")
	+ case True
	+ then show ?thesis
	+ using Cons(1)[OF _ ys_def(2), of n] Cons(2)
	+ by (auto simp: Inr ys_def(1))
	+ next
	+ case False
	+ then show ?thesis
	+ using Cons(1)[OF _ ys_def(2), of "Suc n"] Cons(2)
	+ by (auto simp: Inr ys_def(1))
	+ qed
	+ qed auto
	+qed auto
	+
	+lemma nall_tuples_rec_filter_rev:
	+ assumes "ys \<in> nall_tuples_rec {} n (length ys)" "ys = filter (\<lambda>x. \<not>isl x) xs"
	+ "Inl -` set xs \<subseteq> AD"
	+ shows "xs \<in> nall_tuples_rec AD n (length xs)"
	+ using assms
	+proof (induction xs arbitrary: n ys)
	+ case (Cons x xs)
	+ show ?case
	+ proof (cases x)
	+ case (Inl a)
	+ have a_AD: "a \<in> AD"
	+ using Cons(4)
	+ by (auto simp: Inl)
	+ show ?thesis
	+ using Cons(1)[OF Cons(2)] Cons(3,4) a_AD
	+ by (auto simp: Inl)
	+ next
	+ case (Inr b)
	+ obtain zs where ys_def: "ys = Inr b # zs" "zs = filter (\<lambda>x. \<not> isl x) xs"
	+ using Cons(3)
	+ by (auto simp: Inr)
	+ show ?thesis
	+ using Cons(1)[OF _ ys_def(2)] Cons(2,4)
	+ by (fastforce simp: ys_def(1) Inr)
	+ qed
	+qed auto
	+
	+lemma eval_conj_set_aux:
	+ fixes AD :: "'a set"
	+ assumes ns\<phi>'_def: "ns\<phi>' = filter (\<lambda>n. n \<notin> set ns\<phi>) ns\<psi>"
	+ and ns\<psi>'_def: "ns\<psi>' = filter (\<lambda>n. n \<notin> set ns\<psi>) ns\<phi>"
	+ and X\<phi>_def: "X\<phi> = fo_nmlz AD ` proj_vals R\<phi> ns\<phi>"
	+ and X\<psi>_def: "X\<psi> = fo_nmlz AD ` proj_vals R\<psi> ns\<psi>"
	+ and distinct: "sorted_distinct ns\<phi>" "sorted_distinct ns\<psi>"
	+ and cxs_def: "cxs = filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> isl x) (zip ns\<phi> xs)"
	+ and nxs_def: "nxs = map fst (filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> \<not>isl x) (zip ns\<phi> xs))"
	+ and cys_def: "cys = filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> isl y) (zip ns\<psi> ys)"
	+ and nys_def: "nys = map fst (filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> \<not>isl y) (zip ns\<psi> ys))"
	+ and xs_ys_def: "xs \<in> X\<phi>" "ys \<in> X\<psi>"
	+ and \<sigma>xs_def: "xs = map \<sigma>xs ns\<phi>" "fs\<phi> = map \<sigma>xs ns\<phi>'"
	+ and \<sigma>ys_def: "ys = map \<sigma>ys ns\<psi>" "fs\<psi> = map \<sigma>ys ns\<psi>'"
	+ and fs\<phi>_def: "fs\<phi> \<in> nall_tuples_rec AD (card (Inr -` set xs)) (length ns\<phi>')"
	+ and fs\<psi>_def: "fs\<psi> \<in> nall_tuples_rec AD (card (Inr -` set ys)) (length ns\<psi>')"
	+ and ad_agr: "ad_agr_list AD (map \<sigma>ys (sort (ns\<psi> @ ns\<psi>'))) (map \<sigma>xs (sort (ns\<phi> @ ns\<phi>')))"
	+ shows
	+ "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) =
	+ map snd (merge (zip (sort (ns\<phi> @ map fst cys)) (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))
	+ (zip nys (map \<sigma>xs nys)))" and
	+ "map snd (merge (zip ns\<phi> xs) cys) = map \<sigma>xs (sort (ns\<phi> @ map fst cys))" and
	+ "map \<sigma>xs nys \<in>
	+ nall_tuples_rec {} (card (Inr -` set (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))) (length nys)"
	+proof -
	+ have len_xs_ys: "length xs = length ns\<phi>" "length ys = length ns\<psi>"
	+ using xs_ys_def
	+ by (auto simp: X\<phi>_def X\<psi>_def proj_vals_def fo_nmlz_length)
	+ have len_fs\<phi>: "length fs\<phi> = length ns\<phi>'"
	+ using \<sigma>xs_def(2)
	+ by auto
	+ have set_ns\<phi>': "set ns\<phi>' = set (map fst cys) \<union> set nys"
	+ using len_xs_ys(2)
	+ by (auto simp: ns\<phi>'_def cys_def nys_def dest: set_zip_leftD)
	+ (metis (no_types, lifting) image_eqI in_set_impl_in_set_zip1 mem_Collect_eq
	+ prod.sel(1) split_conv)
	+ have "\<And>x. Inl x \<in> set xs \<union> set fs\<phi> \<Longrightarrow> x \<in> AD" "\<And>y. Inl y \<in> set ys \<union> set fs\<psi> \<Longrightarrow> y \<in> AD"
	+ using xs_ys_def fo_nmlz_set[of AD] nall_tuples_rec_Inl[OF fs\<phi>_def]
	+ nall_tuples_rec_Inl[OF fs\<psi>_def]
	+ by (auto simp: X\<phi>_def X\<psi>_def)
	+ then have Inl_xs_ys:
	+ "\<And>n. n \<in> set ns\<phi> \<union> set ns\<psi> \<Longrightarrow> isl (\<sigma>xs n) \<longleftrightarrow> (\<exists>x. \<sigma>xs n = Inl x \<and> x \<in> AD)"
	+ "\<And>n. n \<in> set ns\<phi> \<union> set ns\<psi> \<Longrightarrow> isl (\<sigma>ys n) \<longleftrightarrow> (\<exists>y. \<sigma>ys n = Inl y \<and> y \<in> AD)"
	+ unfolding \<sigma>xs_def \<sigma>ys_def ns\<phi>'_def ns\<psi>'_def
	+ by (auto simp: isl_def) (smt imageI mem_Collect_eq)+
	+ have sort_sort: "sort (ns\<phi> @ ns\<phi>') = sort (ns\<psi> @ ns\<psi>')"
	+ apply (rule sorted_distinct_set_unique)
	+ using distinct
	+ by (auto simp: ns\<phi>'_def ns\<psi>'_def)
	+ have isl_iff: "\<And>n. n \<in> set ns\<phi>' \<union> set ns\<psi>' \<Longrightarrow> isl (\<sigma>xs n) \<or> isl (\<sigma>ys n) \<Longrightarrow> \<sigma>xs n = \<sigma>ys n"
	+ using ad_agr Inl_xs_ys
	+ unfolding sort_sort[symmetric] ad_agr_list_link[symmetric]
	+ unfolding ns\<phi>'_def ns\<psi>'_def
	+ apply (auto simp: ad_agr_sets_def)
	+ unfolding ad_equiv_pair.simps
	+ apply (metis (no_types, lifting) UnI2 image_eqI mem_Collect_eq)
	+ apply (metis (no_types, lifting) UnI2 image_eqI mem_Collect_eq)
	+ apply (metis (no_types, lifting) UnI1 image_eqI)+
	+ done
	+ have "\<And>n. n \<in> set (map fst cys) \<Longrightarrow> isl (\<sigma>xs n)"
	+ "\<And>n. n \<in> set (map fst cxs) \<Longrightarrow> isl (\<sigma>ys n)"
	+ using isl_iff
	+ by (auto simp: cys_def ns\<phi>'_def \<sigma>ys_def(1) cxs_def ns\<psi>'_def \<sigma>xs_def(1) set_zip)
	+ (metis nth_mem)+
	+ then have Inr_sort: "Inr -` set (map \<sigma>xs (sort (ns\<phi> @ map fst cys))) = Inr -` set xs"
	+ unfolding \<sigma>xs_def(1) \<sigma>ys_def(1)
	+ by (auto simp: zip_map_fst_snd dest: set_zip_leftD)
	+ (metis fst_conv image_iff sum.disc(2))+
	+ have map_nys: "map \<sigma>xs nys = filter (\<lambda>x. \<not>isl x) fs\<phi>"
	+ using isl_iff[unfolded ns\<phi>'_def]
	+ unfolding nys_def \<sigma>ys_def(1) \<sigma>xs_def(2) ns\<phi>'_def filter_map
	+ by (induction ns\<psi>) force+
	+ have map_nys_in_nall: "map \<sigma>xs nys \<in> nall_tuples_rec {} (card (Inr -` set xs)) (length nys)"
	+ using nall_tuples_rec_filter[OF fs\<phi>_def[folded len_fs\<phi>] map_nys]
	+ by auto
	+ have map_cys: "map snd cys = map \<sigma>xs (map fst cys)"
	+ using isl_iff
	+ by (auto simp: cys_def set_zip ns\<phi>'_def \<sigma>ys_def(1)) (metis nth_mem)
	+ show merge_xs_cys: "map snd (merge (zip ns\<phi> xs) cys) = map \<sigma>xs (sort (ns\<phi> @ map fst cys))"
	+ apply (subst zip_map_fst_snd[of cys, symmetric])
	+ unfolding \<sigma>xs_def(1) map_cys
	+ apply (rule merge_map)
	+ using distinct
	+ by (auto simp: cys_def \<sigma>ys_def sorted_filter distinct_map_filter map_fst_zip_take)
	+ have merge_nys_prems: "sorted_distinct (sort (ns\<phi> @ map fst cys))" "sorted_distinct nys"
	+ "set (sort (ns\<phi> @ map fst cys)) \<inter> set nys = {}"
	+ using distinct len_xs_ys(2)
	+ by (auto simp: cys_def nys_def distinct_map_filter sorted_filter)
	+ (metis eq_key_imp_eq_value map_fst_zip)
	+ have map_snd_merge_nys: "map \<sigma>xs (sort (sort (ns\<phi> @ map fst cys) @ nys)) =
	+ map snd (merge (zip (sort (ns\<phi> @ map fst cys)) (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))
	+ (zip nys (map \<sigma>xs nys)))"
	+ by (rule merge_map[OF merge_nys_prems, symmetric])
	+ have sort_sort_nys: "sort (sort (ns\<phi> @ map fst cys) @ nys) = sort (ns\<phi> @ ns\<phi>')"
	+ apply (rule sorted_distinct_set_unique)
	+ using distinct merge_nys_prems set_ns\<phi>'
	+ by (auto simp: cys_def nys_def ns\<phi>'_def dest: set_zip_leftD)
	+ have map_merge_fs\<phi>: "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) = map \<sigma>xs (sort (ns\<phi> @ ns\<phi>'))"
	+ unfolding \<sigma>xs_def
	+ apply (rule merge_map)
	+ using distinct sorted_filter[of id]
	+ by (auto simp: ns\<phi>'_def)
	+ show "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) =
	+ map snd (merge (zip (sort (ns\<phi> @ map fst cys)) (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))
	+ (zip nys (map \<sigma>xs nys)))"
	+ unfolding map_merge_fs\<phi> map_snd_merge_nys[unfolded sort_sort_nys]
	+ by auto
	+ show "map \<sigma>xs nys \<in> nall_tuples_rec {}
	+ (card (Inr -` set (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))) (length nys)"
	+ using map_nys_in_nall
	+ unfolding Inr_sort[symmetric]
	+ by auto
	+qed
	+
	+lemma eval_conj_set_aux':
	+ fixes AD :: "'a set"
	+ assumes ns\<phi>'_def: "ns\<phi>' = filter (\<lambda>n. n \<notin> set ns\<phi>) ns\<psi>"
	+ and ns\<psi>'_def: "ns\<psi>' = filter (\<lambda>n. n \<notin> set ns\<psi>) ns\<phi>"
	+ and X\<phi>_def: "X\<phi> = fo_nmlz AD ` proj_vals R\<phi> ns\<phi>"
	+ and X\<psi>_def: "X\<psi> = fo_nmlz AD ` proj_vals R\<psi> ns\<psi>"
	+ and distinct: "sorted_distinct ns\<phi>" "sorted_distinct ns\<psi>"
	+ and cxs_def: "cxs = filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> isl x) (zip ns\<phi> xs)"
	+ and nxs_def: "nxs = map fst (filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> \<not>isl x) (zip ns\<phi> xs))"
	+ and cys_def: "cys = filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> isl y) (zip ns\<psi> ys)"
	+ and nys_def: "nys = map fst (filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> \<not>isl y) (zip ns\<psi> ys))"
	+ and xs_ys_def: "xs \<in> X\<phi>" "ys \<in> X\<psi>"
	+ and \<sigma>xs_def: "xs = map \<sigma>xs ns\<phi>" "map snd cys = map \<sigma>xs (map fst cys)"
	+ "ys\<psi> = map \<sigma>xs nys"
	+ and \<sigma>ys_def: "ys = map \<sigma>ys ns\<psi>" "map snd cxs = map \<sigma>ys (map fst cxs)"
	+ "xs\<phi> = map \<sigma>ys nxs"
	+ and fs\<phi>_def: "fs\<phi> = map \<sigma>xs ns\<phi>'"
	+ and fs\<psi>_def: "fs\<psi> = map \<sigma>ys ns\<psi>'"
	+ and ys\<psi>_def: "map \<sigma>xs nys \<in> nall_tuples_rec {}
	+ (card (Inr -` set (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))) (length nys)"
	+ and Inl_set_AD: "Inl -` (set (map snd cxs) \<union> set xs\<phi>) \<subseteq> AD"
	+ "Inl -` (set (map snd cys) \<union> set ys\<psi>) \<subseteq> AD"
	+ and ad_agr: "ad_agr_list AD (map \<sigma>ys (sort (ns\<psi> @ ns\<psi>'))) (map \<sigma>xs (sort (ns\<phi> @ ns\<phi>')))"
	+ shows
	+ "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) =
	+ map snd (merge (zip (sort (ns\<phi> @ map fst cys)) (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))
	+ (zip nys (map \<sigma>xs nys)))" and
	+ "map snd (merge (zip ns\<phi> xs) cys) = map \<sigma>xs (sort (ns\<phi> @ map fst cys))"
	+ "fs\<phi> \<in> nall_tuples_rec AD (card (Inr -` set xs)) (length ns\<phi>')"
	+proof -
	+ have len_xs_ys: "length xs = length ns\<phi>" "length ys = length ns\<psi>"
	+ using xs_ys_def
	+ by (auto simp: X\<phi>_def X\<psi>_def proj_vals_def fo_nmlz_length)
	+ have len_fs\<phi>: "length fs\<phi> = length ns\<phi>'"
	+ by (auto simp: fs\<phi>_def)
	+ have set_ns: "set ns\<phi>' = set (map fst cys) \<union> set nys"
	+ "set ns\<psi>' = set (map fst cxs) \<union> set nxs"
	+ using len_xs_ys
	+ by (auto simp: ns\<phi>'_def cys_def nys_def ns\<psi>'_def cxs_def nxs_def dest: set_zip_leftD)
	+ (metis (no_types, lifting) image_eqI in_set_impl_in_set_zip1 mem_Collect_eq
	+ prod.sel(1) split_conv)+
	+ then have set_\<sigma>_ns: "\<sigma>xs ` set ns\<psi>' \<union> \<sigma>xs ` set ns\<phi>' \<subseteq> set xs \<union> set (map snd cys) \<union> set ys\<psi>"
	+ "\<sigma>ys ` set ns\<phi>' \<union> \<sigma>ys ` set ns\<psi>' \<subseteq> set ys \<union> set (map snd cxs) \<union> set xs\<phi>"
	+ by (auto simp: \<sigma>xs_def \<sigma>ys_def ns\<phi>'_def ns\<psi>'_def)
	+ have Inl_sub_AD: "\<And>x. Inl x \<in> set xs \<union> set (map snd cys) \<union> set ys\<psi> \<Longrightarrow> x \<in> AD"
	+ "\<And>y. Inl y \<in> set ys \<union> set (map snd cxs) \<union> set xs\<phi> \<Longrightarrow> y \<in> AD"
	+ using xs_ys_def fo_nmlz_set[of AD] Inl_set_AD
	+ by (auto simp: X\<phi>_def X\<psi>_def) (metis in_set_zipE set_map subset_eq vimageI zip_map_fst_snd)+
	+ then have Inl_xs_ys:
	+ "\<And>n. n \<in> set ns\<phi>' \<union> set ns\<psi>' \<Longrightarrow> isl (\<sigma>xs n) \<longleftrightarrow> (\<exists>x. \<sigma>xs n = Inl x \<and> x \<in> AD)"
	+ "\<And>n. n \<in> set ns\<phi>' \<union> set ns\<psi>' \<Longrightarrow> isl (\<sigma>ys n) \<longleftrightarrow> (\<exists>y. \<sigma>ys n = Inl y \<and> y \<in> AD)"
	+ using set_\<sigma>_ns
	+ by (auto simp: isl_def rev_image_eqI)
	+ have sort_sort: "sort (ns\<phi> @ ns\<phi>') = sort (ns\<psi> @ ns\<psi>')"
	+ apply (rule sorted_distinct_set_unique)
	+ using distinct
	+ by (auto simp: ns\<phi>'_def ns\<psi>'_def)
	+ have isl_iff: "\<And>n. n \<in> set ns\<phi>' \<union> set ns\<psi>' \<Longrightarrow> isl (\<sigma>xs n) \<or> isl (\<sigma>ys n) \<Longrightarrow> \<sigma>xs n = \<sigma>ys n"
	+ using ad_agr Inl_xs_ys
	+ unfolding sort_sort[symmetric] ad_agr_list_link[symmetric]
	+ unfolding ns\<phi>'_def ns\<psi>'_def
	+ apply (auto simp: ad_agr_sets_def)
	+ unfolding ad_equiv_pair.simps
	+ apply (metis (no_types, lifting) UnI2 image_eqI mem_Collect_eq)
	+ apply (metis (no_types, lifting) UnI2 image_eqI mem_Collect_eq)
	+ apply (metis (no_types, lifting) UnI1 image_eqI)+
	+ done
	+ have "\<And>n. n \<in> set (map fst cys) \<Longrightarrow> isl (\<sigma>xs n)"
	+ "\<And>n. n \<in> set (map fst cxs) \<Longrightarrow> isl (\<sigma>ys n)"
	+ using isl_iff
	+ by (auto simp: cys_def ns\<phi>'_def \<sigma>ys_def(1) cxs_def ns\<psi>'_def \<sigma>xs_def(1) set_zip)
	+ (metis nth_mem)+
	+ then have Inr_sort: "Inr -` set (map \<sigma>xs (sort (ns\<phi> @ map fst cys))) = Inr -` set xs"
	+ unfolding \<sigma>xs_def(1) \<sigma>ys_def(1)
	+ by (auto simp: zip_map_fst_snd dest: set_zip_leftD)
	+ (metis fst_conv image_iff sum.disc(2))+
	+ have map_nys: "map \<sigma>xs nys = filter (\<lambda>x. \<not>isl x) fs\<phi>"
	+ using isl_iff[unfolded ns\<phi>'_def]
	+ unfolding nys_def \<sigma>ys_def(1) fs\<phi>_def ns\<phi>'_def
	+ by (induction ns\<psi>) force+
	+ have map_cys: "map snd cys = map \<sigma>xs (map fst cys)"
	+ using isl_iff
	+ by (auto simp: cys_def set_zip ns\<phi>'_def \<sigma>ys_def(1)) (metis nth_mem)
	+ show merge_xs_cys: "map snd (merge (zip ns\<phi> xs) cys) = map \<sigma>xs (sort (ns\<phi> @ map fst cys))"
	+ apply (subst zip_map_fst_snd[of cys, symmetric])
	+ unfolding \<sigma>xs_def(1) map_cys
	+ apply (rule merge_map)
	+ using distinct
	+ by (auto simp: cys_def \<sigma>ys_def sorted_filter distinct_map_filter map_fst_zip_take)
	+ have merge_nys_prems: "sorted_distinct (sort (ns\<phi> @ map fst cys))" "sorted_distinct nys"
	+ "set (sort (ns\<phi> @ map fst cys)) \<inter> set nys = {}"
	+ using distinct len_xs_ys(2)
	+ by (auto simp: cys_def nys_def distinct_map_filter sorted_filter)
	+ (metis eq_key_imp_eq_value map_fst_zip)
	+ have map_snd_merge_nys: "map \<sigma>xs (sort (sort (ns\<phi> @ map fst cys) @ nys)) =
	+ map snd (merge (zip (sort (ns\<phi> @ map fst cys)) (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))
	+ (zip nys (map \<sigma>xs nys)))"
	+ by (rule merge_map[OF merge_nys_prems, symmetric])
	+ have sort_sort_nys: "sort (sort (ns\<phi> @ map fst cys) @ nys) = sort (ns\<phi> @ ns\<phi>')"
	+ apply (rule sorted_distinct_set_unique)
	+ using distinct merge_nys_prems set_ns
	+ by (auto simp: cys_def nys_def ns\<phi>'_def dest: set_zip_leftD)
	+ have map_merge_fs\<phi>: "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) = map \<sigma>xs (sort (ns\<phi> @ ns\<phi>'))"
	+ unfolding \<sigma>xs_def fs\<phi>_def
	+ apply (rule merge_map)
	+ using distinct sorted_filter[of id]
	+ by (auto simp: ns\<phi>'_def)
	+ show "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) =
	+ map snd (merge (zip (sort (ns\<phi> @ map fst cys)) (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))
	+ (zip nys (map \<sigma>xs nys)))"
	+ unfolding map_merge_fs\<phi> map_snd_merge_nys[unfolded sort_sort_nys]
	+ by auto
	+ have "Inl -` set fs\<phi> \<subseteq> AD"
	+ using Inl_sub_AD(1) set_\<sigma>_ns
	+ by (force simp: fs\<phi>_def)
	+ then show "fs\<phi> \<in> nall_tuples_rec AD (card (Inr -` set xs)) (length ns\<phi>')"
	+ unfolding len_fs\<phi>[symmetric]
	+ using nall_tuples_rec_filter_rev[OF _ map_nys] ys\<psi>_def[unfolded Inr_sort]
	+ by auto
	+qed
	+
	+lemma eval_conj_set_correct:
	+ assumes ns\<phi>'_def: "ns\<phi>' = filter (\<lambda>n. n \<notin> set ns\<phi>) ns\<psi>"
	+ and ns\<psi>'_def: "ns\<psi>' = filter (\<lambda>n. n \<notin> set ns\<psi>) ns\<phi>"
	+ and X\<phi>_def: "X\<phi> = fo_nmlz AD ` proj_vals R\<phi> ns\<phi>"
	+ and X\<psi>_def: "X\<psi> = fo_nmlz AD ` proj_vals R\<psi> ns\<psi>"
	+ and distinct: "sorted_distinct ns\<phi>" "sorted_distinct ns\<psi>"
	+ shows "eval_conj_set AD ns\<phi> X\<phi> ns\<psi> X\<psi> = ext_tuple_set AD ns\<phi> ns\<phi>' X\<phi> \<inter> ext_tuple_set AD ns\<psi> ns\<psi>' X\<psi>"
	+proof -
	+ have aux: "ext_tuple_set AD ns\<phi> ns\<phi>' X\<phi> = fo_nmlz AD ` \<Union>(ext_tuple AD ns\<phi> ns\<phi>' ` X\<phi>)"
	+ "ext_tuple_set AD ns\<psi> ns\<psi>' X\<psi> = fo_nmlz AD ` \<Union>(ext_tuple AD ns\<psi> ns\<psi>' ` X\<psi>)"
	+ by (auto simp: ext_tuple_set_def ext_tuple_def X\<phi>_def X\<psi>_def image_iff fo_nmlz_idem[OF fo_nmlz_sound])
	+ show ?thesis
	+ unfolding aux
	+ proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> fo_nmlz AD ` \<Union>(ext_tuple AD ns\<phi> ns\<phi>' ` X\<phi>) \<inter>
	+ fo_nmlz AD ` \<Union>(ext_tuple AD ns\<psi> ns\<psi>' ` X\<psi>)"
	+ then obtain xs ys where xs_ys_def: "xs \<in> X\<phi>" "vs \<in> fo_nmlz AD ` ext_tuple AD ns\<phi> ns\<phi>' xs"
	+ "ys \<in> X\<psi>" "vs \<in> fo_nmlz AD ` ext_tuple AD ns\<psi> ns\<psi>' ys"
	+ by auto
	+ have len_xs_ys: "length xs = length ns\<phi>" "length ys = length ns\<psi>"
	+ using xs_ys_def(1,3)
	+ by (auto simp: X\<phi>_def X\<psi>_def proj_vals_def fo_nmlz_length)
	+ obtain fs\<phi> where fs\<phi>_def: "vs = fo_nmlz AD (map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)))"
	+ "fs\<phi> \<in> nall_tuples_rec AD (card (Inr -` set xs)) (length ns\<phi>')"
	+ using xs_ys_def(1,2)
	+ by (auto simp: X\<phi>_def proj_vals_def ext_tuple_def split: if_splits)
	+ (metis fo_nmlz_map length_map map_snd_zip)
	+ obtain fs\<psi> where fs\<psi>_def: "vs = fo_nmlz AD (map snd (merge (zip ns\<psi> ys) (zip ns\<psi>' fs\<psi>)))"
	+ "fs\<psi> \<in> nall_tuples_rec AD (card (Inr -` set ys)) (length ns\<psi>')"
	+ using xs_ys_def(3,4)
	+ by (auto simp: X\<psi>_def proj_vals_def ext_tuple_def split: if_splits)
	+ (metis fo_nmlz_map length_map map_snd_zip)
	+ note len_fs\<phi> = nall_tuples_rec_length[OF fs\<phi>_def(2)]
	+ note len_fs\<psi> = nall_tuples_rec_length[OF fs\<psi>_def(2)]
	+ obtain \<sigma>xs where \<sigma>xs_def: "xs = map \<sigma>xs ns\<phi>" "fs\<phi> = map \<sigma>xs ns\<phi>'"
	+ using exists_map[of "ns\<phi> @ ns\<phi>'" "xs @ fs\<phi>"] len_xs_ys(1) len_fs\<phi> distinct
	+ by (auto simp: ns\<phi>'_def)
	+ obtain \<sigma>ys where \<sigma>ys_def: "ys = map \<sigma>ys ns\<psi>" "fs\<psi> = map \<sigma>ys ns\<psi>'"
	+ using exists_map[of "ns\<psi> @ ns\<psi>'" "ys @ fs\<psi>"] len_xs_ys(2) len_fs\<psi> distinct
	+ by (auto simp: ns\<psi>'_def)
	+ have map_merge_fs\<phi>: "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) = map \<sigma>xs (sort (ns\<phi> @ ns\<phi>'))"
	+ unfolding \<sigma>xs_def
	+ apply (rule merge_map)
	+ using distinct sorted_filter[of id]
	+ by (auto simp: ns\<phi>'_def)
	+ have map_merge_fs\<psi>: "map snd (merge (zip ns\<psi> ys) (zip ns\<psi>' fs\<psi>)) = map \<sigma>ys (sort (ns\<psi> @ ns\<psi>'))"
	+ unfolding \<sigma>ys_def
	+ apply (rule merge_map)
	+ using distinct sorted_filter[of id]
	+ by (auto simp: ns\<psi>'_def)
	+ define cxs where "cxs = filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> isl x) (zip ns\<phi> xs)"
	+ define nxs where "nxs = map fst (filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> \<not>isl x) (zip ns\<phi> xs))"
	+ define cys where "cys = filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> isl y) (zip ns\<psi> ys)"
	+ define nys where "nys = map fst (filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> \<not>isl y) (zip ns\<psi> ys))"
	+ note ad_agr1 = fo_nmlz_eqD[OF trans[OF fs\<phi>_def(1)[symmetric] fs\<psi>_def(1)],
	+ unfolded map_merge_fs\<phi> map_merge_fs\<psi>]
	+ note ad_agr2 = ad_agr_list_comm[OF ad_agr1]
	+ obtain \<sigma>xs where aux1:
	+ "map snd (merge (zip ns\<phi> xs) (zip ns\<phi>' fs\<phi>)) =
	+ map snd (merge (zip (sort (ns\<phi> @ map fst cys)) (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))
	+ (zip nys (map \<sigma>xs nys)))"
	+ "map snd (merge (zip ns\<phi> xs) cys) = map \<sigma>xs (sort (ns\<phi> @ map fst cys))"
	+ "map \<sigma>xs nys \<in> nall_tuples_rec {}
	+ (card (Inr -` set (map \<sigma>xs (sort (ns\<phi> @ map fst cys))))) (length nys)"
	+ using eval_conj_set_aux[OF ns\<phi>'_def ns\<psi>'_def X\<phi>_def X\<psi>_def distinct cxs_def nxs_def
	+ cys_def nys_def xs_ys_def(1,3) \<sigma>xs_def \<sigma>ys_def fs\<phi>_def(2) fs\<psi>_def(2) ad_agr2]
	+ by blast
	+ obtain \<sigma>ys where aux2:
	+ "map snd (merge (zip ns\<psi> ys) (zip ns\<psi>' fs\<psi>)) =
	+ map snd (merge (zip (sort (ns\<psi> @ map fst cxs)) (map \<sigma>ys (sort (ns\<psi> @ map fst cxs))))
	+ (zip nxs (map \<sigma>ys nxs)))"
	+ "map snd (merge (zip ns\<psi> ys) cxs) = map \<sigma>ys (sort (ns\<psi> @ map fst cxs))"
	+ "map \<sigma>ys nxs \<in> nall_tuples_rec {}
	+ (card (Inr -` set (map \<sigma>ys (sort (ns\<psi> @ map fst cxs))))) (length nxs)"
	+ using eval_conj_set_aux[OF ns\<psi>'_def ns\<phi>'_def X\<psi>_def X\<phi>_def distinct(2,1) cys_def nys_def
	+ cxs_def nxs_def xs_ys_def(3,1) \<sigma>ys_def \<sigma>xs_def fs\<psi>_def(2) fs\<phi>_def(2) ad_agr1]
	+ by blast
	+ have vs_ext_nys: "vs \<in> fo_nmlz AD ` ext_tuple {} (sort (ns\<phi> @ map fst cys)) nys
	+ (map snd (merge (zip ns\<phi> xs) cys))"
	+ using aux1(3)
	+ unfolding fs\<phi>_def(1) aux1(1)
	+ by (simp add: ext_tuple_eq[OF length_map[symmetric]] aux1(2))
	+ have vs_ext_nxs: "vs \<in> fo_nmlz AD ` ext_tuple {} (sort (ns\<psi> @ map fst cxs)) nxs
	+ (map snd (merge (zip ns\<psi> ys) cxs))"
	+ using aux2(3)
	+ unfolding fs\<psi>_def(1) aux2(1)
	+ by (simp add: ext_tuple_eq[OF length_map[symmetric]] aux2(2))
	+ show "vs \<in> eval_conj_set AD ns\<phi> X\<phi> ns\<psi> X\<psi>"
	+ using vs_ext_nys vs_ext_nxs xs_ys_def(1,3)
	+ by (auto simp: eval_conj_set_def eval_conj_tuple_def nys_def cys_def nxs_def cxs_def Let_def)
	+ next
	+ fix vs
	+ assume "vs \<in> eval_conj_set AD ns\<phi> X\<phi> ns\<psi> X\<psi>"
	+ then obtain xs ys cxs nxs cys nys where
	+ cxs_def: "cxs = filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> isl x) (zip ns\<phi> xs)" and
	+ nxs_def: "nxs = map fst (filter (\<lambda>(n, x). n \<notin> set ns\<psi> \<and> \<not>isl x) (zip ns\<phi> xs))" and
	+ cys_def: "cys = filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> isl y) (zip ns\<psi> ys)" and
	+ nys_def: "nys = map fst (filter (\<lambda>(n, y). n \<notin> set ns\<phi> \<and> \<not>isl y) (zip ns\<psi> ys))" and
	+ xs_def: "xs \<in> X\<phi>" "vs \<in> fo_nmlz AD ` ext_tuple {} (sort (ns\<phi> @ map fst cys)) nys
	+ (map snd (merge (zip ns\<phi> xs) cys))" and
	+ ys_def: "ys \<in> X\<psi>" "vs \<in> fo_nmlz AD ` ext_tuple {} (sort (ns\<psi> @ map fst cxs)) nxs
	+ (map snd (merge (zip ns\<psi> ys) cxs))"
	+ by (auto simp: eval_conj_set_def eval_conj_tuple_def Let_def) (metis (no_types, lifting) image_eqI)
	+ have len_xs_ys: "length xs = length ns\<phi>" "length ys = length ns\<psi>"
	+ using xs_def(1) ys_def(1)
	+ by (auto simp: X\<phi>_def X\<psi>_def proj_vals_def fo_nmlz_length)
	+ have len_merge_cys: "length (map snd (merge (zip ns\<phi> xs) cys)) =
	+ length (sort (ns\<phi> @ map fst cys))"
	+ using merge_length[of "zip ns\<phi> xs" cys] len_xs_ys
	+ by auto
	+ obtain ys\<psi> where ys\<psi>_def: "vs = fo_nmlz AD (map snd (merge (zip (sort (ns\<phi> @ map fst cys))
	+ (map snd (merge (zip ns\<phi> xs) cys))) (zip nys ys\<psi>)))"
	+ "ys\<psi> \<in> nall_tuples_rec {} (card (Inr -` set (map snd (merge (zip ns\<phi> xs) cys))))
	+ (length nys)"
	+ using xs_def(2)
	+ unfolding ext_tuple_eq[OF len_merge_cys[symmetric]]
	+ by auto
	+ have distinct_nys: "distinct (ns\<phi> @ map fst cys @ nys)"
	+ using distinct len_xs_ys
	+ by (auto simp: cys_def nys_def sorted_filter distinct_map_filter)
	+ (metis eq_key_imp_eq_value map_fst_zip)
	+ obtain \<sigma>xs where \<sigma>xs_def: "xs = map \<sigma>xs ns\<phi>" "map snd cys = map \<sigma>xs (map fst cys)"
	+ "ys\<psi> = map \<sigma>xs nys"
	+ using exists_map[OF _ distinct_nys, of "xs @ map snd cys @ ys\<psi>"] len_xs_ys(1)
	+ nall_tuples_rec_length[OF ys\<psi>_def(2)]
	+ by (auto simp: ns\<phi>'_def)
	+ have len_merge_cxs: "length (map snd (merge (zip ns\<psi> ys) cxs)) =
	+ length (sort (ns\<psi> @ map fst cxs))"
	+ using merge_length[of "zip ns\<psi> ys"] len_xs_ys
	+ by auto
	+ obtain xs\<phi> where xs\<phi>_def: "vs = fo_nmlz AD (map snd (merge (zip (sort (ns\<psi> @ map fst cxs))
	+ (map snd (merge (zip ns\<psi> ys) cxs))) (zip nxs xs\<phi>)))"
	+ "xs\<phi> \<in> nall_tuples_rec {} (card (Inr -` set (map snd (merge (zip ns\<psi> ys) cxs))))
	+ (length nxs)"
	+ using ys_def(2)
	+ unfolding ext_tuple_eq[OF len_merge_cxs[symmetric]]
	+ by auto
	+ have distinct_nxs: "distinct (ns\<psi> @ map fst cxs @ nxs)"
	+ using distinct len_xs_ys(1)
	+ by (auto simp: cxs_def nxs_def sorted_filter distinct_map_filter)
	+ (metis eq_key_imp_eq_value map_fst_zip)
	+ obtain \<sigma>ys where \<sigma>ys_def: "ys = map \<sigma>ys ns\<psi>" "map snd cxs = map \<sigma>ys (map fst cxs)"
	+ "xs\<phi> = map \<sigma>ys nxs"
	+ using exists_map[OF _ distinct_nxs, of "ys @ map snd cxs @ xs\<phi>"] len_xs_ys(2)
	+ nall_tuples_rec_length[OF xs\<phi>_def(2)]
	+ by (auto simp: ns\<psi>'_def)
	+ have sd_cs_ns: "sorted_distinct (map fst cxs)" "sorted_distinct nxs"
	+ "sorted_distinct (map fst cys)" "sorted_distinct nys"
	+ "sorted_distinct (sort (ns\<psi> @ map fst cxs))"
	+ "sorted_distinct (sort (ns\<phi> @ map fst cys))"
	+ using distinct len_xs_ys
	+ by (auto simp: cxs_def nxs_def cys_def nys_def sorted_filter distinct_map_filter)
	+ have set_cs_ns_disj: "set (map fst cxs) \<inter> set nxs = {}" "set (map fst cys) \<inter> set nys = {}"
	+ "set (sort (ns\<phi> @ map fst cys)) \<inter> set nys = {}"
	+ "set (sort (ns\<psi> @ map fst cxs)) \<inter> set nxs = {}"
	+ using distinct nth_eq_iff_index_eq
	+ by (auto simp: cxs_def nxs_def cys_def nys_def set_zip) blast+
	+ have merge_sort_cxs: "map snd (merge (zip ns\<psi> ys) cxs) = map \<sigma>ys (sort (ns\<psi> @ map fst cxs))"
	+ unfolding \<sigma>ys_def(1)
	+ apply (subst zip_map_fst_snd[of cxs, symmetric])
	+ unfolding \<sigma>ys_def(2)
	+ apply (rule merge_map)
	+ using distinct(2) sd_cs_ns
	+ by (auto simp: cxs_def)
	+ have merge_sort_cys: "map snd (merge (zip ns\<phi> xs) cys) = map \<sigma>xs (sort (ns\<phi> @ map fst cys))"
	+ unfolding \<sigma>xs_def(1)
	+ apply (subst zip_map_fst_snd[of cys, symmetric])
	+ unfolding \<sigma>xs_def(2)
	+ apply (rule merge_map)
	+ using distinct(1) sd_cs_ns
	+ by (auto simp: cys_def)
	+ have set_ns\<phi>': "set ns\<phi>' = set (map fst cys) \<union> set nys"
	+ using len_xs_ys(2)
	+ by (auto simp: ns\<phi>'_def cys_def nys_def dest: set_zip_leftD)
	+ (metis (no_types, lifting) image_eqI in_set_impl_in_set_zip1 mem_Collect_eq
	+ prod.sel(1) split_conv)
	+ have sort_sort_nys: "sort (sort (ns\<phi> @ map fst cys) @ nys) = sort (ns\<phi> @ ns\<phi>')"
	+ apply (rule sorted_distinct_set_unique)
	+ using distinct sd_cs_ns set_cs_ns_disj set_ns\<phi>'
	+ by (auto simp: cys_def nys_def ns\<phi>'_def dest: set_zip_leftD)
	+ have set_ns\<psi>': "set ns\<psi>' = set (map fst cxs) \<union> set nxs"
	+ using len_xs_ys(1)
	+ by (auto simp: ns\<psi>'_def cxs_def nxs_def dest: set_zip_leftD)
	+ (metis (no_types, lifting) image_eqI in_set_impl_in_set_zip1 mem_Collect_eq
	+ prod.sel(1) split_conv)
	+ have sort_sort_nxs: "sort (sort (ns\<psi> @ map fst cxs) @ nxs) = sort (ns\<psi> @ ns\<psi>')"
	+ apply (rule sorted_distinct_set_unique)
	+ using distinct sd_cs_ns set_cs_ns_disj set_ns\<psi>'
	+ by (auto simp: cxs_def nxs_def ns\<psi>'_def dest: set_zip_leftD)
	+ have ad_agr1: "ad_agr_list AD (map \<sigma>ys (sort (ns\<psi> @ ns\<psi>'))) (map \<sigma>xs (sort (ns\<phi> @ ns\<phi>')))"
	+ using fo_nmlz_eqD[OF trans[OF xs\<phi>_def(1)[symmetric] ys\<psi>_def(1)]]
	+ unfolding \<sigma>xs_def(3) \<sigma>ys_def(3) merge_sort_cxs merge_sort_cys
	+ unfolding merge_map[OF sd_cs_ns(5) sd_cs_ns(2) set_cs_ns_disj(4)]
	+ unfolding merge_map[OF sd_cs_ns(6) sd_cs_ns(4) set_cs_ns_disj(3)]
	+ unfolding sort_sort_nxs sort_sort_nys .
	+ note ad_agr2 = ad_agr_list_comm[OF ad_agr1]
	+ have Inl_set_AD: "Inl -` (set (map snd cxs) \<union> set xs\<phi>) \<subseteq> AD"
	+ "Inl -` (set (map snd cys) \<union> set ys\<psi>) \<subseteq> AD"
	+ using xs_def(1) nall_tuples_rec_Inl[OF xs\<phi>_def(2)] ys_def(1)
	+ nall_tuples_rec_Inl[OF ys\<psi>_def(2)] fo_nmlz_set[of AD]
	+ by (fastforce simp: cxs_def X\<phi>_def cys_def X\<psi>_def dest!: set_zip_rightD)+
	+ note aux1 = eval_conj_set_aux'[OF ns\<phi>'_def ns\<psi>'_def X\<phi>_def X\<psi>_def distinct cxs_def nxs_def
	+ cys_def nys_def xs_def(1) ys_def(1) \<sigma>xs_def \<sigma>ys_def refl refl
	+ ys\<psi>_def(2)[unfolded \<sigma>xs_def(3) merge_sort_cys] Inl_set_AD ad_agr1]
	+ note aux2 = eval_conj_set_aux'[OF ns\<psi>'_def ns\<phi>'_def X\<psi>_def X\<phi>_def distinct(2,1) cys_def nys_def
	+ cxs_def nxs_def ys_def(1) xs_def(1) \<sigma>ys_def \<sigma>xs_def refl refl
	+ xs\<phi>_def(2)[unfolded \<sigma>ys_def(3) merge_sort_cxs] Inl_set_AD(2,1) ad_agr2]
	+ show "vs \<in> fo_nmlz AD ` \<Union>(ext_tuple AD ns\<phi> ns\<phi>' ` X\<phi>) \<inter>
	+ fo_nmlz AD ` \<Union>(ext_tuple AD ns\<psi> ns\<psi>' ` X\<psi>)"
	+ using xs_def(1) ys_def(1) ys\<psi>_def(1) xs\<phi>_def(1) aux1(3) aux2(3)
	+ ext_tuple_eq[OF len_xs_ys(1)[symmetric], of AD ns\<phi>']
	+ ext_tuple_eq[OF len_xs_ys(2)[symmetric], of AD ns\<psi>']
	+ unfolding aux1(2) aux2(2) \<sigma>ys_def(3) \<sigma>xs_def(3) aux1(1)[symmetric] aux2(1)[symmetric]
	+ by blast
	+ qed
	+qed
	+
	+lemma esat_exists_not_fv: "n \<notin> fv_fo_fmla \<phi> \<Longrightarrow> X \<noteq> {} \<Longrightarrow>
	+ esat (Exists n \<phi>) I \<sigma> X \<longleftrightarrow> esat \<phi> I \<sigma> X"
	+proof (rule iffI)
	+ assume assms: "n \<notin> fv_fo_fmla \<phi>" "esat (Exists n \<phi>) I \<sigma> X"
	+ then obtain x where "esat \<phi> I (\<sigma>(n := x)) X"
	+ by auto
	+ with assms(1) show "esat \<phi> I \<sigma> X"
	+ using esat_fv_cong[of \<phi> \<sigma> "\<sigma>(n := x)"] by fastforce
	+next
	+ assume assms: "n \<notin> fv_fo_fmla \<phi>" "X \<noteq> {}" "esat \<phi> I \<sigma> X"
	+ from assms(2) obtain x where x_def: "x \<in> X"
	+ by auto
	+ with assms(1,3) have "esat \<phi> I (\<sigma>(n := x)) X"
	+ using esat_fv_cong[of \<phi> \<sigma> "\<sigma>(n := x)"] by fastforce
	+ with x_def show "esat (Exists n \<phi>) I \<sigma> X"
	+ by auto
	+qed
	+
	+lemma esat_forall_not_fv: "n \<notin> fv_fo_fmla \<phi> \<Longrightarrow> X \<noteq> {} \<Longrightarrow>
	+ esat (Forall n \<phi>) I \<sigma> X \<longleftrightarrow> esat \<phi> I \<sigma> X"
	+ using esat_exists_not_fv[of n "Neg \<phi>" X I \<sigma>]
	+ by auto
	+
	+lemma proj_sat_vals: "proj_sat \<phi> I =
	+ proj_vals {\<sigma>. sat \<phi> I \<sigma>} (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: proj_sat_def proj_vals_def)
	+
	+lemma fv_fo_fmla_list_Pred: "remdups_adj (sort (fv_fo_terms_list ts)) = fv_fo_terms_list ts"
	+ unfolding fv_fo_terms_list_def
	+ by (simp add: distinct_remdups_adj_sort remdups_adj_distinct sorted_sort_id)
	+
	+lemma ad_agr_list_fv_list': "\<Union>(set (map set_fo_term ts)) \<subseteq> X \<Longrightarrow>
	+ ad_agr_list X (map \<sigma> (fv_fo_terms_list ts)) (map \<tau> (fv_fo_terms_list ts)) \<Longrightarrow>
	+ ad_agr_list X (\<sigma> \<odot>e ts) (\<tau> \<odot>e ts)"
	+proof (induction ts)
	+ case (Cons t ts)
	+ have IH: "ad_agr_list X (\<sigma> \<odot>e ts) (\<tau> \<odot>e ts)"
	+ using Cons
	+ by (auto simp: ad_agr_list_def ad_equiv_list_link[symmetric] fv_fo_terms_set_list
	+ fv_fo_terms_set_def sp_equiv_list_link sp_equiv_def pairwise_def) blast+
	+ have ad_equiv: "\<And>i. i \<in> fv_fo_term_set t \<union> \<Union>(fv_fo_term_set ` set ts) \<Longrightarrow>
	+ ad_equiv_pair X (\<sigma> i, \<tau> i)"
	+ using Cons(3)
	+ by (auto simp: ad_agr_list_def ad_equiv_list_link[symmetric] fv_fo_terms_set_list
	+ fv_fo_terms_set_def)
	+ have sp_equiv: "\<And>i j. i \<in> fv_fo_term_set t \<union> \<Union>(fv_fo_term_set ` set ts) \<Longrightarrow>
	+ j \<in> fv_fo_term_set t \<union> \<Union>(fv_fo_term_set ` set ts) \<Longrightarrow> sp_equiv_pair (\<sigma> i, \<tau> i) (\<sigma> j, \<tau> j)"
	+ using Cons(3)
	+ by (auto simp: ad_agr_list_def sp_equiv_list_link fv_fo_terms_set_list
	+ fv_fo_terms_set_def sp_equiv_def pairwise_def)
	+ show ?case
	+ proof (cases t)
	+ case (Const c)
	+ show ?thesis
	+ using IH Cons(2)
	+ apply (auto simp: ad_agr_list_def eval_eterms_def ad_equiv_list_def Const
	+ sp_equiv_list_def pairwise_def set_zip)
	+ unfolding ad_equiv_pair.simps
	+ apply (metis nth_map rev_image_eqI)+
	+ done
	+ next
	+ case (Var n)
	+ note t_def = Var
	+ have ad: "ad_equiv_pair X (\<sigma> n, \<tau> n)"
	+ using ad_equiv
	+ by (auto simp: Var)
	+ have "\<And>y. y \<in> set (zip (map ((\<cdot>e) \<sigma>) ts) (map ((\<cdot>e) \<tau>) ts)) \<Longrightarrow> y \<noteq> (\<sigma> n, \<tau> n) \<Longrightarrow>
	+ sp_equiv_pair (\<sigma> n, \<tau> n) y \<and> sp_equiv_pair y (\<sigma> n, \<tau> n)"
	+ proof -
	+ fix y
	+ assume "y \<in> set (zip (map ((\<cdot>e) \<sigma>) ts) (map ((\<cdot>e) \<tau>) ts))"
	+ then obtain t' where y_def: "t' \<in> set ts" "y = (\<sigma> \<cdot>e t', \<tau> \<cdot>e t')"
	+ using nth_mem
	+ by (auto simp: set_zip) blast
	+ show "sp_equiv_pair (\<sigma> n, \<tau> n) y \<and> sp_equiv_pair y (\<sigma> n, \<tau> n)"
	+ proof (cases t')
	+ case (Const c')
	+ have c'_X: "c' \<in> X"
	+ using Cons(2) y_def(1)
	+ by (auto simp: Const) (meson SUP_le_iff fo_term.set_intros subsetD)
	+ then show ?thesis
	+ using ad_equiv[of n] y_def(1)
	+ unfolding y_def
	+ apply (auto simp: Const t_def)
	+ unfolding ad_equiv_pair.simps
	+ apply fastforce+
	+ apply force
	+ apply (metis rev_image_eqI)
	+ done
	+ next
	+ case (Var n')
	+ show ?thesis
	+ using sp_equiv[of n n'] y_def(1)
	+ unfolding y_def
	+ by (fastforce simp: t_def Var)
	+ qed
	+ qed
	+ then show ?thesis
	+ using IH Cons(3)
	+ by (auto simp: ad_agr_list_def eval_eterms_def ad_equiv_list_def Var ad sp_equiv_list_def
	+ pairwise_insert)
	+ qed
	+qed (auto simp: eval_eterms_def ad_agr_list_def ad_equiv_list_def sp_equiv_list_def)
	+
	+lemma ext_tuple_ad_agr_close:
	+ assumes S\<phi>_def: "S\<phi> \<equiv> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ and AD_sub: "act_edom \<phi> I \<subseteq> AD\<phi>" "AD\<phi> \<subseteq> AD"
	+ and X\<phi>_def: "X\<phi> = fo_nmlz AD\<phi> ` proj_vals S\<phi> (fv_fo_fmla_list \<phi>)"
	+ and ns\<phi>'_def: "ns\<phi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<phi>) ns\<psi>"
	+ and sd_ns\<psi>: "sorted_distinct ns\<psi>"
	+ and fv_Un: "fv_fo_fmla \<psi> = fv_fo_fmla \<phi> \<union> set ns\<psi>"
	+ shows "ext_tuple_set AD (fv_fo_fmla_list \<phi>) ns\<phi>' (ad_agr_close_set (AD - AD\<phi>) X\<phi>) =
	+ fo_nmlz AD ` proj_vals S\<phi> (fv_fo_fmla_list \<psi>)"
	+ "ad_agr_close_set (AD - AD\<phi>) X\<phi> = fo_nmlz AD ` proj_vals S\<phi> (fv_fo_fmla_list \<phi>)"
	+proof -
	+ have ad_agr_\<phi>:
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set (fv_fo_fmla_list \<phi>)) (set (fv_fo_fmla_list \<phi>)) AD\<phi> \<sigma> \<tau> \<Longrightarrow>
	+ \<sigma> \<in> S\<phi> \<longleftrightarrow> \<tau> \<in> S\<phi>"
	+ using esat_UNIV_cong[OF ad_agr_sets_restrict, OF _ subset_refl] ad_agr_sets_mono AD_sub
	+ unfolding S\<phi>_def
	+ by blast
	+ show ad_close_alt: "ad_agr_close_set (AD - AD\<phi>) X\<phi> = fo_nmlz AD ` proj_vals S\<phi> (fv_fo_fmla_list \<phi>)"
	+ using ad_agr_close_correct[OF AD_sub(2) ad_agr_\<phi>] AD_sub(2)
	+ unfolding X\<phi>_def S\<phi>_def[symmetric] proj_fmla_def
	+ by (auto simp: ad_agr_close_set_def Set.is_empty_def)
	+ have fv_\<phi>: "set (fv_fo_fmla_list \<phi>) \<subseteq> set (fv_fo_fmla_list \<psi>)"
	+ using fv_Un
	+ by (auto simp: fv_fo_fmla_list_set)
	+ have sd_ns\<phi>': "sorted_distinct ns\<phi>'"
	+ using sd_ns\<psi> sorted_filter[of id]
	+ by (auto simp: ns\<phi>'_def)
	+ show "ext_tuple_set AD (fv_fo_fmla_list \<phi>) ns\<phi>' (ad_agr_close_set (AD - AD\<phi>) X\<phi>) =
	+ fo_nmlz AD ` proj_vals S\<phi> (fv_fo_fmla_list \<psi>)"
	+ apply (rule ext_tuple_correct)
	+ using sorted_distinct_fv_list ad_close_alt ad_agr_\<phi> ad_agr_sets_mono[OF AD_sub(2)]
	+ fv_Un sd_ns\<phi>'
	+ by (fastforce simp: ns\<phi>'_def fv_fo_fmla_list_set)+
	+qed
	+
	+lemma proj_ext_tuple:
	+ assumes S\<phi>_def: "S\<phi> \<equiv> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ and AD_sub: "act_edom \<phi> I \<subseteq> AD"
	+ and X\<phi>_def: "X\<phi> = fo_nmlz AD ` proj_vals S\<phi> (fv_fo_fmla_list \<phi>)"
	+ and ns\<phi>'_def: "ns\<phi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<phi>) ns\<psi>"
	+ and sd_ns\<psi>: "sorted_distinct ns\<psi>"
	+ and fv_Un: "fv_fo_fmla \<psi> = fv_fo_fmla \<phi> \<union> set ns\<psi>"
	+ and Z_props: "\<And>xs. xs \<in> Z \<Longrightarrow> fo_nmlz AD xs = xs \<and> length xs = length (fv_fo_fmla_list \<psi>)"
	+ shows "Z \<inter> ext_tuple_set AD (fv_fo_fmla_list \<phi>) ns\<phi>' X\<phi> =
	+ {xs \<in> Z. fo_nmlz AD (proj_tuple (fv_fo_fmla_list \<phi>) (zip (fv_fo_fmla_list \<psi>) xs)) \<in> X\<phi>}"
	+ "Z - ext_tuple_set AD (fv_fo_fmla_list \<phi>) ns\<phi>' X\<phi> =
	+ {xs \<in> Z. fo_nmlz AD (proj_tuple (fv_fo_fmla_list \<phi>) (zip (fv_fo_fmla_list \<psi>) xs)) \<notin> X\<phi>}"
	+proof -
	+ have ad_agr_\<phi>:
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set (fv_fo_fmla_list \<phi>)) (set (fv_fo_fmla_list \<phi>)) AD \<sigma> \<tau> \<Longrightarrow>
	+ \<sigma> \<in> S\<phi> \<longleftrightarrow> \<tau> \<in> S\<phi>"
	+ using esat_UNIV_cong[OF ad_agr_sets_restrict, OF _ subset_refl] ad_agr_sets_mono AD_sub
	+ unfolding S\<phi>_def
	+ by blast
	+ have sd_ns\<phi>': "sorted_distinct ns\<phi>'"
	+ using sd_ns\<psi> sorted_filter[of id]
	+ by (auto simp: ns\<phi>'_def)
	+ have disj: "set (fv_fo_fmla_list \<phi>) \<inter> set ns\<phi>' = {}"
	+ by (auto simp: ns\<phi>'_def fv_fo_fmla_list_set)
	+ have Un: "set (fv_fo_fmla_list \<phi>) \<union> set ns\<phi>' = set (fv_fo_fmla_list \<psi>)"
	+ using fv_Un
	+ by (auto simp: ns\<phi>'_def fv_fo_fmla_list_set)
	+ note proj = proj_tuple_correct[OF sorted_distinct_fv_list sd_ns\<phi>' sorted_distinct_fv_list
	+ disj Un X\<phi>_def ad_agr_\<phi>, simplified]
	+ have "fo_nmlz AD ` X\<phi> = X\<phi>"
	+ using fo_nmlz_idem[OF fo_nmlz_sound]
	+ by (auto simp: X\<phi>_def image_iff)
	+ then have aux: "ext_tuple_set AD (fv_fo_fmla_list \<phi>) ns\<phi>' X\<phi> = fo_nmlz AD ` \<Union>(ext_tuple AD (fv_fo_fmla_list \<phi>) ns\<phi>' ` X\<phi>)"
	+ by (auto simp: ext_tuple_set_def ext_tuple_def)
	+ show "Z \<inter> ext_tuple_set AD (fv_fo_fmla_list \<phi>) ns\<phi>' X\<phi> =
	+ {xs \<in> Z. fo_nmlz AD (proj_tuple (fv_fo_fmla_list \<phi>) (zip (fv_fo_fmla_list \<psi>) xs)) \<in> X\<phi>}"
	+ using Z_props proj
	+ by (auto simp: aux)
	+ show "Z - ext_tuple_set AD (fv_fo_fmla_list \<phi>) ns\<phi>' X\<phi> =
	+ {xs \<in> Z. fo_nmlz AD (proj_tuple (fv_fo_fmla_list \<phi>) (zip (fv_fo_fmla_list \<psi>) xs)) \<notin> X\<phi>}"
	+ using Z_props proj
	+ by (auto simp: aux)
	+qed
	+
	+lemma fo_nmlz_proj_sub: "fo_nmlz AD ` proj_fmla \<phi> R \<subseteq> nall_tuples AD (nfv \<phi>)"
	+ by (auto simp: proj_fmla_map fo_nmlz_length fo_nmlz_sound nfv_def
	+ intro: nall_tuplesI)
	+
	+lemma fin_ad_agr_list_iff:
	+ fixes AD :: "('a :: infinite) set"
	+ assumes "finite AD" "\<And>vs. vs \<in> Z \<Longrightarrow> length vs = n"
	+ "Z = {ts. \<exists>ts' \<in> X. ad_agr_list AD (map Inl ts) ts'}"
	+ shows "finite Z \<longleftrightarrow> \<Union>(set ` Z) \<subseteq> AD"
	+proof (rule iffI, rule ccontr)
	+ assume fin: "finite Z"
	+ assume "\<not>\<Union>(set ` Z) \<subseteq> AD"
	+ then obtain \<sigma> i vs where \<sigma>_def: "map \<sigma> [0..<n] \<in> Z" "i < n" "\<sigma> i \<notin> AD" "vs \<in> X"
	+ "ad_agr_list AD (map (Inl \<circ> \<sigma>) [0..<n]) vs"
	+ using assms(2)
	+ by (auto simp: assms(3) in_set_conv_nth) (metis map_map map_nth)
	+ define Y where "Y \<equiv> AD \<union> \<sigma> ` {0..<n}"
	+ have inf_UNIV_Y: "infinite (UNIV - Y)"
	+ using assms(1)
	+ by (auto simp: Y_def infinite_UNIV)
	+ have "\<And>y. y \<notin> Y \<Longrightarrow> map ((\<lambda>z. if z = \<sigma> i then y else z) \<circ> \<sigma>) [0..<n] \<in> Z"
	+ using \<sigma>_def(3)
	+ by (auto simp: assms(3) intro!: bexI[OF _ \<sigma>_def(4)] ad_agr_list_trans[OF _ \<sigma>_def(5)])
	+ (auto simp: ad_agr_list_def ad_equiv_list_def set_zip Y_def ad_equiv_pair.simps
	+ sp_equiv_list_def pairwise_def split: if_splits)
	+ then have "(\<lambda>x'. map ((\<lambda>z. if z = \<sigma> i then x' else z) \<circ> \<sigma>) [0..<n]) `
	+ (UNIV - Y) \<subseteq> Z"
	+ by auto
	+ moreover have "inj (\<lambda>x'. map ((\<lambda>z. if z = \<sigma> i then x' else z) \<circ> \<sigma>) [0..<n])"
	+ using \<sigma>_def(2)
	+ by (auto simp: inj_def)
	+ ultimately show "False"
	+ using inf_UNIV_Y fin
	+ by (meson inj_on_diff inj_on_finite)
	+next
	+ assume "\<Union>(set ` Z) \<subseteq> AD"
	+ then have "Z \<subseteq> all_tuples AD n"
	+ using assms(2)
	+ by (auto intro: all_tuplesI)
	+ then show "finite Z"
	+ using all_tuples_finite[OF assms(1)] finite_subset
	+ by auto
	+qed
	+
	+lemma proj_out_list:
	+ fixes AD :: "('a :: infinite) set"
	+ and \<sigma> :: "nat \<Rightarrow> 'a + nat"
	+ and ns :: "nat list"
	+ assumes "finite AD"
	+ shows "\<exists>\<tau>. ad_agr_list AD (map \<sigma> ns) (map (Inl \<circ> \<tau>) ns) \<and>
	+ (\<forall>j x. j \<in> set ns \<longrightarrow> \<sigma> j = Inl x \<longrightarrow> \<tau> j = x)"
	+proof -
	+ have fin: "finite (AD \<union> Inl -` set (map \<sigma> ns))"
	+ using assms(1) finite_Inl[OF finite_set]
	+ by blast
	+ obtain f where f_def: "inj (f :: nat \<Rightarrow> 'a)"
	+ "range f \<subseteq> UNIV - (AD \<union> Inl -` set (map \<sigma> ns))"
	+ using arb_countable_map[OF fin]
	+ by auto
	+ define \<tau> where "\<tau> = case_sum id f \<circ> \<sigma>"
	+ have f_out: "\<And>i x. i < length ns \<Longrightarrow> \<sigma> (ns ! i) = Inl (f x) \<Longrightarrow> False"
	+ using f_def(2)
	+ by (auto simp: vimage_def)
	+ (metis (no_types, lifting) DiffE UNIV_I UnCI imageI image_subset_iff mem_Collect_eq nth_mem)
	+ have "(a, b) \<in> set (zip (map \<sigma> ns) (map (Inl \<circ> \<tau>) ns)) \<Longrightarrow> ad_equiv_pair AD (a, b)" for a b
	+ using f_def(2)
	+ by (auto simp: set_zip \<tau>_def ad_equiv_pair.simps split: sum.splits)+
	+ moreover have "sp_equiv_list (map \<sigma> ns) (map (Inl \<circ> \<tau>) ns)"
	+ using f_def(1) f_out
	+ by (auto simp: sp_equiv_list_def pairwise_def set_zip \<tau>_def inj_def split: sum.splits)+
	+ ultimately have "ad_agr_list AD (map \<sigma> ns) (map (Inl \<circ> \<tau>) ns)"
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def)
	+ then show ?thesis
	+ by (auto simp: \<tau>_def intro!: exI[of _ \<tau>])
	+qed
	+
	+lemma proj_out:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ and J :: "(('a, nat) fo_t, 'b) fo_intp"
	+ assumes "wf_fo_intp \<phi> I" "esat \<phi> I \<sigma> UNIV"
	+ shows "\<exists>\<tau>. esat \<phi> I (Inl \<circ> \<tau>) UNIV \<and> (\<forall>i x. i \<in> fv_fo_fmla \<phi> \<and> \<sigma> i = Inl x \<longrightarrow> \<tau> i = x) \<and>
	+ ad_agr_list (act_edom \<phi> I) (map \<sigma> (fv_fo_fmla_list \<phi>)) (map (Inl \<circ> \<tau>) (fv_fo_fmla_list \<phi>))"
	+ using proj_out_list[OF finite_act_edom[OF assms(1)], of \<sigma> "fv_fo_fmla_list \<phi>"]
	+ esat_UNIV_ad_agr_list[OF _ subset_refl] assms(2)
	+ unfolding fv_fo_fmla_list_set
	+ by fastforce
	+
	+lemma proj_fmla_esat_sat:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ and J :: "(('a, nat) fo_t, 'b) fo_intp"
	+ assumes wf: "wf_fo_intp \<phi> I"
	+ shows "proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV} \<inter> map Inl ` UNIV =
	+ map Inl ` proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ unfolding sat_esat_conv[OF wf]
	+proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV} \<inter> map Inl ` UNIV"
	+ then obtain \<sigma> where \<sigma>_def: "vs = map \<sigma> (fv_fo_fmla_list \<phi>)" "esat \<phi> I \<sigma> UNIV"
	+ "set vs \<subseteq> range Inl"
	+ by (auto simp: proj_fmla_map) (metis image_subset_iff list.set_map range_eqI)
	+ obtain \<tau> where \<tau>_def: "esat \<phi> I (Inl \<circ> \<tau>) UNIV"
	+ "\<And>i x. i \<in> fv_fo_fmla \<phi> \<Longrightarrow> \<sigma> i = Inl x \<Longrightarrow> \<tau> i = x"
	+ using proj_out[OF assms \<sigma>_def(2)]
	+ by fastforce
	+ have "vs = map (Inl \<circ> \<tau>) (fv_fo_fmla_list \<phi>)"
	+ using \<sigma>_def(1,3) \<tau>_def(2)
	+ by (auto simp: fv_fo_fmla_list_set)
	+ then show "vs \<in> map Inl ` proj_fmla \<phi> {\<sigma>. esat \<phi> I (Inl \<circ> \<sigma>) UNIV}"
	+ using \<tau>_def(1)
	+ by (force simp: proj_fmla_map)
	+qed (auto simp: proj_fmla_map)
	+
	+lemma norm_proj_fmla_esat_sat:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes "wf_fo_intp \<phi> I"
	+ shows "fo_nmlz (act_edom \<phi> I) ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV} =
	+ fo_nmlz (act_edom \<phi> I) ` map Inl ` proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+proof -
	+ have "fo_nmlz (act_edom \<phi> I) (map \<sigma> (fv_fo_fmla_list \<phi>)) = fo_nmlz (act_edom \<phi> I) x"
	+ "x \<in> (\<lambda>\<tau>. map \<tau> (fv_fo_fmla_list \<phi>)) ` {\<sigma>. esat \<phi> I \<sigma> UNIV} \<inter> range (map Inl)"
	+ if "esat \<phi> I \<sigma> UNIV" "esat \<phi> I (Inl \<circ> \<tau>) UNIV" "x = map (Inl \<circ> \<tau>) (fv_fo_fmla_list \<phi>)"
	+ "ad_agr_list (act_edom \<phi> I) (map \<sigma> (fv_fo_fmla_list \<phi>)) (map (Inl \<circ> \<tau>) (fv_fo_fmla_list \<phi>))"
	+ for \<sigma> \<tau> x
	+ using that
	+ by (auto intro!: fo_nmlz_eqI) (metis map_map range_eqI)
	+ then show ?thesis
	+ unfolding proj_fmla_esat_sat[OF assms, symmetric]
	+ using proj_out[OF assms]
	+ by (fastforce simp: image_iff proj_fmla_map)
	+qed
	+
	+lemma proj_sat_fmla: "proj_sat \<phi> I = proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ by (auto simp: proj_sat_def proj_fmla_map)
	+
	+fun fo_wf :: "('a, 'b) fo_fmla \<Rightarrow> ('b \<times> nat \<Rightarrow> 'a list set) \<Rightarrow> ('a, nat) fo_t \<Rightarrow> bool" where
	+ "fo_wf \<phi> I (AD, n, X) \<longleftrightarrow> finite AD \<and> finite X \<and> n = nfv \<phi> \<and>
	+ wf_fo_intp \<phi> I \<and> AD = act_edom \<phi> I \<and> fo_rep (AD, n, X) = proj_sat \<phi> I \<and>
	+ Inl -` \<Union>(set ` X) \<subseteq> AD \<and> (\<forall>vs \<in> X. fo_nmlzd AD vs \<and> length vs = n)"
	+
	+fun fo_fin :: "('a, nat) fo_t \<Rightarrow> bool" where
	+ "fo_fin (AD, n, X) \<longleftrightarrow> (\<forall>x \<in> \<Union>(set ` X). isl x)"
	+
	+lemma fo_rep_fin:
	+ assumes "fo_wf \<phi> I (AD, n, X)" "fo_fin (AD, n, X)"
	+ shows "fo_rep (AD, n, X) = map projl ` X"
	+proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> fo_rep (AD, n, X)"
	+ then obtain xs where xs_def: "xs \<in> X" "ad_agr_list AD (map Inl vs) xs"
	+ by auto
	+ obtain zs where zs_def: "xs = map Inl zs"
	+ using xs_def(1) assms
	+ by auto (meson ex_map_conv isl_def)
	+ have "set zs \<subseteq> AD"
	+ using assms(1) xs_def(1) zs_def
	+ by (force simp: vimage_def)
	+ then have vs_zs: "vs = zs"
	+ using xs_def(2)
	+ unfolding zs_def
	+ by (fastforce simp: ad_agr_list_def ad_equiv_list_def set_zip ad_equiv_pair.simps
	+ intro!: nth_equalityI)
	+ show "vs \<in> map projl ` X"
	+ using xs_def(1) zs_def
	+ by (auto simp: image_iff comp_def vs_zs intro!: bexI[of _ "map Inl zs"])
	+next
	+ fix vs
	+ assume "vs \<in> map projl ` X"
	+ then obtain xs where xs_def: "xs \<in> X" "vs = map projl xs"
	+ by auto
	+ have xs_map_Inl: "xs = map Inl vs"
	+ using assms xs_def
	+ by (auto simp: map_idI)
	+ show "vs \<in> fo_rep (AD, n, X)"
	+ using xs_def(1)
	+ by (auto simp: xs_map_Inl intro!: bexI[of _ xs] ad_agr_list_refl)
	+qed
	+
	+definition eval_abs :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> ('a, nat) fo_t" where
	+ "eval_abs \<phi> I = (act_edom \<phi> I, nfv \<phi>, fo_nmlz (act_edom \<phi> I) ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV})"
	+
	+lemma map_projl_Inl: "map projl (map Inl xs) = xs"
	+ by (metis (mono_tags, lifting) length_map nth_equalityI nth_map sum.sel(1))
	+
	+lemma fo_rep_eval_abs:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes "wf_fo_intp \<phi> I"
	+ shows "fo_rep (eval_abs \<phi> I) = proj_sat \<phi> I"
	+proof -
	+ obtain AD n X where AD_X_def: "eval_abs \<phi> I = (AD, n, X)" "AD = act_edom \<phi> I"
	+ "n = nfv \<phi>" "X = fo_nmlz (act_edom \<phi> I) ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ by (cases "eval_abs \<phi> I") (auto simp: eval_abs_def)
	+ have AD_sub: "act_edom \<phi> I \<subseteq> AD"
	+ by (auto simp: AD_X_def)
	+ have X_def: "X = fo_nmlz AD ` map Inl ` proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ using AD_X_def norm_proj_fmla_esat_sat[OF assms]
	+ by auto
	+ have "{ts. \<exists>ts' \<in> X. ad_agr_list AD (map Inl ts) ts'} = proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> {ts. \<exists>ts' \<in> X. ad_agr_list AD (map Inl ts) ts'}"
	+ then obtain vs' where vs'_def: "vs' \<in> proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ "ad_agr_list AD (map Inl vs) (fo_nmlz AD (map Inl vs'))"
	+ using X_def
	+ by auto
	+ have "length vs = length (fv_fo_fmla_list \<phi>)"
	+ using vs'_def
	+ by (auto simp: proj_fmla_map ad_agr_list_def fo_nmlz_length)
	+ then obtain \<sigma> where \<sigma>_def: "vs = map \<sigma> (fv_fo_fmla_list \<phi>)"
	+ using exists_map[of "fv_fo_fmla_list \<phi>" vs] sorted_distinct_fv_list
	+ by fastforce
	+ obtain \<tau> where \<tau>_def: "fo_nmlz AD (map Inl vs') = map \<tau> (fv_fo_fmla_list \<phi>)"
	+ using vs'_def fo_nmlz_map
	+ by (fastforce simp: proj_fmla_map)
	+ have ad_agr: "ad_agr_list AD (map (Inl \<circ> \<sigma>) (fv_fo_fmla_list \<phi>)) (map \<tau> (fv_fo_fmla_list \<phi>))"
	+ by (metis \<sigma>_def \<tau>_def map_map vs'_def(2))
	+ obtain \<tau>' where \<tau>'_def: "map Inl vs' = map (Inl \<circ> \<tau>') (fv_fo_fmla_list \<phi>)"
	+ "sat \<phi> I \<tau>'"
	+ using vs'_def(1)
	+ by (fastforce simp: proj_fmla_map)
	+ have ad_agr': "ad_agr_list AD (map \<tau> (fv_fo_fmla_list \<phi>))
	+ (map (Inl \<circ> \<tau>') (fv_fo_fmla_list \<phi>))"
	+ by (rule ad_agr_list_comm) (metis fo_nmlz_ad_agr \<tau>'_def(1) \<tau>_def map_map map_projl_Inl)
	+ have esat: "esat \<phi> I \<tau> UNIV"
	+ using esat_UNIV_ad_agr_list[OF ad_agr' AD_sub, folded sat_esat_conv[OF assms]] \<tau>'_def(2)
	+ by auto
	+ show "vs \<in> proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ using esat_UNIV_ad_agr_list[OF ad_agr AD_sub, folded sat_esat_conv[OF assms]] esat
	+ unfolding \<sigma>_def
	+ by (auto simp: proj_fmla_map)
	+ next
	+ fix vs
	+ assume "vs \<in> proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ then have vs_X: "fo_nmlz AD (map Inl vs) \<in> X"
	+ using X_def
	+ by auto
	+ then show "vs \<in> {ts. \<exists>ts' \<in> X. ad_agr_list AD (map Inl ts) ts'}"
	+ using fo_nmlz_ad_agr
	+ by auto
	+ qed
	+ then show ?thesis
	+ by (auto simp: AD_X_def proj_sat_fmla)
	+qed
	+
	+lemma fo_wf_eval_abs:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes "wf_fo_intp \<phi> I"
	+ shows "fo_wf \<phi> I (eval_abs \<phi> I)"
	+ using fo_nmlz_set[of "act_edom \<phi> I"] finite_act_edom[OF assms(1)]
	+ finite_subset[OF fo_nmlz_proj_sub, OF nall_tuples_finite]
	+ fo_rep_eval_abs[OF assms] assms
	+ by (auto simp: eval_abs_def fo_nmlz_sound fo_nmlz_length nfv_def proj_sat_def proj_fmla_map) blast
	+
	+lemma fo_fin:
	+ fixes t :: "('a :: infinite, nat) fo_t"
	+ assumes "fo_wf \<phi> I t"
	+ shows "fo_fin t = finite (fo_rep t)"
	+proof -
	+ obtain AD n X where t_def: "t = (AD, n, X)"
	+ using assms
	+ by (cases t) auto
	+ have fin: "finite AD" "finite X"
	+ using assms
	+ by (auto simp: t_def)
	+ have len_in_X: "\<And>vs. vs \<in> X \<Longrightarrow> length vs = n"
	+ using assms
	+ by (auto simp: t_def)
	+ have Inl_X_AD: "\<And>x. Inl x \<in> \<Union>(set ` X) \<Longrightarrow> x \<in> AD"
	+ using assms
	+ by (fastforce simp: t_def)
	+ define Z where "Z = {ts. \<exists>ts' \<in> X. ad_agr_list AD (map Inl ts) ts'}"
	+ have fin_Z_iff: "finite Z = (\<Union>(set ` Z) \<subseteq> AD)"
	+ using assms fin_ad_agr_list_iff[OF fin(1) _ Z_def, of n]
	+ by (auto simp: Z_def t_def ad_agr_list_def)
	+ moreover have "(\<Union>(set ` Z) \<subseteq> AD) \<longleftrightarrow> (\<forall>x \<in> \<Union>(set ` X). isl x)"
	+ proof (rule iffI, rule ccontr)
	+ fix x
	+ assume Z_sub_AD: "\<Union>(set ` Z) \<subseteq> AD"
	+ assume "\<not>(\<forall>x \<in> \<Union>(set ` X). isl x)"
	+ then obtain vs i m where vs_def: "vs \<in> X" "i < n" "vs ! i = Inr m"
	+ using len_in_X
	+ by (auto simp: in_set_conv_nth) (metis sum.collapse(2))
	+ obtain \<sigma> where \<sigma>_def: "vs = map \<sigma> [0..<n]"
	+ using exists_map[of "[0..<n]" vs] len_in_X[OF vs_def(1)]
	+ by auto
	+ obtain \<tau> where \<tau>_def: "ad_agr_list AD vs (map Inl (map \<tau> [0..<n]))"
	+ using proj_out_list[OF fin(1), of \<sigma> "[0..<n]"]
	+ by (auto simp: \<sigma>_def)
	+ have map_\<tau>_in_Z: "map \<tau> [0..<n] \<in> Z"
	+ using vs_def(1) ad_agr_list_comm[OF \<tau>_def]
	+ by (auto simp: Z_def)
	+ moreover have "\<tau> i \<notin> AD"
	+ using \<tau>_def vs_def(2,3)
	+ apply (auto simp: ad_agr_list_def ad_equiv_list_def set_zip comp_def \<sigma>_def)
	+ unfolding ad_equiv_pair.simps
	+ by (metis (no_types, lifting) Inl_Inr_False diff_zero image_iff length_upt nth_map nth_upt
	+ plus_nat.add_0)
	+ ultimately show "False"
	+ using vs_def(2) Z_sub_AD
	+ by fastforce
	+ next
	+ assume "\<forall>x \<in> \<Union>(set ` X). isl x"
	+ then show "\<Union>(set ` Z) \<subseteq> AD"
	+ using Inl_X_AD
	+ apply (auto simp: Z_def ad_agr_list_def ad_equiv_list_def set_zip in_set_conv_nth)
	+ unfolding ad_equiv_pair.simps
	+ by (metis image_eqI isl_def nth_map nth_mem)
	+ qed
	+ ultimately show ?thesis
	+ by (auto simp: t_def Z_def[symmetric])
	+qed
	+
	+lemma eval_pred:
	+ fixes I :: "'b \<times> nat \<Rightarrow> 'a :: infinite list set"
	+ assumes "finite (I (r, length ts))"
	+ shows "fo_wf (Pred r ts) I (eval_pred ts (I (r, length ts)))"
	+proof -
	+ define \<phi> where "\<phi> = Pred r ts"
	+ have nfv_len: "nfv \<phi> = length (fv_fo_terms_list ts)"
	+ by (auto simp: \<phi>_def nfv_def fv_fo_fmla_list_def fv_fo_fmla_list_Pred)
	+ have vimage_unfold: "Inl -` (\<Union>x\<in>I (r, length ts). Inl ` set x) = \<Union>(set ` I (r, length ts))"
	+ by auto
	+ have "eval_table ts (map Inl ` I (r, length ts)) \<subseteq> nall_tuples (act_edom \<phi> I) (nfv \<phi>)"
	+ by (auto simp: \<phi>_def proj_vals_def eval_table nfv_len[unfolded \<phi>_def]
	+ fo_nmlz_length fo_nmlz_sound eval_eterms_def fv_fo_terms_set_list fv_fo_terms_set_def
	+ vimage_unfold intro!: nall_tuplesI fo_nmlzd_all_AD dest!: fv_fo_term_setD)
	+ (smt UN_I Un_iff eval_eterm.simps(2) imageE image_eqI list.set_map)
	+ then have eval: "eval_pred ts (I (r, length ts)) = eval_abs \<phi> I"
	+ by (force simp: eval_abs_def \<phi>_def proj_fmla_def eval_pred_def eval_table fv_fo_fmla_list_def
	+ fv_fo_fmla_list_Pred nall_tuples_set fo_nmlz_idem nfv_len[unfolded \<phi>_def])
	+ have fin: "wf_fo_intp (Pred r ts) I"
	+ using assms
	+ by auto
	+ show ?thesis
	+ using fo_wf_eval_abs[OF fin]
	+ by (auto simp: eval \<phi>_def)
	+qed
	+
	+lemma ad_agr_list_eval: "\<Union>(set (map set_fo_term ts)) \<subseteq> AD \<Longrightarrow> ad_agr_list AD (\<sigma> \<odot>e ts) zs \<Longrightarrow>
	+ \<exists>\<tau>. zs = \<tau> \<odot>e ts"
	+proof (induction ts arbitrary: zs)
	+ case (Cons t ts)
	+ obtain w ws where zs_split: "zs = w # ws"
	+ using Cons(3)
	+ by (cases zs) (auto simp: ad_agr_list_def eval_eterms_def)
	+ obtain \<tau> where \<tau>_def: "ws = \<tau> \<odot>e ts"
	+ using Cons
	+ by (fastforce simp: zs_split ad_agr_list_def ad_equiv_list_def sp_equiv_list_def pairwise_def
	+ eval_eterms_def)
	+ show ?case
	+ proof (cases t)
	+ case (Const c)
	+ then show ?thesis
	+ using Cons(3)[unfolded zs_split] Cons(2)
	+ unfolding Const
	+ apply (auto simp: zs_split eval_eterms_def \<tau>_def ad_agr_list_def ad_equiv_list_def)
	+ unfolding ad_equiv_pair.simps
	+ by blast
	+ next
	+ case (Var n)
	+ show ?thesis
	+ proof (cases "n \<in> fv_fo_terms_set ts")
	+ case True
	+ obtain i where i_def: "i < length ts" "ts ! i = Var n"
	+ using True
	+ by (auto simp: fv_fo_terms_set_def in_set_conv_nth dest!: fv_fo_term_setD)
	+ have "w = \<tau> n"
	+ using Cons(3)[unfolded zs_split \<tau>_def] i_def
	+ using pairwiseD[of sp_equiv_pair _ "(\<sigma> n, w)" "(\<sigma> \<cdot>e (ts ! i), \<tau> \<cdot>e (ts ! i))"]
	+ by (force simp: Var eval_eterms_def ad_agr_list_def sp_equiv_list_def set_zip)
	+ then show ?thesis
	+ by (auto simp: Var zs_split eval_eterms_def \<tau>_def)
	+ next
	+ case False
	+ then have "ws = (\<tau>(n := w)) \<odot>e ts"
	+ using eval_eterms_cong[of ts \<tau> "\<tau>(n := w)"] \<tau>_def
	+ by fastforce
	+ then show ?thesis
	+ by (auto simp: zs_split eval_eterms_def Var fun_upd_def intro: exI[of _ "\<tau>(n := w)"])
	+ qed
	+ qed
	+qed (auto simp: ad_agr_list_def eval_eterms_def)
	+
	+lemma sp_equiv_list_fv_list:
	+ assumes "sp_equiv_list (\<sigma> \<odot>e ts) (\<tau> \<odot>e ts)"
	+ shows "sp_equiv_list (map \<sigma> (fv_fo_terms_list ts)) (map \<tau> (fv_fo_terms_list ts))"
	+proof -
	+ have "sp_equiv_list (\<sigma> \<odot>e (map Var (fv_fo_terms_list ts)))
	+ (\<tau> \<odot>e (map Var (fv_fo_terms_list ts)))"
	+ unfolding eval_eterms_def
	+ by (rule sp_equiv_list_subset[OF _ assms[unfolded eval_eterms_def]])
	+ (auto simp: fv_fo_terms_set_list dest: fv_fo_terms_setD)
	+ then show ?thesis
	+ by (auto simp: eval_eterms_def comp_def)
	+qed
	+
	+lemma ad_agr_list_fv_list: "ad_agr_list X (\<sigma> \<odot>e ts) (\<tau> \<odot>e ts) \<Longrightarrow>
	+ ad_agr_list X (map \<sigma> (fv_fo_terms_list ts)) (map \<tau> (fv_fo_terms_list ts))"
	+ using sp_equiv_list_fv_list
	+ by (auto simp: eval_eterms_def ad_agr_list_def ad_equiv_list_def sp_equiv_list_def set_zip)
	+ (metis (no_types, opaque_lifting) eval_eterm.simps(2) fv_fo_terms_setD fv_fo_terms_set_list
	+ in_set_conv_nth nth_map)
	+
	+lemma eval_bool: "fo_wf (Bool b) I (eval_bool b)"
	+ by (auto simp: eval_bool_def fo_nmlzd_def nats_def Let_def List.map_filter_simps
	+ proj_sat_def fv_fo_fmla_list_def ad_agr_list_def ad_equiv_list_def sp_equiv_list_def nfv_def)
	+
	+lemma eval_eq: fixes I :: "'b \<times> nat \<Rightarrow> 'a :: infinite list set"
	+ shows "fo_wf (Eqa t t') I (eval_eq t t')"
	+proof -
	+ define \<phi> :: "('a, 'b) fo_fmla" where "\<phi> = Eqa t t'"
	+ obtain AD n X where AD_X_def: "eval_eq t t' = (AD, n, X)"
	+ by (cases "eval_eq t t'") auto
	+ have AD_def: "AD = act_edom \<phi> I"
	+ using AD_X_def
	+ by (auto simp: eval_eq_def \<phi>_def split: fo_term.splits if_splits)
	+ have n_def: "n = nfv \<phi>"
	+ using AD_X_def
	+ by (cases t; cases t')
	+ (auto simp: \<phi>_def fv_fo_fmla_list_def eval_eq_def nfv_def split: if_splits)
	+ have fo_nmlz_empty_x_x: "fo_nmlz {} [x, x] = [Inr 0, Inr 0]" for x :: "'a + nat"
	+ by (cases x) (auto simp: fo_nmlz_def)
	+ have Inr_0_in_fo_nmlz_empty: "[Inr 0, Inr 0] \<in> fo_nmlz {} ` (\<lambda>x. [x n', x n']) ` {\<sigma> :: nat \<Rightarrow> 'a + nat. \<sigma> n = \<sigma> n'}" for n n'
	+ by (auto simp: image_def fo_nmlz_empty_x_x intro!: exI[of _ "[Inr 0, Inr 0]"])
	+ have X_def: "X = fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume assm: "vs \<in> X"
	+ define pes where "pes = proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ have "\<And>c c'. t = Const c \<and> t' = Const c' \<Longrightarrow>
	+ fo_nmlz AD ` pes = (if c = c' then {[]} else {})"
	+ by (auto simp: \<phi>_def pes_def proj_fmla_map fo_nmlz_def fv_fo_fmla_list_def)
	+ moreover have "\<And>c n. (t = Const c \<and> t' = Var n) \<or> (t' = Const c \<and> t = Var n) \<Longrightarrow>
	+ fo_nmlz AD ` pes = {[Inl c]}"
	+ by (auto simp: \<phi>_def AD_def pes_def proj_fmla_map fo_nmlz_Cons fv_fo_fmla_list_def image_def
	+ split: sum.splits) (auto simp: fo_nmlz_def)
	+ moreover have "\<And>n. t = Var n \<Longrightarrow> t' = Var n \<Longrightarrow> fo_nmlz AD ` pes = {[Inr 0]}"
	+ by (auto simp: \<phi>_def AD_def pes_def proj_fmla_map fo_nmlz_Cons fv_fo_fmla_list_def image_def
	+ split: sum.splits)
	+ moreover have "\<And>n n'. t = Var n \<Longrightarrow> t' = Var n' \<Longrightarrow> n \<noteq> n' \<Longrightarrow>
	+ fo_nmlz AD ` pes = {[Inr 0, Inr 0]}"
	+ using Inr_0_in_fo_nmlz_empty
	+ by (auto simp: \<phi>_def AD_def pes_def proj_fmla_map fo_nmlz_Cons fv_fo_fmla_list_def fo_nmlz_empty_x_x
	+ split: sum.splits)
	+ ultimately show "vs \<in> fo_nmlz AD ` pes"
	+ using assm AD_X_def
	+ by (cases t; cases t') (auto simp: eval_eq_def split: if_splits)
	+ next
	+ fix vs
	+ assume assm: "vs \<in> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ obtain \<sigma> where \<sigma>_def: "vs = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list \<phi>))"
	+ "esat (Eqa t t') I \<sigma> UNIV"
	+ using assm
	+ by (auto simp: \<phi>_def fv_fo_fmla_list_def proj_fmla_map)
	+ show "vs \<in> X"
	+ using \<sigma>_def AD_X_def
	+ by (cases t; cases t')
	+ (auto simp: \<phi>_def eval_eq_def fv_fo_fmla_list_def fo_nmlz_Cons fo_nmlz_Cons_Cons
	+ split: sum.splits)
	+ qed
	+ have eval: "eval_eq t t' = eval_abs \<phi> I"
	+ using X_def[unfolded AD_def]
	+ by (auto simp: eval_abs_def AD_X_def AD_def n_def)
	+ have fin: "wf_fo_intp \<phi> I"
	+ by (auto simp: \<phi>_def)
	+ show ?thesis
	+ using fo_wf_eval_abs[OF fin]
	+ by (auto simp: eval \<phi>_def)
	+qed
	+
	+lemma fv_fo_terms_list_Var: "fv_fo_terms_list_rec (map Var ns) = ns"
	+ by (induction ns) auto
	+
	+lemma eval_eterms_map_Var: "\<sigma> \<odot>e map Var ns = map \<sigma> ns"
	+ by (auto simp: eval_eterms_def)
	+
	+lemma fo_wf_eval_table:
	+ fixes AD :: "'a set"
	+ assumes "fo_wf \<phi> I (AD, n, X)"
	+ shows "X = fo_nmlz AD ` eval_table (map Var [0..<n]) X"
	+proof -
	+ have AD_sup: "Inl -` \<Union>(set ` X) \<subseteq> AD"
	+ using assms
	+ by fastforce
	+ have fvs: "fv_fo_terms_list (map Var [0..<n]) = [0..<n]"
	+ by (auto simp: fv_fo_terms_list_def fv_fo_terms_list_Var remdups_adj_distinct)
	+ have "\<And>vs. vs \<in> X \<Longrightarrow> length vs = n"
	+ using assms
	+ by auto
	+ then have X_map: "\<And>vs. vs \<in> X \<Longrightarrow> \<exists>\<sigma>. vs = map \<sigma> [0..<n]"
	+ using exists_map[of "[0..<n]"]
	+ by auto
	+ then have proj_vals_X: "proj_vals {\<sigma>. \<sigma> \<odot>e map Var [0..<n] \<in> X} [0..<n] = X"
	+ by (auto simp: eval_eterms_map_Var proj_vals_def)
	+ then show "X = fo_nmlz AD ` eval_table (map Var [0..<n]) X"
	+ unfolding eval_table fvs proj_vals_X
	+ using assms fo_nmlz_idem image_iff
	+ by fastforce
	+qed
	+
	+lemma fo_rep_norm:
	+ fixes AD :: "('a :: infinite) set"
	+ assumes "fo_wf \<phi> I (AD, n, X)"
	+ shows "X = fo_nmlz AD ` map Inl ` fo_rep (AD, n, X)"
	+proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume vs_in: "vs \<in> X"
	+ have fin_AD: "finite AD"
	+ using assms(1)
	+ by auto
	+ have len_vs: "length vs = n"
	+ using vs_in assms(1)
	+ by auto
	+ obtain \<tau> where \<tau>_def: "ad_agr_list AD vs (map Inl (map \<tau> [0..<n]))"
	+ using proj_out_list[OF fin_AD, of "(!) vs" "[0..<length vs]", unfolded map_nth]
	+ by (auto simp: len_vs)
	+ have map_\<tau>_in: "map \<tau> [0..<n] \<in> fo_rep (AD, n, X)"
	+ using vs_in ad_agr_list_comm[OF \<tau>_def]
	+ by auto
	+ have "vs = fo_nmlz AD (map Inl (map \<tau> [0..<n]))"
	+ using fo_nmlz_eqI[OF \<tau>_def] fo_nmlz_idem vs_in assms(1)
	+ by fastforce
	+ then show "vs \<in> fo_nmlz AD ` map Inl ` fo_rep (AD, n, X)"
	+ using map_\<tau>_in
	+ by blast
	+next
	+ fix vs
	+ assume "vs \<in> fo_nmlz AD ` map Inl ` fo_rep (AD, n, X)"
	+ then obtain xs xs' where vs_def: "xs' \<in> X" "ad_agr_list AD (map Inl xs) xs'"
	+ "vs = fo_nmlz AD (map Inl xs)"
	+ by auto
	+ then have "vs = fo_nmlz AD xs'"
	+ using fo_nmlz_eqI[OF vs_def(2)]
	+ by auto
	+ then have "vs = xs'"
	+ using vs_def(1) assms(1) fo_nmlz_idem
	+ by fastforce
	+ then show "vs \<in> X"
	+ using vs_def(1)
	+ by auto
	+qed
	+
	+lemma fo_wf_X:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes wf: "fo_wf \<phi> I (AD, n, X)"
	+ shows "X = fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+proof -
	+ have fin: "wf_fo_intp \<phi> I"
	+ using wf
	+ by auto
	+ have AD_def: "AD = act_edom \<phi> I"
	+ using wf
	+ by auto
	+ have fo_wf: "fo_wf \<phi> I (AD, n, X)"
	+ using wf
	+ by auto
	+ have fo_rep: "fo_rep (AD, n, X) = proj_fmla \<phi> {\<sigma>. sat \<phi> I \<sigma>}"
	+ using wf
	+ by (auto simp: proj_sat_def proj_fmla_map)
	+ show ?thesis
	+ using fo_rep_norm[OF fo_wf] norm_proj_fmla_esat_sat[OF fin]
	+ unfolding fo_rep AD_def[symmetric]
	+ by auto
	+qed
	+
	+lemma eval_neg:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes wf: "fo_wf \<phi> I t"
	+ shows "fo_wf (Neg \<phi>) I (eval_neg (fv_fo_fmla_list \<phi>) t)"
	+proof -
	+ obtain AD n X where t_def: "t = (AD, n, X)"
	+ by (cases t) auto
	+ have eval_neg: "eval_neg (fv_fo_fmla_list \<phi>) t = (AD, nfv \<phi>, nall_tuples AD (nfv \<phi>) - X)"
	+ by (auto simp: t_def nfv_def)
	+ have fv_unfold: "fv_fo_fmla_list (Neg \<phi>) = fv_fo_fmla_list \<phi>"
	+ by (auto simp: fv_fo_fmla_list_def)
	+ then have nfv_unfold: "nfv (Neg \<phi>) = nfv \<phi>"
	+ by (auto simp: nfv_def)
	+ have AD_def: "AD = act_edom (Neg \<phi>) I"
	+ using wf
	+ by (auto simp: t_def)
	+ note X_def = fo_wf_X[OF wf[unfolded t_def]]
	+ have esat_iff: "\<And>vs. vs \<in> nall_tuples AD (nfv \<phi>) \<Longrightarrow>
	+ vs \<in> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV} \<longleftrightarrow>
	+ vs \<notin> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat (Neg \<phi>) I \<sigma> UNIV}"
	+ proof (rule iffI; rule ccontr)
	+ fix vs
	+ assume "vs \<in> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ then obtain \<sigma> where \<sigma>_def: "vs = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list \<phi>))"
	+ "esat \<phi> I \<sigma> UNIV"
	+ by (auto simp: proj_fmla_map)
	+ assume "\<not>vs \<notin> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat (Neg \<phi>) I \<sigma> UNIV}"
	+ then obtain \<sigma>' where \<sigma>'_def: "vs = fo_nmlz AD (map \<sigma>' (fv_fo_fmla_list \<phi>))"
	+ "esat (Neg \<phi>) I \<sigma>' UNIV"
	+ by (auto simp: proj_fmla_map)
	+ have "esat \<phi> I \<sigma> UNIV = esat \<phi> I \<sigma>' UNIV"
	+ using esat_UNIV_cong[OF ad_agr_sets_restrict[OF iffD2[OF ad_agr_list_link],
	+ OF fo_nmlz_eqD[OF trans[OF \<sigma>_def(1)[symmetric] \<sigma>'_def(1)]]]]
	+ by (auto simp: AD_def)
	+ then show "False"
	+ using \<sigma>_def(2) \<sigma>'_def(2) by simp
	+ next
	+ fix vs
	+ assume assms: "vs \<notin> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat (Neg \<phi>) I \<sigma> UNIV}"
	+ "vs \<notin> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ assume "vs \<in> nall_tuples AD (nfv \<phi>)"
	+ then have l_vs: "length vs = length (fv_fo_fmla_list \<phi>)" "fo_nmlzd AD vs"
	+ by (auto simp: nfv_def dest: nall_tuplesD)
	+ obtain \<sigma> where "vs = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list \<phi>))"
	+ using l_vs sorted_distinct_fv_list exists_fo_nmlzd by metis
	+ with assms show "False"
	+ by (auto simp: proj_fmla_map)
	+ qed
	+ moreover have "\<And>R. fo_nmlz AD ` proj_fmla \<phi> R \<subseteq> nall_tuples AD (nfv \<phi>)"
	+ by (auto simp: proj_fmla_map nfv_def nall_tuplesI fo_nmlz_length fo_nmlz_sound)
	+ ultimately have eval: "eval_neg (fv_fo_fmla_list \<phi>) t = eval_abs (Neg \<phi>) I"
	+ unfolding eval_neg eval_abs_def AD_def[symmetric]
	+ by (auto simp: X_def proj_fmla_def fv_unfold nfv_unfold image_subset_iff)
	+ have wf_neg: "wf_fo_intp (Neg \<phi>) I"
	+ using wf
	+ by (auto simp: t_def)
	+ show ?thesis
	+ using fo_wf_eval_abs[OF wf_neg]
	+ by (auto simp: eval)
	+qed
	+
	+definition "cross_with f t t' = \<Union>((\<lambda>xs. \<Union>(f xs ` t')) ` t)"
	+
	+lemma mapping_join_cross_with:
	+ assumes "\<And>x x'. x \<in> t \<Longrightarrow> x' \<in> t' \<Longrightarrow> h x \<noteq> h' x' \<Longrightarrow> f x x' = {}"
	+ shows "set_of_idx (mapping_join (cross_with f) (cluster (Some \<circ> h) t) (cluster (Some \<circ> h') t')) = cross_with f t t'"
	+proof -
	+ have sub: "cross_with f {y \<in> t. h y = h x} {y \<in> t'. h' y = h x} \<subseteq> cross_with f t t'" for t t' x
	+ by (auto simp: cross_with_def)
	+ have "\<exists>a. a \<in> h ` t \<and> a \<in> h' ` t' \<and> z \<in> cross_with f {y \<in> t. h y = a} {y \<in> t'. h' y = a}" if z: "z \<in> cross_with f t t'" for z
	+ proof -
	+ obtain xs ys where wit: "xs \<in> t" "ys \<in> t'" "z \<in> f xs ys"
	+ using z
	+ by (auto simp: cross_with_def)
	+ have h: "h xs = h' ys"
	+ using assms(1)[OF wit(1-2)] wit(3)
	+ by auto
	+ have hys: "h' ys \<in> h ` t"
	+ using wit(1)
	+ by (auto simp: h[symmetric])
	+ show ?thesis
	+ apply (rule exI[of _ "h xs"])
	+ using wit hys h
	+ by (auto simp: cross_with_def)
	+ qed
	+ then show ?thesis
	+ using sub
	+ apply (transfer fixing: f h h')
	+ apply (auto simp: ran_def)
	+ apply fastforce+
	+ done
	+qed
	+
	+lemma fo_nmlzd_mono_sub: "X \<subseteq> X' \<Longrightarrow> fo_nmlzd X xs \<Longrightarrow> fo_nmlzd X' xs"
	+ by (meson fo_nmlzd_def order_trans)
	+
	+lemma idx_join:
	+ assumes X\<phi>_props: "\<And>vs. vs \<in> X\<phi> \<Longrightarrow> fo_nmlzd AD vs \<and> length vs = length ns\<phi>"
	+ assumes X\<psi>_props: "\<And>vs. vs \<in> X\<psi> \<Longrightarrow> fo_nmlzd AD vs \<and> length vs = length ns\<psi>"
	+ assumes sd_ns: "sorted_distinct ns\<phi>" "sorted_distinct ns\<psi>"
	+ assumes ns_def: "ns = filter (\<lambda>n. n \<in> set ns\<psi>) ns\<phi>"
	+ shows "idx_join AD ns ns\<phi> X\<phi> ns\<psi> X\<psi> = eval_conj_set AD ns\<phi> X\<phi> ns\<psi> X\<psi>"
	+proof -
	+ have ect_empty: "x \<in> X\<phi> \<Longrightarrow> x' \<in> X\<psi> \<Longrightarrow> fo_nmlz AD (proj_tuple ns (zip ns\<phi> x)) \<noteq> fo_nmlz AD (proj_tuple ns (zip ns\<psi> x')) \<Longrightarrow>
	+ eval_conj_tuple AD ns\<phi> ns\<psi> x x' = {}"
	+ if "X\<phi>' \<subseteq> X\<phi>" "X\<psi>' \<subseteq> X\<psi>" for X\<phi>' X\<psi>' and x x'
	+ apply (rule eval_conj_tuple_empty[where ?ns="filter (\<lambda>n. n \<in> set ns\<psi>) ns\<phi>"])
	+ using X\<phi>_props X\<psi>_props that sd_ns
	+ by (auto simp: ns_def ad_agr_close_set_def split: if_splits)
	+ have cross_eval_conj_tuple: "(\<lambda>X\<phi>''. eval_conj_set AD ns\<phi> X\<phi>'' ns\<psi>) = cross_with (eval_conj_tuple AD ns\<phi> ns\<psi>)" for AD :: "'a set" and ns\<phi> ns\<psi>
	+ by (rule ext)+ (auto simp: eval_conj_set_def cross_with_def)
	+ have "idx_join AD ns ns\<phi> X\<phi> ns\<psi> X\<psi> = cross_with (eval_conj_tuple AD ns\<phi> ns\<psi>) X\<phi> X\<psi>"
	+ unfolding idx_join_def Let_def cross_eval_conj_tuple
	+ by (rule mapping_join_cross_with[OF ect_empty]) auto
	+ moreover have "\<dots> = eval_conj_set AD ns\<phi> X\<phi> ns\<psi> X\<psi>"
	+ by (auto simp: cross_with_def eval_conj_set_def)
	+ finally show ?thesis .
	+qed
	+
	+lemma proj_fmla_conj_sub:
	+ assumes AD_sub: "act_edom \<psi> I \<subseteq> AD"
	+ shows "fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat \<phi> I \<sigma> UNIV} \<inter>
	+ fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat \<psi> I \<sigma> UNIV} \<subseteq>
	+ fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat (Conj \<phi> \<psi>) I \<sigma> UNIV}"
	+proof (rule subsetI)
	+ fix vs
	+ assume "vs \<in> fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat \<phi> I \<sigma> UNIV} \<inter>
	+ fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ then obtain \<sigma> \<sigma>' where \<sigma>_def:
	+ "\<sigma> \<in> {\<sigma>. esat \<phi> I \<sigma> UNIV}" "vs = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list (Conj \<phi> \<psi>)))"
	+ "\<sigma>' \<in> {\<sigma>. esat \<psi> I \<sigma> UNIV}" "vs = fo_nmlz AD (map \<sigma>' (fv_fo_fmla_list (Conj \<phi> \<psi>)))"
	+ unfolding proj_fmla_map
	+ by blast
	+ have ad_sub: "act_edom \<psi> I \<subseteq> AD"
	+ using assms(1)
	+ by auto
	+ have ad_agr: "ad_agr_list AD (map \<sigma> (fv_fo_fmla_list \<psi>)) (map \<sigma>' (fv_fo_fmla_list \<psi>))"
	+ by (rule ad_agr_list_subset[OF _ fo_nmlz_eqD[OF trans[OF \<sigma>_def(2)[symmetric] \<sigma>_def(4)]]])
	+ (auto simp: fv_fo_fmla_list_set)
	+ have "\<sigma> \<in> {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ using esat_UNIV_cong[OF ad_agr_sets_restrict[OF iffD2[OF ad_agr_list_link]],
	+ OF ad_agr ad_sub] \<sigma>_def(3)
	+ by blast
	+ then show "vs \<in> fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat (Conj \<phi> \<psi>) I \<sigma> UNIV}"
	+ using \<sigma>_def(1,2)
	+ by (auto simp: proj_fmla_map)
	+qed
	+
	+lemma eval_conj:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes wf: "fo_wf \<phi> I t\<phi>" "fo_wf \<psi> I t\<psi>"
	+ shows "fo_wf (Conj \<phi> \<psi>) I (eval_conj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>)"
	+proof -
	+ obtain AD\<phi> n\<phi> X\<phi> AD\<psi> n\<psi> X\<psi> where ts_def:
	+ "t\<phi> = (AD\<phi>, n\<phi>, X\<phi>)" "t\<psi> = (AD\<psi>, n\<psi>, X\<psi>)"
	+ "AD\<phi> = act_edom \<phi> I" "AD\<psi> = act_edom \<psi> I"
	+ using assms
	+ by (cases t\<phi>, cases t\<psi>) auto
	+ have AD_sub: "act_edom \<phi> I \<subseteq> AD\<phi>" "act_edom \<psi> I \<subseteq> AD\<psi>"
	+ by (auto simp: ts_def(3,4))
	+
	+ obtain AD n X where AD_X_def:
	+ "eval_conj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi> = (AD, n, X)"
	+ by (cases "eval_conj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>") auto
	+ have AD_def: "AD = act_edom (Conj \<phi> \<psi>) I" "act_edom (Conj \<phi> \<psi>) I \<subseteq> AD"
	+ "AD\<phi> \<subseteq> AD" "AD\<psi> \<subseteq> AD" "AD = AD\<phi> \<union> AD\<psi>"
	+ using AD_X_def
	+ by (auto simp: ts_def Let_def)
	+ have n_def: "n = nfv (Conj \<phi> \<psi>)"
	+ using AD_X_def
	+ by (auto simp: ts_def Let_def nfv_card fv_fo_fmla_list_set)
	+
	+ define S\<phi> where "S\<phi> \<equiv> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ define S\<psi> where "S\<psi> \<equiv> {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ define AD\<Delta>\<phi> where "AD\<Delta>\<phi> = AD - AD\<phi>"
	+ define AD\<Delta>\<psi> where "AD\<Delta>\<psi> = AD - AD\<psi>"
	+ define ns\<phi> where "ns\<phi> = fv_fo_fmla_list \<phi>"
	+ define ns\<psi> where "ns\<psi> = fv_fo_fmla_list \<psi>"
	+ define ns where "ns = filter (\<lambda>n. n \<in> fv_fo_fmla \<phi>) (fv_fo_fmla_list \<psi>)"
	+ define ns\<phi>' where "ns\<phi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<phi>) (fv_fo_fmla_list \<psi>)"
	+ define ns\<psi>' where "ns\<psi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<psi>) (fv_fo_fmla_list \<phi>)"
	+
	+ note X\<phi>_def = fo_wf_X[OF wf(1)[unfolded ts_def(1)], unfolded proj_fmla_def, folded S\<phi>_def]
	+ note X\<psi>_def = fo_wf_X[OF wf(2)[unfolded ts_def(2)], unfolded proj_fmla_def, folded S\<psi>_def]
	+
	+ have sd_ns: "sorted_distinct ns\<phi>" "sorted_distinct ns\<psi>"
	+ by (auto simp: ns\<phi>_def ns\<psi>_def sorted_distinct_fv_list)
	+ have ad_agr_X\<phi>: "ad_agr_close_set AD\<Delta>\<phi> X\<phi> = fo_nmlz AD ` proj_vals S\<phi> ns\<phi>"
	+ unfolding X\<phi>_def ad_agr_close_set_nmlz_eq ns\<phi>_def[symmetric] AD\<Delta>\<phi>_def
	+ apply (rule ad_agr_close_set_correct[OF AD_def(3) sd_ns(1)])
	+ using AD_sub(1) esat_UNIV_ad_agr_list
	+ by (fastforce simp: ad_agr_list_link S\<phi>_def ns\<phi>_def)
	+ have ad_agr_X\<psi>: "ad_agr_close_set AD\<Delta>\<psi> X\<psi> = fo_nmlz AD ` proj_vals S\<psi> ns\<psi>"
	+ unfolding X\<psi>_def ad_agr_close_set_nmlz_eq ns\<psi>_def[symmetric] AD\<Delta>\<psi>_def
	+ apply (rule ad_agr_close_set_correct[OF AD_def(4) sd_ns(2)])
	+ using AD_sub(2) esat_UNIV_ad_agr_list
	+ by (fastforce simp: ad_agr_list_link S\<psi>_def ns\<psi>_def)
	+
	+ have idx_join_eval_conj: "idx_join AD (filter (\<lambda>n. n \<in> set ns\<psi>) ns\<phi>) ns\<phi> (ad_agr_close_set AD\<Delta>\<phi> X\<phi>) ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> X\<psi>) =
	+ eval_conj_set AD ns\<phi> (ad_agr_close_set AD\<Delta>\<phi> X\<phi>) ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> X\<psi>)"
	+ apply (rule idx_join[OF _ _ sd_ns])
	+ unfolding ad_agr_X\<phi> ad_agr_X\<psi>
	+ by (auto simp: fo_nmlz_sound fo_nmlz_length proj_vals_def)
	+
	+ have fv_sub: "fv_fo_fmla (Conj \<phi> \<psi>) = fv_fo_fmla \<phi> \<union> set (fv_fo_fmla_list \<psi>)"
	+ "fv_fo_fmla (Conj \<phi> \<psi>) = fv_fo_fmla \<psi> \<union> set (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_set)
	+ note res_left_alt = ext_tuple_ad_agr_close[OF S\<phi>_def AD_sub(1) AD_def(3)
	+ X\<phi>_def(1)[folded S\<phi>_def] ns\<phi>'_def sorted_distinct_fv_list fv_sub(1)]
	+ note res_right_alt = ext_tuple_ad_agr_close[OF S\<psi>_def AD_sub(2) AD_def(4)
	+ X\<psi>_def(1)[folded S\<psi>_def] ns\<psi>'_def sorted_distinct_fv_list fv_sub(2)]
	+
	+ note eval_conj_set = eval_conj_set_correct[OF ns\<phi>'_def[folded fv_fo_fmla_list_set]
	+ ns\<psi>'_def[folded fv_fo_fmla_list_set] res_left_alt(2) res_right_alt(2)
	+ sorted_distinct_fv_list sorted_distinct_fv_list]
	+ have "X = fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat \<phi> I \<sigma> UNIV} \<inter>
	+ fo_nmlz AD ` proj_fmla (Conj \<phi> \<psi>) {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ using AD_X_def
	+ apply (simp add: ts_def(1,2) Let_def ts_def(3,4)[symmetric] AD_def(5)[symmetric] idx_join_eval_conj[unfolded ns\<phi>_def ns\<psi>_def AD\<Delta>\<phi>_def AD\<Delta>\<psi>_def])
	+ unfolding eval_conj_set proj_fmla_def
	+ unfolding res_left_alt(1) res_right_alt(1) S\<phi>_def S\<psi>_def
	+ by auto
	+ then have eval: "eval_conj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi> =
	+ eval_abs (Conj \<phi> \<psi>) I"
	+ using proj_fmla_conj_sub[OF AD_def(4)[unfolded ts_def(4)], of \<phi>]
	+ unfolding AD_X_def AD_def(1)[symmetric] n_def eval_abs_def
	+ by (auto simp: proj_fmla_map)
	+ have wf_conj: "wf_fo_intp (Conj \<phi> \<psi>) I"
	+ using wf
	+ by (auto simp: ts_def)
	+ show ?thesis
	+ using fo_wf_eval_abs[OF wf_conj]
	+ by (auto simp: eval)
	+qed
	+
	+lemma map_values_cluster: "(\<And>w z Z. Z \<subseteq> X \<Longrightarrow> z \<in> Z \<Longrightarrow> w \<in> f (h z) {z} \<Longrightarrow> w \<in> f (h z) Z) \<Longrightarrow>
	+ (\<And>w z Z. Z \<subseteq> X \<Longrightarrow> z \<in> Z \<Longrightarrow> w \<in> f (h z) Z \<Longrightarrow> (\<exists>z'\<in>Z. w \<in> f (h z) {z'})) \<Longrightarrow>
	+ set_of_idx (Mapping.map_values f (cluster (Some \<circ> h) X)) = \<Union>((\<lambda>x. f (h x) {x}) ` X)"
	+ apply transfer
	+ apply (auto simp: ran_def)
	+ apply (smt (verit, del_insts) mem_Collect_eq subset_eq)
	+ apply (smt (z3) imageI mem_Collect_eq subset_iff)
	+ done
	+
	+lemma fo_nmlz_twice:
	+ assumes "sorted_distinct ns" "sorted_distinct ns'" "set ns \<subseteq> set ns'"
	+ shows "fo_nmlz AD (proj_tuple ns (zip ns' (fo_nmlz AD (map \<sigma> ns')))) = fo_nmlz AD (map \<sigma> ns)"
	+proof -
	+ obtain \<sigma>' where \<sigma>': "fo_nmlz AD (map \<sigma> ns') = map \<sigma>' ns'"
	+ using exists_map[where ?ys="fo_nmlz AD (map \<sigma> ns')" and ?xs=ns'] assms
	+ by (auto simp: fo_nmlz_length)
	+ have proj: "proj_tuple ns (zip ns' (map \<sigma>' ns')) = map \<sigma>' ns"
	+ by (rule proj_tuple_map[OF assms])
	+ show ?thesis
	+ unfolding \<sigma>' proj
	+ apply (rule fo_nmlz_eqI)
	+ using \<sigma>'
	+ by (metis ad_agr_list_comm ad_agr_list_subset assms(3) fo_nmlz_ad_agr)
	+qed
	+
	+lemma map_values_cong:
	+ assumes "\<And>x y. Mapping.lookup t x = Some y \<Longrightarrow> f x y = f' x y"
	+ shows "Mapping.map_values f t = Mapping.map_values f' t"
	+proof -
	+ have "map_option (f x) (Mapping.lookup t x) = map_option (f' x) (Mapping.lookup t x)" for x
	+ using assms
	+ by (cases "Mapping.lookup t x") auto
	+ then show ?thesis
	+ by (auto simp: lookup_map_values intro!: mapping_eqI)
	+qed
	+
	+lemma ad_agr_close_set_length: "z \<in> ad_agr_close_set AD X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> length x = n) \<Longrightarrow> length z = n"
	+ by (auto simp: ad_agr_close_set_def ad_agr_close_def split: if_splits dest: ad_agr_close_rec_length)
	+
	+lemma ad_agr_close_set_sound: "z \<in> ad_agr_close_set (AD - AD') X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> fo_nmlzd AD' x) \<Longrightarrow> AD' \<subseteq> AD \<Longrightarrow> fo_nmlzd AD z"
	+ using ad_agr_close_sound[where ?X=AD' and ?Y="AD - AD'"]
	+ by (auto simp: ad_agr_close_set_def Set.is_empty_def split: if_splits) (metis Diff_partition Un_Diff_cancel)
	+
	+lemma ext_tuple_set_length: "z \<in> ext_tuple_set AD ns ns' X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> length x = length ns) \<Longrightarrow> length z = length ns + length ns'"
	+ by (auto simp: ext_tuple_set_def ext_tuple_def fo_nmlz_length merge_length dest: nall_tuples_rec_length split: if_splits)
	+
	+lemma eval_ajoin:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes wf: "fo_wf \<phi> I t\<phi>" "fo_wf \<psi> I t\<psi>"
	+ shows "fo_wf (Conj \<phi> (Neg \<psi>)) I
	+ (eval_ajoin (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>)"
	+proof -
	+ obtain AD\<phi> n\<phi> X\<phi> AD\<psi> n\<psi> X\<psi> where ts_def:
	+ "t\<phi> = (AD\<phi>, n\<phi>, X\<phi>)" "t\<psi> = (AD\<psi>, n\<psi>, X\<psi>)"
	+ "AD\<phi> = act_edom \<phi> I" "AD\<psi> = act_edom \<psi> I"
	+ using assms
	+ by (cases t\<phi>, cases t\<psi>) auto
	+ have AD_sub: "act_edom \<phi> I \<subseteq> AD\<phi>" "act_edom \<psi> I \<subseteq> AD\<psi>"
	+ by (auto simp: ts_def(3,4))
	+
	+ obtain AD n X where AD_X_def:
	+ "eval_ajoin (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi> = (AD, n, X)"
	+ by (cases "eval_ajoin (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>") auto
	+ have AD_def: "AD = act_edom (Conj \<phi> (Neg \<psi>)) I"
	+ "act_edom (Conj \<phi> (Neg \<psi>)) I \<subseteq> AD" "AD\<phi> \<subseteq> AD" "AD\<psi> \<subseteq> AD" "AD = AD\<phi> \<union> AD\<psi>"
	+ using AD_X_def
	+ by (auto simp: ts_def Let_def)
	+ have n_def: "n = nfv (Conj \<phi> (Neg \<psi>))"
	+ using AD_X_def
	+ by (auto simp: ts_def Let_def nfv_card fv_fo_fmla_list_set)
	+
	+ define S\<phi> where "S\<phi> \<equiv> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ define S\<psi> where "S\<psi> \<equiv> {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ define both where "both = remdups_adj (sort (fv_fo_fmla_list \<phi> @ fv_fo_fmla_list \<psi>))"
	+ define ns\<phi>' where "ns\<phi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<phi>) (fv_fo_fmla_list \<psi>)"
	+ define ns\<psi>' where "ns\<psi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<psi>) (fv_fo_fmla_list \<phi>)"
	+
	+ define AD\<Delta>\<phi> where "AD\<Delta>\<phi> = AD - AD\<phi>"
	+ define AD\<Delta>\<psi> where "AD\<Delta>\<psi> = AD - AD\<psi>"
	+ define ns\<phi> where "ns\<phi> = fv_fo_fmla_list \<phi>"
	+ define ns\<psi> where "ns\<psi> = fv_fo_fmla_list \<psi>"
	+ define ns where "ns = filter (\<lambda>n. n \<in> set ns\<psi>) ns\<phi>"
	+ define X\<phi>' where "X\<phi>' = ext_tuple_set AD ns\<phi> ns\<phi>' (ad_agr_close_set AD\<Delta>\<phi> X\<phi>)"
	+ define idx\<phi> where "idx\<phi> = cluster (Some \<circ> (\<lambda>xs. fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> xs)))) (ad_agr_close_set AD\<Delta>\<phi> X\<phi>)"
	+ define idx\<psi> where "idx\<psi> = cluster (Some \<circ> (\<lambda>ys. fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<psi> ys)))) X\<psi>"
	+ define res where "res = Mapping.map_values (\<lambda>xs X. case Mapping.lookup idx\<psi> xs of
	+ Some Y \<Rightarrow> eval_conj_set AD ns\<phi> X ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {xs} - Y))
	+ \| _ \<Rightarrow> ext_tuple_set AD ns\<phi> ns\<phi>' X) idx\<phi>"
	+
	+ note X\<phi>_def = fo_wf_X[OF wf(1)[unfolded ts_def(1)], unfolded proj_fmla_def, folded S\<phi>_def]
	+ note X\<psi>_def = fo_wf_X[OF wf(2)[unfolded ts_def(2)], unfolded proj_fmla_def, folded S\<psi>_def]
	+
	+ have fv_sub: "fv_fo_fmla (Conj \<phi> (Neg \<psi>)) = fv_fo_fmla \<psi> \<union> set (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_set)
	+ have fv_sort: "fv_fo_fmla_list (Conj \<phi> (Neg \<psi>)) = both"
	+ unfolding both_def
	+ apply (rule sorted_distinct_set_unique)
	+ using sorted_distinct_fv_list
	+ by (auto simp: fv_fo_fmla_list_def distinct_remdups_adj_sort)
	+
	+ have AD_disj: "AD\<phi> \<inter> AD\<Delta>\<phi> = {}" "AD\<psi> \<inter> AD\<Delta>\<psi> = {}"
	+ by (auto simp: AD\<Delta>\<phi>_def AD\<Delta>\<psi>_def)
	+ have AD_delta: "AD = AD\<phi> \<union> AD\<Delta>\<phi>" "AD = AD\<psi> \<union> AD\<Delta>\<psi>"
	+ by (auto simp: AD\<Delta>\<phi>_def AD\<Delta>\<psi>_def AD_def ts_def)
	+ have fo_nmlzd_X: "Ball X\<phi> (fo_nmlzd AD\<phi>)" "Ball X\<psi> (fo_nmlzd AD\<psi>)"
	+ using wf
	+ by (auto simp: ts_def)
	+ have Ball_ad_agr: "Ball (ad_agr_close_set AD\<Delta>\<phi> X\<phi>) (fo_nmlzd AD)"
	+ using ad_agr_close_sound[where ?X="AD\<phi>" and ?Y="AD\<Delta>\<phi>"] fo_nmlzd_X(1)
	+ by (auto simp: ad_agr_close_set_eq[OF fo_nmlzd_X(1)] AD_disj AD_delta)
	+ have ad_agr_\<phi>:
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set (fv_fo_fmla_list \<phi>)) (set (fv_fo_fmla_list \<phi>)) AD\<phi> \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> S\<phi> \<longleftrightarrow> \<tau> \<in> S\<phi>"
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set (fv_fo_fmla_list \<phi>)) (set (fv_fo_fmla_list \<phi>)) AD \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> S\<phi> \<longleftrightarrow> \<tau> \<in> S\<phi>"
	+ using esat_UNIV_cong[OF ad_agr_sets_restrict, OF _ subset_refl] ad_agr_sets_mono AD_sub(1) subset_trans[OF AD_sub(1) AD_def(3)]
	+ unfolding S\<phi>_def
	+ by blast+
	+ have ad_agr_S\<phi>: "\<tau>' \<in> S\<phi> \<Longrightarrow> ad_agr_list AD\<phi> (map \<tau>' ns\<phi>) (map \<tau>'' ns\<phi>) \<Longrightarrow> \<tau>'' \<in> S\<phi>" for \<tau>' \<tau>''
	+ using ad_agr_\<phi>
	+ by (auto simp: ad_agr_list_link ns\<phi>_def)
	+ have ad_agr_\<psi>:
	+ "\<And>\<sigma> \<tau>. ad_agr_sets (set (fv_fo_fmla_list \<psi>)) (set (fv_fo_fmla_list \<psi>)) AD\<psi> \<sigma> \<tau> \<Longrightarrow> \<sigma> \<in> S\<psi> \<longleftrightarrow> \<tau> \<in> S\<psi>"
	+ using esat_UNIV_cong[OF ad_agr_sets_restrict, OF _ subset_refl] ad_agr_sets_mono[OF AD_sub(2)]
	+ unfolding S\<psi>_def
	+ by blast+
	+ have ad_agr_S\<psi>: "\<tau>' \<in> S\<psi> \<Longrightarrow> ad_agr_list AD\<psi> (map \<tau>' ns\<psi>) (map \<tau>'' ns\<psi>) \<Longrightarrow> \<tau>'' \<in> S\<psi>" for \<tau>' \<tau>''
	+ using ad_agr_\<psi>
	+ by (auto simp: ad_agr_list_link ns\<psi>_def)
	+ have aux: "sorted_distinct ns\<phi>" "sorted_distinct ns\<phi>'" "sorted_distinct both" "set ns\<phi> \<inter> set ns\<phi>' = {}" "set ns\<phi> \<union> set ns\<phi>' = set both"
	+ by (auto simp: ns\<phi>_def ns\<phi>'_def fv_sort[symmetric] fv_fo_fmla_list_set sorted_distinct_fv_list intro: sorted_filter[where ?f=id, simplified])
	+ have aux2: "ns\<phi>' = filter (\<lambda>n. n \<notin> set ns\<phi>) ns\<phi>'" "ns\<phi> = filter (\<lambda>n. n \<notin> set ns\<phi>') ns\<phi>"
	+ by (auto simp: ns\<phi>_def ns\<phi>'_def ns\<psi>_def ns\<psi>'_def fv_fo_fmla_list_set)
	+ have aux3: "set ns\<phi>' \<inter> set ns = {}" "set ns\<phi>' \<union> set ns = set ns\<psi>"
	+ by (auto simp: ns\<phi>_def ns\<phi>'_def ns\<psi>_def ns_def fv_fo_fmla_list_set)
	+ have aux4: "set ns \<inter> set ns\<phi>' = {}" "set ns \<union> set ns\<phi>' = set ns\<psi>"
	+ by (auto simp: ns\<phi>_def ns\<phi>'_def ns\<psi>_def ns_def fv_fo_fmla_list_set)
	+ have aux5: "ns\<phi>' = filter (\<lambda>n. n \<notin> set ns\<phi>) ns\<psi>" "ns\<psi>' = filter (\<lambda>n. n \<notin> set ns\<psi>) ns\<phi>"
	+ by (auto simp: ns\<phi>_def ns\<phi>'_def ns\<psi>_def ns\<psi>'_def fv_fo_fmla_list_set)
	+ have aux6: "set ns\<psi> \<inter> set ns\<psi>' = {}" "set ns\<psi> \<union> set ns\<psi>' = set both"
	+ by (auto simp: ns\<phi>_def ns\<phi>'_def ns\<psi>_def ns\<psi>'_def both_def fv_fo_fmla_list_set)
	+ have ns_sd: "sorted_distinct ns" "sorted_distinct ns\<phi>" "sorted_distinct ns\<psi>" "set ns \<subseteq> set ns\<phi>" "set ns \<subseteq> set ns\<psi>" "set ns \<subseteq> set both" "set ns\<phi>' \<subseteq> set ns\<psi>" "set ns\<psi> \<subseteq> set both"
	+ by (auto simp: ns_def ns\<phi>_def ns\<phi>'_def ns\<psi>_def both_def sorted_distinct_fv_list intro: sorted_filter[where ?f=id, simplified])
	+ have ns_sd': "sorted_distinct ns\<psi>'"
	+ by (auto simp: ns\<psi>'_def sorted_distinct_fv_list intro: sorted_filter[where ?f=id, simplified])
	+ have ns: "ns = filter (\<lambda>n. n \<in> fv_fo_fmla \<phi>) (fv_fo_fmla_list \<psi>)"
	+ by (rule sorted_distinct_set_unique)
	+ (auto simp: ns_def ns\<phi>_def ns\<psi>_def fv_fo_fmla_list_set sorted_distinct_fv_list intro: sorted_filter[where ?f=id, simplified])
	+ have len_ns\<psi>: "length ns + length ns\<phi>' = length ns\<psi>"
	+ using sum_length_filter_compl[where ?P="\<lambda>n. n \<in> fv_fo_fmla \<phi>" and ?xs="fv_fo_fmla_list \<psi>"]
	+ by (auto simp: ns ns\<phi>_def ns\<phi>'_def ns\<psi>_def fv_fo_fmla_list_set)
	+
	+ have res_eq: "res = Mapping.map_values (\<lambda>xs X. case Mapping.lookup idx\<psi> xs of
	+ Some Y \<Rightarrow> idx_join AD ns ns\<phi> X ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {xs} - Y))
	+ \| _ \<Rightarrow> ext_tuple_set AD ns\<phi> ns\<phi>' X) idx\<phi>"
	+ proof -
	+ have ad_agr_X\<phi>: "ad_agr_close_set AD\<Delta>\<phi> X\<phi> = fo_nmlz AD ` proj_vals S\<phi> ns\<phi>"
	+ unfolding X\<phi>_def ad_agr_close_set_nmlz_eq ns\<phi>_def[symmetric]
	+ apply (rule ad_agr_close_set_correct[OF AD_def(3) aux(1), folded AD\<Delta>\<phi>_def])
	+ using ad_agr_S\<phi> ad_agr_list_comm
	+ by (fastforce simp: ad_agr_list_link)
	+ have idx_eval: "idx_join AD ns ns\<phi> y ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {x} - x2)) =
	+ eval_conj_set AD ns\<phi> y ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {x} - x2))"
	+ if lup: "Mapping.lookup idx\<phi> x = Some y" "Mapping.lookup idx\<psi> x = Some x2" for x y x2
	+ proof -
	+ have "vs \<in> y \<Longrightarrow> fo_nmlzd AD vs \<and> length vs = length ns\<phi>" for vs
	+ using lup(1)
	+ by (auto simp: idx\<phi>_def lookup_cluster' ad_agr_X\<phi> fo_nmlz_sound fo_nmlz_length proj_vals_def split: if_splits)
	+ moreover have "vs \<in> ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {x} - x2) \<Longrightarrow> fo_nmlzd AD vs" for vs
	+ apply (rule ad_agr_close_set_sound[OF _ _ AD_def(4), folded AD\<Delta>\<psi>_def, where ?X="ext_tuple_set AD\<psi> ns ns\<phi>' {x} - x2"])
	+ using lup(1)
	+ by (auto simp: idx\<phi>_def lookup_cluster' ext_tuple_set_def fo_nmlz_sound split: if_splits)
	+ moreover have "vs \<in> ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {x} - x2) \<Longrightarrow> length vs = length ns\<psi>" for vs
	+ apply (erule ad_agr_close_set_length)
	+ apply (rule ext_tuple_set_length[where ?AD=AD\<psi> and ?ns=ns and ?ns'=ns\<phi>' and ?X="{x}", unfolded len_ns\<psi>])
	+ using lup(1) ns_sd(1,2,4)
	+ by (auto simp: idx\<phi>_def lookup_cluster' fo_nmlz_length ad_agr_X\<phi> proj_vals_def intro!: proj_tuple_length split: if_splits)
	+ ultimately show ?thesis
	+ by (auto intro!: idx_join[OF _ _ ns_sd(2-3) ns_def])
	+ qed
	+ show ?thesis
	+ unfolding res_def
	+ by (rule map_values_cong) (auto simp: idx_eval split: option.splits)
	+ qed
	+
	+ have eval_conj: "eval_conj_set AD ns\<phi> {x} ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))} - Y)) =
	+ ext_tuple_set AD ns\<phi> ns\<phi>' {x} \<inter> ext_tuple_set AD ns\<psi> ns\<psi>' (fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>)"
	+ if x_ns: "proj_tuple ns (zip ns\<phi> x) = map \<sigma>' ns"
	+ and x_proj_singleton: "{x} = fo_nmlz AD ` proj_vals {\<sigma>} ns\<phi>"
	+ and Some: "Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))) = Some Y"
	+ for x Y \<sigma> \<sigma>'
	+ proof -
	+ have "Y = {ys \<in> fo_nmlz AD\<psi> ` proj_vals S\<psi> ns\<psi>. fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<psi> ys)) = fo_nmlz AD\<psi> (map \<sigma>' ns)}"
	+ using Some
	+ apply (auto simp: X\<psi>_def idx\<psi>_def ns\<psi>_def x_ns lookup_cluster' split: if_splits)
	+ done
	+ moreover have "\<dots> = fo_nmlz AD\<psi> ` proj_vals {\<sigma> \<in> S\<psi>. fo_nmlz AD\<psi> (map \<sigma> ns) = fo_nmlz AD\<psi> (map \<sigma>' ns)} ns\<psi>"
	+ by (auto simp: proj_vals_def fo_nmlz_twice[OF ns_sd(1,3,5)])+
	+ moreover have "\<dots> = fo_nmlz AD\<psi> ` proj_vals {\<sigma> \<in> S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>"
	+ by (auto simp: fo_nmlz_eq)
	+ ultimately have Y_def: "Y = fo_nmlz AD\<psi> ` proj_vals {\<sigma> \<in> S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>"
	+ by auto
	+ have R_def: "{fo_nmlz AD\<psi> (map \<sigma>' ns)} = fo_nmlz AD\<psi> ` proj_vals {\<sigma>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns"
	+ using ad_agr_list_refl
	+ by (auto simp: proj_vals_def intro: fo_nmlz_eqI)
	+ have "ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (map \<sigma>' ns)} = fo_nmlz AD\<psi> ` proj_vals {\<sigma>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>"
	+ apply (rule ext_tuple_correct[OF ns_sd(1) aux(2) ns_sd(3) aux4 R_def])
	+ using ad_agr_list_trans ad_agr_list_comm
	+ apply (auto simp: ad_agr_list_link)
	+ by fast
	+ then have "ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (map \<sigma>' ns)} - Y = fo_nmlz AD\<psi> ` proj_vals {\<sigma> \<in> -S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>"
	+ apply (auto simp: Y_def proj_vals_def fo_nmlz_eq)
	+ using ad_agr_S\<psi> ad_agr_list_comm
	+ by blast+
	+ moreover have "ad_agr_close_set AD\<Delta>\<psi> (fo_nmlz AD\<psi> ` proj_vals {\<sigma> \<in> -S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>) =
	+ fo_nmlz AD ` proj_vals {\<sigma> \<in> -S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>"
	+ unfolding ad_agr_close_set_eq[OF Ball_fo_nmlzd]
	+ apply (rule ad_agr_close_set_correct[OF AD_def(4) ns_sd(3), folded AD\<Delta>\<psi>_def])
	+ apply (auto simp: ad_agr_list_link)
	+ using ad_agr_S\<psi> ad_agr_list_comm ad_agr_list_subset[OF ns_sd(5)] ad_agr_list_trans
	+ by blast+
	+ ultimately have comp_proj: "ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (map \<sigma>' ns)} - Y) =
	+ fo_nmlz AD ` proj_vals {\<sigma> \<in> -S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>"
	+ by simp
	+ have "ext_tuple_set AD ns\<psi> ns\<psi>' (fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>) = fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} both"
	+ apply (rule ext_tuple_correct[OF ns_sd(3) ns_sd'(1) aux(3) aux6 refl])
	+ apply (auto simp: ad_agr_list_link)
	+ using ad_agr_S\<psi> ad_agr_list_comm ad_agr_list_subset[OF ns_sd(5)] ad_agr_list_trans ad_agr_list_mono[OF AD_def(4)]
	+ by fast+
	+ show "eval_conj_set AD ns\<phi> {x} ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))} - Y)) =
	+ ext_tuple_set AD ns\<phi> ns\<phi>' {x} \<inter> ext_tuple_set AD ns\<psi> ns\<psi>' (fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>)"
	+ unfolding x_ns comp_proj
	+ using eval_conj_set_correct[OF aux5 x_proj_singleton refl aux(1) ns_sd(3)]
	+ by auto
	+ qed
	+
	+ have "X = set_of_idx res"
	+ using AD_X_def
	+ unfolding eval_ajoin.simps ts_def(1,2) Let_def AD_def(5)[symmetric] fv_fo_fmla_list_set
	+ ns\<phi>'_def[symmetric] fv_sort[symmetric] proj_fmla_def S\<phi>_def[symmetric] S\<psi>_def[symmetric]
	+ AD\<Delta>\<phi>_def[symmetric] AD\<Delta>\<psi>_def[symmetric]
	+ ns\<phi>_def[symmetric] ns\<phi>'_def[symmetric, folded fv_fo_fmla_list_set[of \<phi>, folded ns\<phi>_def] ns\<psi>_def] ns\<psi>_def[symmetric] ns_def[symmetric]
	+ X\<phi>'_def[symmetric] idx\<phi>_def[symmetric] idx\<psi>_def[symmetric] res_eq[symmetric]
	+ by auto
	+ moreover have "\<dots> = (\<Union>x\<in>ad_agr_close_set AD\<Delta>\<phi> X\<phi>.
	+ case Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))) of None \<Rightarrow> ext_tuple_set AD ns\<phi> ns\<phi>' {x}
	+ \| Some Y \<Rightarrow> eval_conj_set AD ns\<phi> {x} ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))} - Y)))"
	+ unfolding res_def[unfolded idx\<phi>_def]
	+ apply (rule map_values_cluster)
	+ apply (auto simp: eval_conj_set_def split: option.splits)
	+ apply (auto simp: ext_tuple_set_def split: if_splits)
	+ done
	+ moreover have "\<dots> = fo_nmlz AD ` proj_fmla (Conj \<phi> (Neg \<psi>)) {\<sigma>. esat \<phi> I \<sigma> UNIV} -
	+ fo_nmlz AD ` proj_fmla (Conj \<phi> (Neg \<psi>)) {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ unfolding S\<phi>_def[symmetric] S\<psi>_def[symmetric] proj_fmla_def fv_sort
	+ proof (rule set_eqI, rule iffI)
	+ fix t
	+ assume "t \<in> (\<Union>x\<in>ad_agr_close_set AD\<Delta>\<phi> X\<phi>. case Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))) of
	+ None \<Rightarrow> ext_tuple_set AD ns\<phi> ns\<phi>' {x}
	+ \| Some Y \<Rightarrow> eval_conj_set AD ns\<phi> {x} ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))} - Y)))"
	+ then obtain x where x: "x \<in> ad_agr_close_set AD\<Delta>\<phi> X\<phi>"
	+ "Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))) = None \<Longrightarrow> t \<in> ext_tuple_set AD ns\<phi> ns\<phi>' {x}"
	+ "\<And>Y. Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))) = Some Y \<Longrightarrow>
	+ t \<in> eval_conj_set AD ns\<phi> {x} ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))} - Y))"
	+ by (fastforce split: option.splits)
	+ obtain \<sigma> where val: "\<sigma> \<in> S\<phi>" "x = fo_nmlz AD (map \<sigma> ns\<phi>)"
	+ using ad_agr_close_correct[OF AD_def(3) ad_agr_\<phi>(1), folded AD\<Delta>\<phi>_def] X\<phi>_def[folded proj_fmla_def] ad_agr_close_set_eq[OF fo_nmlzd_X(1)] x(1)
	+ apply (auto simp: proj_fmla_def proj_vals_def ns\<phi>_def)
	+ apply fast
	+ done
	+ obtain \<sigma>' where \<sigma>': "x = map \<sigma>' ns\<phi>"
	+ using exists_map[where ?ys=x and ?xs=ns\<phi>] aux(1)
	+ by (auto simp: val(2) fo_nmlz_length)
	+ have x_proj_singleton: "{x} = fo_nmlz AD ` proj_vals {\<sigma>} ns\<phi>"
	+ by (auto simp: val(2) proj_vals_def)
	+ have x_ns: "proj_tuple ns (zip ns\<phi> x) = map \<sigma>' ns"
	+ unfolding \<sigma>'
	+ by (rule proj_tuple_map[OF ns_sd(1-2,4)])
	+ have ad_agr_\<sigma>_\<sigma>': "ad_agr_list AD (map \<sigma> ns\<phi>) (map \<sigma>' ns\<phi>)"
	+ using \<sigma>'
	+ by (auto simp: val(2)) (metis fo_nmlz_ad_agr)
	+ have x_proj_ad_agr: "{x} = fo_nmlz AD ` proj_vals {\<sigma>. ad_agr_list AD (map \<sigma> ns\<phi>) (map \<sigma>' ns\<phi>)} ns\<phi>"
	+ using ad_agr_\<sigma>_\<sigma>' ad_agr_list_comm ad_agr_list_trans
	+ by (auto simp: val(2) proj_vals_def fo_nmlz_eq) blast
	+ have "t \<in> fo_nmlz AD ` \<Union> (ext_tuple AD ns\<phi> ns\<phi>' ` {x}) \<Longrightarrow> fo_nmlz AD (proj_tuple ns\<phi> (zip both t)) \<in> {x}"
	+ apply (rule ext_tuple_sound(1)[OF aux x_proj_ad_agr])
	+ apply (auto simp: ad_agr_list_link)
	+ using ad_agr_list_comm ad_agr_list_trans
	+ by blast+
	+ then have x_proj: "t \<in> ext_tuple_set AD ns\<phi> ns\<phi>' {x} \<Longrightarrow> x = fo_nmlz AD (proj_tuple ns\<phi> (zip both t))"
	+ using ext_tuple_set_eq[where ?AD=AD] Ball_ad_agr x(1)
	+ by (auto simp: val(2) proj_vals_def)
	+ have x_S\<phi>: "t \<in> ext_tuple_set AD ns\<phi> ns\<phi>' {x} \<Longrightarrow> t \<in> fo_nmlz AD ` proj_vals S\<phi> both"
	+ using ext_tuple_correct[OF aux refl ad_agr_\<phi>(2)[folded ns\<phi>_def]] ext_tuple_set_mono[of "{x}" "fo_nmlz AD ` proj_vals S\<phi> ns\<phi>"] val(1)
	+ by (fastforce simp: val(2) proj_vals_def)
	+ show "t \<in> fo_nmlz AD ` proj_vals S\<phi> both - fo_nmlz AD ` proj_vals S\<psi> both"
	+ proof (cases "Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x)))")
	+ case None
	+ have "False" if t_in_S\<psi>: "t \<in> fo_nmlz AD ` proj_vals S\<psi> both"
	+ proof -
	+ obtain \<tau> where \<tau>: "\<tau> \<in> S\<psi>" "t = fo_nmlz AD (map \<tau> both)"
	+ using t_in_S\<psi>
	+ by (auto simp: proj_vals_def)
	+ obtain \<tau>' where t_\<tau>': "t = map \<tau>' both"
	+ using aux(3) exists_map[where ?ys=t and ?xs=both]
	+ by (auto simp: \<tau>(2) fo_nmlz_length)
	+ obtain \<tau>'' where \<tau>'': "fo_nmlz AD\<psi> (map \<tau> ns\<psi>) = map \<tau>'' ns\<psi>"
	+ using ns_sd exists_map[where ?ys="fo_nmlz AD\<psi> (map \<tau> ns\<psi>)" and xs=ns\<psi>]
	+ by (auto simp: fo_nmlz_length)
	+ have proj_\<tau>'': "proj_tuple ns (zip ns\<psi> (map \<tau>'' ns\<psi>)) = map \<tau>'' ns"
	+ apply (rule proj_tuple_map)
	+ using ns_sd
	+ by auto
	+ have "proj_tuple ns\<phi> (zip both t) = map \<tau>' ns\<phi>"
	+ unfolding t_\<tau>'
	+ apply (rule proj_tuple_map)
	+ using aux
	+ by auto
	+ then have x_\<tau>': "x = fo_nmlz AD (map \<tau>' ns\<phi>)"
	+ by (auto simp: x_proj[OF x(2)[OF None]])
	+ obtain \<tau>''' where \<tau>''': "x = map \<tau>''' ns\<phi>"
	+ using aux exists_map[where ?ys=x and ?xs=ns\<phi>]
	+ by (auto simp: x_\<tau>' fo_nmlz_length)
	+ have ad_\<tau>_\<tau>': "ad_agr_list AD (map \<tau> both) (map \<tau>' both)"
	+ using t_\<tau>'
	+ by (auto simp: \<tau>) (metis fo_nmlz_ad_agr)
	+ have ad_\<tau>_\<tau>'': "ad_agr_list AD\<psi> (map \<tau> ns\<psi>) (map \<tau>'' ns\<psi>)"
	+ using \<tau>''
	+ by (metis fo_nmlz_ad_agr)
	+ have ad_\<tau>'_\<tau>''': "ad_agr_list AD (map \<tau>' ns\<phi>) (map \<tau>''' ns\<phi>)"
	+ using \<tau>'''
	+ by (auto simp: x_\<tau>') (metis fo_nmlz_ad_agr)
	+ have proj_\<tau>''': "proj_tuple ns (zip ns\<phi> (map \<tau>''' ns\<phi>)) = map \<tau>''' ns"
	+ apply (rule proj_tuple_map)
	+ using aux ns_sd
	+ by auto
	+ have "fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x)) = fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<psi> (fo_nmlz AD\<psi> (map \<tau> ns\<psi>))))"
	+ unfolding \<tau>'' proj_\<tau>'' \<tau>''' proj_\<tau>'''
	+ apply (rule fo_nmlz_eqI)
	+ using ad_agr_list_trans ad_agr_list_subset ns_sd(4-6) ad_agr_list_mono[OF AD_def(4)] ad_agr_list_comm[OF ad_\<tau>'_\<tau>'''] ad_agr_list_comm[OF ad_\<tau>_\<tau>'] ad_\<tau>_\<tau>''
	+ by metis
	+ then show ?thesis
	+ using None \<tau>(1)
	+ by (auto simp: idx\<psi>_def lookup_cluster' X\<psi>_def ns\<psi>_def[symmetric] proj_vals_def split: if_splits)
	+ qed
	+ then show ?thesis
	+ using x_S\<phi>[OF x(2)[OF None]]
	+ by auto
	+ next
	+ case (Some Y)
	+ have t_in: "t \<in> ext_tuple_set AD ns\<phi> ns\<phi>' {x}" "t \<in> ext_tuple_set AD ns\<psi> ns\<psi>' (fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>)"
	+ using x(3)[OF Some] eval_conj[OF x_ns x_proj_singleton Some]
	+ by auto
	+ have "ext_tuple_set AD ns\<psi> ns\<psi>' (fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>) = fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} both"
	+ apply (rule ext_tuple_correct[OF ns_sd(3) ns_sd'(1) aux(3) aux6 refl])
	+ apply (auto simp: ad_agr_list_link)
	+ using ad_agr_S\<psi> ad_agr_list_comm ad_agr_list_subset[OF ns_sd(5)] ad_agr_list_trans ad_agr_list_mono[OF AD_def(4)]
	+ by fast+
	+ then have t_both: "t \<in> fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} both"
	+ using t_in(2)
	+ by auto
	+ {
	+ assume "t \<in> fo_nmlz AD ` proj_vals S\<psi> both"
	+ then obtain \<tau> where \<tau>: "\<tau> \<in> S\<psi>" "t = fo_nmlz AD (map \<tau> both)"
	+ by (auto simp: proj_vals_def)
	+ obtain \<tau>' where \<tau>': "\<tau>' \<notin> S\<psi>" "t = fo_nmlz AD (map \<tau>' both)"
	+ using t_both
	+ by (auto simp: proj_vals_def)
	+ have "False"
	+ using \<tau> \<tau>'
	+ apply (auto simp: fo_nmlz_eq)
	+ using ad_agr_S\<psi> ad_agr_list_comm ad_agr_list_subset[OF ns_sd(8)] ad_agr_list_mono[OF AD_def(4)]
	+ by blast
	+ }
	+ then show ?thesis
	+ using x_S\<phi>[OF t_in(1)]
	+ by auto
	+ qed
	+ next
	+ fix t
	+ assume t_in_asm: "t \<in> fo_nmlz AD ` proj_vals S\<phi> both - fo_nmlz AD ` proj_vals S\<psi> both"
	+ then obtain \<sigma> where val: "\<sigma> \<in> S\<phi>" "t = fo_nmlz AD (map \<sigma> both)"
	+ by (auto simp: proj_vals_def)
	+ define x where "x = fo_nmlz AD (map \<sigma> ns\<phi>)"
	+ obtain \<sigma>' where \<sigma>': "x = map \<sigma>' ns\<phi>"
	+ using exists_map[where ?ys=x and ?xs=ns\<phi>] aux(1)
	+ by (auto simp: x_def fo_nmlz_length)
	+ have x_proj_singleton: "{x} = fo_nmlz AD ` proj_vals {\<sigma>} ns\<phi>"
	+ by (auto simp: x_def proj_vals_def)
	+ have x_in_ad_agr_close: "x \<in> ad_agr_close_set AD\<Delta>\<phi> X\<phi>"
	+ using ad_agr_close_correct[OF AD_def(3) ad_agr_\<phi>(1), folded AD\<Delta>\<phi>_def] val(1)
	+ unfolding ad_agr_close_set_eq[OF fo_nmlzd_X(1)] x_def
	+ unfolding X\<phi>_def[folded proj_fmla_def] proj_fmla_map
	+ by (fastforce simp: x_def ns\<phi>_def)
	+ have ad_agr_\<sigma>_\<sigma>': "ad_agr_list AD (map \<sigma> ns\<phi>) (map \<sigma>' ns\<phi>)"
	+ using \<sigma>'
	+ by (auto simp: x_def) (metis fo_nmlz_ad_agr)
	+ have x_proj_ad_agr: "{x} = fo_nmlz AD ` proj_vals {\<sigma>. ad_agr_list AD (map \<sigma> ns\<phi>) (map \<sigma>' ns\<phi>)} ns\<phi>"
	+ using ad_agr_\<sigma>_\<sigma>' ad_agr_list_comm ad_agr_list_trans
	+ by (auto simp: x_def proj_vals_def fo_nmlz_eq) blast+
	+ have x_ns: "proj_tuple ns (zip ns\<phi> x) = map \<sigma>' ns"
	+ unfolding \<sigma>'
	+ by (rule proj_tuple_map[OF ns_sd(1-2,4)])
	+ have "ext_tuple_set AD ns\<phi> ns\<phi>' {x} = fo_nmlz AD ` proj_vals {\<sigma>. ad_agr_list AD (map \<sigma> ns\<phi>) (map \<sigma>' ns\<phi>)} both"
	+ apply (rule ext_tuple_correct[OF aux x_proj_ad_agr])
	+ using ad_agr_list_comm ad_agr_list_trans
	+ by (auto simp: ad_agr_list_link) blast+
	+ then have t_in_ext_x: "t \<in> ext_tuple_set AD ns\<phi> ns\<phi>' {x}"
	+ using ad_agr_\<sigma>_\<sigma>'
	+ by (auto simp: val(2) proj_vals_def)
	+ {
	+ fix Y
	+ assume Some: "Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (map \<sigma>' ns)) = Some Y"
	+ have tmp: "proj_tuple ns (zip ns\<phi> x) = map \<sigma>' ns"
	+ unfolding \<sigma>'
	+ by (rule proj_tuple_map[OF ns_sd(1) aux(1) ns_sd(4)])
	+ have unfold: "ext_tuple_set AD ns\<psi> ns\<psi>' (fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>) =
	+ fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} both"
	+ apply (rule ext_tuple_correct[OF ns_sd(3) ns_sd'(1) aux(3) aux6 refl])
	+ apply (auto simp: ad_agr_list_link)
	+ using ad_agr_S\<psi> ad_agr_list_mono[OF AD_def(4)] ad_agr_list_comm ad_agr_list_trans ad_agr_list_subset[OF ns_sd(5)]
	+ by blast+
	+ have "\<sigma> \<notin> S\<psi>"
	+ using t_in_asm
	+ by (auto simp: val(2) proj_vals_def)
	+ moreover have "ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)"
	+ using ad_agr_\<sigma>_\<sigma>' ad_agr_list_mono[OF AD_def(4)] ad_agr_list_subset[OF ns_sd(4)]
	+ by blast
	+ ultimately have "t \<in> ext_tuple_set AD ns\<psi> ns\<psi>' (fo_nmlz AD ` proj_vals {\<sigma> \<in> - S\<psi>. ad_agr_list AD\<psi> (map \<sigma> ns) (map \<sigma>' ns)} ns\<psi>)"
	+ unfolding unfold val(2)
	+ by (auto simp: proj_vals_def)
	+ then have "t \<in> eval_conj_set AD ns\<phi> {x} ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (map \<sigma>' ns)} - Y))"
	+ using eval_conj[OF tmp x_proj_singleton Some[folded x_ns]] t_in_ext_x
	+ by (auto simp: x_ns)
	+ }
	+ then show "t \<in> (\<Union>x\<in>ad_agr_close_set AD\<Delta>\<phi> X\<phi>. case Mapping.lookup idx\<psi> (fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))) of
	+ None \<Rightarrow> ext_tuple_set AD ns\<phi> ns\<phi>' {x}
	+ \| Some Y \<Rightarrow> eval_conj_set AD ns\<phi> {x} ns\<psi> (ad_agr_close_set AD\<Delta>\<psi> (ext_tuple_set AD\<psi> ns ns\<phi>' {fo_nmlz AD\<psi> (proj_tuple ns (zip ns\<phi> x))} - Y)))"
	+ using t_in_ext_x
	+ by (intro UN_I[OF x_in_ad_agr_close]) (auto simp: x_ns split: option.splits)
	+ qed
	+ ultimately have X_def: "X = fo_nmlz AD ` proj_fmla (Conj \<phi> (Neg \<psi>)) {\<sigma>. esat \<phi> I \<sigma> UNIV} -
	+ fo_nmlz AD ` proj_fmla (Conj \<phi> (Neg \<psi>)) {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ by simp
	+
	+ have AD_Neg_sub: "act_edom (Neg \<psi>) I \<subseteq> AD"
	+ by (auto simp: AD_def(1))
	+ have "X = fo_nmlz AD ` proj_fmla (Conj \<phi> (Neg \<psi>)) {\<sigma>. esat \<phi> I \<sigma> UNIV} \<inter>
	+ fo_nmlz AD ` proj_fmla (Conj \<phi> (Neg \<psi>)) {\<sigma>. esat (Neg \<psi>) I \<sigma> UNIV}"
	+ unfolding X_def
	+ by (auto simp: proj_fmla_map dest!: fo_nmlz_eqD)
	+ (metis AD_def(4) ad_agr_list_subset esat_UNIV_ad_agr_list fv_fo_fmla_list_set fv_sub
	+ sup_ge1 ts_def(4))
	+ then have eval: "eval_ajoin (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi> =
	+ eval_abs (Conj \<phi> (Neg \<psi>)) I"
	+ using proj_fmla_conj_sub[OF AD_Neg_sub, of \<phi>]
	+ unfolding AD_X_def AD_def(1)[symmetric] n_def eval_abs_def
	+ by (auto simp: proj_fmla_map)
	+ have wf_conj_neg: "wf_fo_intp (Conj \<phi> (Neg \<psi>)) I"
	+ using wf
	+ by (auto simp: ts_def)
	+ show ?thesis
	+ using fo_wf_eval_abs[OF wf_conj_neg]
	+ by (auto simp: eval)
	+qed
	+
	+lemma eval_disj:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes wf: "fo_wf \<phi> I t\<phi>" "fo_wf \<psi> I t\<psi>"
	+ shows "fo_wf (Disj \<phi> \<psi>) I
	+ (eval_disj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>)"
	+proof -
	+ obtain AD\<phi> n\<phi> X\<phi> AD\<psi> n\<psi> X\<psi> where ts_def:
	+ "t\<phi> = (AD\<phi>, n\<phi>, X\<phi>)" "t\<psi> = (AD\<psi>, n\<psi>, X\<psi>)"
	+ "AD\<phi> = act_edom \<phi> I" "AD\<psi> = act_edom \<psi> I"
	+ using assms
	+ by (cases t\<phi>, cases t\<psi>) auto
	+ have AD_sub: "act_edom \<phi> I \<subseteq> AD\<phi>" "act_edom \<psi> I \<subseteq> AD\<psi>"
	+ by (auto simp: ts_def(3,4))
	+
	+ obtain AD n X where AD_X_def:
	+ "eval_disj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi> = (AD, n, X)"
	+ by (cases "eval_disj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>") auto
	+ have AD_def: "AD = act_edom (Disj \<phi> \<psi>) I" "act_edom (Disj \<phi> \<psi>) I \<subseteq> AD"
	+ "AD\<phi> \<subseteq> AD" "AD\<psi> \<subseteq> AD" "AD = AD\<phi> \<union> AD\<psi>"
	+ using AD_X_def
	+ by (auto simp: ts_def Let_def)
	+ have n_def: "n = nfv (Disj \<phi> \<psi>)"
	+ using AD_X_def
	+ by (auto simp: ts_def Let_def nfv_card fv_fo_fmla_list_set)
	+
	+ define S\<phi> where "S\<phi> \<equiv> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ define S\<psi> where "S\<psi> \<equiv> {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ define ns\<phi>' where "ns\<phi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<phi>) (fv_fo_fmla_list \<psi>)"
	+ define ns\<psi>' where "ns\<psi>' = filter (\<lambda>n. n \<notin> fv_fo_fmla \<psi>) (fv_fo_fmla_list \<phi>)"
	+
	+ note X\<phi>_def = fo_wf_X[OF wf(1)[unfolded ts_def(1)], unfolded proj_fmla_def, folded S\<phi>_def]
	+ note X\<psi>_def = fo_wf_X[OF wf(2)[unfolded ts_def(2)], unfolded proj_fmla_def, folded S\<psi>_def]
	+ have fv_sub: "fv_fo_fmla (Disj \<phi> \<psi>) = fv_fo_fmla \<phi> \<union> set (fv_fo_fmla_list \<psi>)"
	+ "fv_fo_fmla (Disj \<phi> \<psi>) = fv_fo_fmla \<psi> \<union> set (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_set)
	+ note res_left_alt = ext_tuple_ad_agr_close[OF S\<phi>_def AD_sub(1) AD_def(3)
	+ X\<phi>_def(1)[folded S\<phi>_def] ns\<phi>'_def sorted_distinct_fv_list fv_sub(1)]
	+ note res_right_alt = ext_tuple_ad_agr_close[OF S\<psi>_def AD_sub(2) AD_def(4)
	+ X\<psi>_def(1)[folded S\<psi>_def] ns\<psi>'_def sorted_distinct_fv_list fv_sub(2)]
	+
	+ have "X = fo_nmlz AD ` proj_fmla (Disj \<phi> \<psi>) {\<sigma>. esat \<phi> I \<sigma> UNIV} \<union>
	+ fo_nmlz AD ` proj_fmla (Disj \<phi> \<psi>) {\<sigma>. esat \<psi> I \<sigma> UNIV}"
	+ using AD_X_def
	+ apply (simp add: ts_def(1,2) Let_def AD_def(5)[symmetric])
	+ unfolding fv_fo_fmla_list_set proj_fmla_def ns\<phi>'_def[symmetric] ns\<psi>'_def[symmetric]
	+ S\<phi>_def[symmetric] S\<psi>_def[symmetric]
	+ using res_left_alt(1) res_right_alt(1)
	+ by auto
	+ then have eval: "eval_disj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi> =
	+ eval_abs (Disj \<phi> \<psi>) I"
	+ unfolding AD_X_def AD_def(1)[symmetric] n_def eval_abs_def
	+ by (auto simp: proj_fmla_map)
	+ have wf_disj: "wf_fo_intp (Disj \<phi> \<psi>) I"
	+ using wf
	+ by (auto simp: ts_def)
	+ show ?thesis
	+ using fo_wf_eval_abs[OF wf_disj]
	+ by (auto simp: eval)
	+qed
	+
	+lemma fv_ex_all:
	+ assumes "pos i (fv_fo_fmla_list \<phi>) = None"
	+ shows "fv_fo_fmla_list (Exists i \<phi>) = fv_fo_fmla_list \<phi>"
	+ "fv_fo_fmla_list (Forall i \<phi>) = fv_fo_fmla_list \<phi>"
	+ using pos_complete[of i "fv_fo_fmla_list \<phi>"] fv_fo_fmla_list_eq[of "Exists i \<phi>" \<phi>]
	+ fv_fo_fmla_list_eq[of "Forall i \<phi>" \<phi>] assms
	+ by (auto simp: fv_fo_fmla_list_set)
	+
	+lemma nfv_ex_all:
	+ assumes Some: "pos i (fv_fo_fmla_list \<phi>) = Some j"
	+ shows "nfv \<phi> = Suc (nfv (Exists i \<phi>))" "nfv \<phi> = Suc (nfv (Forall i \<phi>))"
	+proof -
	+ have "i \<in> fv_fo_fmla \<phi>" "j < nfv \<phi>" "i \<in> set (fv_fo_fmla_list \<phi>)"
	+ using fv_fo_fmla_list_set pos_set[of i "fv_fo_fmla_list \<phi>"]
	+ pos_length[of i "fv_fo_fmla_list \<phi>"] Some
	+ by (fastforce simp: nfv_def)+
	+ then show "nfv \<phi> = Suc (nfv (Exists i \<phi>))" "nfv \<phi> = Suc (nfv (Forall i \<phi>))"
	+ using nfv_card[of \<phi>] nfv_card[of "Exists i \<phi>"] nfv_card[of "Forall i \<phi>"]
	+ by (auto simp: finite_fv_fo_fmla)
	+qed
	+
	+lemma fv_fo_fmla_list_exists: "fv_fo_fmla_list (Exists n \<phi>) = filter ((\<noteq>) n) (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_def)
	+ (metis (mono_tags, lifting) distinct_filter distinct_remdups_adj_sort
	+ distinct_remdups_id filter_set filter_sort remdups_adj_set sorted_list_of_set_sort_remdups
	+ sorted_remdups_adj sorted_sort sorted_sort_id)
	+
	+lemma eval_exists:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes wf: "fo_wf \<phi> I t"
	+ shows "fo_wf (Exists i \<phi>) I (eval_exists i (fv_fo_fmla_list \<phi>) t)"
	+proof -
	+ obtain AD n X where t_def: "t = (AD, n, X)"
	+ "AD = act_edom \<phi> I" "AD = act_edom (Exists i \<phi>) I"
	+ using assms
	+ by (cases t) auto
	+ note X_def = fo_wf_X[OF wf[unfolded t_def], folded t_def(2)]
	+ have eval: "eval_exists i (fv_fo_fmla_list \<phi>) t = eval_abs (Exists i \<phi>) I"
	+ proof (cases "pos i (fv_fo_fmla_list \<phi>)")
	+ case None
	+ note fv_eq = fv_ex_all[OF None]
	+ have "X = fo_nmlz AD ` proj_fmla (Exists i \<phi>) {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ unfolding X_def
	+ by (auto simp: proj_fmla_def fv_eq)
	+ also have "\<dots> = fo_nmlz AD ` proj_fmla (Exists i \<phi>) {\<sigma>. esat (Exists i \<phi>) I \<sigma> UNIV}"
	+ using esat_exists_not_fv[of i \<phi> UNIV I] pos_complete[OF None]
	+ by (simp add: fv_fo_fmla_list_set)
	+ finally show ?thesis
	+ by (auto simp: t_def None eval_abs_def fv_eq nfv_def)
	+ next
	+ case (Some j)
	+ have "fo_nmlz AD ` rem_nth j ` X =
	+ fo_nmlz AD ` proj_fmla (Exists i \<phi>) {\<sigma>. esat (Exists i \<phi>) I \<sigma> UNIV}"
	+ proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> fo_nmlz AD ` rem_nth j ` X"
	+ then obtain ws where ws_def: "ws \<in> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ "vs = fo_nmlz AD (rem_nth j ws)"
	+ unfolding X_def
	+ by auto
	+ then obtain \<sigma> where \<sigma>_def: "esat \<phi> I \<sigma> UNIV"
	+ "ws = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list \<phi>))"
	+ by (auto simp: proj_fmla_map)
	+ obtain \<tau> where \<tau>_def: "ws = map \<tau> (fv_fo_fmla_list \<phi>)"
	+ using fo_nmlz_map \<sigma>_def(2)
	+ by blast
	+ have esat_\<tau>: "esat (Exists i \<phi>) I \<tau> UNIV"
	+ using esat_UNIV_ad_agr_list[OF fo_nmlz_ad_agr[of AD "map \<sigma> (fv_fo_fmla_list \<phi>)",
	+ folded \<sigma>_def(2), unfolded \<tau>_def]] \<sigma>_def(1)
	+ by (auto simp: t_def intro!: exI[of _ "\<tau> i"])
	+ have rem_nth_ws: "rem_nth j ws = map \<tau> (fv_fo_fmla_list (Exists i \<phi>))"
	+ using rem_nth_sound[of "fv_fo_fmla_list \<phi>" i j \<tau>] sorted_distinct_fv_list Some
	+ unfolding fv_fo_fmla_list_exists \<tau>_def
	+ by auto
	+ have "vs \<in> fo_nmlz AD ` proj_fmla (Exists i \<phi>) {\<sigma>. esat (Exists i \<phi>) I \<sigma> UNIV}"
	+ using ws_def(2) esat_\<tau>
	+ unfolding rem_nth_ws
	+ by (auto simp: proj_fmla_map)
	+ then show "vs \<in> fo_nmlz AD ` proj_fmla (Exists i \<phi>) {\<sigma>. esat (Exists i \<phi>) I \<sigma> UNIV}"
	+ by auto
	+ next
	+ fix vs
	+ assume assm: "vs \<in> fo_nmlz AD ` proj_fmla (Exists i \<phi>) {\<sigma>. esat (Exists i \<phi>) I \<sigma> UNIV}"
	+ from assm obtain \<sigma> where \<sigma>_def: "vs = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list (Exists i \<phi>)))"
	+ "esat (Exists i \<phi>) I \<sigma> UNIV"
	+ by (auto simp: proj_fmla_map)
	+ then obtain x where x_def: "esat \<phi> I (\<sigma>(i := x)) UNIV"
	+ by auto
	+ define ws where "ws \<equiv> fo_nmlz AD (map (\<sigma>(i := x)) (fv_fo_fmla_list \<phi>))"
	+ then have "length ws = nfv \<phi>"
	+ using nfv_def fo_nmlz_length by (metis length_map)
	+ then have ws_in: "ws \<in> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ using x_def ws_def
	+ by (auto simp: fo_nmlz_sound proj_fmla_map)
	+ obtain \<tau> where \<tau>_def: "ws = map \<tau> (fv_fo_fmla_list \<phi>)"
	+ using fo_nmlz_map ws_def
	+ by blast
	+ have rem_nth_ws: "rem_nth j ws = map \<tau> (fv_fo_fmla_list (Exists i \<phi>))"
	+ using rem_nth_sound[of "fv_fo_fmla_list \<phi>" i j] sorted_distinct_fv_list Some
	+ unfolding fv_fo_fmla_list_exists \<tau>_def
	+ by auto
	+ have "set (fv_fo_fmla_list (Exists i \<phi>)) \<subseteq> set (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_exists)
	+ then have ad_agr: "ad_agr_list AD (map (\<sigma>(i := x)) (fv_fo_fmla_list (Exists i \<phi>)))
	+ (map \<tau> (fv_fo_fmla_list (Exists i \<phi>)))"
	+ by (rule ad_agr_list_subset)
	+ (rule fo_nmlz_ad_agr[of AD "map (\<sigma>(i := x)) (fv_fo_fmla_list \<phi>)", folded ws_def,
	+ unfolded \<tau>_def])
	+ have map_fv_cong: "map (\<sigma>(i := x)) (fv_fo_fmla_list (Exists i \<phi>)) =
	+ map \<sigma> (fv_fo_fmla_list (Exists i \<phi>))"
	+ by (auto simp: fv_fo_fmla_list_exists)
	+ have vs_rem_nth: "vs = fo_nmlz AD (rem_nth j ws)"
	+ unfolding \<sigma>_def(1) rem_nth_ws
	+ apply (rule fo_nmlz_eqI)
	+ using ad_agr[unfolded map_fv_cong] .
	+ show "vs \<in> fo_nmlz AD ` rem_nth j ` X"
	+ using Some ws_in
	+ unfolding vs_rem_nth X_def
	+ by auto
	+ qed
	+ then show ?thesis
	+ using nfv_ex_all[OF Some]
	+ by (auto simp: t_def Some eval_abs_def nfv_def)
	+ qed
	+ have wf_ex: "wf_fo_intp (Exists i \<phi>) I"
	+ using wf
	+ by (auto simp: t_def)
	+ show ?thesis
	+ using fo_wf_eval_abs[OF wf_ex]
	+ by (auto simp: eval)
	+qed
	+
	+lemma fv_fo_fmla_list_forall: "fv_fo_fmla_list (Forall n \<phi>) = filter ((\<noteq>) n) (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_def)
	+ (metis (mono_tags, lifting) distinct_filter distinct_remdups_adj_sort
	+ distinct_remdups_id filter_set filter_sort remdups_adj_set sorted_list_of_set_sort_remdups
	+ sorted_remdups_adj sorted_sort sorted_sort_id)
	+
	+lemma pairwise_take_drop:
	+ assumes "pairwise P (set (zip xs ys))" "length xs = length ys"
	+ shows "pairwise P (set (zip (take i xs @ drop (Suc i) xs) (take i ys @ drop (Suc i) ys)))"
	+ by (rule pairwise_subset[OF assms(1)]) (auto simp: set_zip assms(2))
	+
	+lemma fo_nmlz_set_card:
	+ "fo_nmlz AD xs = xs \<Longrightarrow> set xs = set xs \<inter> Inl ` AD \<union> Inr ` {..<card (Inr -` set xs)}"
	+ by (metis fo_nmlz_sound fo_nmlzd_set card_Inr_vimage_le_length min.absorb2)
	+
	+lemma ad_agr_list_take_drop: "ad_agr_list AD xs ys \<Longrightarrow>
	+ ad_agr_list AD (take i xs @ drop (Suc i) xs) (take i ys @ drop (Suc i) ys)"
	+ apply (auto simp: ad_agr_list_def ad_equiv_list_def sp_equiv_list_def)
	+ apply (metis take_zip in_set_takeD)
	+ apply (metis drop_zip in_set_dropD)
	+ using pairwise_take_drop
	+ by fastforce
	+
	+lemma fo_nmlz_rem_nth_add_nth:
	+ assumes "fo_nmlz AD zs = zs" "i \<le> length zs"
	+ shows "fo_nmlz AD (rem_nth i (fo_nmlz AD (add_nth i z zs))) = zs"
	+proof -
	+ have ad_agr: "ad_agr_list AD (add_nth i z zs) (fo_nmlz AD (add_nth i z zs))"
	+ using fo_nmlz_ad_agr
	+ by auto
	+ have i_lt_add: "i < length (add_nth i z zs)" "i < length (fo_nmlz AD (add_nth i z zs))"
	+ using add_nth_length assms(2)
	+ by (fastforce simp: fo_nmlz_length)+
	+ show ?thesis
	+ using ad_agr_list_take_drop[OF ad_agr, of i, folded rem_nth_take_drop[OF i_lt_add(1)]
	+ rem_nth_take_drop[OF i_lt_add(2)], unfolded rem_nth_add_nth[OF assms(2)]]
	+ apply (subst eq_commute)
	+ apply (subst assms(1)[symmetric])
	+ apply (auto intro: fo_nmlz_eqI)
	+ done
	+qed
	+
	+lemma ad_agr_list_add:
	+ assumes "ad_agr_list AD xs ys" "i \<le> length xs"
	+ shows "\<exists>z' \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set ys))} \<union> set ys.
	+ ad_agr_list AD (take i xs @ z # drop i xs) (take i ys @ z' # drop i ys)"
	+proof -
	+ define n where "n = length xs"
	+ have len_ys: "n = length ys"
	+ using assms(1)
	+ by (auto simp: ad_agr_list_def n_def)
	+ obtain \<sigma> where \<sigma>_def: "xs = map \<sigma> [0..<n]"
	+ unfolding n_def
	+ by (metis map_nth)
	+ obtain \<tau> where \<tau>_def: "ys = map \<tau> [0..<n]"
	+ unfolding len_ys
	+ by (metis map_nth)
	+ have i_le_n: "i \<le> n"
	+ using assms(2)
	+ by (auto simp: n_def)
	+ have set_n: "set [0..<n] = {..n} - {n}" "set ([0..<i] @ n # [i..<n]) = {..n}"
	+ using i_le_n
	+ by auto
	+ have ad_agr: "ad_agr_sets ({..n} - {n}) ({..n} - {n}) AD \<sigma> \<tau>"
	+ using iffD2[OF ad_agr_list_link, OF assms(1)[unfolded \<sigma>_def \<tau>_def]]
	+ unfolding set_n .
	+ have set_ys: "\<tau> ` ({..n} - {n}) = set ys"
	+ by (auto simp: \<tau>_def)
	+ obtain z' where z'_def: "z' \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set ys))} \<union> set ys"
	+ "ad_agr_sets {..n} {..n} AD (\<sigma>(n := z)) (\<tau>(n := z'))"
	+ using extend_\<tau>[OF ad_agr subset_refl,
	+ of "Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set ys))} \<union> set ys" z]
	+ by (auto simp: set_ys)
	+ have map_take: "map (\<sigma>(n := z)) ([0..<i] @ n # [i..<n]) = take i xs @ z # drop i xs"
	+ "map (\<tau>(n := z')) ([0..<i] @ n # [i..<n]) = take i ys @ z' # drop i ys"
	+ using i_le_n
	+ by (auto simp: \<sigma>_def \<tau>_def take_map drop_map)
	+ show ?thesis
	+ using iffD1[OF ad_agr_list_link, OF z'_def(2)[unfolded set_n[symmetric]]] z'_def(1)
	+ unfolding map_take
	+ by auto
	+qed
	+
	+lemma add_nth_restrict:
	+ assumes "fo_nmlz AD zs = zs" "i \<le> length zs"
	+ shows "\<exists>z' \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}.
	+ fo_nmlz AD (add_nth i z zs) = fo_nmlz AD (add_nth i z' zs)"
	+proof -
	+ have "set zs \<subseteq> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}"
	+ using fo_nmlz_set_card[OF assms(1)]
	+ by auto
	+ then obtain z' where z'_def:
	+ "z' \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}"
	+ "ad_agr_list AD (take i zs @ z # drop i zs) (take i zs @ z' # drop i zs)"
	+ using ad_agr_list_add[OF ad_agr_list_refl assms(2), of AD z]
	+ by auto blast
	+ then show ?thesis
	+ unfolding add_nth_take_drop[OF assms(2)]
	+ by (auto intro: fo_nmlz_eqI)
	+qed
	+
	+lemma fo_nmlz_add_rem:
	+ assumes "i \<le> length zs"
	+ shows "\<exists>z'. fo_nmlz AD (add_nth i z zs) = fo_nmlz AD (add_nth i z' (fo_nmlz AD zs))"
	+proof -
	+ have ad_agr: "ad_agr_list AD zs (fo_nmlz AD zs)"
	+ using fo_nmlz_ad_agr
	+ by auto
	+ have i_le_fo_nmlz: "i \<le> length (fo_nmlz AD zs)"
	+ using assms(1)
	+ by (auto simp: fo_nmlz_length)
	+ obtain x where x_def: "ad_agr_list AD (add_nth i z zs) (add_nth i x (fo_nmlz AD zs))"
	+ using ad_agr_list_add[OF ad_agr assms(1)]
	+ by (auto simp: add_nth_take_drop[OF assms(1)] add_nth_take_drop[OF i_le_fo_nmlz])
	+ then show ?thesis
	+ using fo_nmlz_eqI
	+ by auto
	+qed
	+
	+lemma fo_nmlz_add_rem':
	+ assumes "i \<le> length zs"
	+ shows "\<exists>z'. fo_nmlz AD (add_nth i z (fo_nmlz AD zs)) = fo_nmlz AD (add_nth i z' zs)"
	+proof -
	+ have ad_agr: "ad_agr_list AD (fo_nmlz AD zs) zs"
	+ using ad_agr_list_comm[OF fo_nmlz_ad_agr]
	+ by auto
	+ have i_le_fo_nmlz: "i \<le> length (fo_nmlz AD zs)"
	+ using assms(1)
	+ by (auto simp: fo_nmlz_length)
	+ obtain x where x_def: "ad_agr_list AD (add_nth i z (fo_nmlz AD zs)) (add_nth i x zs)"
	+ using ad_agr_list_add[OF ad_agr i_le_fo_nmlz]
	+ by (auto simp: add_nth_take_drop[OF assms(1)] add_nth_take_drop[OF i_le_fo_nmlz])
	+ then show ?thesis
	+ using fo_nmlz_eqI
	+ by auto
	+qed
	+
	+lemma fo_nmlz_add_nth_rem_nth:
	+ assumes "fo_nmlz AD xs = xs" "i < length xs"
	+ shows "\<exists>z. fo_nmlz AD (add_nth i z (fo_nmlz AD (rem_nth i xs))) = xs"
	+ using rem_nth_length[OF assms(2)] fo_nmlz_add_rem[of i "rem_nth i xs" AD "xs ! i",
	+ unfolded assms(1) add_nth_rem_nth_self[OF assms(2)]] assms(2)
	+ by (subst eq_commute) auto
	+
	+lemma sp_equiv_list_almost_same: "sp_equiv_list (xs @ v # ys) (xs @ w # ys) \<Longrightarrow>
	+ v \<in> set xs \<union> set ys \<or> w \<in> set xs \<union> set ys \<Longrightarrow> v = w"
	+ by (auto simp: sp_equiv_list_def pairwise_def) (metis UnCI sp_equiv_pair.simps zip_same)+
	+
	+lemma ad_agr_list_add_nth:
	+ assumes "i \<le> length zs" "ad_agr_list AD (add_nth i v zs) (add_nth i w zs)" "v \<noteq> w"
	+ shows "{v, w} \<inter> (Inl ` AD \<union> set zs) = {}"
	+ using assms(2)[unfolded add_nth_take_drop[OF assms(1)]] assms(1,3) sp_equiv_list_almost_same
	+ by (auto simp: ad_agr_list_def ad_equiv_list_def ad_equiv_pair.simps)
	+ (smt append_take_drop_id set_append sp_equiv_list_almost_same)+
	+
	+lemma Inr_in_tuple:
	+ assumes "fo_nmlz AD zs = zs" "n < card (Inr -` set zs)"
	+ shows "Inr n \<in> set zs"
	+ using assms fo_nmlz_set_card[OF assms(1)]
	+ by (auto simp: fo_nmlzd_code[symmetric])
	+
	+lemma card_wit_sub:
	+ assumes "finite Z" "card Z \<le> card {ts \<in> X. \<exists>z \<in> Z. ts = f z}"
	+ shows "f ` Z \<subseteq> X"
	+proof -
	+ have set_unfold: "{ts \<in> X. \<exists>z \<in> Z. ts = f z} = f ` Z \<inter> X"
	+ by auto
	+ show ?thesis
	+ using assms
	+ unfolding set_unfold
	+ by (metis Int_lower1 card_image_le card_seteq finite_imageI inf.absorb_iff1 le_antisym
	+ surj_card_le)
	+qed
	+
	+lemma add_nth_iff_card:
	+ assumes "(\<And>xs. xs \<in> X \<Longrightarrow> fo_nmlz AD xs = xs)" "(\<And>xs. xs \<in> X \<Longrightarrow> i < length xs)"
	+ "fo_nmlz AD zs = zs" "i \<le> length zs" "finite AD" "finite X"
	+ shows "(\<forall>z. fo_nmlz AD (add_nth i z zs) \<in> X) \<longleftrightarrow>
	+ Suc (card AD + card (Inr -` set zs)) \<le> card {ts \<in> X. \<exists>z. ts = fo_nmlz AD (add_nth i z zs)}"
	+proof -
	+ have inj: "inj_on (\<lambda>z. fo_nmlz AD (add_nth i z zs))
	+ (Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))})"
	+ using ad_agr_list_add_nth[OF assms(4)] Inr_in_tuple[OF assms(3)] less_Suc_eq
	+ by (fastforce simp: inj_on_def dest!: fo_nmlz_eqD)
	+ have card_Un: "card (Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}) =
	+ Suc (card AD + card (Inr -` set zs))"
	+ using card_Un_disjoint[of "Inl ` AD" "Inr ` {..<Suc (card (Inr -` set zs))}"] assms(5)
	+ by (auto simp add: card_image disjoint_iff_not_equal)
	+ have restrict_z: "(\<forall>z. fo_nmlz AD (add_nth i z zs) \<in> X) \<longleftrightarrow>
	+ (\<forall>z \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}. fo_nmlz AD (add_nth i z zs) \<in> X)"
	+ using add_nth_restrict[OF assms(3,4)]
	+ by metis
	+ have restrict_z': "{ts \<in> X. \<exists>z. ts = fo_nmlz AD (add_nth i z zs)} =
	+ {ts \<in> X. \<exists>z \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}.
	+ ts = fo_nmlz AD (add_nth i z zs)}"
	+ using add_nth_restrict[OF assms(3,4)]
	+ by auto
	+ {
	+ assume "\<And>z. fo_nmlz AD (add_nth i z zs) \<in> X"
	+ then have image_sub: "(\<lambda>z. fo_nmlz AD (add_nth i z zs)) `
	+ (Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}) \<subseteq>
	+ {ts \<in> X. \<exists>z. ts = fo_nmlz AD (add_nth i z zs)}"
	+ by auto
	+ have "Suc (card AD + card (Inr -` set zs)) \<le>
	+ card {ts \<in> X. \<exists>z. ts = fo_nmlz AD (add_nth i z zs)}"
	+ unfolding card_Un[symmetric]
	+ using card_inj_on_le[OF inj image_sub] assms(6)
	+ by auto
	+ then have "Suc (card AD + card (Inr -` set zs)) \<le>
	+ card {ts \<in> X. \<exists>z. ts = fo_nmlz AD (add_nth i z zs)}"
	+ by (auto simp: card_image)
	+ }
	+ moreover
	+ {
	+ assume assm: "card (Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}) \<le>
	+ card {ts \<in> X. \<exists>z \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}.
	+ ts = fo_nmlz AD (add_nth i z zs)}"
	+ have "\<forall>z \<in> Inl ` AD \<union> Inr ` {..<Suc (card (Inr -` set zs))}. fo_nmlz AD (add_nth i z zs) \<in> X"
	+ using card_wit_sub[OF _ assm] assms(5)
	+ by auto
	+ }
	+ ultimately show ?thesis
	+ unfolding restrict_z[symmetric] restrict_z'[symmetric] card_Un
	+ by auto
	+qed
	+
	+lemma set_fo_nmlz_add_nth_rem_nth:
	+ assumes "j < length xs" "\<And>x. x \<in> X \<Longrightarrow> fo_nmlz AD x = x"
	+ "\<And>x. x \<in> X \<Longrightarrow> j < length x"
	+ shows "{ts \<in> X. \<exists>z. ts = fo_nmlz AD (add_nth j z (fo_nmlz AD (rem_nth j xs)))} =
	+ {y \<in> X. fo_nmlz AD (rem_nth j y) = fo_nmlz AD (rem_nth j xs)}"
	+ using fo_nmlz_rem_nth_add_nth[where ?zs="fo_nmlz AD (rem_nth j xs)"] rem_nth_length[OF assms(1)] fo_nmlz_add_nth_rem_nth assms
	+ by (fastforce simp: fo_nmlz_idem[OF fo_nmlz_sound] fo_nmlz_length)
	+
	+lemma eval_forall:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes wf: "fo_wf \<phi> I t"
	+ shows "fo_wf (Forall i \<phi>) I (eval_forall i (fv_fo_fmla_list \<phi>) t)"
	+proof -
	+ obtain AD n X where t_def: "t = (AD, n, X)" "AD = act_edom \<phi> I"
	+ "AD = act_edom (Forall i \<phi>) I"
	+ using assms
	+ by (cases t) auto
	+ have AD_sub: "act_edom \<phi> I \<subseteq> AD"
	+ by (auto simp: t_def(2))
	+ have fin_AD: "finite AD"
	+ using finite_act_edom wf
	+ by (auto simp: t_def)
	+ have fin_X: "finite X"
	+ using wf
	+ by (auto simp: t_def)
	+ note X_def = fo_wf_X[OF wf[unfolded t_def], folded t_def(2)]
	+ have eval: "eval_forall i (fv_fo_fmla_list \<phi>) t = eval_abs (Forall i \<phi>) I"
	+ proof (cases "pos i (fv_fo_fmla_list \<phi>)")
	+ case None
	+ note fv_eq = fv_ex_all[OF None]
	+ have "X = fo_nmlz AD ` proj_fmla (Forall i \<phi>) {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ unfolding X_def
	+ by (auto simp: proj_fmla_def fv_eq)
	+ also have "\<dots> = fo_nmlz AD ` proj_fmla (Forall i \<phi>) {\<sigma>. esat (Forall i \<phi>) I \<sigma> UNIV}"
	+ using esat_forall_not_fv[of i \<phi> UNIV I] pos_complete[OF None]
	+ by (auto simp: fv_fo_fmla_list_set)
	+ finally show ?thesis
	+ by (auto simp: t_def None eval_abs_def fv_eq nfv_def)
	+ next
	+ case (Some j)
	+ have i_in_fv: "i \<in> fv_fo_fmla \<phi>"
	+ by (rule pos_set[OF Some, unfolded fv_fo_fmla_list_set])
	+ have fo_nmlz_X: "\<And>xs. xs \<in> X \<Longrightarrow> fo_nmlz AD xs = xs"
	+ by (auto simp: X_def proj_fmla_map fo_nmlz_idem[OF fo_nmlz_sound])
	+ have j_lt_len: "\<And>xs. xs \<in> X \<Longrightarrow> j < length xs"
	+ using pos_sound[OF Some]
	+ by (auto simp: X_def proj_fmla_map fo_nmlz_length)
	+ have rem_nth_j_le_len: "\<And>xs. xs \<in> X \<Longrightarrow> j \<le> length (fo_nmlz AD (rem_nth j xs))"
	+ using rem_nth_length j_lt_len
	+ by (fastforce simp: fo_nmlz_length)
	+ have img_proj_fmla: "Mapping.keys (Mapping.filter (\<lambda>t Z. Suc (card AD + card (Inr -` set t)) \<le> card Z)
	+ (cluster (Some \<circ> (\<lambda>ts. fo_nmlz AD (rem_nth j ts))) X)) =
	+ fo_nmlz AD ` proj_fmla (Forall i \<phi>) {\<sigma>. esat (Forall i \<phi>) I \<sigma> UNIV}"
	+ proof (rule set_eqI, rule iffI)
	+ fix vs
	+ assume "vs \<in> Mapping.keys (Mapping.filter (\<lambda>t Z. Suc (card AD + card (Inr -` set t)) \<le> card Z)
	+ (cluster (Some \<circ> (\<lambda>ts. fo_nmlz AD (rem_nth j ts))) X))"
	+ then obtain ws where ws_def: "ws \<in> X" "vs = fo_nmlz AD (rem_nth j ws)"
	+ "\<And>a. fo_nmlz AD (add_nth j a (fo_nmlz AD (rem_nth j ws))) \<in> X"
	+ using add_nth_iff_card[OF fo_nmlz_X j_lt_len fo_nmlz_idem[OF fo_nmlz_sound]
	+ rem_nth_j_le_len fin_AD fin_X] set_fo_nmlz_add_nth_rem_nth[OF j_lt_len fo_nmlz_X j_lt_len]
	+ by transfer (fastforce split: option.splits if_splits)
	+ then obtain \<sigma> where \<sigma>_def:
	+ "esat \<phi> I \<sigma> UNIV" "ws = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list \<phi>))"
	+ unfolding X_def
	+ by (auto simp: proj_fmla_map)
	+ obtain \<tau> where \<tau>_def: "ws = map \<tau> (fv_fo_fmla_list \<phi>)"
	+ using fo_nmlz_map \<sigma>_def(2)
	+ by blast
	+ have fo_nmlzd_\<tau>: "fo_nmlzd AD (map \<tau> (fv_fo_fmla_list \<phi>))"
	+ unfolding \<tau>_def[symmetric] \<sigma>_def(2)
	+ by (rule fo_nmlz_sound)
	+ have rem_nth_j_ws: "rem_nth j ws = map \<tau> (filter ((\<noteq>) i) (fv_fo_fmla_list \<phi>))"
	+ using rem_nth_sound[OF _ Some] sorted_distinct_fv_list
	+ by (auto simp: \<tau>_def)
	+ have esat_\<tau>: "esat (Forall i \<phi>) I \<tau> UNIV"
	+ unfolding esat.simps
	+ proof (rule ballI)
	+ fix x
	+ have "fo_nmlz AD (add_nth j x (rem_nth j ws)) \<in> X"
	+ using fo_nmlz_add_rem[of j "rem_nth j ws" AD x] rem_nth_length
	+ j_lt_len[OF ws_def(1)] ws_def(3)
	+ by fastforce
	+ then have "fo_nmlz AD (map (\<tau>(i := x)) (fv_fo_fmla_list \<phi>)) \<in> X"
	+ using add_nth_rem_nth_map[OF _ Some, of x] sorted_distinct_fv_list
	+ unfolding \<tau>_def
	+ by fastforce
	+ then show "esat \<phi> I (\<tau>(i := x)) UNIV"
	+ by (auto simp: X_def proj_fmla_map esat_UNIV_ad_agr_list[OF _ AD_sub]
	+ dest!: fo_nmlz_eqD)
	+ qed
	+ have rem_nth_ws: "rem_nth j ws = map \<tau> (fv_fo_fmla_list (Forall i \<phi>))"
	+ using rem_nth_sound[OF _ Some] sorted_distinct_fv_list
	+ by (auto simp: fv_fo_fmla_list_forall \<tau>_def)
	+ then show "vs \<in> fo_nmlz AD ` proj_fmla (Forall i \<phi>) {\<sigma>. esat (Forall i \<phi>) I \<sigma> UNIV}"
	+ using ws_def(2) esat_\<tau>
	+ by (auto simp: proj_fmla_map rem_nth_ws)
	+ next
	+ fix vs
	+ assume assm: "vs \<in> fo_nmlz AD ` proj_fmla (Forall i \<phi>) {\<sigma>. esat (Forall i \<phi>) I \<sigma> UNIV}"
	+ from assm obtain \<sigma> where \<sigma>_def: "vs = fo_nmlz AD (map \<sigma> (fv_fo_fmla_list (Forall i \<phi>)))"
	+ "esat (Forall i \<phi>) I \<sigma> UNIV"
	+ by (auto simp: proj_fmla_map)
	+ then have all_esat: "\<And>x. esat \<phi> I (\<sigma>(i := x)) UNIV"
	+ by auto
	+ define ws where "ws \<equiv> fo_nmlz AD (map \<sigma> (fv_fo_fmla_list \<phi>))"
	+ then have "length ws = nfv \<phi>"
	+ using nfv_def fo_nmlz_length by (metis length_map)
	+ then have ws_in: "ws \<in> fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ using all_esat[of "\<sigma> i"] ws_def
	+ by (auto simp: fo_nmlz_sound proj_fmla_map)
	+ then have ws_in_X: "ws \<in> X"
	+ by (auto simp: X_def)
	+ obtain \<tau> where \<tau>_def: "ws = map \<tau> (fv_fo_fmla_list \<phi>)"
	+ using fo_nmlz_map ws_def
	+ by blast
	+ have rem_nth_ws: "rem_nth j ws = map \<tau> (fv_fo_fmla_list (Forall i \<phi>))"
	+ using rem_nth_sound[of "fv_fo_fmla_list \<phi>" i j] sorted_distinct_fv_list Some
	+ unfolding fv_fo_fmla_list_forall \<tau>_def
	+ by auto
	+ have "set (fv_fo_fmla_list (Forall i \<phi>)) \<subseteq> set (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_forall)
	+ then have ad_agr: "ad_agr_list AD (map \<sigma> (fv_fo_fmla_list (Forall i \<phi>)))
	+ (map \<tau> (fv_fo_fmla_list (Forall i \<phi>)))"
	+ apply (rule ad_agr_list_subset)
	+ using fo_nmlz_ad_agr[of AD] ws_def \<tau>_def
	+ by metis
	+ have map_fv_cong: "\<And>x. map (\<sigma>(i := x)) (fv_fo_fmla_list (Forall i \<phi>)) =
	+ map \<sigma> (fv_fo_fmla_list (Forall i \<phi>))"
	+ by (auto simp: fv_fo_fmla_list_forall)
	+ have vs_rem_nth: "vs = fo_nmlz AD (rem_nth j ws)"
	+ unfolding \<sigma>_def(1) rem_nth_ws
	+ apply (rule fo_nmlz_eqI)
	+ using ad_agr[unfolded map_fv_cong] .
	+ have "\<And>a. fo_nmlz AD (add_nth j a (fo_nmlz AD (rem_nth j ws))) \<in>
	+ fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ proof -
	+ fix a
	+ obtain x where add_rem: "fo_nmlz AD (add_nth j a (fo_nmlz AD (rem_nth j ws))) =
	+ fo_nmlz AD (map (\<tau>(i := x)) (fv_fo_fmla_list \<phi>))"
	+ using add_nth_rem_nth_map[OF _ Some, of _ \<tau>] sorted_distinct_fv_list
	+ fo_nmlz_add_rem'[of j "rem_nth j ws"] rem_nth_length[of j ws]
	+ j_lt_len[OF ws_in_X]
	+ by (fastforce simp: \<tau>_def)
	+ have "esat (Forall i \<phi>) I \<tau> UNIV"
	+ apply (rule iffD1[OF esat_UNIV_ad_agr_list \<sigma>_def(2), OF _ subset_refl, folded t_def])
	+ using fo_nmlz_ad_agr[of AD "map \<sigma> (fv_fo_fmla_list \<phi>)", folded ws_def, unfolded \<tau>_def]
	+ unfolding ad_agr_list_link[symmetric]
	+ by (auto simp: fv_fo_fmla_list_set ad_agr_sets_def sp_equiv_def pairwise_def)
	+ then have "esat \<phi> I (\<tau>(i := x)) UNIV"
	+ by auto
	+ then show "fo_nmlz AD (add_nth j a (fo_nmlz AD (rem_nth j ws))) \<in>
	+ fo_nmlz AD ` proj_fmla \<phi> {\<sigma>. esat \<phi> I \<sigma> UNIV}"
	+ by (auto simp: add_rem proj_fmla_map)
	+ qed
	+ then show "vs \<in> Mapping.keys (Mapping.filter (\<lambda>t Z. Suc (card AD + card (Inr -` set t)) \<le> card Z)
	+ (cluster (Some \<circ> (\<lambda>ts. fo_nmlz AD (rem_nth j ts))) X))"
	+ unfolding vs_rem_nth X_def[symmetric]
	+ using add_nth_iff_card[OF fo_nmlz_X j_lt_len fo_nmlz_idem[OF fo_nmlz_sound]
	+ rem_nth_j_le_len fin_AD fin_X] set_fo_nmlz_add_nth_rem_nth[OF j_lt_len fo_nmlz_X j_lt_len] ws_in_X
	+ by transfer (fastforce split: option.splits if_splits)
	+ qed
	+ show ?thesis
	+ using nfv_ex_all[OF Some]
	+ by (simp add: t_def Some eval_abs_def nfv_def img_proj_fmla[unfolded t_def(2)]
	+ split: option.splits)
	+ qed
	+ have wf_all: "wf_fo_intp (Forall i \<phi>) I"
	+ using wf
	+ by (auto simp: t_def)
	+ show ?thesis
	+ using fo_wf_eval_abs[OF wf_all]
	+ by (auto simp: eval)
	+qed
	+
	+fun fo_res :: "('a, nat) fo_t \<Rightarrow> 'a eval_res" where
	+ "fo_res (AD, n, X) = (if fo_fin (AD, n, X) then Fin (map projl ` X) else Infin)"
	+
	+lemma fo_res_fin:
	+ fixes t :: "('a :: infinite, nat) fo_t"
	+ assumes "fo_wf \<phi> I t" "finite (fo_rep t)"
	+ shows "fo_res t = Fin (fo_rep t)"
	+proof -
	+ obtain AD n X where t_def: "t = (AD, n, X)"
	+ using assms(1)
	+ by (cases t) auto
	+ show ?thesis
	+ using fo_fin assms
	+ by (fastforce simp only: t_def fo_res.simps fo_rep_fin split: if_splits)
	+qed
	+
	+lemma fo_res_infin:
	+ fixes t :: "('a :: infinite, nat) fo_t"
	+ assumes "fo_wf \<phi> I t" "\<not>finite (fo_rep t)"
	+ shows "fo_res t = Infin"
	+proof -
	+ obtain AD n X where t_def: "t = (AD, n, X)"
	+ using assms(1)
	+ by (cases t) auto
	+ show ?thesis
	+ using fo_fin assms
	+ by (fastforce simp only: t_def fo_res.simps split: if_splits)
	+qed
	+
	+lemma fo_rep: "fo_wf \<phi> I t \<Longrightarrow> fo_rep t = proj_sat \<phi> I"
	+ by (cases t) auto
	+
	+global_interpretation Ailamazyan: eval_fo fo_wf eval_pred fo_rep fo_res
	+ eval_bool eval_eq eval_neg eval_conj eval_ajoin eval_disj
	+ eval_exists eval_forall
	+ defines eval_fmla = Ailamazyan.eval_fmla
	+ and eval = Ailamazyan.eval
	+ apply standard
	+ apply (rule fo_rep, assumption+)
	+ apply (rule fo_res_fin, assumption+)
	+ apply (rule fo_res_infin, assumption+)
	+ apply (rule eval_pred, assumption+)
	+ apply (rule eval_bool)
	+ apply (rule eval_eq)
	+ apply (rule eval_neg, assumption+)
	+ apply (rule eval_conj, assumption+)
	+ apply (rule eval_ajoin, assumption+)
	+ apply (rule eval_disj, assumption+)
	+ apply (rule eval_exists, assumption+)
	+ apply (rule eval_forall, assumption+)
	+ done
	+
	+definition esat_UNIV :: "('a :: infinite, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> ('a + nat) val \<Rightarrow> bool" where
	+ "esat_UNIV \<phi> I \<sigma> = esat \<phi> I \<sigma> UNIV"
	+
	+lemma esat_UNIV_code[code]: "esat_UNIV \<phi> I \<sigma> \<longleftrightarrow> (if wf_fo_intp \<phi> I then
	+ (case eval_fmla \<phi> I of (AD, n, X) \<Rightarrow>
	+ fo_nmlz (act_edom \<phi> I) (map \<sigma> (fv_fo_fmla_list \<phi>)) \<in> X)
	+ else esat_UNIV \<phi> I \<sigma>)"
	+proof -
	+ obtain AD n T where t_def: "Ailamazyan.eval_fmla \<phi> I = (AD, n, T)"
	+ by (cases "Ailamazyan.eval_fmla \<phi> I") auto
	+ {
	+ assume wf_fo_intp: "wf_fo_intp \<phi> I"
	+ note fo_wf = Ailamazyan.eval_fmla_correct[OF wf_fo_intp, unfolded t_def]
	+ note T_def = fo_wf_X[OF fo_wf]
	+ have AD_def: "AD = act_edom \<phi> I"
	+ using fo_wf
	+ by auto
	+ have "esat_UNIV \<phi> I \<sigma> \<longleftrightarrow>
	+ fo_nmlz (act_edom \<phi> I) (map \<sigma> (fv_fo_fmla_list \<phi>)) \<in> T"
	+ using esat_UNIV_ad_agr_list[OF _ subset_refl]
	+ by (force simp add: esat_UNIV_def T_def AD_def proj_fmla_map
	+ dest!: fo_nmlz_eqD)
	+ }
	+ then show ?thesis
	+ by (auto simp: t_def)
	+qed
	+
	+lemma sat_code[code]:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ shows "sat \<phi> I \<sigma> \<longleftrightarrow> (if wf_fo_intp \<phi> I then
	+ (case eval_fmla \<phi> I of (AD, n, X) \<Rightarrow>
	+ fo_nmlz (act_edom \<phi> I) (map (Inl \<circ> \<sigma>) (fv_fo_fmla_list \<phi>)) \<in> X)
	+ else sat \<phi> I \<sigma>)"
	+ using esat_UNIV_code sat_esat_conv[folded esat_UNIV_def]
	+ by metis
	+
	+end
	diff --git a/thys/Eval_FO/Ailamazyan_Code.thy b/thys/Eval_FO/Ailamazyan_Code.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/Ailamazyan_Code.thy
	@@ -0,0 +1,124 @@
	+theory Ailamazyan_Code
	+ imports "HOL-Library.Code_Target_Nat" "Containers.Containers" Ailamazyan
	+begin
	+
	+(* Convert database to fo_intp *)
	+
	+definition insert_db :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b set) mapping \<Rightarrow> ('a, 'b set) mapping" where
	+ "insert_db k v m = (case Mapping.lookup m k of None \<Rightarrow>
	+ Mapping.update k ({v}) m
	+ \| Some vs \<Rightarrow> Mapping.update k (({v} \<union> vs)) m)"
	+
	+fun convert_db_rec :: "('a \<times> 'c list) list \<Rightarrow> (('a \<times> nat), 'c list set) mapping \<Rightarrow>
	+ (('a \<times> nat), 'c list set) mapping" where
	+ "convert_db_rec [] m = m"
	+\| "convert_db_rec ((r, ts) # ktss) m = convert_db_rec ktss (insert_db (r, length ts) ts m)"
	+
	+lemma convert_db_rec_mono: "Mapping.lookup m (r, n) = Some tss \<Longrightarrow>
	+ \<exists>tss'. Mapping.lookup (convert_db_rec ktss m) (r, n) = Some tss' \<and> tss \<subseteq> tss'"
	+ apply (induction ktss m arbitrary: tss rule: convert_db_rec.induct)
	+ apply (auto simp: insert_db_def fun_upd_def Mapping.lookup_update' split: option.splits if_splits)
	+ apply (metis option.discI)
	+ apply (smt option.inject order_trans subset_insertI)
	+ done
	+
	+lemma convert_db_rec_sound: "(r, ts) \<in> set ktss \<Longrightarrow>
	+ \<exists>tss. Mapping.lookup (convert_db_rec ktss m) (r, length ts) = Some tss \<and> ts \<in> tss"
	+proof (induction ktss m rule: convert_db_rec.induct)
	+ case (2 r ts ktss m)
	+ obtain tss where
	+ "Mapping.lookup (convert_db_rec ktss (insert_db (r, length ts) ts m)) (r, length ts) = Some tss"
	+ "ts \<in> tss"
	+ using convert_db_rec_mono[of "insert_db (r, length ts) ts m" r "length ts" _ ktss]
	+ by atomize_elim (auto simp: insert_db_def Mapping.lookup_update' split: option.splits)+
	+ then show ?case
	+ using 2
	+ by auto
	+qed auto
	+
	+lemma convert_db_rec_complete: "Mapping.lookup (convert_db_rec ktss m) (r, n) = Some tss' \<Longrightarrow>
	+ ts \<in> tss' \<Longrightarrow>
	+ (length ts = n \<and> (r, ts) \<in> set ktss) \<or> (\<exists>tss. Mapping.lookup m (r, n) = Some tss \<and> ts \<in> tss)"
	+ by (induction ktss m rule: convert_db_rec.induct)
	+ (auto simp: insert_db_def Mapping.lookup_update' split: option.splits if_splits)
	+
	+definition convert_db :: "('a \<times> 'c list) list \<Rightarrow> ('c table, 'a) fo_intp" where
	+ "convert_db ktss = (let m = convert_db_rec ktss Mapping.empty in
	+ (\<lambda>x. case Mapping.lookup m x of None \<Rightarrow> {} \| Some v \<Rightarrow> v))"
	+
	+lemma convert_db_correct: "(ts \<in> convert_db ktss (r, n) \<longrightarrow> n = length ts) \<and>
	+ ((r, ts) \<in> set ktss \<longleftrightarrow> ts \<in> convert_db ktss (r, length ts))"
	+ by (auto simp: convert_db_def dest!: convert_db_rec_sound[of _ _ _ Mapping.empty]
	+ split: option.splits)
	+ (metis Mapping.lookup_empty convert_db_rec_complete option.distinct(1))+
	+
	+(* Code setup *)
	+
	+lemma Inl_vimage_set_code[code_unfold]: "Inl -` set as = set (List.map_filter (case_sum Some Map.empty) as)"
	+ by (induction as) (auto simp: List.map_filter_simps split: option.splits sum.splits)
	+
	+lemma Inr_vimage_set_code[code_unfold]: "Inr -` set as = set (List.map_filter (case_sum Map.empty Some) as)"
	+ by (induction as) (auto simp: List.map_filter_simps split: option.splits sum.splits)
	+
	+lemma Inl_vimage_code: "Inl -` as = projl ` {x \<in> as. isl x}"
	+ by (force simp: vimage_def)
	+
	+lemmas ad_pred_code[code] = ad_terms.simps[unfolded Inl_vimage_code]
	+lemmas fo_wf_code[code] = fo_wf.simps[unfolded Inl_vimage_code]
	+
	+(* Monomorphise *)
	+
	+definition empty_J :: "((nat, nat) fo_t, String.literal) fo_intp" where
	+ "empty_J = (\<lambda>(_, n). eval_pred (map Var [0..<n]) {})"
	+
	+definition eval_fin_nat :: "(nat, String.literal) fo_fmla \<Rightarrow> (nat table, String.literal) fo_intp \<Rightarrow> nat eval_res" where
	+ "eval_fin_nat \<phi> I = eval \<phi> I"
	+
	+definition sat_fin_nat :: "(nat, String.literal) fo_fmla \<Rightarrow> (nat table, String.literal) fo_intp \<Rightarrow> nat val \<Rightarrow> bool" where
	+ "sat_fin_nat \<phi> I = sat \<phi> I"
	+
	+definition convert_nat_db :: "(String.literal \<times> nat list) list \<Rightarrow>
	+ (nat table, String.literal) fo_intp" where
	+ "convert_nat_db = convert_db"
	+
	+definition rbt_nat_fold :: "_ \<Rightarrow> nat set_rbt \<Rightarrow> _ \<Rightarrow> _" where
	+ "rbt_nat_fold = RBT_Set2.fold"
	+
	+definition rbt_nat_list_fold :: "_ \<Rightarrow> (nat list) set_rbt \<Rightarrow> _ \<Rightarrow> _" where
	+ "rbt_nat_list_fold = RBT_Set2.fold"
	+
	+definition rbt_sum_list_fold :: "_ \<Rightarrow> ((nat + nat) list) set_rbt \<Rightarrow> _ \<Rightarrow> _" where
	+ "rbt_sum_list_fold = RBT_Set2.fold"
	+
	+export_code eval_fin_nat sat_fin_nat fv_fo_fmla_list convert_nat_db rbt_nat_fold rbt_nat_list_fold
	+ rbt_sum_list_fold Const Conj Inl Fin nat_of_integer integer_of_nat RBT_set
	+ in OCaml module_name Eval_FO file_prefix verified
	+
	+(* Examples *)
	+
	+definition \<phi> :: "(nat, String.literal) fo_fmla" where
	+ "\<phi> \<equiv> Exists 0 (Conj (FO.Eqa (Var 0) (Const 2)) (FO.Eqa (Var 0) (Var 1)))"
	+
	+value "eval_fin_nat \<phi> (convert_nat_db [])"
	+
	+value "sat_fin_nat \<phi> (convert_nat_db []) (\<lambda>_. 0)"
	+value "sat_fin_nat \<phi> (convert_nat_db []) (\<lambda>_. 2)"
	+
	+definition \<psi> :: "(nat, String.literal) fo_fmla" where
	+ "\<psi> \<equiv> Forall 2 (Disj (FO.Eqa (Var 2) (Const 42))
	+ (Exists 1 (Conj (FO.Pred (String.implode ''P'') [Var 0, Var 1])
	+ (Neg (FO.Pred (String.implode ''Q'') [Var 1, Var 2])))))"
	+
	+value "eval_fin_nat \<psi> (convert_nat_db
	+ [(String.implode ''P'', [1, 20]),
	+ (String.implode ''P'', [9, 20]),
	+ (String.implode ''P'', [2, 30]),
	+ (String.implode ''P'', [3, 31]),
	+ (String.implode ''P'', [4, 32]),
	+ (String.implode ''P'', [5, 30]),
	+ (String.implode ''P'', [6, 30]),
	+ (String.implode ''P'', [7, 30]),
	+ (String.implode ''Q'', [20, 42]),
	+ (String.implode ''Q'', [30, 43])])"
	+
	+end
	diff --git a/thys/Eval_FO/Cluster.thy b/thys/Eval_FO/Cluster.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/Cluster.thy
	@@ -0,0 +1,218 @@
	+theory Cluster
	+ imports Mapping_Code
	+begin
	+
	+lemma these_Un[simp]: "Option.these (A \<union> B) = Option.these A \<union> Option.these B"
	+ by (auto simp: Option.these_def)
	+
	+lemma these_insert[simp]: "Option.these (insert x A) = (case x of Some a \<Rightarrow> insert a \| None \<Rightarrow> id) (Option.these A)"
	+ by (auto simp: Option.these_def split: option.splits) force
	+
	+lemma these_image_Un[simp]: "Option.these (f ` (A \<union> B)) = Option.these (f ` A) \<union> Option.these (f ` B)"
	+ by (auto simp: Option.these_def)
	+
	+lemma these_imageI: "f x = Some y \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> Option.these (f ` X)"
	+ by (force simp: Option.these_def)
	+
	+lift_definition cluster :: "('b \<Rightarrow> 'a option) \<Rightarrow> 'b set \<Rightarrow> ('a, 'b set) mapping" is
	+ "\<lambda>f Y x. if Some x \<in> f ` Y then Some {y \<in> Y. f y = Some x} else None" .
	+
	+lemma set_of_idx_cluster: "set_of_idx (cluster (Some \<circ> f) X) = X"
	+ by transfer (auto simp: ran_def)
	+
	+lemma lookup_cluster': "Mapping.lookup (cluster (Some \<circ> h) X) y = (if y \<notin> h ` X then None else Some {x \<in> X. h x = y})"
	+ by transfer auto
	+
	+context ord
	+begin
	+
	+definition add_to_rbt :: "'a \<times> 'b \<Rightarrow> ('a, 'b set) rbt \<Rightarrow> ('a, 'b set) rbt" where
	+ "add_to_rbt = (\<lambda>(a, b) t. case rbt_lookup t a of Some X \<Rightarrow> rbt_insert a (insert b X) t \| None \<Rightarrow> rbt_insert a {b} t)"
	+
	+abbreviation "add_option_to_rbt f \<equiv> (\<lambda>b _ t. case f b of Some a \<Rightarrow> add_to_rbt (a, b) t \| None \<Rightarrow> t)"
	+
	+definition cluster_rbt :: "('b \<Rightarrow> 'a option) \<Rightarrow> ('b, unit) rbt \<Rightarrow> ('a, 'b set) rbt" where
	+ "cluster_rbt f t = RBT_Impl.fold (add_option_to_rbt f) t RBT_Impl.Empty"
	+
	+end
	+
	+context linorder
	+begin
	+
	+lemma is_rbt_add_to_rbt: "is_rbt t \<Longrightarrow> is_rbt (add_to_rbt ab t)"
	+ by (auto simp: add_to_rbt_def split: prod.splits option.splits)
	+
	+lemma is_rbt_fold_add_to_rbt: "is_rbt t' \<Longrightarrow>
	+ is_rbt (RBT_Impl.fold (add_option_to_rbt f) t t')"
	+ by (induction t arbitrary: t') (auto 0 0 simp: is_rbt_add_to_rbt split: option.splits)
	+
	+lemma is_rbt_cluster_rbt: "is_rbt (cluster_rbt f t)"
	+ using is_rbt_fold_add_to_rbt Empty_is_rbt
	+ by (fastforce simp: cluster_rbt_def)
	+
	+lemma rbt_insert_entries_None: "is_rbt t \<Longrightarrow> rbt_lookup t k = None \<Longrightarrow>
	+ set (RBT_Impl.entries (rbt_insert k v t)) = insert (k, v) (set (RBT_Impl.entries t))"
	+ by (auto simp: rbt_lookup_in_tree[symmetric] rbt_lookup_rbt_insert split: if_splits)
	+
	+lemma rbt_insert_entries_Some: "is_rbt t \<Longrightarrow> rbt_lookup t k = Some v' \<Longrightarrow>
	+ set (RBT_Impl.entries (rbt_insert k v t)) = insert (k, v) (set (RBT_Impl.entries t) - {(k, v')})"
	+ by (auto simp: rbt_lookup_in_tree[symmetric] rbt_lookup_rbt_insert split: if_splits)
	+
	+lemma keys_add_to_rbt: "is_rbt t \<Longrightarrow> set (RBT_Impl.keys (add_to_rbt (a, b) t)) = insert a (set (RBT_Impl.keys t))"
	+ by (auto simp: add_to_rbt_def RBT_Impl.keys_def rbt_insert_entries_None rbt_insert_entries_Some split: option.splits)
	+
	+lemma keys_fold_add_to_rbt: "is_rbt t' \<Longrightarrow> set (RBT_Impl.keys (RBT_Impl.fold (add_option_to_rbt f) t t')) =
	+ Option.these (f ` set (RBT_Impl.keys t)) \<union> set (RBT_Impl.keys t')"
	+proof (induction t arbitrary: t')
	+ case (Branch col t1 k v t2)
	+ have valid: "is_rbt (RBT_Impl.fold (add_option_to_rbt f) t1 t')"
	+ using Branch(3)
	+ by (auto intro: is_rbt_fold_add_to_rbt)
	+ show ?case
	+ proof (cases "f k")
	+ case None
	+ show ?thesis
	+ by (auto simp: None Branch(2)[OF valid] Branch(1)[OF Branch(3)])
	+ next
	+ case (Some a)
	+ have valid': "is_rbt (add_to_rbt (a, k) (RBT_Impl.fold (add_option_to_rbt f) t1 t'))"
	+ by (auto intro: is_rbt_add_to_rbt[OF valid])
	+ show ?thesis
	+ by (auto simp: Some Branch(2)[OF valid'] keys_add_to_rbt[OF valid] Branch(1)[OF Branch(3)])
	+ qed
	+qed auto
	+
	+lemma rbt_lookup_add_to_rbt: "is_rbt t \<Longrightarrow> rbt_lookup (add_to_rbt (a, b) t) x = (if a = x then Some (case rbt_lookup t x of None \<Rightarrow> {b} \| Some Y \<Rightarrow> insert b Y) else rbt_lookup t x)"
	+ by (auto simp: add_to_rbt_def rbt_lookup_rbt_insert split: option.splits)
	+
	+lemma rbt_lookup_fold_add_to_rbt: "is_rbt t' \<Longrightarrow> rbt_lookup (RBT_Impl.fold (add_option_to_rbt f) t t') x =
	+ (if x \<in> Option.these (f ` set (RBT_Impl.keys t)) \<union> set (RBT_Impl.keys t') then Some ({y \<in> set (RBT_Impl.keys t). f y = Some x}
	+ \<union> (case rbt_lookup t' x of None \<Rightarrow> {} \| Some Y \<Rightarrow> Y)) else None)"
	+proof (induction t arbitrary: t')
	+ case Empty
	+ then show ?case
	+ using rbt_lookup_iff_keys(2,3)[OF is_rbt_rbt_sorted]
	+ by (fastforce split: option.splits)
	+next
	+ case (Branch col t1 k v t2)
	+ have valid: "is_rbt (RBT_Impl.fold (add_option_to_rbt f) t1 t')"
	+ using Branch(3)
	+ by (auto intro: is_rbt_fold_add_to_rbt)
	+ show ?case
	+ proof (cases "f k")
	+ case None
	+ have fold_set: "x \<in> Option.these (f ` set (RBT_Impl.keys t2)) \<union> ((Option.these (f ` set (RBT_Impl.keys t1)) \<union> set (RBT_Impl.keys t'))) \<longleftrightarrow>
	+ x \<in> Option.these (f ` set (RBT_Impl.keys (Branch col t1 k v t2))) \<union> set (RBT_Impl.keys t')"
	+ by (auto simp: None)
	+ show ?thesis
	+ unfolding fold_simps comp_def None option.case(1) Branch(2)[OF valid] keys_add_to_rbt[OF valid] keys_fold_add_to_rbt[OF Branch(3)]
	+ rbt_lookup_add_to_rbt[OF valid] Branch(1)[OF Branch(3)] fold_set
	+ using rbt_lookup_iff_keys(2,3)[OF is_rbt_rbt_sorted[OF Branch(3)]]
	+ by (auto simp: None split: option.splits) (auto dest: these_imageI)
	+ next
	+ case (Some a)
	+ have valid': "is_rbt (add_to_rbt (a, k) (RBT_Impl.fold (add_option_to_rbt f) t1 t'))"
	+ by (auto intro: is_rbt_add_to_rbt[OF valid])
	+ have fold_set: "x \<in> Option.these (f ` set (RBT_Impl.keys t2)) \<union> (insert a (Option.these (f ` set (RBT_Impl.keys t1)) \<union> set (RBT_Impl.keys t'))) \<longleftrightarrow>
	+ x \<in> Option.these (f ` set (RBT_Impl.keys (Branch col t1 k v t2))) \<union> set (RBT_Impl.keys t')"
	+ by (auto simp: Some)
	+ have F1: "(case if P then Some X else None of None \<Rightarrow> {k} \| Some Y \<Rightarrow> insert k Y) =
	+ (if P then (insert k X) else {k})" for P X
	+ by auto
	+ have F2: "(case if a = x then Some X else if P then Some Y else None of None \<Rightarrow> {} \| Some Y \<Rightarrow> Y) =
	+ (if a = x then X else if P then Y else {})"
	+ for P X and Y :: "'b set"
	+ by auto
	+ show ?thesis
	+ unfolding fold_simps comp_def Some option.case(2) Branch(2)[OF valid'] keys_add_to_rbt[OF valid] keys_fold_add_to_rbt[OF Branch(3)]
	+ rbt_lookup_add_to_rbt[OF valid] Branch(1)[OF Branch(3)] fold_set F1 F2
	+ using rbt_lookup_iff_keys(2,3)[OF is_rbt_rbt_sorted[OF Branch(3)]]
	+ by (auto simp: Some split: option.splits) (auto dest: these_imageI)
	+ qed
	+qed
	+
	+end
	+
	+context
	+ fixes c :: "'a comparator"
	+begin
	+
	+definition add_to_rbt_comp :: "'a \<times> 'b \<Rightarrow> ('a, 'b set) rbt \<Rightarrow> ('a, 'b set) rbt" where
	+ "add_to_rbt_comp = (\<lambda>(a, b) t. case rbt_comp_lookup c t a of None \<Rightarrow> rbt_comp_insert c a {b} t
	+ \| Some X \<Rightarrow> rbt_comp_insert c a (insert b X) t)"
	+
	+abbreviation "add_option_to_rbt_comp f \<equiv> (\<lambda>b _ t. case f b of Some a \<Rightarrow> add_to_rbt_comp (a, b) t \| None \<Rightarrow> t)"
	+
	+definition cluster_rbt_comp :: "('b \<Rightarrow> 'a option) \<Rightarrow> ('b, unit) rbt \<Rightarrow> ('a, 'b set) rbt" where
	+ "cluster_rbt_comp f t = RBT_Impl.fold (add_option_to_rbt_comp f) t RBT_Impl.Empty"
	+
	+context
	+ assumes c: "comparator c"
	+begin
	+
	+lemma add_to_rbt_comp: "add_to_rbt_comp = ord.add_to_rbt (lt_of_comp c)"
	+ unfolding add_to_rbt_comp_def ord.add_to_rbt_def rbt_comp_lookup[OF c] rbt_comp_insert[OF c]
	+ by simp
	+
	+lemma cluster_rbt_comp: "cluster_rbt_comp = ord.cluster_rbt (lt_of_comp c)"
	+ unfolding cluster_rbt_comp_def ord.cluster_rbt_def add_to_rbt_comp
	+ by simp
	+
	+end
	+
	+end
	+
	+lift_definition mapping_of_cluster :: "('b \<Rightarrow> 'a :: ccompare option) \<Rightarrow> ('b, unit) rbt \<Rightarrow> ('a, 'b set) mapping_rbt" is
	+ "cluster_rbt_comp ccomp"
	+ using linorder.is_rbt_fold_add_to_rbt[OF comparator.linorder[OF ID_ccompare'] ord.Empty_is_rbt]
	+ by (fastforce simp: cluster_rbt_comp[OF ID_ccompare'] ord.cluster_rbt_def)
	+
	+lemma cluster_code[code]:
	+ fixes f :: "'b :: ccompare \<Rightarrow> 'a :: ccompare option" and t :: "('b, unit) mapping_rbt"
	+ shows "cluster f (RBT_set t) = (case ID CCOMPARE('a) of None \<Rightarrow>
	+ Code.abort (STR ''cluster: ccompare = None'') (\<lambda>_. cluster f (RBT_set t))
	+ \| Some c \<Rightarrow> (case ID CCOMPARE('b) of None \<Rightarrow>
	+ Code.abort (STR ''cluster: ccompare = None'') (\<lambda>_. cluster f (RBT_set t))
	+ \| Some c' \<Rightarrow> (RBT_Mapping (mapping_of_cluster f (RBT_Mapping2.impl_of t)))))"
	+proof -
	+ {
	+ fix c c'
	+ assume assms: "ID ccompare = (Some c :: 'a comparator option)" "ID ccompare = (Some c' :: 'b comparator option)"
	+ have c_def: "c = ccomp"
	+ using assms(1)
	+ by auto
	+ have c'_def: "c' = ccomp"
	+ using assms(2)
	+ by auto
	+ have c: "comparator (ccomp :: 'a comparator)"
	+ using ID_ccompare'[OF assms(1)]
	+ by (auto simp: c_def)
	+ have c': "comparator (ccomp :: 'b comparator)"
	+ using ID_ccompare'[OF assms(2)]
	+ by (auto simp: c'_def)
	+ note c_class = comparator.linorder[OF c]
	+ note c'_class = comparator.linorder[OF c']
	+ have rbt_lookup_cluster: "ord.rbt_lookup cless (cluster_rbt_comp ccomp f t) =
	+ (\<lambda>x. if x \<in> Option.these (f ` (set (RBT_Impl.keys t))) then Some {y \<in> (set (RBT_Impl.keys t)). f y = Some x} else None)"
	+ if "ord.is_rbt cless (t :: ('b, unit) rbt) \<or> ID ccompare = (None :: 'b comparator option)" for t
	+ proof -
	+ have is_rbt_t: "ord.is_rbt cless t"
	+ using assms that
	+ by auto
	+ show ?thesis
	+ unfolding cluster_rbt_comp[OF c] ord.cluster_rbt_def linorder.rbt_lookup_fold_add_to_rbt[OF c_class ord.Empty_is_rbt]
	+ by (auto simp: ord.rbt_lookup.simps split: option.splits)
	+ qed
	+ have dom_ord_rbt_lookup: "ord.is_rbt cless t \<Longrightarrow> dom (ord.rbt_lookup cless t) = set (RBT_Impl.keys t)" for t :: "('b, unit) rbt"
	+ using linorder.rbt_lookup_keys[OF c'_class] ord.is_rbt_def
	+ by auto
	+ have "cluster f (Collect (RBT_Set2.member t)) = Mapping (RBT_Mapping2.lookup (mapping_of_cluster f (mapping_rbt.impl_of t)))"
	+ using assms(2)[unfolded c'_def]
	+ by (transfer fixing: f) (auto simp: in_these_eq rbt_comp_lookup[OF c] rbt_comp_lookup[OF c'] rbt_lookup_cluster dom_ord_rbt_lookup)
	+ }
	+ then show ?thesis
	+ unfolding RBT_set_def
	+ by (auto split: option.splits)
	+qed
	+
	+end
	diff --git a/thys/Eval_FO/Eval_FO.thy b/thys/Eval_FO/Eval_FO.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/Eval_FO.thy
	@@ -0,0 +1,168 @@
	+theory Eval_FO
	+ imports Infinite FO
	+begin
	+
	+datatype 'a eval_res = Fin "'a table" \| Infin \| Wf_error
	+
	+locale eval_fo =
	+ fixes wf :: "('a :: infinite, 'b) fo_fmla \<Rightarrow> ('b \<times> nat \<Rightarrow> 'a list set) \<Rightarrow> 't \<Rightarrow> bool"
	+ and abs :: "('a fo_term) list \<Rightarrow> 'a table \<Rightarrow> 't"
	+ and rep :: "'t \<Rightarrow> 'a table"
	+ and res :: "'t \<Rightarrow> 'a eval_res"
	+ and eval_bool :: "bool \<Rightarrow> 't"
	+ and eval_eq :: "'a fo_term \<Rightarrow> 'a fo_term \<Rightarrow> 't"
	+ and eval_neg :: "nat list \<Rightarrow> 't \<Rightarrow> 't"
	+ and eval_conj :: "nat list \<Rightarrow> 't \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
	+ and eval_ajoin :: "nat list \<Rightarrow> 't \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
	+ and eval_disj :: "nat list \<Rightarrow> 't \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
	+ and eval_exists :: "nat \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
	+ and eval_forall :: "nat \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
	+ assumes fo_rep: "wf \<phi> I t \<Longrightarrow> rep t = proj_sat \<phi> I"
	+ and fo_res_fin: "wf \<phi> I t \<Longrightarrow> finite (rep t) \<Longrightarrow> res t = Fin (rep t)"
	+ and fo_res_infin: "wf \<phi> I t \<Longrightarrow> \<not>finite (rep t) \<Longrightarrow> res t = Infin"
	+ and fo_abs: "finite (I (r, length ts)) \<Longrightarrow> wf (Pred r ts) I (abs ts (I (r, length ts)))"
	+ and fo_bool: "wf (Bool b) I (eval_bool b)"
	+ and fo_eq: "wf (Eqa trm trm') I (eval_eq trm trm')"
	+ and fo_neg: "wf \<phi> I t \<Longrightarrow> wf (Neg \<phi>) I (eval_neg (fv_fo_fmla_list \<phi>) t)"
	+ and fo_conj: "wf \<phi> I t\<phi> \<Longrightarrow> wf \<psi> I t\<psi> \<Longrightarrow> (case \<psi> of Neg \<psi>' \<Rightarrow> False \| _ \<Rightarrow> True) \<Longrightarrow>
	+ wf (Conj \<phi> \<psi>) I (eval_conj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>)"
	+ and fo_ajoin: "wf \<phi> I t\<phi> \<Longrightarrow> wf \<psi>' I t\<psi>' \<Longrightarrow>
	+ wf (Conj \<phi> (Neg \<psi>')) I (eval_ajoin (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>') t\<psi>')"
	+ and fo_disj: "wf \<phi> I t\<phi> \<Longrightarrow> wf \<psi> I t\<psi> \<Longrightarrow>
	+ wf (Disj \<phi> \<psi>) I (eval_disj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>)"
	+ and fo_exists: "wf \<phi> I t \<Longrightarrow> wf (Exists i \<phi>) I (eval_exists i (fv_fo_fmla_list \<phi>) t)"
	+ and fo_forall: "wf \<phi> I t \<Longrightarrow> wf (Forall i \<phi>) I (eval_forall i (fv_fo_fmla_list \<phi>) t)"
	+begin
	+
	+fun eval_fmla :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 't" where
	+ "eval_fmla (Pred r ts) I = abs ts (I (r, length ts))"
	+\| "eval_fmla (Bool b) I = eval_bool b"
	+\| "eval_fmla (Eqa t t') I = eval_eq t t'"
	+\| "eval_fmla (Neg \<phi>) I = eval_neg (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)"
	+\| "eval_fmla (Conj \<phi> \<psi>) I = (let ns\<phi> = fv_fo_fmla_list \<phi>; ns\<psi> = fv_fo_fmla_list \<psi>;
	+ X\<phi> = eval_fmla \<phi> I in
	+ case \<psi> of Neg \<psi>' \<Rightarrow> let X\<psi>' = eval_fmla \<psi>' I in
	+ eval_ajoin ns\<phi> X\<phi> (fv_fo_fmla_list \<psi>') X\<psi>'
	+ \| _ \<Rightarrow> eval_conj ns\<phi> X\<phi> ns\<psi> (eval_fmla \<psi> I))"
	+\| "eval_fmla (Disj \<phi> \<psi>) I = eval_disj (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)
	+ (fv_fo_fmla_list \<psi>) (eval_fmla \<psi> I)"
	+\| "eval_fmla (Exists i \<phi>) I = eval_exists i (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)"
	+\| "eval_fmla (Forall i \<phi>) I = eval_forall i (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)"
	+
	+lemma eval_fmla_correct:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes "wf_fo_intp \<phi> I"
	+ shows "wf \<phi> I (eval_fmla \<phi> I)"
	+ using assms
	+proof (induction \<phi> I rule: eval_fmla.induct)
	+ case (1 r ts I)
	+ then show ?case
	+ using fo_abs
	+ by auto
	+next
	+ case (2 b I)
	+ then show ?case
	+ using fo_bool
	+ by auto
	+next
	+ case (3 t t' I)
	+ then show ?case
	+ using fo_eq
	+ by auto
	+next
	+ case (4 \<phi> I)
	+ then show ?case
	+ using fo_neg
	+ by auto
	+next
	+ case (5 \<phi> \<psi> I)
	+ have fins: "wf_fo_intp \<phi> I" "wf_fo_intp \<psi> I"
	+ using 5(10)
	+ by auto
	+ have eval\<phi>: "wf \<phi> I (eval_fmla \<phi> I)"
	+ using 5(1)[OF _ _ fins(1)]
	+ by auto
	+ show ?case
	+ proof (cases "\<exists>\<psi>'. \<psi> = Neg \<psi>'")
	+ case True
	+ then obtain \<psi>' where \<psi>_def: "\<psi> = Neg \<psi>'"
	+ by auto
	+ have fin: "wf_fo_intp \<psi>' I"
	+ using fins(2)
	+ by (auto simp: \<psi>_def)
	+ have eval\<psi>': "wf \<psi>' I (eval_fmla \<psi>' I)"
	+ using 5(5)[OF _ _ _ \<psi>_def fin]
	+ by auto
	+ show ?thesis
	+ unfolding \<psi>_def
	+ using fo_ajoin[OF eval\<phi> eval\<psi>']
	+ by auto
	+ next
	+ case False
	+ then have eval\<psi>: "wf \<psi> I (eval_fmla \<psi> I)"
	+ using 5 fins(2)
	+ by (cases \<psi>) auto
	+ have eval: "eval_fmla (Conj \<phi> \<psi>) I = eval_conj (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)
	+ (fv_fo_fmla_list \<psi>) (eval_fmla \<psi> I)"
	+ using False
	+ by (auto simp: Let_def split: fo_fmla.splits)
	+ show "wf (Conj \<phi> \<psi>) I (eval_fmla (Conj \<phi> \<psi>) I)"
	+ using fo_conj[OF eval\<phi> eval\<psi>, folded eval] False
	+ by (auto split: fo_fmla.splits)
	+ qed
	+next
	+ case (6 \<phi> \<psi> I)
	+ then show ?case
	+ using fo_disj
	+ by auto
	+next
	+ case (7 i \<phi> I)
	+ then show ?case
	+ using fo_exists
	+ by auto
	+next
	+ case (8 i \<phi> I)
	+ then show ?case
	+ using fo_forall
	+ by auto
	+qed
	+
	+definition eval :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 'a eval_res" where
	+ "eval \<phi> I = (if wf_fo_intp \<phi> I then res (eval_fmla \<phi> I) else Wf_error)"
	+
	+lemma eval_fmla_proj_sat:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes "wf_fo_intp \<phi> I"
	+ shows "rep (eval_fmla \<phi> I) = proj_sat \<phi> I"
	+ using eval_fmla_correct[OF assms]
	+ by (auto simp: fo_rep)
	+
	+lemma eval_sound:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes "eval \<phi> I = Fin Z"
	+ shows "Z = proj_sat \<phi> I"
	+proof -
	+ have "wf \<phi> I (eval_fmla \<phi> I)"
	+ using eval_fmla_correct assms
	+ by (auto simp: eval_def split: if_splits)
	+ then show ?thesis
	+ using assms fo_res_fin fo_res_infin
	+ by (fastforce simp: eval_def fo_rep split: if_splits)
	+qed
	+
	+lemma eval_complete:
	+ fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
	+ assumes "eval \<phi> I = Infin"
	+ shows "infinite (proj_sat \<phi> I)"
	+proof -
	+ have "wf \<phi> I (eval_fmla \<phi> I)"
	+ using eval_fmla_correct assms
	+ by (auto simp: eval_def split: if_splits)
	+ then show ?thesis
	+ using assms fo_res_fin
	+ by (auto simp: eval_def fo_rep split: if_splits)
	+qed
	+
	+end
	+
	+end
	diff --git a/thys/Eval_FO/FO.thy b/thys/Eval_FO/FO.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/FO.thy
	@@ -0,0 +1,220 @@
	+theory FO
	+ imports Main
	+begin
	+
	+abbreviation "sorted_distinct xs \<equiv> sorted xs \<and> distinct xs"
	+
	+datatype 'a fo_term = Const 'a \| Var nat
	+
	+type_synonym 'a val = "nat \<Rightarrow> 'a"
	+
	+fun list_fo_term :: "'a fo_term \<Rightarrow> 'a list" where
	+ "list_fo_term (Const c) = [c]"
	+\| "list_fo_term _ = []"
	+
	+fun fv_fo_term_list :: "'a fo_term \<Rightarrow> nat list" where
	+ "fv_fo_term_list (Var n) = [n]"
	+\| "fv_fo_term_list _ = []"
	+
	+fun fv_fo_term_set :: "'a fo_term \<Rightarrow> nat set" where
	+ "fv_fo_term_set (Var n) = {n}"
	+\| "fv_fo_term_set _ = {}"
	+
	+definition fv_fo_terms_set :: "('a fo_term) list \<Rightarrow> nat set" where
	+ "fv_fo_terms_set ts = \<Union>(set (map fv_fo_term_set ts))"
	+
	+fun fv_fo_terms_list_rec :: "('a fo_term) list \<Rightarrow> nat list" where
	+ "fv_fo_terms_list_rec [] = []"
	+\| "fv_fo_terms_list_rec (t # ts) = fv_fo_term_list t @ fv_fo_terms_list_rec ts"
	+
	+definition fv_fo_terms_list :: "('a fo_term) list \<Rightarrow> nat list" where
	+ "fv_fo_terms_list ts = remdups_adj (sort (fv_fo_terms_list_rec ts))"
	+
	+fun eval_term :: "'a val \<Rightarrow> 'a fo_term \<Rightarrow> 'a" (infix "\<cdot>" 60) where
	+ "eval_term \<sigma> (Const c) = c"
	+\| "eval_term \<sigma> (Var n) = \<sigma> n"
	+
	+definition eval_terms :: "'a val \<Rightarrow> ('a fo_term) list \<Rightarrow> 'a list" (infix "\<odot>" 60) where
	+ "eval_terms \<sigma> ts = map (eval_term \<sigma>) ts"
	+
	+lemma finite_set_fo_term: "finite (set_fo_term t)"
	+ by (cases t) auto
	+
	+lemma list_fo_term_set: "set (list_fo_term t) = set_fo_term t"
	+ by (cases t) auto
	+
	+lemma finite_fv_fo_term_set: "finite (fv_fo_term_set t)"
	+ by (cases t) auto
	+
	+lemma fv_fo_term_setD: "n \<in> fv_fo_term_set t \<Longrightarrow> t = Var n"
	+ by (cases t) auto
	+
	+lemma fv_fo_term_set_list: "set (fv_fo_term_list t) = fv_fo_term_set t"
	+ by (cases t) auto
	+
	+lemma sorted_distinct_fv_fo_term_list: "sorted_distinct (fv_fo_term_list t)"
	+ by (cases t) auto
	+
	+lemma fv_fo_term_set_cong: "fv_fo_term_set t = fv_fo_term_set (map_fo_term f t)"
	+ by (cases t) auto
	+
	+lemma fv_fo_terms_setI: "Var m \<in> set ts \<Longrightarrow> m \<in> fv_fo_terms_set ts"
	+ by (induction ts) (auto simp: fv_fo_terms_set_def)
	+
	+lemma fv_fo_terms_setD: "m \<in> fv_fo_terms_set ts \<Longrightarrow> Var m \<in> set ts"
	+ by (induction ts) (auto simp: fv_fo_terms_set_def dest: fv_fo_term_setD)
	+
	+lemma finite_fv_fo_terms_set: "finite (fv_fo_terms_set ts)"
	+ by (auto simp: fv_fo_terms_set_def finite_fv_fo_term_set)
	+
	+lemma fv_fo_terms_set_list: "set (fv_fo_terms_list ts) = fv_fo_terms_set ts"
	+ using fv_fo_term_set_list
	+ unfolding fv_fo_terms_list_def
	+ by (induction ts rule: fv_fo_terms_list_rec.induct)
	+ (auto simp: fv_fo_terms_set_def set_insort_key)
	+
	+lemma distinct_remdups_adj_sort: "sorted xs \<Longrightarrow> distinct (remdups_adj xs)"
	+ by (induction xs rule: induct_list012) auto
	+
	+lemma sorted_distinct_fv_fo_terms_list: "sorted_distinct (fv_fo_terms_list ts)"
	+ unfolding fv_fo_terms_list_def
	+ by (induction ts rule: fv_fo_terms_list_rec.induct)
	+ (auto simp add: sorted_insort intro: distinct_remdups_adj_sort)
	+
	+lemma fv_fo_terms_set_cong: "fv_fo_terms_set ts = fv_fo_terms_set (map (map_fo_term f) ts)"
	+ using fv_fo_term_set_cong
	+ by (induction ts) (fastforce simp: fv_fo_terms_set_def)+
	+
	+lemma eval_term_cong: "(\<And>n. n \<in> fv_fo_term_set t \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
	+ eval_term \<sigma> t = eval_term \<sigma>' t"
	+ by (cases t) auto
	+
	+lemma eval_terms_fv_fo_terms_set: "\<sigma> \<odot> ts = \<sigma>' \<odot> ts \<Longrightarrow> n \<in> fv_fo_terms_set ts \<Longrightarrow> \<sigma> n = \<sigma>' n"
	+proof (induction ts)
	+ case (Cons t ts)
	+ then show ?case
	+ by (cases t) (auto simp: eval_terms_def fv_fo_terms_set_def)
	+qed (auto simp: eval_terms_def fv_fo_terms_set_def)
	+
	+lemma eval_terms_cong: "(\<And>n. n \<in> fv_fo_terms_set ts \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
	+ eval_terms \<sigma> ts = eval_terms \<sigma>' ts"
	+ by (auto simp: eval_terms_def fv_fo_terms_set_def intro: eval_term_cong)
	+
	+datatype ('a, 'b) fo_fmla =
	+ Pred 'b "('a fo_term) list"
	+\| Bool bool
	+\| Eqa "'a fo_term" "'a fo_term"
	+\| Neg "('a, 'b) fo_fmla"
	+\| Conj "('a, 'b) fo_fmla" "('a, 'b) fo_fmla"
	+\| Disj "('a, 'b) fo_fmla" "('a, 'b) fo_fmla"
	+\| Exists nat "('a, 'b) fo_fmla"
	+\| Forall nat "('a, 'b) fo_fmla"
	+
	+fun fv_fo_fmla_list_rec :: "('a, 'b) fo_fmla \<Rightarrow> nat list" where
	+ "fv_fo_fmla_list_rec (Pred _ ts) = fv_fo_terms_list ts"
	+\| "fv_fo_fmla_list_rec (Bool b) = []"
	+\| "fv_fo_fmla_list_rec (Eqa t t') = fv_fo_term_list t @ fv_fo_term_list t'"
	+\| "fv_fo_fmla_list_rec (Neg \<phi>) = fv_fo_fmla_list_rec \<phi>"
	+\| "fv_fo_fmla_list_rec (Conj \<phi> \<psi>) = fv_fo_fmla_list_rec \<phi> @ fv_fo_fmla_list_rec \<psi>"
	+\| "fv_fo_fmla_list_rec (Disj \<phi> \<psi>) = fv_fo_fmla_list_rec \<phi> @ fv_fo_fmla_list_rec \<psi>"
	+\| "fv_fo_fmla_list_rec (Exists n \<phi>) = filter (\<lambda>m. n \<noteq> m) (fv_fo_fmla_list_rec \<phi>)"
	+\| "fv_fo_fmla_list_rec (Forall n \<phi>) = filter (\<lambda>m. n \<noteq> m) (fv_fo_fmla_list_rec \<phi>)"
	+
	+definition fv_fo_fmla_list :: "('a, 'b) fo_fmla \<Rightarrow> nat list" where
	+ "fv_fo_fmla_list \<phi> = remdups_adj (sort (fv_fo_fmla_list_rec \<phi>))"
	+
	+fun fv_fo_fmla :: "('a, 'b) fo_fmla \<Rightarrow> nat set" where
	+ "fv_fo_fmla (Pred _ ts) = fv_fo_terms_set ts"
	+\| "fv_fo_fmla (Bool b) = {}"
	+\| "fv_fo_fmla (Eqa t t') = fv_fo_term_set t \<union> fv_fo_term_set t'"
	+\| "fv_fo_fmla (Neg \<phi>) = fv_fo_fmla \<phi>"
	+\| "fv_fo_fmla (Conj \<phi> \<psi>) = fv_fo_fmla \<phi> \<union> fv_fo_fmla \<psi>"
	+\| "fv_fo_fmla (Disj \<phi> \<psi>) = fv_fo_fmla \<phi> \<union> fv_fo_fmla \<psi>"
	+\| "fv_fo_fmla (Exists n \<phi>) = fv_fo_fmla \<phi> - {n}"
	+\| "fv_fo_fmla (Forall n \<phi>) = fv_fo_fmla \<phi> - {n}"
	+
	+lemma finite_fv_fo_fmla: "finite (fv_fo_fmla \<phi>)"
	+ by (induction \<phi> rule: fv_fo_fmla.induct)
	+ (auto simp: finite_fv_fo_term_set finite_fv_fo_terms_set)
	+
	+lemma fv_fo_fmla_list_set: "set (fv_fo_fmla_list \<phi>) = fv_fo_fmla \<phi>"
	+ unfolding fv_fo_fmla_list_def
	+ by (induction \<phi> rule: fv_fo_fmla.induct) (auto simp: fv_fo_terms_set_list fv_fo_term_set_list)
	+
	+lemma sorted_distinct_fv_list: "sorted_distinct (fv_fo_fmla_list \<phi>)"
	+ by (auto simp: fv_fo_fmla_list_def intro: distinct_remdups_adj_sort)
	+
	+lemma length_fv_fo_fmla_list: "length (fv_fo_fmla_list \<phi>) = card (fv_fo_fmla \<phi>)"
	+ using fv_fo_fmla_list_set[of \<phi>] sorted_distinct_fv_list[of \<phi>]
	+ distinct_card[of "fv_fo_fmla_list \<phi>"]
	+ by auto
	+
	+lemma fv_fo_fmla_list_eq: "fv_fo_fmla \<phi> = fv_fo_fmla \<psi> \<Longrightarrow> fv_fo_fmla_list \<phi> = fv_fo_fmla_list \<psi>"
	+ using fv_fo_fmla_list_set sorted_distinct_fv_list
	+ by (metis sorted_distinct_set_unique)
	+
	+lemma fv_fo_fmla_list_Conj: "fv_fo_fmla_list (Conj \<phi> \<psi>) = fv_fo_fmla_list (Conj \<psi> \<phi>)"
	+ using fv_fo_fmla_list_eq[of "Conj \<phi> \<psi>" "Conj \<psi> \<phi>"]
	+ by auto
	+
	+type_synonym 'a table = "('a list) set"
	+
	+type_synonym ('t, 'b) fo_intp = "'b \<times> nat \<Rightarrow> 't"
	+
	+fun wf_fo_intp :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> bool" where
	+ "wf_fo_intp (Pred r ts) I \<longleftrightarrow> finite (I (r, length ts))"
	+\| "wf_fo_intp (Bool b) I \<longleftrightarrow> True"
	+\| "wf_fo_intp (Eqa t t') I \<longleftrightarrow> True"
	+\| "wf_fo_intp (Neg \<phi>) I \<longleftrightarrow> wf_fo_intp \<phi> I"
	+\| "wf_fo_intp (Conj \<phi> \<psi>) I \<longleftrightarrow> wf_fo_intp \<phi> I \<and> wf_fo_intp \<psi> I"
	+\| "wf_fo_intp (Disj \<phi> \<psi>) I \<longleftrightarrow> wf_fo_intp \<phi> I \<and> wf_fo_intp \<psi> I"
	+\| "wf_fo_intp (Exists n \<phi>) I \<longleftrightarrow> wf_fo_intp \<phi> I"
	+\| "wf_fo_intp (Forall n \<phi>) I \<longleftrightarrow> wf_fo_intp \<phi> I"
	+
	+fun sat :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 'a val \<Rightarrow> bool" where
	+ "sat (Pred r ts) I \<sigma> \<longleftrightarrow> \<sigma> \<odot> ts \<in> I (r, length ts)"
	+\| "sat (Bool b) I \<sigma> \<longleftrightarrow> b"
	+\| "sat (Eqa t t') I \<sigma> \<longleftrightarrow> \<sigma> \<cdot> t = \<sigma> \<cdot> t'"
	+\| "sat (Neg \<phi>) I \<sigma> \<longleftrightarrow> \<not>sat \<phi> I \<sigma>"
	+\| "sat (Conj \<phi> \<psi>) I \<sigma> \<longleftrightarrow> sat \<phi> I \<sigma> \<and> sat \<psi> I \<sigma>"
	+\| "sat (Disj \<phi> \<psi>) I \<sigma> \<longleftrightarrow> sat \<phi> I \<sigma> \<or> sat \<psi> I \<sigma>"
	+\| "sat (Exists n \<phi>) I \<sigma> \<longleftrightarrow> (\<exists>x. sat \<phi> I (\<sigma>(n := x)))"
	+\| "sat (Forall n \<phi>) I \<sigma> \<longleftrightarrow> (\<forall>x. sat \<phi> I (\<sigma>(n := x)))"
	+
	+lemma sat_fv_cong: "(\<And>n. n \<in> fv_fo_fmla \<phi> \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
	+ sat \<phi> I \<sigma> \<longleftrightarrow> sat \<phi> I \<sigma>'"
	+proof (induction \<phi> arbitrary: \<sigma> \<sigma>')
	+ case (Neg \<phi>)
	+ show ?case
	+ using Neg(1)[of \<sigma> \<sigma>'] Neg(2)
	+ by auto
	+next
	+ case (Conj \<phi> \<psi>)
	+ show ?case
	+ using Conj(1,2)[of \<sigma> \<sigma>'] Conj(3)
	+ by auto
	+next
	+ case (Disj \<phi> \<psi>)
	+ show ?case
	+ using Disj(1,2)[of \<sigma> \<sigma>'] Disj(3)
	+ by auto
	+next
	+ case (Exists n \<phi>)
	+ have "\<And>x. sat \<phi> I (\<sigma>(n := x)) = sat \<phi> I (\<sigma>'(n := x))"
	+ using Exists(2)
	+ by (auto intro!: Exists(1))
	+ then show ?case
	+ by simp
	+next
	+ case (Forall n \<phi>)
	+ have "\<And>x. sat \<phi> I (\<sigma>(n := x)) = sat \<phi> I (\<sigma>'(n := x))"
	+ using Forall(2)
	+ by (auto intro!: Forall(1))
	+ then show ?case
	+ by simp
	+qed (auto cong: eval_terms_cong eval_term_cong)
	+
	+definition proj_sat :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 'a table" where
	+ "proj_sat \<phi> I = (\<lambda>\<sigma>. map \<sigma> (fv_fo_fmla_list \<phi>)) ` {\<sigma>. sat \<phi> I \<sigma>}"
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Eval_FO/Infinite.thy b/thys/Eval_FO/Infinite.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/Infinite.thy
	@@ -0,0 +1,32 @@
	+theory Infinite
	+ imports Main
	+begin
	+
	+class infinite =
	+ assumes infinite_UNIV: "infinite (UNIV :: 'a set)"
	+begin
	+
	+lemma arb_element: "finite Y \<Longrightarrow> \<exists>x :: 'a. x \<notin> Y"
	+ using ex_new_if_finite infinite_UNIV
	+ by blast
	+
	+lemma arb_finite_subset: "finite Y \<Longrightarrow> \<exists>X :: 'a set. Y \<inter> X = {} \<and> finite X \<and> n \<le> card X"
	+proof -
	+ assume fin: "finite Y"
	+ then obtain X where "X \<subseteq> UNIV - Y" "finite X" "n \<le> card X"
	+ using infinite_UNIV
	+ by (metis Compl_eq_Diff_UNIV finite_compl infinite_arbitrarily_large order_refl)
	+ then show ?thesis
	+ by auto
	+qed
	+
	+lemma arb_countable_map: "finite Y \<Longrightarrow> \<exists>f :: (nat \<Rightarrow> 'a). inj f \<and> range f \<subseteq> UNIV - Y"
	+ using infinite_UNIV
	+ by (auto simp: infinite_countable_subset)
	+
	+end
	+
	+instance nat :: infinite
	+ by standard auto
	+
	+end
	diff --git a/thys/Eval_FO/Mapping_Code.thy b/thys/Eval_FO/Mapping_Code.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/Mapping_Code.thy
	@@ -0,0 +1,61 @@
	+theory Mapping_Code
	+ imports "Containers.Mapping_Impl"
	+begin
	+
	+lift_definition set_of_idx :: "('a, 'b set) mapping \<Rightarrow> 'b set" is
	+ "\<lambda>m. \<Union>(ran m)" .
	+
	+lemma set_of_idx_code[code]:
	+ fixes t :: "('a :: ccompare, 'b set) mapping_rbt"
	+ shows "set_of_idx (RBT_Mapping t) =
	+ (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''set_of_idx RBT_Mapping: ccompare = None'') (\<lambda>_. set_of_idx (RBT_Mapping t))
	+ \| Some _ \<Rightarrow> \<Union>(snd ` set (RBT_Mapping2.entries t)))"
	+ unfolding RBT_Mapping_def
	+ by transfer (auto simp: ran_def rbt_comp_lookup[OF ID_ccompare'] ord.is_rbt_def linorder.rbt_lookup_in_tree[OF comparator.linorder[OF ID_ccompare']] split: option.splits)+
	+
	+lemma mapping_combine[code]:
	+ fixes t :: "('a :: ccompare, 'b) mapping_rbt"
	+ shows "Mapping.combine f (RBT_Mapping t) (RBT_Mapping u) =
	+ (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''combine RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.combine f (RBT_Mapping t) (RBT_Mapping u))
	+ \| Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.join (\<lambda>_. f) t u))"
	+ by (auto simp add: Mapping.combine.abs_eq Mapping_inject lookup_join split: option.split)
	+
	+lift_definition mapping_join :: "('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping" is
	+ "\<lambda>f m m' x. case m x of None \<Rightarrow> None \| Some y \<Rightarrow> (case m' x of None \<Rightarrow> None \| Some y' \<Rightarrow> Some (f y y'))" .
	+
	+lemma mapping_join_code[code]:
	+ fixes t :: "('a :: ccompare, 'b) mapping_rbt"
	+ shows "mapping_join f (RBT_Mapping t) (RBT_Mapping u) =
	+ (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''mapping_join RBT_Mapping: ccompare = None'') (\<lambda>_. mapping_join f (RBT_Mapping t) (RBT_Mapping u))
	+ \| Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.meet (\<lambda>_. f) t u))"
	+ by (auto simp add: mapping_join.abs_eq Mapping_inject lookup_meet split: option.split)
	+
	+context fixes dummy :: "'a :: ccompare" begin
	+
	+lift_definition diff ::
	+ "('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is "rbt_comp_minus ccomp"
	+ by (auto 4 3 intro: linorder.rbt_minus_is_rbt ID_ccompare ord.is_rbt_rbt_sorted simp: rbt_comp_minus[OF ID_ccompare'])
	+
	+end
	+
	+context assumes ID_ccompare_neq_None: "ID CCOMPARE('a :: ccompare) \<noteq> None"
	+begin
	+
	+lemma lookup_diff:
	+ "RBT_Mapping2.lookup (diff (t1 :: ('a, 'b) mapping_rbt) t2) =
	+ (\<lambda>k. case RBT_Mapping2.lookup t1 k of None \<Rightarrow> None \| Some v1 \<Rightarrow> (case RBT_Mapping2.lookup t2 k of None \<Rightarrow> Some v1 \| Some v2 \<Rightarrow> None))"
	+ by transfer (auto simp add: fun_eq_iff linorder.rbt_lookup_rbt_minus[OF mapping_linorder] ID_ccompare_neq_None restrict_map_def split: option.splits)
	+
	+end
	+
	+lift_definition mapping_antijoin :: "('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping" is
	+ "\<lambda>m m' x. case m x of None \<Rightarrow> None \| Some y \<Rightarrow> (case m' x of None \<Rightarrow> Some y \| Some y' \<Rightarrow> None)" .
	+
	+lemma mapping_antijoin_code[code]:
	+ fixes t :: "('a :: ccompare, 'b) mapping_rbt"
	+ shows "mapping_antijoin (RBT_Mapping t) (RBT_Mapping u) =
	+ (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''mapping_antijoin RBT_Mapping: ccompare = None'') (\<lambda>_. mapping_antijoin (RBT_Mapping t) (RBT_Mapping u))
	+ \| Some _ \<Rightarrow> RBT_Mapping (diff t u))"
	+ by (auto simp add: mapping_antijoin.abs_eq Mapping_inject lookup_diff split: option.split)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Eval_FO/ROOT b/thys/Eval_FO/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/ROOT
	@@ -0,0 +1,17 @@
	+chapter AFP
	+
	+session Eval_FO (AFP) = Containers +
	+ options [timeout=600]
	+ theories
	+ Ailamazyan_Code
	+ Ailamazyan
	+ Cluster
	+ Eval_FO
	+ FO
	+ Infinite
	+ Mapping_Code
	+ document_files
	+ "root.tex"
	+ "root.bib"
	+export_files (in ".") [2]
	+ "Eval_FO.Ailamazyan_Code:code/**"
	diff --git a/thys/Eval_FO/document/root.bib b/thys/Eval_FO/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/document/root.bib
	@@ -0,0 +1,45 @@
	+@article{AGSS86,
	+ author = {Ailamazyan, Alfred K. and Gilula, Mikhail M. and Stolboushkin, Alexei P. and Schwartz, Grigorii F.},
	+ title = {Reduction of a relational model with infinite domains to the case of finite domains},
	+ journal = {Dokl. Akad. Nauk SSSR},
	+ year = {1986},
	+ volume = {286},
	+ issue = {2},
	+ pages = {308--311},
	+ url = {http://mi.mathnet.ru/dan47310}
	+}
	+
	+@inproceedings{DBLP:conf/lics/AvronH91,
	+ author = {Arnon Avron and
	+ Yoram Hirshfeld},
	+ title = {On First Order Database Query Languages},
	+ booktitle = {Proceedings of the Sixth Annual Symposium on Logic in Computer Science
	+ {(LICS} '91), Amsterdam, The Netherlands, July 15-18, 1991},
	+ pages = {226--231},
	+ publisher = {{IEEE} Computer Society},
	+ year = {1991},
	+ url = {https://doi.org/10.1109/LICS.1991.151647},
	+ doi = {10.1109/LICS.1991.151647},
	+ timestamp = {Wed, 16 Oct 2019 14:14:54 +0200},
	+ biburl = {https://dblp.org/rec/conf/lics/AvronH91.bib},
	+ bibsource = {dblp computer science bibliography, https://dblp.org}
	+}
	+
	+@inproceedings{DBLP:conf/stoc/Vardi82,
	+ author = {Moshe Y. Vardi},
	+ editor = {Harry R. Lewis and
	+ Barbara B. Simons and
	+ Walter A. Burkhard and
	+ Lawrence H. Landweber},
	+ title = {The Complexity of Relational Query Languages (Extended Abstract)},
	+ booktitle = {Proceedings of the 14th Annual {ACM} Symposium on Theory of Computing,
	+ May 5-7, 1982, San Francisco, California, {USA}},
	+ pages = {137--146},
	+ publisher = {{ACM}},
	+ year = {1982},
	+ url = {https://doi.org/10.1145/800070.802186},
	+ doi = {10.1145/800070.802186},
	+ timestamp = {Wed, 14 Nov 2018 10:51:38 +0100},
	+ biburl = {https://dblp.org/rec/conf/stoc/Vardi82.bib},
	+ bibsource = {dblp computer science bibliography, https://dblp.org}
	+}
	diff --git a/thys/Eval_FO/document/root.tex b/thys/Eval_FO/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Eval_FO/document/root.tex
	@@ -0,0 +1,70 @@
	+\documentclass[10pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{a4wide}
	+\usepackage[english]{babel}
	+\usepackage{eufrak}
	+\usepackage{amssymb}
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{literal}
	+
	+
	+\begin{document}
	+
	+\title{First-Order Query Evaluation}
	+\author{Martin Raszyk}
	+
	+\maketitle
	+
	+\begin{abstract}
	+We formalize first-order query evaluation over an infinite domain with equality.
	+We first define the syntax and semantics of first-order logic with equality.
	+Next we define a locale $\mathit{eval\_fo}$ abstracting a representation of a
	+potentially infinite set of tuples satisfying a first-order query over finite
	+relations. Inside the locale, we define a function $\mathit{eval}$ checking if
	+the set of tuples satisfying a first-order query over a database (an
	+interpretation of the query's predicates) is finite (i.e., deciding
	+\emph{relative safety}) and computing the set of satisfying tuples if it is
	+finite. Altogether the function $\mathit{eval}$ solves
	+\emph{capturability}~\cite{DBLP:conf/lics/AvronH91} of first-order logic with
	+equality. We also use the function $\mathit{eval}$ to prove a code equation for
	+the semantics of first-order logic, i.e., the function checking if a first-order
	+query over a database is satisfied by a variable assignment.
	+
	+We provide an interpretation of the locale $\mathit{eval\_fo}$ based on the
	+approach by Ailamazyan et al.~\cite{AGSS86}. A core notion in the interpretation
	+is the active domain of a query and a database that contains all domain elements
	+that occur in the database or interpret the query's constants. We prove the main
	+theorem of Ailamazyan et al.~\cite{AGSS86} relating the satisfaction of a
	+first-order query over an infinite domain to the satisfaction of this query over
	+a finite domain consisting of the active domain and a few additional domain
	+elements (outside the active domain) whose number only depends on the query. In
	+our interpretation of the locale $\mathit{eval\_fo}$, we use a potentially
	+higher number of the additional domain elements, but their number still only
	+depends on the query and thus has no effect on the data
	+complexity~\cite{DBLP:conf/stoc/Vardi82} of query evaluation. Our interpretation
	+yields an \emph{executable} function $\mathit{eval}$. The time complexity of
	+$\mathit{eval}$ on a query is linear in the total number of tuples in the
	+intermediate relations for the subqueries. Specifically, we build a database
	+index to evaluate a conjunction. We also optimize the case of a negated subquery
	+in a conjunction. Finally, we export code for the infinite domain of natural
	+numbers.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+% sane default for proof documents
	+\parindent 0pt\parskip 0.5ex
	+
	+% generated text of all theories
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/FOL_Axiomatic/FOL_Axiomatic.thy b/thys/FOL_Axiomatic/FOL_Axiomatic.thy
	--- a/thys/FOL_Axiomatic/FOL_Axiomatic.thy
	+++ b/thys/FOL_Axiomatic/FOL_Axiomatic.thy
	@@ -1,798 +1,826 @@
	(*
	File: FOL_Axiomatic.thy
	Author: Asta Halkjær From

	This work is a formalization of the soundness and completeness of an axiomatic system
	for first-order logic. The proof system is based on System Q1 by Smullyan
	and the completeness proof follows his textbook "First-Order Logic" (Springer-Verlag 1968).
	The completeness proof is in the Henkin style where a consistent set
	is extended to a maximal consistent set using Lindenbaum's construction
	and Henkin witnesses are added during the construction to ensure saturation as well.
	The resulting set is a Hintikka set which, by the model existence theorem, is satisfiable
	in the Herbrand universe.
	*)

	theory FOL_Axiomatic imports "HOL-Library.Countable" begin

	section \<open>Syntax\<close>

	datatype (params_tm: 'f) tm
	= Var nat (\<open>\<^bold>#\<close>)
	\| Fun 'f \<open>'f tm list\<close> (\<open>\<^bold>\<dagger>\<close>)

	abbreviation Const (\<open>\<^bold>\<star>\<close>) where \<open>\<^bold>\<star>a \<equiv> \<^bold>\<dagger>a []\<close>

	datatype (params_fm: 'f, 'p) fm
	= Falsity (\<open>\<^bold>\<bottom>\<close>)
	\| Pre 'p \<open>'f tm list\<close> (\<open>\<^bold>\<ddagger>\<close>)
	- \| Imp \<open>('f, 'p) fm\<close> \<open>('f, 'p) fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 25)
	+ \| Imp \<open>('f, 'p) fm\<close> \<open>('f, 'p) fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)
	\| Uni \<open>('f, 'p) fm\<close> (\<open>\<^bold>\<forall>\<close>)

	-abbreviation Neg (\<open>\<^bold>\<not> _\<close> [40] 40) where \<open>\<^bold>\<not> p \<equiv> p \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>
	+abbreviation Neg (\<open>\<^bold>\<not> _\<close> [70] 70) where \<open>\<^bold>\<not> p \<equiv> p \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>

	term \<open>\<^bold>\<forall>(\<^bold>\<bottom> \<^bold>\<longrightarrow> \<^bold>\<ddagger>''P'' [\<^bold>\<dagger>''f'' [\<^bold>#0]])\<close>

	section \<open>Semantics\<close>

	definition shift :: \<open>(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a\<close>
	(\<open>_\<langle>_:_\<rangle>\<close> [90, 0, 0] 91) where
	\<open>E\<langle>n:x\<rangle> = (\<lambda>m. if m < n then E m else if m = n then x else E (m-1))\<close>

	primrec semantics_tm (\<open>\<lparr>_, _\<rparr>\<close>) where
	\<open>\<lparr>E, F\<rparr> (\<^bold>#n) = E n\<close>
	\| \<open>\<lparr>E, F\<rparr> (\<^bold>\<dagger>f ts) = F f (map \<lparr>E, F\<rparr> ts)\<close>

	primrec semantics_fm (\<open>\<lbrakk>_, _, _\<rbrakk>\<close>) where
	\<open>\<lbrakk>_, _, _\<rbrakk> \<^bold>\<bottom> = False\<close>
	\| \<open>\<lbrakk>E, F, G\<rbrakk> (\<^bold>\<ddagger>P ts) = G P (map \<lparr>E, F\<rparr> ts)\<close>
	\| \<open>\<lbrakk>E, F, G\<rbrakk> (p \<^bold>\<longrightarrow> q) = (\<lbrakk>E, F, G\<rbrakk> p \<longrightarrow> \<lbrakk>E, F, G\<rbrakk> q)\<close>
	\| \<open>\<lbrakk>E, F, G\<rbrakk> (\<^bold>\<forall>p) = (\<forall>x. \<lbrakk>E\<langle>0:x\<rangle>, F, G\<rbrakk> p)\<close>

	proposition \<open>\<lbrakk>E, F, G\<rbrakk> (\<^bold>\<forall>(\<^bold>\<ddagger>P [\<^bold># 0]) \<^bold>\<longrightarrow> \<^bold>\<ddagger>P [\<^bold>\<star>a])\<close>
	by (simp add: shift_def)

	section \<open>Operations\<close>

	subsection \<open>Shift\<close>

	lemma shift_eq [simp]: \<open>n = m \<Longrightarrow> (E\<langle>n:x\<rangle>) m = x\<close>
	by (simp add: shift_def)

	lemma shift_gt [simp]: \<open>m < n \<Longrightarrow> (E\<langle>n:x\<rangle>) m = E m\<close>
	by (simp add: shift_def)

	lemma shift_lt [simp]: \<open>n < m \<Longrightarrow> (E\<langle>n:x\<rangle>) m = E (m-1)\<close>
	by (simp add: shift_def)

	lemma shift_commute [simp]: \<open>E\<langle>n:y\<rangle>\<langle>0:x\<rangle> = E\<langle>0:x\<rangle>\<langle>n+1:y\<rangle>\<close>
	proof
	fix m
	show \<open>(E\<langle>n:y\<rangle>\<langle>0:x\<rangle>) m = (E\<langle>0:x\<rangle>\<langle>n+1:y\<rangle>) m\<close>
	unfolding shift_def by (cases m) simp_all
	qed

	subsection \<open>Parameters\<close>

	abbreviation \<open>params S \<equiv> \<Union>p \<in> S. params_fm p\<close>

	lemma upd_params_tm [simp]: \<open>f \<notin> params_tm t \<Longrightarrow> \<lparr>E, F(f := x)\<rparr> t = \<lparr>E, F\<rparr> t\<close>
	by (induct t) (auto cong: map_cong)

	lemma upd_params_fm [simp]: \<open>f \<notin> params_fm p \<Longrightarrow> \<lbrakk>E, F(f := x), G\<rbrakk> p = \<lbrakk>E, F, G\<rbrakk> p\<close>
	by (induct p arbitrary: E) (auto cong: map_cong)

	lemma finite_params_tm [simp]: \<open>finite (params_tm t)\<close>
	by (induct t) simp_all

	lemma finite_params_fm [simp]: \<open>finite (params_fm p)\<close>
	by (induct p) simp_all

	subsection \<open>Instantiation\<close>

	primrec lift_tm (\<open>\<^bold>\<up>\<close>) where
	\<open>\<^bold>\<up>(\<^bold>#n) = \<^bold>#(n+1)\<close>
	\| \<open>\<^bold>\<up>(\<^bold>\<dagger>f ts) = \<^bold>\<dagger>f (map \<^bold>\<up> ts)\<close>

	primrec inst_tm (\<open>_'\<llangle>_'/_'\<rrangle>\<close> [90, 0, 0] 91) where
	\<open>(\<^bold>#n)\<llangle>s/m\<rrangle> = (if n < m then \<^bold>#n else if n = m then s else \<^bold>#(n-1))\<close>
	\| \<open>(\<^bold>\<dagger>f ts)\<llangle>s/m\<rrangle> = \<^bold>\<dagger>f (map (\<lambda>t. t\<llangle>s/m\<rrangle>) ts)\<close>

	primrec inst_fm (\<open>_'\<langle>_'/_'\<rangle>\<close> [90, 0, 0] 91) where
	\<open>\<^bold>\<bottom>\<langle>_/_\<rangle> = \<^bold>\<bottom>\<close>
	\| \<open>(\<^bold>\<ddagger>P ts)\<langle>s/m\<rangle> = \<^bold>\<ddagger>P (map (\<lambda>t. t\<llangle>s/m\<rrangle>) ts)\<close>
	\| \<open>(p \<^bold>\<longrightarrow> q)\<langle>s/m\<rangle> = (p\<langle>s/m\<rangle> \<^bold>\<longrightarrow> q\<langle>s/m\<rangle>)\<close>
	\| \<open>(\<^bold>\<forall>p)\<langle>s/m\<rangle> = \<^bold>\<forall>(p\<langle>\<^bold>\<up>s/m+1\<rangle>)\<close>

	lemma lift_lemma [simp]: \<open>\<lparr>E\<langle>0:x\<rangle>, F\<rparr> (\<^bold>\<up>t) = \<lparr>E, F\<rparr> t\<close>
	by (induct t) (auto cong: map_cong)

	lemma inst_tm_semantics [simp]: \<open>\<lparr>E, F\<rparr> (t\<llangle>s/m\<rrangle>) = \<lparr>E\<langle>m:\<lparr>E, F\<rparr> s\<rangle>, F\<rparr> t\<close>
	by (induct t) (auto cong: map_cong)

	lemma inst_fm_semantics [simp]: \<open>\<lbrakk>E, F, G\<rbrakk> (p\<langle>t/m\<rangle>) = \<lbrakk>E\<langle>m:\<lparr>E, F\<rparr> t\<rangle>, F, G\<rbrakk> p\<close>
	by (induct p arbitrary: E m t) (auto cong: map_cong)

	subsection \<open>Size\<close>

	text \<open>The built-in \<open>size\<close> is not invariant under substitution.\<close>

	primrec size_fm where
	\<open>size_fm \<^bold>\<bottom> = 1\<close>
	\| \<open>size_fm (\<^bold>\<ddagger>_ _) = 1\<close>
	\| \<open>size_fm (p \<^bold>\<longrightarrow> q) = 1 + size_fm p + size_fm q\<close>
	\| \<open>size_fm (\<^bold>\<forall>p) = 1 + size_fm p\<close>

	lemma size_inst_fm [simp]:
	\<open>size_fm (p\<langle>t/m\<rangle>) = size_fm p\<close>
	by (induct p arbitrary: m t) auto

	section \<open>Propositional Semantics\<close>

	primrec boolean where
	\<open>boolean _ _ \<^bold>\<bottom> = False\<close>
	\| \<open>boolean G _ (\<^bold>\<ddagger>P ts) = G P ts\<close>
	\| \<open>boolean G A (p \<^bold>\<longrightarrow> q) = (boolean G A p \<longrightarrow> boolean G A q)\<close>
	\| \<open>boolean _ A (\<^bold>\<forall>p) = A (\<^bold>\<forall>p)\<close>

	abbreviation \<open>tautology p \<equiv> \<forall>G A. boolean G A p\<close>

	proposition \<open>tautology (\<^bold>\<forall>(\<^bold>\<ddagger>P [\<^bold>#0]) \<^bold>\<longrightarrow> \<^bold>\<forall>(\<^bold>\<ddagger>P [\<^bold>#0]))\<close>
	by simp

	lemma boolean_semantics: \<open>boolean (\<lambda>a. G a \<circ> map \<lparr>E, F\<rparr>) \<lbrakk>E, F, G\<rbrakk> = \<lbrakk>E, F, G\<rbrakk>\<close>
	proof
	fix p
	show \<open>boolean (\<lambda>a. G a \<circ> map \<lparr>E, F\<rparr>) \<lbrakk>E, F, G\<rbrakk> p = \<lbrakk>E, F, G\<rbrakk> p\<close>
	by (induct p) simp_all
	qed

	lemma tautology: \<open>tautology p \<Longrightarrow> \<lbrakk>E, F, G\<rbrakk> p\<close>
	using boolean_semantics by metis

	proposition \<open>\<exists>p. (\<forall>E F G. \<lbrakk>E, F, G\<rbrakk> p) \<and> \<not> tautology p\<close>
	by (metis boolean.simps(4) fm.simps(36) semantics_fm.simps(1,3,4))

	section \<open>Calculus\<close>

	text \<open>Adapted from System Q1 by Smullyan in First-Order Logic (1968)\<close>

	-inductive Axiomatic (\<open>\<turnstile> _\<close> [20] 20) where
	+inductive Axiomatic (\<open>\<turnstile> _\<close> [50] 50) where
	TA: \<open>tautology p \<Longrightarrow> \<turnstile> p\<close>
	\| IA: \<open>\<turnstile> \<^bold>\<forall>p \<^bold>\<longrightarrow> p\<langle>t/0\<rangle>\<close>
	\| MP: \<open>\<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> \<turnstile> p \<Longrightarrow> \<turnstile> q\<close>
	\| GR: \<open>\<turnstile> q \<^bold>\<longrightarrow> p\<langle>\<^bold>\<star>a/0\<rangle> \<Longrightarrow> a \<notin> params {p, q} \<Longrightarrow> \<turnstile> q \<^bold>\<longrightarrow> \<^bold>\<forall>p\<close>

	lemmas
	TA[simp]
	MP[trans, dest]
	GR[intro]

	text \<open>We simulate assumptions on the lhs of \<open>\<turnstile>\<close> with a chain of implications on the rhs.\<close>

	-primrec imply (infixr \<open>\<^bold>\<leadsto>\<close> 26) where
	+primrec imply (infixr \<open>\<^bold>\<leadsto>\<close> 56) where
	\<open>([] \<^bold>\<leadsto> q) = q\<close>
	\| \<open>(p # ps \<^bold>\<leadsto> q) = (p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q)\<close>

	-abbreviation Axiomatic_assms (\<open>_ \<turnstile> _\<close> [20, 20] 20) where
	+abbreviation Axiomatic_assms (\<open>_ \<turnstile> _\<close> [50, 50] 50) where
	\<open>ps \<turnstile> q \<equiv> \<turnstile> ps \<^bold>\<leadsto> q\<close>

	section \<open>Soundness\<close>

	theorem soundness: \<open>\<turnstile> p \<Longrightarrow> \<lbrakk>E, F, G\<rbrakk> p\<close>
	proof (induct p arbitrary: F rule: Axiomatic.induct)
	case (GR q p a)
	moreover from this
	have \<open>\<lbrakk>E, F(a := x), G\<rbrakk> (q \<^bold>\<longrightarrow> p\<langle>\<^bold>\<star>a/0\<rangle>)\<close> for x
	by blast
	ultimately show ?case
	by fastforce
	qed (auto simp: tautology)

	corollary \<open>\<not> (\<turnstile> \<^bold>\<bottom>)\<close>
	using soundness by fastforce

	section \<open>Derived Rules\<close>

	lemma AS: \<open>\<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r\<close>
	by auto

	lemma AK: \<open>\<turnstile> q \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close>
	by auto

	lemma Neg: \<open>\<turnstile> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> p\<close>
	by auto

	lemma contraposition:
	\<open>\<turnstile> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> \<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<not> p\<close>
	\<open>\<turnstile> (\<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<not> p) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close>
	by (auto intro: TA)

	lemma GR': \<open>\<turnstile> \<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle> \<^bold>\<longrightarrow> q \<Longrightarrow> a \<notin> params {p, q} \<Longrightarrow> \<turnstile> \<^bold>\<not> \<^bold>\<forall>p \<^bold>\<longrightarrow> q\<close>
	proof -
	assume *: \<open>\<turnstile> \<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle> \<^bold>\<longrightarrow> q\<close> and a: \<open>a \<notin> params {p, q}\<close>
	have \<open>\<turnstile> \<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<not> \<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>\<close>
	using * contraposition(1) by fast
	then have \<open>\<turnstile> \<^bold>\<not> q \<^bold>\<longrightarrow> p\<langle>\<^bold>\<star>a/0\<rangle>\<close>
	by (meson AK AS MP Neg)
	then have \<open>\<turnstile> \<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<forall>p\<close>
	using a by auto
	then have \<open>\<turnstile> \<^bold>\<not> \<^bold>\<forall>p \<^bold>\<longrightarrow> \<^bold>\<not> \<^bold>\<not> q\<close>
	using contraposition(1) by fast
	then show ?thesis
	by (meson AK AS MP Neg)
	qed

	lemma Imp3: \<open>\<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> ((s \<^bold>\<longrightarrow> p) \<^bold>\<longrightarrow> (s \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> s \<^bold>\<longrightarrow> r)\<close>
	by auto

	lemma imply_ImpE: \<open>\<turnstile> ps \<^bold>\<leadsto> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q\<close>
	by (induct ps) (auto intro: Imp3 MP)

	lemma MP' [trans, dest]: \<open>ps \<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> ps \<turnstile> p \<Longrightarrow> ps \<turnstile> q\<close>
	using imply_ImpE by fast

	lemma imply_Cons [intro]: \<open>ps \<turnstile> q \<Longrightarrow> p # ps \<turnstile> q\<close>
	by (auto intro: MP AK)

	lemma imply_head [intro]: \<open>p # ps \<turnstile> p\<close>
	proof (induct ps)
	case (Cons q ps)
	then show ?case
	by (metis AK MP' imply.simps(1-2))
	qed auto

	lemma imply_lift_Imp [simp]:
	assumes \<open>\<turnstile> p \<^bold>\<longrightarrow> q\<close>
	shows \<open>\<turnstile> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q\<close>
	using assms MP MP' imply_head by (metis imply.simps(2))

	lemma add_imply [simp]: \<open>\<turnstile> q \<Longrightarrow> ps \<turnstile> q\<close>
	using MP imply_head by (auto simp del: TA)

	lemma imply_mem [simp]: \<open>p \<in> set ps \<Longrightarrow> ps \<turnstile> p\<close>
	proof (induct ps)
	case (Cons q ps)
	then show ?case
	by (metis imply_Cons imply_head set_ConsD)
	qed simp

	lemma deduct1: \<open>ps \<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> p # ps \<turnstile> q\<close>
	by (meson MP' imply_Cons imply_head)

	lemma imply_append [iff]: \<open>(ps @ qs \<^bold>\<leadsto> r) = (ps \<^bold>\<leadsto> qs \<^bold>\<leadsto> r)\<close>
	by (induct ps) simp_all

	lemma imply_swap_append: \<open>ps @ qs \<turnstile> r \<Longrightarrow> qs @ ps \<turnstile> r\<close>
	proof (induct qs arbitrary: ps)
	case (Cons q qs)
	then show ?case
	by (metis deduct1 imply.simps(2) imply_append)
	qed simp

	lemma deduct2: \<open>p # ps \<turnstile> q \<Longrightarrow> ps \<turnstile> p \<^bold>\<longrightarrow> q\<close>
	by (metis imply.simps(1-2) imply_append imply_swap_append)

	lemmas deduct [iff] = deduct1 deduct2

	lemma cut [trans, dest]: \<open>p # ps \<turnstile> r \<Longrightarrow> q # ps \<turnstile> p \<Longrightarrow> q # ps \<turnstile> r\<close>
	by (meson MP' deduct(2) imply_Cons)

	lemma Boole: \<open>(\<^bold>\<not> p) # ps \<turnstile> \<^bold>\<bottom> \<Longrightarrow> ps \<turnstile> p\<close>
	by (meson MP' Neg add_imply deduct(2))

	lemma imply_weaken: \<open>ps \<turnstile> q \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> ps' \<turnstile> q\<close>
	proof (induct ps arbitrary: q)
	case (Cons p ps)
	then show ?case
	by (metis MP' deduct(2) imply_mem insert_subset list.simps(15))
	qed simp

	section \<open>Consistent\<close>

	-definition \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> (S' \<turnstile> \<^bold>\<bottom>)\<close>
	+definition \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>

	lemma UN_finite_bound:
	assumes \<open>finite A\<close> and \<open>A \<subseteq> (\<Union>n. f n)\<close>
	shows \<open>\<exists>m :: nat. A \<subseteq> (\<Union>n \<le> m. f n)\<close>
	using assms
	proof (induct rule: finite_induct)
	case (insert x A)
	then obtain m where \<open>A \<subseteq> (\<Union>n \<le> m. f n)\<close>
	by fast
	then have \<open>A \<subseteq> (\<Union>n \<le> (m + k). f n)\<close> for k
	by fastforce
	moreover obtain m' where \<open>x \<in> f m'\<close>
	using insert(4) by blast
	ultimately have \<open>{x} \<union> A \<subseteq> (\<Union>n \<le> m + m'. f n)\<close>
	by auto
	then show ?case
	by blast
	qed simp

	lemma split_list:
	assumes \<open>x \<in> set A\<close>
	shows \<open>set (x # removeAll x A) = set A \<and> x \<notin> set (removeAll x A)\<close>
	using assms by auto

	lemma imply_params_fm: \<open>params_fm (ps \<^bold>\<leadsto> q) = params_fm q \<union> (\<Union>p \<in> set ps. params_fm p)\<close>
	by (induct ps) auto

	lemma inconsistent_fm:
	assumes \<open>consistent S\<close> and \<open>\<not> consistent ({p} \<union> S)\<close>
	obtains S' where \<open>set S' \<subseteq> S\<close> and \<open>p # S' \<turnstile> \<^bold>\<bottom>\<close>
	proof -
	obtain S' where S': \<open>set S' \<subseteq> {p} \<union> S\<close> \<open>p \<in> set S'\<close> \<open>S' \<turnstile> \<^bold>\<bottom>\<close>
	using assms unfolding consistent_def by blast
	then obtain S'' where S'': \<open>set (p # S'') = set S'\<close> \<open>p \<notin> set S''\<close>
	using split_list by metis
	then have \<open>p # S'' \<turnstile> \<^bold>\<bottom>\<close>
	using \<open>S' \<turnstile> \<^bold>\<bottom>\<close> imply_weaken by blast
	then show ?thesis
	using that S'' S'(1)
	by (metis Diff_insert_absorb Diff_subset_conv list.simps(15))
	qed

	lemma consistent_add_witness:
	assumes \<open>consistent S\<close> and \<open>(\<^bold>\<not> \<^bold>\<forall>p) \<in> S\<close> and \<open>a \<notin> params S\<close>
	shows \<open>consistent ({\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>} \<union> S)\<close>
	unfolding consistent_def
	proof
	- assume \<open>\<exists>S'. set S' \<subseteq> {\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>} \<union> S \<and> (S' \<turnstile> \<^bold>\<bottom>)\<close>
	+ assume \<open>\<exists>S'. set S' \<subseteq> {\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>} \<union> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	then obtain S' where \<open>set S' \<subseteq> S\<close> and \<open>(\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>) # S' \<turnstile> \<^bold>\<bottom>\<close>
	using assms inconsistent_fm unfolding consistent_def by metis
	then have \<open>\<turnstile> \<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle> \<^bold>\<longrightarrow> S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	by simp
	moreover have \<open>a \<notin> params_fm p\<close>
	using assms(2-3) by auto
	moreover have \<open>\<forall>p \<in> set S'. a \<notin> params_fm p\<close>
	using \<open>set S' \<subseteq> S\<close> assms(3) by auto
	then have \<open>a \<notin> params_fm (S' \<^bold>\<leadsto> \<^bold>\<bottom>)\<close>
	by (simp add: imply_params_fm)
	ultimately have \<open>\<turnstile> \<^bold>\<not> \<^bold>\<forall>p \<^bold>\<longrightarrow> S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	using GR' by fast
	then have \<open>(\<^bold>\<not> \<^bold>\<forall>p) # S' \<turnstile> \<^bold>\<bottom>\<close>
	by simp
	moreover have \<open>set ((\<^bold>\<not> \<^bold>\<forall>p) # S') \<subseteq> S\<close>
	using \<open>set S' \<subseteq> S\<close> assms(2) by simp
	ultimately show False
	using assms(1) unfolding consistent_def by blast
	qed

	lemma consistent_add_instance:
	assumes \<open>consistent S\<close> and \<open>\<^bold>\<forall>p \<in> S\<close>
	shows \<open>consistent ({p\<langle>t/0\<rangle>} \<union> S)\<close>
	unfolding consistent_def
	proof
	- assume \<open>\<exists>S'. set S' \<subseteq> {p\<langle>t/0\<rangle>} \<union> S \<and> (S' \<turnstile> \<^bold>\<bottom>)\<close>
	+ assume \<open>\<exists>S'. set S' \<subseteq> {p\<langle>t/0\<rangle>} \<union> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	then obtain S' where \<open>set S' \<subseteq> S\<close> and \<open>p\<langle>t/0\<rangle> # S' \<turnstile> \<^bold>\<bottom>\<close>
	using assms inconsistent_fm unfolding consistent_def by blast
	moreover have \<open>\<turnstile> \<^bold>\<forall>p \<^bold>\<longrightarrow> p\<langle>t/0\<rangle>\<close>
	using IA by blast
	ultimately have \<open>\<^bold>\<forall>p # S' \<turnstile> \<^bold>\<bottom>\<close>
	by (meson add_imply cut deduct(1))
	moreover have \<open>set ((\<^bold>\<forall>p) # S') \<subseteq> S\<close>
	using \<open>set S' \<subseteq> S\<close> assms(2) by simp
	ultimately show False
	using assms(1) unfolding consistent_def by blast
	qed

	section \<open>Extension\<close>

	fun witness where
	\<open>witness used (\<^bold>\<not> \<^bold>\<forall>p) = {\<^bold>\<not> p\<langle>\<^bold>\<star>(SOME a. a \<notin> used)/0\<rangle>}\<close>
	\| \<open>witness _ _ = {}\<close>

	primrec extend where
	\<open>extend S f 0 = S\<close>
	\| \<open>extend S f (Suc n) =
	(let Sn = extend S f n in
	if consistent ({f n} \<union> Sn)
	then witness (params ({f n} \<union> Sn)) (f n) \<union> {f n} \<union> Sn
	else Sn)\<close>

	definition \<open>Extend S f \<equiv> \<Union>n. extend S f n\<close>

	+lemma extend_subset: \<open>S \<subseteq> extend S f n\<close>
	+ by (induct n) (fastforce simp: Let_def)+
	+
	lemma Extend_subset: \<open>S \<subseteq> Extend S f\<close>
	unfolding Extend_def by (metis Union_upper extend.simps(1) range_eqI)

	lemma extend_bound: \<open>(\<Union>n \<le> m. extend S f n) = extend S f m\<close>
	by (induct m) (simp_all add: atMost_Suc Let_def)

	lemma finite_params_witness [simp]: \<open>finite (params (witness used p))\<close>
	by (induct used p rule: witness.induct) simp_all

	-lemma finite_params_extend [simp]: \<open>finite (params S) \<Longrightarrow> finite (params (extend S f n))\<close>
	- by (induct n) (simp_all add: Let_def)
	+lemma finite_params_extend [simp]: \<open>finite (params (extend S f n) - params S)\<close>
	+ by (induct n) (simp_all add: Let_def Un_Diff)
	+
	+lemma Set_Diff_Un: \<open>X - (Y \<union> Z) = X - Y - Z\<close>
	+ by blast
	+
	+lemma infinite_params_extend:
	+ assumes \<open>infinite (UNIV - params S)\<close>
	+ shows \<open>infinite (UNIV - params (extend S f n))\<close>
	+proof -
	+ have \<open>finite (params (extend S f n) - params S)\<close>
	+ by simp
	+ then obtain extra where \<open>finite extra\<close> \<open>params (extend S f n) = extra \<union> params S\<close>
	+ using extend_subset by fast
	+ then have \<open>?thesis = infinite (UNIV - (extra \<union> params S))\<close>
	+ by simp
	+ also have \<open>\<dots> = infinite (UNIV - extra - params S)\<close>
	+ by (simp add: Set_Diff_Un)
	+ also have \<open>\<dots> = infinite (UNIV - params S)\<close>
	+ using \<open>finite extra\<close> by (metis Set_Diff_Un finite_Diff2 sup_commute)
	+ finally show ?thesis
	+ using assms ..
	+qed

	lemma consistent_witness:
	- fixes p :: \<open>('f, 'p) fm\<close>
	assumes \<open>consistent S\<close> and \<open>p \<in> S\<close> and \<open>params S \<subseteq> used\<close>
	- and \<open>finite used\<close> and \<open>infinite (UNIV :: 'f set)\<close>
	+ and \<open>infinite (UNIV - used)\<close>
	shows \<open>consistent (witness used p \<union> S)\<close>
	using assms
	proof (induct used p rule: witness.induct)
	case (1 used p)
	moreover have \<open>\<exists>a. a \<notin> used\<close>
	- using 1(4-) ex_new_if_finite by blast
	+ using 1(4) by (meson Diff_iff finite_params_fm finite_subset subset_iff)
	ultimately obtain a where a: \<open>witness used (\<^bold>\<not> \<^bold>\<forall>p) = {\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>}\<close> and \<open>a \<notin> used\<close>
	by (metis someI_ex witness.simps(1))
	then have \<open>a \<notin> params S\<close>
	using 1(3) by fast
	then show ?case
	using 1(1-2) a(1) consistent_add_witness by metis
	qed (auto simp: assms)

	lemma consistent_extend:
	- fixes f :: \<open>nat \<Rightarrow> ('f, 'p) fm\<close>
	- assumes \<open>consistent S\<close> and \<open>finite (params S)\<close>
	- and \<open>infinite (UNIV :: 'f set)\<close>
	+ assumes \<open>consistent S\<close> and \<open>infinite (UNIV - params S)\<close>
	shows \<open>consistent (extend S f n)\<close>
	using assms
	proof (induct n)
	case (Suc n)
	- then show ?case
	- using consistent_witness[where S=\<open>{f n} \<union> _\<close>] by (auto simp: Let_def)
	+ moreover from this have \<open>infinite (UNIV - params ({f n} \<union> extend S f n))\<close>
	+ using infinite_params_extend
	+ by (metis (no_types, lifting) Diff_infinite_finite Set_Diff_Un UN_Un finite.emptyI
	+ finite.insertI finite_UN_I finite_params_fm sup_commute)
	+ ultimately show ?case
	+ using consistent_witness[where S=\<open>{f n} \<union> _\<close>]
	+ by (simp add: Let_def)
	qed simp

	lemma consistent_Extend:
	- fixes f :: \<open>nat \<Rightarrow> ('f, 'p) fm\<close>
	- assumes \<open>consistent S\<close> and \<open>finite (params S)\<close>
	- and \<open>infinite (UNIV :: 'f set)\<close>
	+ assumes \<open>consistent S\<close> and \<open>infinite (UNIV - params S)\<close>
	shows \<open>consistent (Extend S f)\<close>
	-proof (rule ccontr)
	- assume \<open>\<not> consistent (Extend S f)\<close>
	+ unfolding consistent_def
	+proof
	+ assume \<open>\<exists>S'. set S' \<subseteq> Extend S f \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	then obtain S' where \<open>S' \<turnstile> \<^bold>\<bottom>\<close> and \<open>set S' \<subseteq> Extend S f\<close>
	unfolding consistent_def by blast
	then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend S f n)\<close>
	unfolding Extend_def using UN_finite_bound by (metis List.finite_set)
	then have \<open>set S' \<subseteq> extend S f m\<close>
	using extend_bound by blast
	moreover have \<open>consistent (extend S f m)\<close>
	using assms consistent_extend by blast
	ultimately show False
	unfolding consistent_def using \<open>S' \<turnstile> \<^bold>\<bottom>\<close> by blast
	qed

	section \<open>Maximal\<close>

	definition \<open>maximal S \<equiv> \<forall>p. p \<notin> S \<longrightarrow> \<not> consistent ({p} \<union> S)\<close>

	lemma maximal_exactly_one:
	assumes \<open>consistent S\<close> and \<open>maximal S\<close>
	shows \<open>p \<in> S \<longleftrightarrow> (\<^bold>\<not> p) \<notin> S\<close>
	proof
	assume \<open>p \<in> S\<close>
	show \<open>(\<^bold>\<not> p) \<notin> S\<close>
	proof
	assume \<open>(\<^bold>\<not> p) \<in> S\<close>
	then have \<open>set [p, \<^bold>\<not> p] \<subseteq> S\<close>
	using \<open>p \<in> S\<close> by simp
	moreover have \<open>[p, \<^bold>\<not> p] \<turnstile> \<^bold>\<bottom>\<close>
	by blast
	ultimately show False
	using \<open>consistent S\<close> unfolding consistent_def by blast
	qed
	next
	assume \<open>(\<^bold>\<not> p) \<notin> S\<close>
	then have \<open>\<not> consistent ({\<^bold>\<not> p} \<union> S)\<close>
	using \<open>maximal S\<close> unfolding maximal_def by blast
	then obtain S' where \<open>set S' \<subseteq> S\<close> \<open>(\<^bold>\<not> p) # S' \<turnstile> \<^bold>\<bottom>\<close>
	using \<open>consistent S\<close> inconsistent_fm by blast
	then have \<open>S' \<turnstile> p\<close>
	using Boole by blast
	have \<open>consistent ({p} \<union> S)\<close>
	unfolding consistent_def
	proof
	- assume \<open>\<exists>S'. set S' \<subseteq> {p} \<union> S \<and> (S' \<turnstile> \<^bold>\<bottom>)\<close>
	+ assume \<open>\<exists>S'. set S' \<subseteq> {p} \<union> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	then obtain S'' where \<open>set S'' \<subseteq> S\<close> and \<open>p # S'' \<turnstile> \<^bold>\<bottom>\<close>
	using assms inconsistent_fm unfolding consistent_def by blast
	then have \<open>S' @ S'' \<turnstile> \<^bold>\<bottom>\<close>
	using \<open>S' \<turnstile> p\<close> by (metis MP' add_imply imply.simps(2) imply_append)
	moreover have \<open>set (S' @ S'') \<subseteq> S\<close>
	using \<open>set S' \<subseteq> S\<close> \<open>set S'' \<subseteq> S\<close> by simp
	ultimately show False
	using \<open>consistent S\<close> unfolding consistent_def by blast
	qed
	then show \<open>p \<in> S\<close>
	using \<open>maximal S\<close> unfolding maximal_def by blast
	qed

	lemma maximal_Extend:
	assumes \<open>surj f\<close>
	shows \<open>maximal (Extend S f)\<close>
	proof (rule ccontr)
	assume \<open>\<not> maximal (Extend S f)\<close>
	then obtain p where
	\<open>p \<notin> Extend S f\<close> and \<open>consistent ({p} \<union> Extend S f)\<close>
	unfolding maximal_def using assms consistent_Extend by blast
	obtain k where k: \<open>f k = p\<close>
	using \<open>surj f\<close> unfolding surj_def by metis
	then have \<open>p \<notin> extend S f (Suc k)\<close>
	using \<open>p \<notin> Extend S f\<close> unfolding Extend_def by blast
	then have \<open>\<not> consistent ({p} \<union> extend S f k)\<close>
	using k by (auto simp: Let_def)
	moreover have \<open>{p} \<union> extend S f k \<subseteq> {p} \<union> Extend S f\<close>
	unfolding Extend_def by blast
	ultimately have \<open>\<not> consistent ({p} \<union> Extend S f)\<close>
	unfolding consistent_def by auto
	then show False
	using \<open>consistent ({p} \<union> Extend S f)\<close> by blast
	qed

	section \<open>Saturation\<close>

	definition \<open>saturated S \<equiv> \<forall>p. (\<^bold>\<not> \<^bold>\<forall>p) \<in> S \<longrightarrow> (\<exists>a. (\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>) \<in> S)\<close>

	lemma saturated_Extend:
	assumes \<open>consistent (Extend S f)\<close> and \<open>surj f\<close>
	shows \<open>saturated (Extend S f)\<close>
	proof (rule ccontr)
	assume \<open>\<not> saturated (Extend S f)\<close>
	then obtain p where p: \<open>(\<^bold>\<not> \<^bold>\<forall>p) \<in> Extend S f\<close> \<open>\<nexists>a. (\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>) \<in> Extend S f\<close>
	unfolding saturated_def by blast
	obtain k where k: \<open>f k = (\<^bold>\<not> \<^bold>\<forall>p)\<close>
	using \<open>surj f\<close> unfolding surj_def by metis

	have \<open>extend S f k \<subseteq> Extend S f\<close>
	unfolding Extend_def by auto
	then have \<open>consistent ({\<^bold>\<not> \<^bold>\<forall>p} \<union> extend S f k)\<close>
	using assms(1) p(1) unfolding consistent_def by blast
	then have \<open>\<exists>a. extend S f (Suc k) = {\<^bold>\<not> p\<langle>\<^bold>\<star>a/0\<rangle>} \<union> {\<^bold>\<not> \<^bold>\<forall>p} \<union> extend S f k\<close>
	using k by (auto simp: Let_def)
	moreover have \<open>extend S f (Suc k) \<subseteq> Extend S f\<close>
	unfolding Extend_def by blast
	ultimately show False
	using p(2) by blast
	qed

	section \<open>Hintikka\<close>

	locale Hintikka =
	fixes H :: \<open>('f, 'p) fm set\<close>
	assumes
	NoFalsity: \<open>\<^bold>\<bottom> \<notin> H\<close> and
	ImpP: \<open>(p \<^bold>\<longrightarrow> q) \<in> H \<Longrightarrow> p \<notin> H \<or> q \<in> H\<close> and
	ImpN: \<open>(p \<^bold>\<longrightarrow> q) \<notin> H \<Longrightarrow> p \<in> H \<and> q \<notin> H\<close> and
	UniP: \<open>\<^bold>\<forall>p \<in> H \<Longrightarrow> \<forall>t. p\<langle>t/0\<rangle> \<in> H\<close> and
	UniN: \<open>\<^bold>\<forall>p \<notin> H \<Longrightarrow> \<exists>a. p\<langle>\<^bold>\<star>a/0\<rangle> \<notin> H\<close>

	subsection \<open>Model Existence\<close>

	abbreviation hmodel (\<open>\<lbrakk>_\<rbrakk>\<close>) where \<open>\<lbrakk>H\<rbrakk> \<equiv> \<lbrakk>\<^bold>#, \<^bold>\<dagger>, \<lambda>P ts. Pre P ts \<in> H\<rbrakk>\<close>

	lemma semantics_tm_id [simp]:
	\<open>\<lparr>\<^bold>#, \<^bold>\<dagger>\<rparr> t = t\<close>
	by (induct t) (auto cong: map_cong)

	lemma semantics_tm_id_map [simp]: \<open>map \<lparr>\<^bold>#, \<^bold>\<dagger>\<rparr> ts = ts\<close>
	by (auto cong: map_cong)

	theorem Hintikka_model:
	assumes \<open>Hintikka H\<close>
	shows \<open>p \<in> H \<longleftrightarrow> \<lbrakk>H\<rbrakk> p\<close>
	proof (induct p rule: wf_induct[where r=\<open>measure size_fm\<close>])
	case 1
	then show ?case ..
	next
	case (2 x)
	show \<open>x \<in> H \<longleftrightarrow> \<lbrakk>H\<rbrakk> x\<close>
	proof (cases x; safe)
	case Falsity
	assume \<open>\<^bold>\<bottom> \<in> H\<close>
	then have False
	using assms Hintikka.NoFalsity by fast
	then show \<open>\<lbrakk>H\<rbrakk> \<^bold>\<bottom>\<close> ..
	next
	case Falsity
	assume \<open>\<lbrakk>H\<rbrakk> \<^bold>\<bottom>\<close>
	then have False
	by simp
	then show \<open>\<^bold>\<bottom> \<in> H\<close> ..
	next
	case (Pre P ts)
	assume \<open>\<^bold>\<ddagger>P ts \<in> H\<close>
	then show \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<ddagger>P ts)\<close>
	by simp
	next
	case (Pre P ts)
	assume \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<ddagger>P ts)\<close>
	then show \<open>\<^bold>\<ddagger>P ts \<in> H\<close>
	by simp
	next
	case (Imp p q)
	assume \<open>(p \<^bold>\<longrightarrow> q) \<in> H\<close>
	then have \<open>p \<notin> H \<or> q \<in> H\<close>
	using assms Hintikka.ImpP by blast
	then have \<open>\<not> \<lbrakk>H\<rbrakk> p \<or> \<lbrakk>H\<rbrakk> q\<close>
	using 2 Imp by simp
	then show \<open>\<lbrakk>H\<rbrakk> (p \<^bold>\<longrightarrow> q)\<close>
	by simp
	next
	case (Imp p q)
	assume \<open>\<lbrakk>H\<rbrakk> (p \<^bold>\<longrightarrow> q)\<close>
	then have \<open>\<not> \<lbrakk>H\<rbrakk> p \<or> \<lbrakk>H\<rbrakk> q\<close>
	by simp
	then have \<open>p \<notin> H \<or> q \<in> H\<close>
	using 2 Imp by simp
	then show \<open>(p \<^bold>\<longrightarrow> q) \<in> H\<close>
	using assms Hintikka.ImpN by blast
	next
	case (Uni p)
	assume \<open>\<^bold>\<forall>p \<in> H\<close>
	then have \<open>\<forall>t. p\<langle>t/0\<rangle> \<in> H\<close>
	using assms Hintikka.UniP by metis
	then have \<open>\<forall>t. \<lbrakk>H\<rbrakk> (p\<langle>t/0\<rangle>)\<close>
	using 2 Uni by simp
	then show \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<forall>p)\<close>
	by simp
	next
	case (Uni p)
	assume \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<forall>p)\<close>
	then have \<open>\<forall>t. \<lbrakk>H\<rbrakk> (p\<langle>t/0\<rangle>)\<close>
	by simp
	then have \<open>\<forall>t. p\<langle>t/0\<rangle> \<in> H\<close>
	using 2 Uni by simp
	then show \<open>\<^bold>\<forall>p \<in> H\<close>
	using assms Hintikka.UniN by blast
	qed
	qed

	subsection \<open>Maximal Consistent Sets are Hintikka Sets\<close>

	lemma inconsistent_head:
	assumes \<open>consistent S\<close> and \<open>maximal S\<close> and \<open>p \<notin> S\<close>
	obtains S' where \<open>set S' \<subseteq> S\<close> and \<open>p # S' \<turnstile> \<^bold>\<bottom>\<close>
	using assms inconsistent_fm unfolding consistent_def maximal_def by metis

	lemma inconsistent_parts [simp]:
	assumes \<open>ps \<turnstile> \<^bold>\<bottom>\<close> and \<open>set ps \<subseteq> S\<close>
	shows \<open>\<not> consistent S\<close>
	using assms unfolding consistent_def by blast

	lemma Hintikka_Extend:
	fixes H :: \<open>('f, 'p) fm set\<close>
	assumes \<open>consistent H\<close> and \<open>maximal H\<close> and \<open>saturated H\<close>
	and \<open>infinite (UNIV :: 'f set)\<close>
	shows \<open>Hintikka H\<close>
	proof
	show \<open>\<^bold>\<bottom> \<notin> H\<close>
	proof
	assume \<open>\<^bold>\<bottom> \<in> H\<close>
	moreover have \<open>[\<^bold>\<bottom>] \<turnstile> \<^bold>\<bottom>\<close>
	by blast
	ultimately have \<open>\<not> consistent H\<close>
	using inconsistent_parts[where ps=\<open>[\<^bold>\<bottom>]\<close>] by simp
	then show False
	using \<open>consistent H\<close> ..
	qed
	next
	fix p q
	assume *: \<open>(p \<^bold>\<longrightarrow> q) \<in> H\<close>
	show \<open>p \<notin> H \<or> q \<in> H\<close>
	proof safe
	assume \<open>q \<notin> H\<close>
	then obtain Hq' where Hq': \<open>q # Hq' \<turnstile> \<^bold>\<bottom>\<close> \<open>set Hq' \<subseteq> H\<close>
	using assms inconsistent_head by metis

	assume \<open>p \<in> H\<close>
	then have \<open>(\<^bold>\<not> p) \<notin> H\<close>
	using assms maximal_exactly_one by blast
	then obtain Hp' where Hp': \<open>(\<^bold>\<not> p) # Hp' \<turnstile> \<^bold>\<bottom>\<close> \<open>set Hp' \<subseteq> H\<close>
	using assms inconsistent_head by metis

	let ?H' = \<open>Hp' @ Hq'\<close>
	have H': \<open>set ?H' = set Hp' \<union> set Hq'\<close>
	by simp
	then have \<open>set Hp' \<subseteq> set ?H'\<close> and \<open>set Hq' \<subseteq> set ?H'\<close>
	by blast+
	then have \<open>(\<^bold>\<not> p) # ?H' \<turnstile> \<^bold>\<bottom>\<close> and \<open>q # ?H' \<turnstile> \<^bold>\<bottom>\<close>
	using Hp'(1) Hq'(1) deduct imply_weaken by metis+
	then have \<open>(p \<^bold>\<longrightarrow> q) # ?H' \<turnstile> \<^bold>\<bottom>\<close>
	using Boole imply_Cons imply_head MP' cut by metis
	moreover have \<open>set ((p \<^bold>\<longrightarrow> q) # ?H') \<subseteq> H\<close>
	using \<open>q \<notin> H\<close> *(1) H' Hp'(2) Hq'(2) by auto
	ultimately show False
	using assms unfolding consistent_def by blast
	qed
	next
	fix p q
	assume *: \<open>(p \<^bold>\<longrightarrow> q) \<notin> H\<close>
	show \<open>p \<in> H \<and> q \<notin> H\<close>
	proof (safe, rule ccontr)
	assume \<open>p \<notin> H\<close>
	then obtain H' where S': \<open>p # H' \<turnstile> \<^bold>\<bottom>\<close> \<open>set H' \<subseteq> H\<close>
	using assms inconsistent_head by metis
	moreover have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> p\<close>
	by auto
	ultimately have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> \<^bold>\<bottom>\<close>
	by blast
	moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H') \<subseteq> H\<close>
	using *(1) S'(2) assms maximal_exactly_one by auto
	ultimately show False
	using assms unfolding consistent_def by blast
	next
	assume \<open>q \<in> H\<close>
	then have \<open>(\<^bold>\<not> q) \<notin> H\<close>
	using assms maximal_exactly_one by blast
	then obtain H' where H': \<open>(\<^bold>\<not> q) # H' \<turnstile> \<^bold>\<bottom>\<close> \<open>set H' \<subseteq> H\<close>
	using assms inconsistent_head by metis
	moreover have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> \<^bold>\<not> q\<close>
	by auto
	ultimately have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> \<^bold>\<bottom>\<close>
	by blast
	moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H') \<subseteq> H\<close>
	using *(1) H'(2) assms maximal_exactly_one by auto
	ultimately show False
	using assms unfolding consistent_def by blast
	qed
	next
	fix p
	assume \<open>\<^bold>\<forall>p \<in> H\<close>
	then show \<open>\<forall>t. p\<langle>t/0\<rangle> \<in> H\<close>
	using assms consistent_add_instance unfolding maximal_def by blast
	next
	fix p
	assume \<open>\<^bold>\<forall>p \<notin> H\<close>
	then show \<open>\<exists>a. p\<langle>\<^bold>\<star>a/0\<rangle> \<notin> H\<close>
	using assms maximal_exactly_one unfolding saturated_def by fast
	qed

	section \<open>Countable Formulas\<close>

	instance tm :: (countable) countable
	by countable_datatype

	instance fm :: (countable, countable) countable
	by countable_datatype

	section \<open>Completeness\<close>

	-lemma imply_completeness:
	+lemma infinite_Diff_fin_Un: \<open>infinite (X - Y) \<Longrightarrow> finite Z \<Longrightarrow> infinite (X - (Z \<union> Y))\<close>
	+ by (simp add: Set_Diff_Un sup_commute)
	+
	+theorem strong_completeness:
	fixes p :: \<open>('f :: countable, 'p :: countable) fm\<close>
	assumes \<open>\<forall>(E :: _ \<Rightarrow> 'f tm) F G. Ball X \<lbrakk>E, F, G\<rbrakk> \<longrightarrow> \<lbrakk>E, F, G\<rbrakk> p\<close>
	- and \<open>finite (params X)\<close> and \<open>infinite (UNIV :: 'f set)\<close>
	- shows \<open>\<exists>ps. set ps \<subseteq> X \<and> (ps \<turnstile> p)\<close>
	+ and \<open>infinite (UNIV - params X)\<close>
	+ shows \<open>\<exists>ps. set ps \<subseteq> X \<and> ps \<turnstile> p\<close>
	proof (rule ccontr)
	- assume \<open>\<nexists>ps. set ps \<subseteq> X \<and> (ps \<turnstile> p)\<close>
	+ assume \<open>\<nexists>ps. set ps \<subseteq> X \<and> ps \<turnstile> p\<close>
	then have *: \<open>\<nexists>ps. set ps \<subseteq> X \<and> ((\<^bold>\<not> p) # ps \<turnstile> \<^bold>\<bottom>)\<close>
	using Boole by blast

	let ?S = \<open>{\<^bold>\<not> p} \<union> X\<close>
	let ?H = \<open>Extend ?S from_nat\<close>

	have \<open>consistent ?S\<close>
	using * by (metis consistent_def imply_Cons inconsistent_fm)
	- moreover have \<open>finite (params ?S)\<close>
	- using assms by simp
	+ moreover have \<open>infinite (UNIV - params ?S)\<close>
	+ using assms(2) finite_params_fm by (simp add: infinite_Diff_fin_Un)
	ultimately have \<open>consistent ?H\<close> and \<open>maximal ?H\<close>
	- using assms(3) consistent_Extend maximal_Extend surj_from_nat by blast+
	+ using consistent_Extend maximal_Extend surj_from_nat by blast+
	moreover from this have \<open>saturated ?H\<close>
	using saturated_Extend by fastforce
	ultimately have \<open>Hintikka ?H\<close>
	- using assms(3) Hintikka_Extend by blast
	+ using assms(2) Hintikka_Extend by blast

	have \<open>\<lbrakk>?H\<rbrakk> p\<close> if \<open>p \<in> ?S\<close> for p
	using that Extend_subset Hintikka_model \<open>Hintikka ?H\<close> by blast
	then have \<open>\<lbrakk>?H\<rbrakk> (\<^bold>\<not> p)\<close> and \<open>\<forall>q \<in> X. \<lbrakk>?H\<rbrakk> q\<close>
	by blast+
	moreover from this have \<open>\<lbrakk>?H\<rbrakk> p\<close>
	using assms(1) by blast
	ultimately show False
	by simp
	qed

	theorem completeness:
	fixes p :: \<open>(nat, nat) fm\<close>
	assumes \<open>\<forall>(E :: nat \<Rightarrow> nat tm) F G. \<lbrakk>E, F, G\<rbrakk> p\<close>
	shows \<open>\<turnstile> p\<close>
	- using assms imply_completeness[where X=\<open>{}\<close>] by auto
	+ using assms strong_completeness[where X=\<open>{}\<close>] by auto

	section \<open>Main Result\<close>

	abbreviation valid :: \<open>(nat, nat) fm \<Rightarrow> bool\<close> where
	\<open>valid p \<equiv> \<forall>(E :: nat \<Rightarrow> nat tm) F G. \<lbrakk>E, F, G\<rbrakk> p\<close>

	theorem main: \<open>valid p \<longleftrightarrow> (\<turnstile> p)\<close>
	using completeness soundness by blast

	end
	diff --git a/thys/FOL_Axiomatic/FOL_Axiomatic_Variant.thy b/thys/FOL_Axiomatic/FOL_Axiomatic_Variant.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Axiomatic/FOL_Axiomatic_Variant.thy
	@@ -0,0 +1,889 @@
	+(*
	+ File: FOL_Axiomatic_Variant.thy
	+ Author: Asta Halkjær From
	+
	+ This work is a formalization of the soundness and completeness of an axiomatic system
	+ for first-order logic. The proof system is based on System Q1 by Smullyan
	+ and the completeness proof follows his textbook "First-Order Logic" (Springer-Verlag 1968).
	+ The completeness proof is in the Henkin style where a consistent set
	+ is extended to a maximal consistent set using Lindenbaum's construction
	+ and Henkin witnesses are added during the construction to ensure saturation as well.
	+ The resulting set is a Hintikka set which, by the model existence theorem, is satisfiable
	+ in the Herbrand universe.
	+
	+ This variant uses free variables as Henkin witnesses. This gives completeness for syntax
	+ with only finitely many available constants.
	+*)
	+
	+theory FOL_Axiomatic_Variant imports "HOL-Library.Countable" begin
	+
	+section \<open>Syntax\<close>
	+
	+datatype 'f tm
	+ = Var nat (\<open>\<^bold>#\<close>)
	+ \| Fun 'f \<open>'f tm list\<close> (\<open>\<^bold>\<dagger>\<close>)
	+
	+datatype ('f, 'p) fm
	+ = Falsity (\<open>\<^bold>\<bottom>\<close>)
	+ \| Pre 'p \<open>'f tm list\<close> (\<open>\<^bold>\<ddagger>\<close>)
	+ \| Imp \<open>('f, 'p) fm\<close> \<open>('f, 'p) fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)
	+ \| Uni \<open>('f, 'p) fm\<close> (\<open>\<^bold>\<forall>\<close>)
	+
	+abbreviation Neg (\<open>\<^bold>\<not> _\<close> [70] 70) where \<open>\<^bold>\<not> p \<equiv> p \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>
	+
	+term \<open>\<^bold>\<forall>(\<^bold>\<bottom> \<^bold>\<longrightarrow> \<^bold>\<ddagger>''P'' [\<^bold>\<dagger>''f'' [\<^bold>#0]])\<close>
	+
	+section \<open>Semantics\<close>
	+
	+definition shift :: \<open>(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a\<close>
	+ (\<open>_\<langle>_:_\<rangle>\<close> [90, 0, 0] 91) where
	+ \<open>E\<langle>n:x\<rangle> = (\<lambda>m. if m < n then E m else if m = n then x else E (m-1))\<close>
	+
	+primrec semantics_tm (\<open>\<lparr>_, _\<rparr>\<close>) where
	+ \<open>\<lparr>E, F\<rparr> (\<^bold>#n) = E n\<close>
	+\| \<open>\<lparr>E, F\<rparr> (\<^bold>\<dagger>f ts) = F f (map \<lparr>E, F\<rparr> ts)\<close>
	+
	+primrec semantics_fm (\<open>\<lbrakk>_, _, _\<rbrakk>\<close>) where
	+ \<open>\<lbrakk>_, _, _\<rbrakk> \<^bold>\<bottom> = False\<close>
	+\| \<open>\<lbrakk>E, F, G\<rbrakk> (\<^bold>\<ddagger>P ts) = G P (map \<lparr>E, F\<rparr> ts)\<close>
	+\| \<open>\<lbrakk>E, F, G\<rbrakk> (p \<^bold>\<longrightarrow> q) = (\<lbrakk>E, F, G\<rbrakk> p \<longrightarrow> \<lbrakk>E, F, G\<rbrakk> q)\<close>
	+\| \<open>\<lbrakk>E, F, G\<rbrakk> (\<^bold>\<forall>p) = (\<forall>x. \<lbrakk>E\<langle>0:x\<rangle>, F, G\<rbrakk> p)\<close>
	+
	+proposition \<open>\<lbrakk>E, F, G\<rbrakk> (\<^bold>\<forall>(\<^bold>\<ddagger>P [\<^bold># 0]) \<^bold>\<longrightarrow> \<^bold>\<ddagger>P [\<^bold>\<dagger> a []])\<close>
	+ by (simp add: shift_def)
	+
	+section \<open>Operations\<close>
	+
	+subsection \<open>Shift\<close>
	+
	+lemma shift_eq [simp]: \<open>n = m \<Longrightarrow> (E\<langle>n:x\<rangle>) m = x\<close>
	+ by (simp add: shift_def)
	+
	+lemma shift_gt [simp]: \<open>m < n \<Longrightarrow> (E\<langle>n:x\<rangle>) m = E m\<close>
	+ by (simp add: shift_def)
	+
	+lemma shift_lt [simp]: \<open>n < m \<Longrightarrow> (E\<langle>n:x\<rangle>) m = E (m-1)\<close>
	+ by (simp add: shift_def)
	+
	+lemma shift_commute [simp]: \<open>E\<langle>n:y\<rangle>\<langle>0:x\<rangle> = E\<langle>0:x\<rangle>\<langle>n+1:y\<rangle>\<close>
	+proof
	+ fix m
	+ show \<open>(E\<langle>n:y\<rangle>\<langle>0:x\<rangle>) m = (E\<langle>0:x\<rangle>\<langle>n+1:y\<rangle>) m\<close>
	+ unfolding shift_def by (cases m) simp_all
	+qed
	+
	+subsection \<open>Variables\<close>
	+
	+primrec vars_tm where
	+ \<open>vars_tm (\<^bold>#n) = [n]\<close>
	+\| \<open>vars_tm (\<^bold>\<dagger>_ ts) = concat (map vars_tm ts)\<close>
	+
	+primrec vars_fm where
	+ \<open>vars_fm \<^bold>\<bottom> = []\<close>
	+\| \<open>vars_fm (\<^bold>\<ddagger>_ ts) = concat (map vars_tm ts)\<close>
	+\| \<open>vars_fm (p \<^bold>\<longrightarrow> q) = vars_fm p @ vars_fm q\<close>
	+\| \<open>vars_fm (\<^bold>\<forall>p) = vars_fm p\<close>
	+
	+abbreviation \<open>vars S \<equiv> \<Union>p \<in> S. set (vars_fm p)\<close>
	+
	+primrec max_list :: \<open>nat list \<Rightarrow> nat\<close> where
	+ \<open>max_list [] = 0\<close>
	+\| \<open>max_list (x # xs) = max x (max_list xs)\<close>
	+
	+lemma max_list_append: \<open>max_list (xs @ ys) = max (max_list xs) (max_list ys)\<close>
	+ by (induct xs) auto
	+
	+lemma upd_vars_tm [simp]: \<open>n \<notin> set (vars_tm t) \<Longrightarrow> \<lparr>E(n := x), F\<rparr> t = \<lparr>E, F\<rparr> t\<close>
	+ by (induct t) (auto cong: map_cong)
	+
	+lemma shift_upd_commute: \<open>m \<le> n \<Longrightarrow> (E(n := x)\<langle>m:y\<rangle>) = ((E\<langle>m:y\<rangle>)(n + 1 := x))\<close>
	+ unfolding shift_def by fastforce
	+
	+lemma max_list_concat: \<open>xs \<in> set xss \<Longrightarrow> max_list xs \<le> max_list (concat xss)\<close>
	+ by (induct xss) (auto simp: max_list_append)
	+
	+lemma max_list_in: \<open>max_list xs < n \<Longrightarrow> n \<notin> set xs\<close>
	+ by (induct xs) auto
	+
	+lemma upd_vars_fm [simp]: \<open>max_list (vars_fm p) < n \<Longrightarrow> \<lbrakk>E(n := x), F, G\<rbrakk> p = \<lbrakk>E, F, G\<rbrakk> p\<close>
	+proof (induct p arbitrary: E n)
	+ case (Pre P ts)
	+ moreover have \<open>max_list (concat (map vars_tm ts)) < n\<close>
	+ using Pre.prems max_list_concat by simp
	+ then have \<open>n \<notin> set (concat (map vars_tm ts))\<close>
	+ using max_list_in by blast
	+ then have \<open>\<forall>t \<in> set ts. n \<notin> set (vars_tm t)\<close>
	+ by simp
	+ ultimately show ?case
	+ using upd_vars_tm by (metis list.map_cong semantics_fm.simps(2))
	+next
	+ case (Uni p)
	+ have \<open>?case = ((\<forall>y. \<lbrakk>E(n := x)\<langle>0:y\<rangle>, F, G\<rbrakk> p) = (\<forall>y. \<lbrakk>E\<langle>0:y\<rangle>, F, G\<rbrakk> p))\<close>
	+ by (simp add: fun_upd_def)
	+ also have \<open>\<dots> = ((\<forall>y. \<lbrakk>(E\<langle>0:y\<rangle>)(n + 1 := x), F, G\<rbrakk> p) = (\<forall>y. \<lbrakk>E\<langle>0:y\<rangle>, F, G\<rbrakk> p))\<close>
	+ by (simp add: shift_upd_commute)
	+ finally show ?case
	+ using Uni by fastforce
	+qed (auto simp: max_list_append cong: map_cong)
	+
	+abbreviation \<open>max_var p \<equiv> max_list (vars_fm p)\<close>
	+
	+subsection \<open>Instantiation\<close>
	+
	+primrec lift_tm (\<open>\<^bold>\<up>\<close>) where
	+ \<open>\<^bold>\<up>(\<^bold>#n) = \<^bold>#(n+1)\<close>
	+\| \<open>\<^bold>\<up>(\<^bold>\<dagger>f ts) = \<^bold>\<dagger>f (map \<^bold>\<up> ts)\<close>
	+
	+primrec inst_tm (\<open>_'\<llangle>_'/_'\<rrangle>\<close> [90, 0, 0] 91) where
	+ \<open>(\<^bold>#n)\<llangle>s/m\<rrangle> = (if n < m then \<^bold>#n else if n = m then s else \<^bold>#(n-1))\<close>
	+\| \<open>(\<^bold>\<dagger>f ts)\<llangle>s/m\<rrangle> = \<^bold>\<dagger>f (map (\<lambda>t. t\<llangle>s/m\<rrangle>) ts)\<close>
	+
	+primrec inst_fm (\<open>_'\<langle>_'/_'\<rangle>\<close> [90, 0, 0] 91) where
	+ \<open>\<^bold>\<bottom>\<langle>_/_\<rangle> = \<^bold>\<bottom>\<close>
	+\| \<open>(\<^bold>\<ddagger>P ts)\<langle>s/m\<rangle> = \<^bold>\<ddagger>P (map (\<lambda>t. t\<llangle>s/m\<rrangle>) ts)\<close>
	+\| \<open>(p \<^bold>\<longrightarrow> q)\<langle>s/m\<rangle> = (p\<langle>s/m\<rangle> \<^bold>\<longrightarrow> q\<langle>s/m\<rangle>)\<close>
	+\| \<open>(\<^bold>\<forall>p)\<langle>s/m\<rangle> = \<^bold>\<forall>(p\<langle>\<^bold>\<up>s/m+1\<rangle>)\<close>
	+
	+lemma lift_lemma [simp]: \<open>\<lparr>E\<langle>0:x\<rangle>, F\<rparr> (\<^bold>\<up>t) = \<lparr>E, F\<rparr> t\<close>
	+ by (induct t) (auto cong: map_cong)
	+
	+lemma inst_tm_semantics [simp]: \<open>\<lparr>E, F\<rparr> (t\<llangle>s/m\<rrangle>) = \<lparr>E\<langle>m:\<lparr>E, F\<rparr> s\<rangle>, F\<rparr> t\<close>
	+ by (induct t) (auto cong: map_cong)
	+
	+lemma inst_fm_semantics [simp]: \<open>\<lbrakk>E, F, G\<rbrakk> (p\<langle>t/m\<rangle>) = \<lbrakk>E\<langle>m:\<lparr>E, F\<rparr> t\<rangle>, F, G\<rbrakk> p\<close>
	+ by (induct p arbitrary: E m t) (auto cong: map_cong)
	+
	+subsection \<open>Size\<close>
	+
	+text \<open>The built-in \<open>size\<close> is not invariant under substitution.\<close>
	+
	+primrec size_fm where
	+ \<open>size_fm \<^bold>\<bottom> = 1\<close>
	+\| \<open>size_fm (\<^bold>\<ddagger>_ _) = 1\<close>
	+\| \<open>size_fm (p \<^bold>\<longrightarrow> q) = 1 + size_fm p + size_fm q\<close>
	+\| \<open>size_fm (\<^bold>\<forall>p) = 1 + size_fm p\<close>
	+
	+lemma size_inst_fm [simp]:
	+ \<open>size_fm (p\<langle>t/m\<rangle>) = size_fm p\<close>
	+ by (induct p arbitrary: m t) auto
	+
	+section \<open>Propositional Semantics\<close>
	+
	+primrec boolean where
	+ \<open>boolean _ _ \<^bold>\<bottom> = False\<close>
	+\| \<open>boolean G _ (\<^bold>\<ddagger>P ts) = G P ts\<close>
	+\| \<open>boolean G A (p \<^bold>\<longrightarrow> q) = (boolean G A p \<longrightarrow> boolean G A q)\<close>
	+\| \<open>boolean _ A (\<^bold>\<forall>p) = A (\<^bold>\<forall>p)\<close>
	+
	+abbreviation \<open>tautology p \<equiv> \<forall>G A. boolean G A p\<close>
	+
	+proposition \<open>tautology (\<^bold>\<forall>(\<^bold>\<ddagger>P [\<^bold>#0]) \<^bold>\<longrightarrow> \<^bold>\<forall>(\<^bold>\<ddagger>P [\<^bold>#0]))\<close>
	+ by simp
	+
	+lemma boolean_semantics: \<open>boolean (\<lambda>a. G a \<circ> map \<lparr>E, F\<rparr>) \<lbrakk>E, F, G\<rbrakk> = \<lbrakk>E, F, G\<rbrakk>\<close>
	+proof
	+ fix p
	+ show \<open>boolean (\<lambda>a. G a \<circ> map \<lparr>E, F\<rparr>) \<lbrakk>E, F, G\<rbrakk> p = \<lbrakk>E, F, G\<rbrakk> p\<close>
	+ by (induct p) simp_all
	+qed
	+
	+lemma tautology: \<open>tautology p \<Longrightarrow> \<lbrakk>E, F, G\<rbrakk> p\<close>
	+ using boolean_semantics by metis
	+
	+proposition \<open>\<exists>p. (\<forall>E F G. \<lbrakk>E, F, G\<rbrakk> p) \<and> \<not> tautology p\<close>
	+ by (metis boolean.simps(4) fm.simps(36) semantics_fm.simps(1,3,4))
	+
	+section \<open>Calculus\<close>
	+
	+text \<open>Adapted from System Q1 by Smullyan in First-Order Logic (1968)\<close>
	+
	+inductive Axiomatic (\<open>\<turnstile> _\<close> [50] 50) where
	+ TA: \<open>tautology p \<Longrightarrow> \<turnstile> p\<close>
	+\| IA: \<open>\<turnstile> \<^bold>\<forall>p \<^bold>\<longrightarrow> p\<langle>t/0\<rangle>\<close>
	+\| MP: \<open>\<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> \<turnstile> p \<Longrightarrow> \<turnstile> q\<close>
	+\| GR: \<open>\<turnstile> q \<^bold>\<longrightarrow> p\<langle>\<^bold>#n/0\<rangle> \<Longrightarrow> max_var p < n \<Longrightarrow> max_var q < n \<Longrightarrow> \<turnstile> q \<^bold>\<longrightarrow> \<^bold>\<forall>p\<close>
	+
	+lemmas
	+ TA[simp]
	+ MP[trans, dest]
	+ GR[intro]
	+
	+text \<open>We simulate assumptions on the lhs of \<open>\<turnstile>\<close> with a chain of implications on the rhs.\<close>
	+
	+primrec imply (infixr \<open>\<^bold>\<leadsto>\<close> 56) where
	+ \<open>([] \<^bold>\<leadsto> q) = q\<close>
	+\| \<open>(p # ps \<^bold>\<leadsto> q) = (p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q)\<close>
	+
	+abbreviation Axiomatic_assms (\<open>_ \<turnstile> _\<close> [50, 50] 50) where
	+ \<open>ps \<turnstile> q \<equiv> \<turnstile> ps \<^bold>\<leadsto> q\<close>
	+
	+section \<open>Soundness\<close>
	+
	+theorem soundness: \<open>\<turnstile> p \<Longrightarrow> \<lbrakk>E, F, G\<rbrakk> p\<close>
	+proof (induct p arbitrary: E F rule: Axiomatic.induct)
	+ case (GR q p n)
	+ then have \<open>\<lbrakk>E(n := x), F, G\<rbrakk> (q \<^bold>\<longrightarrow> p\<langle>\<^bold>#n/0\<rangle>)\<close> for x
	+ by blast
	+ then have \<open>\<lbrakk>E(n := x), F, G\<rbrakk> q \<longrightarrow> \<lbrakk>E(n := x), F, G\<rbrakk> (p\<langle>\<^bold>#n/0\<rangle>)\<close> for x
	+ by simp
	+ then have \<open>\<lbrakk>E, F, G\<rbrakk> q \<longrightarrow> \<lbrakk>E(n := x), F, G\<rbrakk> (p\<langle>\<^bold>#n/0\<rangle>)\<close> for x
	+ using GR.hyps(3-4) by simp
	+ then have \<open>\<lbrakk>E, F, G\<rbrakk> q \<longrightarrow> (\<forall>x. \<lbrakk>E(n := x), F, G\<rbrakk> (p\<langle>\<^bold>#n/0\<rangle>))\<close>
	+ by blast
	+ then have \<open>\<lbrakk>E, F, G\<rbrakk> q \<longrightarrow> (\<forall>x. \<lbrakk>E(n := x)\<langle>0:x\<rangle>, F, G\<rbrakk> p)\<close>
	+ by simp
	+ then have \<open>\<lbrakk>E, F, G\<rbrakk> q \<longrightarrow> (\<forall>x. \<lbrakk>(E\<langle>0:x\<rangle>)(n + 1 := x), F, G\<rbrakk> p)\<close>
	+ using shift_upd_commute by (metis zero_le)
	+ moreover have \<open>max_list (vars_fm p) < n\<close>
	+ using GR.hyps(3) by (simp add: max_list_append)
	+ ultimately have \<open>\<lbrakk>E, F, G\<rbrakk> q \<longrightarrow> (\<forall>x. \<lbrakk>E\<langle>0:x\<rangle>, F, G\<rbrakk> p)\<close>
	+ using upd_vars_fm by simp
	+ then show ?case
	+ by simp
	+qed (auto simp: tautology)
	+
	+corollary \<open>\<not> (\<turnstile> \<^bold>\<bottom>)\<close>
	+ using soundness by fastforce
	+
	+section \<open>Derived Rules\<close>
	+
	+lemma AS: \<open>\<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r\<close>
	+ by auto
	+
	+lemma AK: \<open>\<turnstile> q \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close>
	+ by auto
	+
	+lemma Neg: \<open>\<turnstile> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> p\<close>
	+ by auto
	+
	+lemma contraposition:
	+ \<open>\<turnstile> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> \<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<not> p\<close>
	+ \<open>\<turnstile> (\<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<not> p) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> q\<close>
	+ by (auto intro: TA)
	+
	+lemma GR': \<open>\<turnstile> \<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle> \<^bold>\<longrightarrow> q \<Longrightarrow> max_var p < n \<Longrightarrow> max_var q < n \<Longrightarrow> \<turnstile> \<^bold>\<not> \<^bold>\<forall>p \<^bold>\<longrightarrow> q\<close>
	+proof -
	+ assume *: \<open>\<turnstile> \<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle> \<^bold>\<longrightarrow> q\<close> and n: \<open>max_var p < n\<close> \<open>max_var q < n\<close>
	+ have \<open>\<turnstile> \<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<not> \<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>\<close>
	+ using * contraposition(1) by fast
	+ then have \<open>\<turnstile> \<^bold>\<not> q \<^bold>\<longrightarrow> p\<langle>\<^bold>#n/0\<rangle>\<close>
	+ by (meson AK AS MP Neg)
	+ then have \<open>\<turnstile> \<^bold>\<not> q \<^bold>\<longrightarrow> \<^bold>\<forall>p\<close>
	+ using n by auto
	+ then have \<open>\<turnstile> \<^bold>\<not> \<^bold>\<forall>p \<^bold>\<longrightarrow> \<^bold>\<not> \<^bold>\<not> q\<close>
	+ using contraposition(1) by fast
	+ then show ?thesis
	+ by (meson AK AS MP Neg)
	+qed
	+
	+lemma Imp3: \<open>\<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> ((s \<^bold>\<longrightarrow> p) \<^bold>\<longrightarrow> (s \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> s \<^bold>\<longrightarrow> r)\<close>
	+ by auto
	+
	+lemma imply_ImpE: \<open>\<turnstile> ps \<^bold>\<leadsto> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q\<close>
	+ by (induct ps) (auto intro: Imp3 MP)
	+
	+lemma MP' [trans, dest]: \<open>ps \<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> ps \<turnstile> p \<Longrightarrow> ps \<turnstile> q\<close>
	+ using imply_ImpE by fast
	+
	+lemma imply_Cons [intro]: \<open>ps \<turnstile> q \<Longrightarrow> p # ps \<turnstile> q\<close>
	+ by (auto intro: MP AK)
	+
	+lemma imply_head [intro]: \<open>p # ps \<turnstile> p\<close>
	+proof (induct ps)
	+ case (Cons q ps)
	+ then show ?case
	+ by (metis AK MP' imply.simps(1-2))
	+qed auto
	+
	+lemma imply_lift_Imp [simp]:
	+ assumes \<open>\<turnstile> p \<^bold>\<longrightarrow> q\<close>
	+ shows \<open>\<turnstile> p \<^bold>\<longrightarrow> ps \<^bold>\<leadsto> q\<close>
	+ using assms MP MP' imply_head by (metis imply.simps(2))
	+
	+lemma add_imply [simp]: \<open>\<turnstile> q \<Longrightarrow> ps \<turnstile> q\<close>
	+ using MP imply_head by (auto simp del: TA)
	+
	+lemma imply_mem [simp]: \<open>p \<in> set ps \<Longrightarrow> ps \<turnstile> p\<close>
	+proof (induct ps)
	+ case (Cons q ps)
	+ then show ?case
	+ by (metis imply_Cons imply_head set_ConsD)
	+qed simp
	+
	+lemma deduct1: \<open>ps \<turnstile> p \<^bold>\<longrightarrow> q \<Longrightarrow> p # ps \<turnstile> q\<close>
	+ by (meson MP' imply_Cons imply_head)
	+
	+lemma imply_append [iff]: \<open>(ps @ qs \<^bold>\<leadsto> r) = (ps \<^bold>\<leadsto> qs \<^bold>\<leadsto> r)\<close>
	+ by (induct ps) simp_all
	+
	+lemma imply_swap_append: \<open>ps @ qs \<turnstile> r \<Longrightarrow> qs @ ps \<turnstile> r\<close>
	+proof (induct qs arbitrary: ps)
	+ case (Cons q qs)
	+ then show ?case
	+ by (metis deduct1 imply.simps(2) imply_append)
	+qed simp
	+
	+lemma deduct2: \<open>p # ps \<turnstile> q \<Longrightarrow> ps \<turnstile> p \<^bold>\<longrightarrow> q\<close>
	+ by (metis imply.simps(1-2) imply_append imply_swap_append)
	+
	+lemmas deduct [iff] = deduct1 deduct2
	+
	+lemma cut [trans, dest]: \<open>p # ps \<turnstile> r \<Longrightarrow> q # ps \<turnstile> p \<Longrightarrow> q # ps \<turnstile> r\<close>
	+ by (meson MP' deduct(2) imply_Cons)
	+
	+lemma Boole: \<open>(\<^bold>\<not> p) # ps \<turnstile> \<^bold>\<bottom> \<Longrightarrow> ps \<turnstile> p\<close>
	+ by (meson MP' Neg add_imply deduct(2))
	+
	+lemma imply_weaken: \<open>ps \<turnstile> q \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> ps' \<turnstile> q\<close>
	+proof (induct ps arbitrary: q)
	+ case (Cons p ps)
	+ then show ?case
	+ by (metis MP' deduct(2) imply_mem insert_subset list.simps(15))
	+qed simp
	+
	+section \<open>Consistent\<close>
	+
	+definition \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	+
	+lemma UN_finite_bound:
	+ assumes \<open>finite A\<close> and \<open>A \<subseteq> (\<Union>n. f n)\<close>
	+ shows \<open>\<exists>m :: nat. A \<subseteq> (\<Union>n \<le> m. f n)\<close>
	+ using assms
	+proof (induct rule: finite_induct)
	+ case (insert x A)
	+ then obtain m where \<open>A \<subseteq> (\<Union>n \<le> m. f n)\<close>
	+ by fast
	+ then have \<open>A \<subseteq> (\<Union>n \<le> (m + k). f n)\<close> for k
	+ by fastforce
	+ moreover obtain m' where \<open>x \<in> f m'\<close>
	+ using insert(4) by blast
	+ ultimately have \<open>{x} \<union> A \<subseteq> (\<Union>n \<le> m + m'. f n)\<close>
	+ by auto
	+ then show ?case
	+ by blast
	+qed simp
	+
	+lemma split_list:
	+ assumes \<open>x \<in> set A\<close>
	+ shows \<open>set (x # removeAll x A) = set A \<and> x \<notin> set (removeAll x A)\<close>
	+ using assms by auto
	+
	+lemma imply_vars_fm: \<open>vars_fm (ps \<^bold>\<leadsto> q) = concat (map vars_fm ps) @ vars_fm q\<close>
	+ by (induct ps) auto
	+
	+lemma inconsistent_fm:
	+ assumes \<open>consistent S\<close> and \<open>\<not> consistent ({p} \<union> S)\<close>
	+ obtains S' where \<open>set S' \<subseteq> S\<close> and \<open>p # S' \<turnstile> \<^bold>\<bottom>\<close>
	+proof -
	+ obtain S' where S': \<open>set S' \<subseteq> {p} \<union> S\<close> \<open>p \<in> set S'\<close> \<open>S' \<turnstile> \<^bold>\<bottom>\<close>
	+ using assms unfolding consistent_def by blast
	+ then obtain S'' where S'': \<open>set (p # S'') = set S'\<close> \<open>p \<notin> set S''\<close>
	+ using split_list by metis
	+ then have \<open>p # S'' \<turnstile> \<^bold>\<bottom>\<close>
	+ using \<open>S' \<turnstile> \<^bold>\<bottom>\<close> imply_weaken by blast
	+ then show ?thesis
	+ using that S'' S'(1)
	+ by (metis Diff_insert_absorb Diff_subset_conv list.simps(15))
	+qed
	+
	+definition max_set :: \<open>nat set \<Rightarrow> nat\<close> where
	+ \<open>max_set X \<equiv> if X = {} then 0 else Max X\<close>
	+
	+lemma max_list_in_Cons: \<open>xs \<noteq> [] \<Longrightarrow> max_list xs \<in> set xs\<close>
	+proof (induct xs)
	+ case Nil
	+ then show ?case
	+ by simp
	+next
	+ case (Cons x xs)
	+ then show ?case
	+ by (metis linorder_not_less list.set_intros(1-2) max.absorb2 max.absorb3
	+ max_list.simps(1-2) max_nat.right_neutral)
	+qed
	+
	+lemma max_list_max: \<open>\<forall>x \<in> set xs. x \<le> max_list xs\<close>
	+ by (induct xs) auto
	+
	+lemma max_list_in_set: \<open>finite S \<Longrightarrow> set xs \<subseteq> S \<Longrightarrow> max_list xs \<le> max_set S\<close>
	+ unfolding max_set_def using max_list_in_Cons
	+ by (metis (mono_tags, lifting) Max_ge bot.extremum_uniqueI bot_nat_0.extremum max_list.simps(1)
	+ set_empty subsetD)
	+
	+lemma consistent_add_witness:
	+ assumes \<open>consistent S\<close> and \<open>(\<^bold>\<not> \<^bold>\<forall>p) \<in> S\<close>
	+ and \<open>finite (vars S)\<close> and \<open>max_set (vars S) < n\<close>
	+ shows \<open>consistent ({\<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>} \<union> S)\<close>
	+ unfolding consistent_def
	+proof
	+ assume \<open>\<exists>S'. set S' \<subseteq> {\<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>} \<union> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	+ then obtain S' where \<open>set S' \<subseteq> S\<close> and \<open>(\<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>) # S' \<turnstile> \<^bold>\<bottom>\<close>
	+ using assms inconsistent_fm unfolding consistent_def by metis
	+ then have \<open>\<turnstile> \<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle> \<^bold>\<longrightarrow> S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	+ by simp
	+ moreover have \<open>max_list (vars_fm p) < n\<close>
	+ using assms(2-4) max_list_in_set by fastforce
	+ moreover have \<open>\<forall>p \<in> set S'. max_list (vars_fm p) < n\<close>
	+ using \<open>set S' \<subseteq> S\<close> assms(3-4) max_list_in_set
	+ by (meson Union_upper image_eqI order_le_less_trans subsetD)
	+ then have \<open>max_list (concat (map vars_fm S')) < n\<close>
	+ using assms(4) by (induct S') (auto simp: max_list_append)
	+ then have \<open>max_list (vars_fm (S' \<^bold>\<leadsto> \<^bold>\<bottom>)) < n\<close>
	+ unfolding imply_vars_fm max_list_append by simp
	+ ultimately have \<open>\<turnstile> \<^bold>\<not> \<^bold>\<forall>p \<^bold>\<longrightarrow> S' \<^bold>\<leadsto> \<^bold>\<bottom>\<close>
	+ using GR' unfolding max_list_append by auto
	+ then have \<open>(\<^bold>\<not> \<^bold>\<forall>p) # S' \<turnstile> \<^bold>\<bottom>\<close>
	+ by simp
	+ moreover have \<open>set ((\<^bold>\<not> \<^bold>\<forall>p) # S') \<subseteq> S\<close>
	+ using \<open>set S' \<subseteq> S\<close> assms(2) by simp
	+ ultimately show False
	+ using assms(1) unfolding consistent_def by blast
	+qed
	+
	+lemma consistent_add_instance:
	+ assumes \<open>consistent S\<close> and \<open>\<^bold>\<forall>p \<in> S\<close>
	+ shows \<open>consistent ({p\<langle>t/0\<rangle>} \<union> S)\<close>
	+ unfolding consistent_def
	+proof
	+ assume \<open>\<exists>S'. set S' \<subseteq> {p\<langle>t/0\<rangle>} \<union> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	+ then obtain S' where \<open>set S' \<subseteq> S\<close> and \<open>p\<langle>t/0\<rangle> # S' \<turnstile> \<^bold>\<bottom>\<close>
	+ using assms inconsistent_fm unfolding consistent_def by blast
	+ moreover have \<open>\<turnstile> \<^bold>\<forall>p \<^bold>\<longrightarrow> p\<langle>t/0\<rangle>\<close>
	+ using IA by blast
	+ ultimately have \<open>\<^bold>\<forall>p # S' \<turnstile> \<^bold>\<bottom>\<close>
	+ by (meson add_imply cut deduct(1))
	+ moreover have \<open>set ((\<^bold>\<forall>p) # S') \<subseteq> S\<close>
	+ using \<open>set S' \<subseteq> S\<close> assms(2) by simp
	+ ultimately show False
	+ using assms(1) unfolding consistent_def by blast
	+qed
	+
	+section \<open>Extension\<close>
	+
	+fun witness where
	+ \<open>witness used (\<^bold>\<not> \<^bold>\<forall>p) = {\<^bold>\<not> p\<langle>\<^bold>#(SOME n. max_set used < n)/0\<rangle>}\<close>
	+\| \<open>witness _ _ = {}\<close>
	+
	+primrec extend where
	+ \<open>extend S f 0 = S\<close>
	+\| \<open>extend S f (Suc n) =
	+ (let Sn = extend S f n in
	+ if consistent ({f n} \<union> Sn)
	+ then witness (vars ({f n} \<union> Sn)) (f n) \<union> {f n} \<union> Sn
	+ else Sn)\<close>
	+
	+definition \<open>Extend S f \<equiv> \<Union>n. extend S f n\<close>
	+
	+lemma Extend_subset: \<open>S \<subseteq> Extend S f\<close>
	+ unfolding Extend_def by (metis Union_upper extend.simps(1) range_eqI)
	+
	+lemma extend_bound: \<open>(\<Union>n \<le> m. extend S f n) = extend S f m\<close>
	+ by (induct m) (simp_all add: atMost_Suc Let_def)
	+
	+lemma finite_vars_witness [simp]: \<open>finite (vars (witness used p))\<close>
	+ by (induct used p rule: witness.induct) simp_all
	+
	+lemma finite_vars_extend [simp]: \<open>finite (vars S) \<Longrightarrow> finite (vars (extend S f n))\<close>
	+ by (induct n) (simp_all add: Let_def)
	+
	+lemma max_list_mono: \<open>set xs \<subseteq> set ys \<Longrightarrow> max_list xs \<le> max_list ys\<close>
	+ using max_list_max max_list_in_Cons
	+ by (metis less_nat_zero_code linorder_not_le max_list.simps(1) subset_code(1))
	+
	+lemma consistent_witness:
	+ fixes p :: \<open>('f, 'p) fm\<close>
	+ assumes \<open>consistent S\<close> and \<open>p \<in> S\<close> and \<open>vars S \<subseteq> used\<close> and \<open>finite used\<close>
	+ shows \<open>consistent (witness used p \<union> S)\<close>
	+ using assms
	+proof (induct used p rule: witness.induct)
	+ case (1 used p)
	+ moreover have \<open>\<exists>n. max_set used < n\<close>
	+ by blast
	+ ultimately obtain n where n: \<open>witness used (\<^bold>\<not> \<^bold>\<forall>p) = {\<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>}\<close> and \<open>max_set used < n\<close>
	+ by (metis someI_ex witness.simps(1))
	+ then have \<open>max_set (vars S) < n\<close>
	+ using 1(3-4) max_list_mono order_le_less_trans
	+ by (metis (no_types, lifting) Max.subset_imp bot.extremum_uniqueI less_nat_zero_code linorder_neqE_nat max_set_def)
	+ moreover have \<open>finite (vars S)\<close>
	+ using 1(3-4) infinite_super by blast
	+ ultimately show ?case
	+ using 1 n(1) consistent_add_witness by metis
	+qed (auto simp: assms)
	+
	+lemma consistent_extend:
	+ fixes f :: \<open>nat \<Rightarrow> ('f, 'p) fm\<close>
	+ assumes \<open>consistent S\<close> \<open>finite (vars S)\<close>
	+ shows \<open>consistent (extend S f n)\<close>
	+ using assms
	+proof (induct n)
	+ case (Suc n)
	+ then show ?case
	+ using consistent_witness[where S=\<open>{f n} \<union> _\<close>] by (auto simp: Let_def)
	+qed simp
	+
	+lemma consistent_Extend:
	+ fixes f :: \<open>nat \<Rightarrow> ('f, 'p) fm\<close>
	+ assumes \<open>consistent S\<close> \<open>finite (vars S)\<close>
	+ shows \<open>consistent (Extend S f)\<close>
	+ unfolding consistent_def
	+proof
	+ assume \<open>\<exists>S'. set S' \<subseteq> Extend S f \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	+ then obtain S' where \<open>S' \<turnstile> \<^bold>\<bottom>\<close> and \<open>set S' \<subseteq> Extend S f\<close>
	+ unfolding consistent_def by blast
	+ then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend S f n)\<close>
	+ unfolding Extend_def using UN_finite_bound by (metis List.finite_set)
	+ then have \<open>set S' \<subseteq> extend S f m\<close>
	+ using extend_bound by blast
	+ moreover have \<open>consistent (extend S f m)\<close>
	+ using assms consistent_extend by blast
	+ ultimately show False
	+ unfolding consistent_def using \<open>S' \<turnstile> \<^bold>\<bottom>\<close> by blast
	+qed
	+
	+section \<open>Maximal\<close>
	+
	+definition \<open>maximal S \<equiv> \<forall>p. p \<notin> S \<longrightarrow> \<not> consistent ({p} \<union> S)\<close>
	+
	+lemma maximal_exactly_one:
	+ assumes \<open>consistent S\<close> and \<open>maximal S\<close>
	+ shows \<open>p \<in> S \<longleftrightarrow> (\<^bold>\<not> p) \<notin> S\<close>
	+proof
	+ assume \<open>p \<in> S\<close>
	+ show \<open>(\<^bold>\<not> p) \<notin> S\<close>
	+ proof
	+ assume \<open>(\<^bold>\<not> p) \<in> S\<close>
	+ then have \<open>set [p, \<^bold>\<not> p] \<subseteq> S\<close>
	+ using \<open>p \<in> S\<close> by simp
	+ moreover have \<open>[p, \<^bold>\<not> p] \<turnstile> \<^bold>\<bottom>\<close>
	+ by blast
	+ ultimately show False
	+ using \<open>consistent S\<close> unfolding consistent_def by blast
	+ qed
	+next
	+ assume \<open>(\<^bold>\<not> p) \<notin> S\<close>
	+ then have \<open>\<not> consistent ({\<^bold>\<not> p} \<union> S)\<close>
	+ using \<open>maximal S\<close> unfolding maximal_def by blast
	+ then obtain S' where \<open>set S' \<subseteq> S\<close> \<open>(\<^bold>\<not> p) # S' \<turnstile> \<^bold>\<bottom>\<close>
	+ using \<open>consistent S\<close> inconsistent_fm by blast
	+ then have \<open>S' \<turnstile> p\<close>
	+ using Boole by blast
	+ have \<open>consistent ({p} \<union> S)\<close>
	+ unfolding consistent_def
	+ proof
	+ assume \<open>\<exists>S'. set S' \<subseteq> {p} \<union> S \<and> S' \<turnstile> \<^bold>\<bottom>\<close>
	+ then obtain S'' where \<open>set S'' \<subseteq> S\<close> and \<open>p # S'' \<turnstile> \<^bold>\<bottom>\<close>
	+ using assms inconsistent_fm unfolding consistent_def by blast
	+ then have \<open>S' @ S'' \<turnstile> \<^bold>\<bottom>\<close>
	+ using \<open>S' \<turnstile> p\<close> by (metis MP' add_imply imply.simps(2) imply_append)
	+ moreover have \<open>set (S' @ S'') \<subseteq> S\<close>
	+ using \<open>set S' \<subseteq> S\<close> \<open>set S'' \<subseteq> S\<close> by simp
	+ ultimately show False
	+ using \<open>consistent S\<close> unfolding consistent_def by blast
	+ qed
	+ then show \<open>p \<in> S\<close>
	+ using \<open>maximal S\<close> unfolding maximal_def by blast
	+qed
	+
	+lemma maximal_Extend:
	+ assumes \<open>surj f\<close>
	+ shows \<open>maximal (Extend S f)\<close>
	+proof (rule ccontr)
	+ assume \<open>\<not> maximal (Extend S f)\<close>
	+ then obtain p where
	+ \<open>p \<notin> Extend S f\<close> and \<open>consistent ({p} \<union> Extend S f)\<close>
	+ unfolding maximal_def using assms consistent_Extend by blast
	+ obtain k where k: \<open>f k = p\<close>
	+ using \<open>surj f\<close> unfolding surj_def by metis
	+ then have \<open>p \<notin> extend S f (Suc k)\<close>
	+ using \<open>p \<notin> Extend S f\<close> unfolding Extend_def by blast
	+ then have \<open>\<not> consistent ({p} \<union> extend S f k)\<close>
	+ using k by (auto simp: Let_def)
	+ moreover have \<open>{p} \<union> extend S f k \<subseteq> {p} \<union> Extend S f\<close>
	+ unfolding Extend_def by blast
	+ ultimately have \<open>\<not> consistent ({p} \<union> Extend S f)\<close>
	+ unfolding consistent_def by auto
	+ then show False
	+ using \<open>consistent ({p} \<union> Extend S f)\<close> by blast
	+qed
	+
	+section \<open>Saturation\<close>
	+
	+definition \<open>saturated S \<equiv> \<forall>p. (\<^bold>\<not> \<^bold>\<forall>p) \<in> S \<longrightarrow> (\<exists>n. (\<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>) \<in> S)\<close>
	+
	+lemma saturated_Extend:
	+ assumes \<open>consistent (Extend S f)\<close> and \<open>surj f\<close>
	+ shows \<open>saturated (Extend S f)\<close>
	+proof (rule ccontr)
	+ assume \<open>\<not> saturated (Extend S f)\<close>
	+ then obtain p where p: \<open>(\<^bold>\<not> \<^bold>\<forall>p) \<in> Extend S f\<close> \<open>\<nexists>n. (\<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>) \<in> Extend S f\<close>
	+ unfolding saturated_def by blast
	+ obtain k where k: \<open>f k = (\<^bold>\<not> \<^bold>\<forall>p)\<close>
	+ using \<open>surj f\<close> unfolding surj_def by metis
	+
	+ have \<open>extend S f k \<subseteq> Extend S f\<close>
	+ unfolding Extend_def by auto
	+ then have \<open>consistent ({\<^bold>\<not> \<^bold>\<forall>p} \<union> extend S f k)\<close>
	+ using assms(1) p(1) unfolding consistent_def by blast
	+ then have \<open>\<exists>n. extend S f (Suc k) = {\<^bold>\<not> p\<langle>\<^bold>#n/0\<rangle>} \<union> {\<^bold>\<not> \<^bold>\<forall>p} \<union> extend S f k\<close>
	+ using k by (auto simp: Let_def)
	+ moreover have \<open>extend S f (Suc k) \<subseteq> Extend S f\<close>
	+ unfolding Extend_def by blast
	+ ultimately show False
	+ using p(2) by auto
	+qed
	+
	+section \<open>Hintikka\<close>
	+
	+locale Hintikka =
	+ fixes H :: \<open>('f, 'p) fm set\<close>
	+ assumes
	+ NoFalsity: \<open>\<^bold>\<bottom> \<notin> H\<close> and
	+ ImpP: \<open>(p \<^bold>\<longrightarrow> q) \<in> H \<Longrightarrow> p \<notin> H \<or> q \<in> H\<close> and
	+ ImpN: \<open>(p \<^bold>\<longrightarrow> q) \<notin> H \<Longrightarrow> p \<in> H \<and> q \<notin> H\<close> and
	+ UniP: \<open>\<^bold>\<forall>p \<in> H \<Longrightarrow> \<forall>t. p\<langle>t/0\<rangle> \<in> H\<close> and
	+ UniN: \<open>\<^bold>\<forall>p \<notin> H \<Longrightarrow> \<exists>n. p\<langle>\<^bold>#n/0\<rangle> \<notin> H\<close>
	+
	+subsection \<open>Model Existence\<close>
	+
	+abbreviation hmodel (\<open>\<lbrakk>_\<rbrakk>\<close>) where \<open>\<lbrakk>H\<rbrakk> \<equiv> \<lbrakk>\<^bold>#, \<^bold>\<dagger>, \<lambda>P ts. Pre P ts \<in> H\<rbrakk>\<close>
	+
	+lemma semantics_tm_id [simp]:
	+ \<open>\<lparr>\<^bold>#, \<^bold>\<dagger>\<rparr> t = t\<close>
	+ by (induct t) (auto cong: map_cong)
	+
	+lemma semantics_tm_id_map [simp]: \<open>map \<lparr>\<^bold>#, \<^bold>\<dagger>\<rparr> ts = ts\<close>
	+ by (auto cong: map_cong)
	+
	+theorem Hintikka_model:
	+ assumes \<open>Hintikka H\<close>
	+ shows \<open>p \<in> H \<longleftrightarrow> \<lbrakk>H\<rbrakk> p\<close>
	+proof (induct p rule: wf_induct[where r=\<open>measure size_fm\<close>])
	+ case 1
	+ then show ?case ..
	+next
	+ case (2 x)
	+ show \<open>x \<in> H \<longleftrightarrow> \<lbrakk>H\<rbrakk> x\<close>
	+ proof (cases x; safe)
	+ case Falsity
	+ assume \<open>\<^bold>\<bottom> \<in> H\<close>
	+ then have False
	+ using assms Hintikka.NoFalsity by fast
	+ then show \<open>\<lbrakk>H\<rbrakk> \<^bold>\<bottom>\<close> ..
	+ next
	+ case Falsity
	+ assume \<open>\<lbrakk>H\<rbrakk> \<^bold>\<bottom>\<close>
	+ then have False
	+ by simp
	+ then show \<open>\<^bold>\<bottom> \<in> H\<close> ..
	+ next
	+ case (Pre P ts)
	+ assume \<open>\<^bold>\<ddagger>P ts \<in> H\<close>
	+ then show \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<ddagger>P ts)\<close>
	+ by simp
	+ next
	+ case (Pre P ts)
	+ assume \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<ddagger>P ts)\<close>
	+ then show \<open>\<^bold>\<ddagger>P ts \<in> H\<close>
	+ by simp
	+ next
	+ case (Imp p q)
	+ assume \<open>(p \<^bold>\<longrightarrow> q) \<in> H\<close>
	+ then have \<open>p \<notin> H \<or> q \<in> H\<close>
	+ using assms Hintikka.ImpP by blast
	+ then have \<open>\<not> \<lbrakk>H\<rbrakk> p \<or> \<lbrakk>H\<rbrakk> q\<close>
	+ using 2 Imp by simp
	+ then show \<open>\<lbrakk>H\<rbrakk> (p \<^bold>\<longrightarrow> q)\<close>
	+ by simp
	+ next
	+ case (Imp p q)
	+ assume \<open>\<lbrakk>H\<rbrakk> (p \<^bold>\<longrightarrow> q)\<close>
	+ then have \<open>\<not> \<lbrakk>H\<rbrakk> p \<or> \<lbrakk>H\<rbrakk> q\<close>
	+ by simp
	+ then have \<open>p \<notin> H \<or> q \<in> H\<close>
	+ using 2 Imp by simp
	+ then show \<open>(p \<^bold>\<longrightarrow> q) \<in> H\<close>
	+ using assms Hintikka.ImpN by blast
	+ next
	+ case (Uni p)
	+ assume \<open>\<^bold>\<forall>p \<in> H\<close>
	+ then have \<open>\<forall>t. p\<langle>t/0\<rangle> \<in> H\<close>
	+ using assms Hintikka.UniP by metis
	+ then have \<open>\<forall>t. \<lbrakk>H\<rbrakk> (p\<langle>t/0\<rangle>)\<close>
	+ using 2 Uni by simp
	+ then show \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<forall>p)\<close>
	+ by simp
	+ next
	+ case (Uni p)
	+ assume \<open>\<lbrakk>H\<rbrakk> (\<^bold>\<forall>p)\<close>
	+ then have \<open>\<forall>t. \<lbrakk>H\<rbrakk> (p\<langle>t/0\<rangle>)\<close>
	+ by simp
	+ then have \<open>\<forall>t. p\<langle>t/0\<rangle> \<in> H\<close>
	+ using 2 Uni by simp
	+ then show \<open>\<^bold>\<forall>p \<in> H\<close>
	+ using assms Hintikka.UniN by blast
	+ qed
	+qed
	+
	+subsection \<open>Maximal Consistent Sets are Hintikka Sets\<close>
	+
	+lemma inconsistent_head:
	+ assumes \<open>consistent S\<close> and \<open>maximal S\<close> and \<open>p \<notin> S\<close>
	+ obtains S' where \<open>set S' \<subseteq> S\<close> and \<open>p # S' \<turnstile> \<^bold>\<bottom>\<close>
	+ using assms inconsistent_fm unfolding consistent_def maximal_def by metis
	+
	+lemma inconsistent_parts [simp]:
	+ assumes \<open>ps \<turnstile> \<^bold>\<bottom>\<close> and \<open>set ps \<subseteq> S\<close>
	+ shows \<open>\<not> consistent S\<close>
	+ using assms unfolding consistent_def by blast
	+
	+lemma Hintikka_Extend:
	+ fixes H :: \<open>('f, 'p) fm set\<close>
	+ assumes \<open>consistent H\<close> and \<open>maximal H\<close> and \<open>saturated H\<close>
	+ shows \<open>Hintikka H\<close>
	+proof
	+ show \<open>\<^bold>\<bottom> \<notin> H\<close>
	+ proof
	+ assume \<open>\<^bold>\<bottom> \<in> H\<close>
	+ moreover have \<open>[\<^bold>\<bottom>] \<turnstile> \<^bold>\<bottom>\<close>
	+ by blast
	+ ultimately have \<open>\<not> consistent H\<close>
	+ using inconsistent_parts[where ps=\<open>[\<^bold>\<bottom>]\<close>] by simp
	+ then show False
	+ using \<open>consistent H\<close> ..
	+ qed
	+next
	+ fix p q
	+ assume *: \<open>(p \<^bold>\<longrightarrow> q) \<in> H\<close>
	+ show \<open>p \<notin> H \<or> q \<in> H\<close>
	+ proof safe
	+ assume \<open>q \<notin> H\<close>
	+ then obtain Hq' where Hq': \<open>q # Hq' \<turnstile> \<^bold>\<bottom>\<close> \<open>set Hq' \<subseteq> H\<close>
	+ using assms inconsistent_head by metis
	+
	+ assume \<open>p \<in> H\<close>
	+ then have \<open>(\<^bold>\<not> p) \<notin> H\<close>
	+ using assms maximal_exactly_one by blast
	+ then obtain Hp' where Hp': \<open>(\<^bold>\<not> p) # Hp' \<turnstile> \<^bold>\<bottom>\<close> \<open>set Hp' \<subseteq> H\<close>
	+ using assms inconsistent_head by metis
	+
	+ let ?H' = \<open>Hp' @ Hq'\<close>
	+ have H': \<open>set ?H' = set Hp' \<union> set Hq'\<close>
	+ by simp
	+ then have \<open>set Hp' \<subseteq> set ?H'\<close> and \<open>set Hq' \<subseteq> set ?H'\<close>
	+ by blast+
	+ then have \<open>(\<^bold>\<not> p) # ?H' \<turnstile> \<^bold>\<bottom>\<close> and \<open>q # ?H' \<turnstile> \<^bold>\<bottom>\<close>
	+ using Hp'(1) Hq'(1) deduct imply_weaken by metis+
	+ then have \<open>(p \<^bold>\<longrightarrow> q) # ?H' \<turnstile> \<^bold>\<bottom>\<close>
	+ using Boole imply_Cons imply_head MP' cut by metis
	+ moreover have \<open>set ((p \<^bold>\<longrightarrow> q) # ?H') \<subseteq> H\<close>
	+ using \<open>q \<notin> H\<close> *(1) H' Hp'(2) Hq'(2) by auto
	+ ultimately show False
	+ using assms unfolding consistent_def by blast
	+ qed
	+next
	+ fix p q
	+ assume *: \<open>(p \<^bold>\<longrightarrow> q) \<notin> H\<close>
	+ show \<open>p \<in> H \<and> q \<notin> H\<close>
	+ proof (safe, rule ccontr)
	+ assume \<open>p \<notin> H\<close>
	+ then obtain H' where S': \<open>p # H' \<turnstile> \<^bold>\<bottom>\<close> \<open>set H' \<subseteq> H\<close>
	+ using assms inconsistent_head by metis
	+ moreover have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> p\<close>
	+ by auto
	+ ultimately have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> \<^bold>\<bottom>\<close>
	+ by blast
	+ moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H') \<subseteq> H\<close>
	+ using *(1) S'(2) assms maximal_exactly_one by auto
	+ ultimately show False
	+ using assms unfolding consistent_def by blast
	+ next
	+ assume \<open>q \<in> H\<close>
	+ then have \<open>(\<^bold>\<not> q) \<notin> H\<close>
	+ using assms maximal_exactly_one by blast
	+ then obtain H' where H': \<open>(\<^bold>\<not> q) # H' \<turnstile> \<^bold>\<bottom>\<close> \<open>set H' \<subseteq> H\<close>
	+ using assms inconsistent_head by metis
	+ moreover have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> \<^bold>\<not> q\<close>
	+ by auto
	+ ultimately have \<open>(\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H' \<turnstile> \<^bold>\<bottom>\<close>
	+ by blast
	+ moreover have \<open>set ((\<^bold>\<not> (p \<^bold>\<longrightarrow> q)) # H') \<subseteq> H\<close>
	+ using *(1) H'(2) assms maximal_exactly_one by auto
	+ ultimately show False
	+ using assms unfolding consistent_def by blast
	+ qed
	+next
	+ fix p
	+ assume \<open>\<^bold>\<forall>p \<in> H\<close>
	+ then show \<open>\<forall>t. p\<langle>t/0\<rangle> \<in> H\<close>
	+ using assms consistent_add_instance unfolding maximal_def by blast
	+next
	+ fix p
	+ assume \<open>\<^bold>\<forall>p \<notin> H\<close>
	+ then show \<open>\<exists>n. p\<langle>\<^bold>#n/0\<rangle> \<notin> H\<close>
	+ using assms maximal_exactly_one unfolding saturated_def by fast
	+qed
	+
	+section \<open>Countable Formulas\<close>
	+
	+instance tm :: (countable) countable
	+ by countable_datatype
	+
	+instance fm :: (countable, countable) countable
	+ by countable_datatype
	+
	+section \<open>Completeness\<close>
	+
	+theorem strong_completeness:
	+ fixes p :: \<open>('f :: countable, 'p :: countable) fm\<close>
	+ assumes \<open>\<forall>(E :: _ \<Rightarrow> 'f tm) F G. Ball X \<lbrakk>E, F, G\<rbrakk> \<longrightarrow> \<lbrakk>E, F, G\<rbrakk> p\<close>
	+ and \<open>finite (vars X)\<close>
	+ shows \<open>\<exists>ps. set ps \<subseteq> X \<and> ps \<turnstile> p\<close>
	+proof (rule ccontr)
	+ assume \<open>\<nexists>ps. set ps \<subseteq> X \<and> ps \<turnstile> p\<close>
	+ then have *: \<open>\<nexists>ps. set ps \<subseteq> X \<and> (\<^bold>\<not> p) # ps \<turnstile> \<^bold>\<bottom>\<close>
	+ using Boole by blast
	+
	+ let ?S = \<open>{\<^bold>\<not> p} \<union> X\<close>
	+ let ?H = \<open>Extend ?S from_nat\<close>
	+
	+ have \<open>consistent ?S\<close>
	+ using * by (metis consistent_def imply_Cons inconsistent_fm)
	+ moreover have \<open>finite (vars ?S)\<close>
	+ using assms by simp
	+ ultimately have \<open>consistent ?H\<close> and \<open>maximal ?H\<close>
	+ using assms consistent_Extend maximal_Extend surj_from_nat by blast+
	+ moreover from this have \<open>saturated ?H\<close>
	+ using saturated_Extend by fastforce
	+ ultimately have \<open>Hintikka ?H\<close>
	+ using assms Hintikka_Extend by blast
	+
	+ have \<open>\<lbrakk>?H\<rbrakk> p\<close> if \<open>p \<in> ?S\<close> for p
	+ using that Extend_subset Hintikka_model \<open>Hintikka ?H\<close> by blast
	+ then have \<open>\<lbrakk>?H\<rbrakk> (\<^bold>\<not> p)\<close> and \<open>\<forall>q \<in> X. \<lbrakk>?H\<rbrakk> q\<close>
	+ by fastforce+
	+ moreover from this have \<open>\<lbrakk>?H\<rbrakk> p\<close>
	+ using assms(1) by blast
	+ ultimately show False
	+ by simp
	+qed
	+
	+theorem completeness:
	+ fixes p :: \<open>('f :: countable, 'p :: countable) fm\<close>
	+ assumes \<open>\<forall>(E :: _ \<Rightarrow> 'f tm) F G. \<lbrakk>E, F, G\<rbrakk> p\<close>
	+ shows \<open>\<turnstile> p\<close>
	+ using assms strong_completeness[where X=\<open>{}\<close>] by simp
	+
	+corollary
	+ fixes p :: \<open>(unit, unit) fm\<close>
	+ assumes \<open>\<forall>(E :: nat \<Rightarrow> unit tm) F G. \<lbrakk>E, F, G\<rbrakk> p\<close>
	+ shows \<open>\<turnstile> p\<close>
	+ using completeness assms .
	+
	+section \<open>Main Result\<close>
	+
	+abbreviation valid :: \<open>(nat, nat) fm \<Rightarrow> bool\<close> where
	+ \<open>valid p \<equiv> \<forall>(E :: nat \<Rightarrow> nat tm) F G. \<lbrakk>E, F, G\<rbrakk> p\<close>
	+
	+theorem main: \<open>valid p \<longleftrightarrow> (\<turnstile> p)\<close>
	+ using completeness soundness by blast
	+
	+end
	diff --git a/thys/FOL_Axiomatic/ROOT b/thys/FOL_Axiomatic/ROOT
	--- a/thys/FOL_Axiomatic/ROOT
	+++ b/thys/FOL_Axiomatic/ROOT
	@@ -1,11 +1,12 @@
	chapter AFP

	session FOL_Axiomatic (AFP) = "HOL" +
	options [timeout = 300]
	sessions
	"HOL-Library"
	theories
	FOL_Axiomatic
	+ FOL_Axiomatic_Variant
	document_files
	"root.tex"
	"root.bib"
	diff --git a/thys/FOL_Seq_Calc2/.gitignore b/thys/FOL_Seq_Calc2/.gitignore
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/.gitignore
	@@ -0,0 +1,41 @@
	+# -- mode: gitignore; --
	+
	+### Haskell ###
	+dist
	+dist-*
	+cabal-dev
	+*.o
	+*.hi
	+*.hie
	+*.chi
	+*.chs.h
	+*.dyn_o
	+*.dyn_hi
	+.hpc
	+.hsenv
	+.cabal-sandbox/
	+cabal.sandbox.config
	+*.prof
	+*.aux
	+*.hp
	+*.eventlog
	+.stack-work/
	+cabal.project.local
	+cabal.project.local~
	+.HTF/
	+.ghc.environment.*
	+
	+### Autogenerated code ###
	+**/prover
	+output
	+test-tmp
	+
	+### Backups ###
	+*~
	+\#*\#
	+/.emacs.desktop
	+/.emacs.desktop.lock
	+*.elc
	+auto-save-list
	+tramp
	+.\#*
	diff --git a/thys/FOL_Seq_Calc2/.hlint.yaml b/thys/FOL_Seq_Calc2/.hlint.yaml
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/.hlint.yaml
	@@ -0,0 +1,1 @@
	+- arguments: [--ignore-glob=haskell/prover]
	diff --git a/thys/FOL_Seq_Calc2/Completeness.thy b/thys/FOL_Seq_Calc2/Completeness.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Completeness.thy
	@@ -0,0 +1,82 @@
	+section \<open>Completeness\<close>
	+
	+theory Completeness
	+ imports Countermodel EPathHintikka
	+begin
	+
	+text \<open>In this theory, we prove that the prover is complete with regards to the SeCaV proof system
	+ using the abstract completeness framework.\<close>
	+
	+text \<open>We start out by specializing the abstract completeness theorem to our prover.
	+ It is necessary to reproduce the final theorem here so we can alter it to state that our prover
	+ produces a proof tree instead of simply stating that a proof tree exists.\<close>
	+theorem epath_prover_completeness:
	+ fixes A :: \<open>tm list\<close> and z :: \<open>fm list\<close>
	+ defines \<open>t \<equiv> secavProver (A, z)\<close>
	+ shows \<open>(fst (root t) = (A, z) \<and> wf t \<and> tfinite t) \<or>
	+ (\<exists> steps. fst (shd steps) = (A, z) \<and> epath steps \<and> Saturated steps)\<close>
	+ (is \<open>?A \<or> ?B\<close>)
	+proof -
	+ { assume \<open>\<not> ?A\<close>
	+ with assms have \<open>\<not> tfinite (mkTree rules (A, z))\<close>
	+ unfolding secavProver_def using wf_mkTree fair_rules by simp
	+ then obtain steps where \<open>ipath (mkTree rules (A, z)) steps\<close> using Konig by blast
	+ with assms have \<open>fst (shd steps) = (A, z) \<and> epath steps \<and> Saturated steps\<close>
	+ by (metis UNIV_I fair_rules ipath.cases ipath_mkTree_Saturated mkTree.simps(1) prod.sel(1)
	+ wf_ipath_epath wf_mkTree)
	+ then have ?B by blast
	+ }
	+ then show ?thesis by blast
	+qed
	+
	+text \<open>This is an abbreviation for validity under our bounded semantics
	+ (for well-formed interpretations).\<close>
	+abbreviation
	+ \<open>uvalid z \<equiv> \<forall>u (e :: nat \<Rightarrow> tm) f g. is_env u e \<longrightarrow> is_fdenot u f \<longrightarrow>
	+ (\<exists>p \<in> set z. usemantics u e f g p)\<close>
	+
	+text \<open>The sequent in the first state of a saturated escape path is not valid.
	+ This follows from our results in the theories EPathHintikka and Countermodel.\<close>
	+lemma epath_countermodel:
	+ assumes \<open>fst (shd steps) = (A, z)\<close> and \<open>epath steps\<close> and \<open>Saturated steps\<close>
	+ shows \<open>\<not> uvalid z\<close>
	+proof
	+ assume \<open>uvalid z\<close>
	+ moreover have \<open>Hintikka (tree_fms steps)\<close> (is \<open>Hintikka ?S\<close>)
	+ using assms escape_path_Hintikka assms by simp
	+ moreover have \<open>\<forall>p \<in> set z. p \<in> tree_fms steps\<close>
	+ using assms shd_sset by (metis Pair_inject prod.collapse pseq_def pseq_in_tree_fms)
	+ then have \<open>\<exists>g. \<forall>p \<in> set z. \<not> usemantics (terms ?S) (E ?S) (F ?S) g p\<close>
	+ using calculation(2) Hintikka_counter_model assms by blast
	+ moreover have \<open>is_env (terms ?S) (E ?S)\<close> \<open>is_fdenot (terms ?S) (F ?S)\<close>
	+ using is_env_E is_fdenot_F by blast+
	+ ultimately show False
	+ by blast
	+qed
	+
	+text \<open>Combining the results above, we can prove completeness with regards to our bounded
	+ semantics: if a sequent is valid under our bounded semantics, the prover will produce a finite,
	+ well-formed proof tree with the sequent at its root.\<close>
	+theorem prover_completeness_usemantics:
	+ fixes A :: \<open>tm list\<close>
	+ assumes \<open>uvalid z\<close>
	+ defines \<open>t \<equiv> secavProver (A, z)\<close>
	+ shows \<open>fst (root t) = (A, z) \<and> wf t \<and> tfinite t\<close>
	+ using assms epath_prover_completeness epath_countermodel by blast
	+
	+text \<open>Since our bounded semantics are sound, we can derive our main completeness theorem as
	+ a corollary: if a sequent is provable in the SeCaV proof system, the prover will produce a finite,
	+ well-formed proof tree with the sequent at its root.\<close>
	+corollary prover_completeness_SeCaV:
	+ fixes A :: \<open>tm list\<close>
	+ assumes \<open>\<tturnstile> z\<close>
	+ defines \<open>t \<equiv> secavProver (A, z)\<close>
	+ shows \<open>fst (root t) = (A, z) \<and> wf t \<and> tfinite t\<close>
	+proof -
	+ have \<open>uvalid z\<close>
	+ using assms sound_usemantics by blast
	+ then show ?thesis
	+ using assms prover_completeness_usemantics by blast
	+qed
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/Countermodel.thy b/thys/FOL_Seq_Calc2/Countermodel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Countermodel.thy
	@@ -0,0 +1,265 @@
	+section \<open>Countermodels from Hintikka sets\<close>
	+
	+theory Countermodel
	+ imports Hintikka Usemantics ProverLemmas
	+begin
	+
	+text \<open>In this theory, we will construct a countermodel in the bounded semantics from a Hintikka
	+ set. This will allow us to prove completeness of the prover.\<close>
	+
	+text \<open>A predicate is satisfied in the model based on a set of formulas S when its negation is in S.\<close>
	+abbreviation (input)
	+ \<open>G S n ts \<equiv> Neg (Pre n ts) \<in> S\<close>
	+
	+text \<open>Alternate interpretation for environments: if a variable is not present, we interpret it as
	+ some existing term.\<close>
	+abbreviation
	+ \<open>E S n \<equiv> if Var n \<in> terms S then Var n else SOME t. t \<in> terms S\<close>
	+
	+text \<open>Alternate interpretation for functions: if a function application is not present, we interpret
	+ it as some existing term.\<close>
	+abbreviation
	+ \<open>F S i l \<equiv> if Fun i l \<in> terms S then Fun i l else SOME t. t \<in> terms S\<close>
	+
	+text \<open>The terms function never returns the empty set (because it will add \<open>Fun 0 []\<close> if that is the
	+ case).\<close>
	+lemma terms_ne [simp]: \<open>terms S \<noteq> {}\<close>
	+ unfolding terms_def by simp
	+
	+text \<open>If a term is in the set of terms, it is either the default term or a subterm of some formula
	+ in the set.\<close>
	+lemma terms_cases: \<open>t \<in> terms S \<Longrightarrow> t = Fun 0 [] \<or> (\<exists>p \<in> S. t \<in> set (subtermFm p))\<close>
	+ unfolding terms_def by (simp split: if_splits)
	+
	+text \<open>The set of terms is downwards closed under the subterm function.\<close>
	+lemma terms_downwards_closed: \<open>t \<in> terms S \<Longrightarrow> set (subtermTm t) \<subseteq> terms S\<close>
	+proof (induct t)
	+ case (Fun n ts)
	+ moreover have \<open>\<forall>t \<in> set ts. t \<in> set ts\<close>
	+ by simp
	+ moreover have \<open>\<forall>t \<in> set ts. t \<in> terms S\<close>
	+ proof
	+ fix t
	+ assume *: \<open>t \<in> set ts\<close>
	+ then show \<open>t \<in> terms S\<close>
	+ proof (cases \<open>terms S = {Fun 0 []}\<close>)
	+ case True
	+ then show ?thesis
	+ using Fun * by simp
	+ next
	+ case False
	+ moreover obtain p where p: \<open>p \<in> S\<close> \<open>Fun n ts \<in> set (subtermFm p)\<close>
	+ using Fun(2) terms_cases * by fastforce
	+ then have \<open>set ts \<subseteq> set (subtermFm p)\<close>
	+ using fun_arguments_subterm by blast
	+ ultimately show \<open>t \<in> terms S\<close>
	+ unfolding terms_def using * p(1) by (metis UN_iff in_mono)
	+ qed
	+ qed
	+ ultimately have \<open>\<forall>t \<in> set ts. set (subtermTm t) \<subseteq> terms S\<close>
	+ using Fun by meson
	+ moreover note \<open>Fun n ts \<in> terms S\<close>
	+ ultimately show ?case
	+ by auto
	+next
	+ case (Var x)
	+ then show ?case
	+ by simp
	+qed
	+
	+text \<open>If terms are actually in a set of formulas, interpreting the environment over these formulas
	+allows for a Herbrand interpretation.\<close>
	+lemma usemantics_E:
	+ \<open>t \<in> terms S \<Longrightarrow> semantics_term (E S) (F S) t = t\<close>
	+ \<open>list_all (\<lambda>t. t \<in> terms S) ts \<Longrightarrow> semantics_list (E S) (F S) ts = ts\<close>
	+proof (induct t and ts arbitrary: ts rule: semantics_term.induct semantics_list.induct)
	+ case (Fun i ts')
	+ moreover have \<open>\<forall>t' \<in> set ts'. t' \<in> set (subtermTm (Fun i ts'))\<close>
	+ using subterm_Fun_refl by blast
	+ ultimately have \<open>list_all (\<lambda>t. t \<in> terms S) ts'\<close>
	+ using terms_downwards_closed unfolding list_all_def by (metis (no_types, lifting) subsetD)
	+ then show ?case
	+ using Fun by simp
	+qed simp_all
	+
	+text \<open>Our alternate interpretation of environments is well-formed for the terms function.\<close>
	+lemma is_env_E:
	+ \<open>is_env (terms S) (E S)\<close>
	+ unfolding is_env_def
	+proof
	+ fix n
	+ show \<open>E S n \<in> terms S\<close>
	+ by (cases \<open>Var n \<in> terms S\<close>) (simp_all add: some_in_eq)
	+qed
	+
	+text \<open>Our alternate function interpretation is well-formed for the terms function.\<close>
	+lemma is_fdenot_F:
	+ \<open>is_fdenot (terms S) (F S)\<close>
	+ unfolding is_fdenot_def
	+proof (intro allI impI)
	+ fix i l
	+ assume \<open>list_all (\<lambda>x. x \<in> terms S) l\<close>
	+ then show \<open>F S i l \<in> terms S\<close>
	+ by (cases \<open>\<forall>n. Var n \<in> terms S\<close>) (simp_all add: some_in_eq)
	+qed
	+
	+abbreviation
	+ \<open>M S \<equiv> usemantics (terms S) (E S) (F S) (G S)\<close>
	+
	+text \<open>If S is a Hintikka set, then we can construct a countermodel for any formula using our
	+ bounded semantics and a Herbrand interpretation.\<close>
	+theorem Hintikka_counter_model:
	+ assumes \<open>Hintikka S\<close>
	+ shows \<open>(p \<in> S \<longrightarrow> \<not> M S p) \<and> (Neg p \<in> S \<longrightarrow> M S p)\<close>
	+proof (induct p rule: wf_induct [where r=\<open>measure size\<close>])
	+ case 1
	+ then show ?case ..
	+next
	+ fix x
	+ assume wf: \<open>\<forall>q. (q, x) \<in> measure size \<longrightarrow>
	+ (q \<in> S \<longrightarrow> \<not> M S q) \<and> (Neg q \<in> S \<longrightarrow> M S q)\<close>
	+ show \<open>(x \<in> S \<longrightarrow> \<not> M S x) \<and> (Neg x \<in> S \<longrightarrow> M S x)\<close>
	+ proof (cases x)
	+ case (Pre n ts)
	+ show ?thesis
	+ proof (intro conjI impI)
	+ assume \<open>x \<in> S\<close>
	+ then have \<open>Neg (Pre n ts) \<notin> S\<close>
	+ using assms Pre Hintikka.Basic by blast
	+ moreover have \<open>list_all (\<lambda>t. t \<in> terms S) ts\<close>
	+ using \<open>x \<in> S\<close> Pre subterm_Pre_refl unfolding terms_def list_all_def by force
	+ ultimately show \<open>\<not> M S x\<close>
	+ using Pre usemantics_E
	+ by (metis (no_types, lifting) usemantics.simps(1))
	+ next
	+ assume \<open>Neg x \<in> S\<close>
	+ then have \<open>G S n ts\<close>
	+ using assms Pre Hintikka.Basic by blast
	+ moreover have \<open>list_all (\<lambda>t. t \<in> terms S) ts\<close>
	+ using \<open>Neg x \<in> S\<close> Pre subterm_Pre_refl unfolding terms_def list_all_def by force
	+ ultimately show \<open>M S x\<close>
	+ using Pre usemantics_E
	+ by (metis (no_types, lifting) usemantics.simps(1))
	+ qed
	+ next
	+ case (Imp p q)
	+ show ?thesis
	+ proof (intro conjI impI)
	+ assume \<open>x \<in> S\<close>
	+ then have \<open>Neg p \<in> S\<close> \<open>q \<in> S\<close>
	+ using Imp assms Hintikka.AlphaImp by blast+
	+ then show \<open>\<not> M S x\<close>
	+ using wf Imp by fastforce
	+ next
	+ assume \<open>Neg x \<in> S\<close>
	+ then have \<open>p \<in> S \<or> Neg q \<in> S\<close>
	+ using Imp assms Hintikka.BetaImp by blast
	+ then show \<open>M S x\<close>
	+ using wf Imp by fastforce
	+ qed
	+ next
	+ case (Dis p q)
	+ show ?thesis
	+ proof (intro conjI impI)
	+ assume \<open>x \<in> S\<close>
	+ then have \<open>p \<in> S\<close> \<open>q \<in> S\<close>
	+ using Dis assms Hintikka.AlphaDis by blast+
	+ then show \<open>\<not> M S x\<close>
	+ using wf Dis by fastforce
	+ next
	+ assume \<open>Neg x \<in> S\<close>
	+ then have \<open>Neg p \<in> S \<or> Neg q \<in> S\<close>
	+ using Dis assms Hintikka.BetaDis by blast
	+ then show \<open>M S x\<close>
	+ using wf Dis by fastforce
	+ qed
	+ next
	+ case (Con p q)
	+ show ?thesis
	+ proof (intro conjI impI)
	+ assume \<open>x \<in> S\<close>
	+ then have \<open>p \<in> S \<or> q \<in> S\<close>
	+ using Con assms Hintikka.BetaCon by blast
	+ then show \<open>\<not> M S x\<close>
	+ using wf Con by fastforce
	+ next
	+ assume \<open>Neg x \<in> S\<close>
	+ then have \<open>Neg p \<in> S\<close> \<open>Neg q \<in> S\<close>
	+ using Con assms Hintikka.AlphaCon by blast+
	+ then show \<open>M S x\<close>
	+ using wf Con by fastforce
	+ qed
	+ next
	+ case (Exi p)
	+ show ?thesis
	+ proof (intro conjI impI)
	+ assume \<open>x \<in> S\<close>
	+ then have \<open>\<forall>t \<in> terms S. sub 0 t p \<in> S\<close>
	+ using Exi assms Hintikka.GammaExi by blast
	+ then have \<open>\<forall>t \<in> terms S. \<not> M S (sub 0 t p)\<close>
	+ using wf Exi size_sub
	+ by (metis (no_types, lifting) add.right_neutral add_Suc_right fm.size(12) in_measure lessI)
	+ moreover have \<open>\<forall>t \<in> terms S. semantics_term (E S) (F S) t = t\<close>
	+ using usemantics_E(1) terms_downwards_closed unfolding list_all_def by blast
	+ ultimately have \<open>\<forall>t \<in> terms S. \<not> usemantics (terms S) (SeCaV.shift (E S) 0 t) (F S) (G S) p\<close>
	+ by simp
	+ then show \<open>\<not> M S x\<close>
	+ using Exi by simp
	+ next
	+ assume \<open>Neg x \<in> S\<close>
	+ then obtain t where \<open>t \<in> terms S\<close> \<open>Neg (sub 0 t p) \<in> S\<close>
	+ using Exi assms Hintikka.DeltaExi by metis
	+ then have \<open>M S (sub 0 t p)\<close>
	+ using wf Exi size_sub
	+ by (metis (no_types, lifting) add.right_neutral add_Suc_right fm.size(12) in_measure lessI)
	+ moreover have \<open>semantics_term (E S) (F S) t = t\<close>
	+ using \<open>t \<in> terms S\<close> usemantics_E(1) terms_downwards_closed unfolding list_all_def by blast
	+ ultimately show \<open>M S x\<close>
	+ using Exi \<open>t \<in> terms S\<close> by auto
	+ qed
	+ next
	+ case (Uni p)
	+ show ?thesis
	+ proof (intro conjI impI)
	+ assume \<open>x \<in> S\<close>
	+ then obtain t where \<open>t \<in> terms S\<close> \<open>sub 0 t p \<in> S\<close>
	+ using Uni assms Hintikka.DeltaUni by metis
	+ then have \<open>\<not> M S (sub 0 t p)\<close>
	+ using wf Uni size_sub
	+ by (metis (no_types, lifting) add.right_neutral add_Suc_right fm.size(13) in_measure lessI)
	+ moreover have \<open>semantics_term (E S) (F S) t = t\<close>
	+ using \<open>t \<in> terms S\<close> usemantics_E(1) terms_downwards_closed unfolding list_all_def by blast
	+ ultimately show \<open>\<not> M S x\<close>
	+ using Uni \<open>t \<in> terms S\<close> by auto
	+ next
	+ assume \<open>Neg x \<in> S\<close>
	+ then have \<open>\<forall>t \<in> terms S. Neg (sub 0 t p) \<in> S\<close>
	+ using Uni assms Hintikka.GammaUni by blast
	+ then have \<open>\<forall>t \<in> terms S. M S (sub 0 t p)\<close>
	+ using wf Uni size_sub
	+ by (metis (no_types, lifting) Nat.add_0_right add_Suc_right fm.size(13) in_measure lessI)
	+ moreover have \<open>\<forall>t \<in> terms S. semantics_term (E S) (F S) t = t\<close>
	+ using usemantics_E(1) terms_downwards_closed unfolding list_all_def by blast
	+ ultimately have \<open>\<forall>t \<in> terms S. \<not> usemantics (terms S) (SeCaV.shift (E S) 0 t) (F S) (G S) (Neg p)\<close>
	+ by simp
	+ then show \<open>M S x\<close>
	+ using Uni by simp
	+ qed
	+ next
	+ case (Neg p)
	+ show ?thesis
	+ proof (intro conjI impI)
	+ assume \<open>x \<in> S\<close>
	+ then show \<open>\<not> M S x\<close>
	+ using wf Neg by fastforce
	+ next
	+ assume \<open>Neg x \<in> S\<close>
	+ then have \<open>p \<in> S\<close>
	+ using Neg assms Hintikka.Neg by blast
	+ then show \<open>M S x\<close>
	+ using wf Neg by fastforce
	+ qed
	+ qed
	+qed
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/EPathHintikka.thy b/thys/FOL_Seq_Calc2/EPathHintikka.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/EPathHintikka.thy
	@@ -0,0 +1,808 @@
	+section \<open>Escape path formulas are Hintikka\<close>
	+
	+theory EPathHintikka imports Hintikka ProverLemmas begin
	+
	+text \<open>In this theory, we show that the formulas in the sequents on a saturated escape path in a
	+ proof tree form a Hintikka set.
	+ This is a crucial part of our completeness proof.\<close>
	+
	+subsection \<open>Definitions\<close>
	+text \<open>In this section we define a few concepts that make the following proofs easier to read.\<close>
	+
	+text \<open>\<open>pseq\<close> is the sequent in a node.\<close>
	+definition pseq :: \<open>state \<times> rule \<Rightarrow> sequent\<close> where
	+ \<open>pseq z = snd (fst z)\<close>
	+
	+text \<open>\<open>ptms\<close> is the list of terms in a node.\<close>
	+definition ptms :: \<open>state \<times> rule \<Rightarrow> tm list\<close> where
	+ \<open>ptms z = fst (fst z)\<close>
	+
	+subsection \<open>Facts about streams\<close>
	+
	+text \<open>Escape paths are infinite, so if you drop the first \<open>n\<close> nodes, you are still on the path.\<close>
	+lemma epath_sdrop: \<open>epath steps \<Longrightarrow> epath (sdrop n steps)\<close>
	+ by (induct n) (auto elim: epath.cases)
	+
	+text \<open>Dropping the first \<open>n\<close> elements of a stream can only reduce the set of elements in the stream.\<close>
	+lemma sset_sdrop: \<open>sset (sdrop n s) \<subseteq> sset s\<close>
	+proof (induct n arbitrary: s)
	+ case (Suc n)
	+ then show ?case
	+ by (metis in_mono sdrop_simps(2) stl_sset subsetI)
	+qed simp
	+
	+subsection \<open>Transformation of states on an escape path\<close>
	+text \<open>We need to prove some lemmas about how the states of an escape path are connected.\<close>
	+
	+text \<open>Since escape paths are well-formed, the eff relation holds between the nodes on the path.\<close>
	+lemma epath_eff:
	+ assumes \<open>epath steps\<close> \<open>eff (snd (shd steps)) (fst (shd steps)) ss\<close>
	+ shows \<open>fst (shd (stl steps)) \|\<in>\| ss\<close>
	+ using assms by (metis (mono_tags, lifting) epath.simps eff_def)
	+
	+text \<open>The list of terms in a state contains the terms of the current sequent and the terms from the
	+ previous state.\<close>
	+lemma effect_tms:
	+ assumes \<open>(B, z') \|\<in>\| effect r (A, z)\<close>
	+ shows \<open>B = remdups (A @ subterms z @ subterms z')\<close>
	+ using assms by (smt (verit, best) effect.simps fempty_iff fimageE prod.simps(1))
	+
	+text \<open>The two previous lemmas can be combined into a single lemma.\<close>
	+lemma epath_effect:
	+ assumes \<open>epath steps\<close> \<open>shd steps = ((A, z), r)\<close>
	+ shows \<open>\<exists>B z' r'. (B, z') \|\<in>\| effect r (A, z) \<and> shd (stl steps) = ((B, z'), r') \<and>
	+ (B = remdups (A @ subterms z @ subterms z'))\<close>
	+ using assms epath_eff effect_tms
	+ by (metis (mono_tags, lifting) eff_def fst_conv prod.collapse snd_conv)
	+
	+text \<open>The list of terms in the next state on an escape path contains the terms in the current state
	+ plus the terms from the next state.\<close>
	+lemma epath_stl_ptms:
	+ assumes \<open>epath steps\<close>
	+ shows \<open>ptms (shd (stl steps)) = remdups (ptms (shd steps) @
	+ subterms (pseq (shd steps)) @ subterms (pseq (shd (stl steps))))\<close>
	+ using assms epath_effect
	+ by (metis (mono_tags) eff_def effect_tms epath_eff pseq_def ptms_def surjective_pairing)
	+
	+text \<open>The list of terms never decreases on an escape path.\<close>
	+lemma epath_sdrop_ptms:
	+ assumes \<open>epath steps\<close>
	+ shows \<open>set (ptms (shd steps)) \<subseteq> set (ptms (shd (sdrop n steps)))\<close>
	+ using assms
	+proof (induct n)
	+ case (Suc n)
	+ then have \<open>epath (sdrop n steps)\<close>
	+ using epath_sdrop by blast
	+ then show ?case
	+ using Suc epath_stl_ptms by fastforce
	+qed simp
	+
	+subsection \<open>Preservation of formulas on escape paths\<close>
	+
	+text \<open>If a property will eventually hold on a path, there is some index from which it begins to
	+ hold, and before which it does not hold.\<close>
	+lemma ev_prefix_sdrop:
	+ assumes \<open>ev (holds P) xs\<close>
	+ shows \<open>\<exists>n. list_all (not P) (stake n xs) \<and> holds P (sdrop n xs)\<close>
	+ using assms
	+proof (induct xs)
	+ case (base xs)
	+ then show ?case
	+ by (metis list.pred_inject(1) sdrop.simps(1) stake.simps(1))
	+next
	+ case (step xs)
	+ then show ?case
	+ by (metis holds.elims(1) list.pred_inject(2) list_all_simps(2) sdrop.simps(1-2) stake.simps(1-2))
	+qed
	+
	+text \<open>More specifically, the path will consists of a prefix and a suffix for which the property
	+ does not hold and does hold, respectively.\<close>
	+lemma ev_prefix:
	+ assumes \<open>ev (holds P) xs\<close>
	+ shows \<open>\<exists>pre suf. list_all (not P) pre \<and> holds P suf \<and> xs = pre @- suf\<close>
	+ using assms ev_prefix_sdrop by (metis stake_sdrop)
	+
	+text \<open>All rules are always enabled, so they are also always enabled at specific steps.\<close>
	+lemma always_enabledAtStep: \<open>enabledAtStep r xs\<close>
	+ by (simp add: RuleSystem_Defs.enabled_def eff_def)
	+
	+text \<open>If a formula is in the sequent in the first state of an escape path and none of the rule
	+ applications in some prefix of the path affect that formula, the formula will still be in the
	+ sequent after that prefix.\<close>
	+lemma epath_preserves_unaffected:
	+ assumes \<open>p \<in> set (pseq (shd steps))\<close> and \<open>epath steps\<close> and \<open>steps = pre @- suf\<close> and
	+ \<open>list_all (not (\<lambda>step. affects (snd step) p)) pre\<close>
	+ shows \<open>p \<in> set (pseq (shd suf))\<close>
	+ using assms
	+proof (induct pre arbitrary: steps)
	+ case Nil
	+ then show ?case
	+ by simp
	+next
	+ case (Cons q pre)
	+ from this(3) show ?case
	+ proof cases
	+ case (epath sl)
	+ from this(2-4) show ?thesis
	+ using Cons(1-2, 4-5) effect_preserves_unaffected unfolding eff_def pseq_def list_all_def
	+ by (metis (no_types, lifting) list.sel(1) list.set_intros(1-2) prod.exhaust_sel
	+ shift.simps(2) shift_simps(1) stream.sel(2))
	+ qed
	+qed
	+
	+subsection \<open>Formulas on an escape path form a Hintikka set\<close>
	+
	+text \<open>This definition captures the set of formulas on an entire path\<close>
	+definition \<open>tree_fms steps \<equiv> \<Union>ss \<in> sset steps. set (pseq ss)\<close>
	+
	+text \<open>The sequent at the head of a path is in the set of formulas on that path\<close>
	+lemma pseq_in_tree_fms: \<open>\<lbrakk>x \<in> sset steps; p \<in> set (pseq x)\<rbrakk> \<Longrightarrow> p \<in> tree_fms steps\<close>
	+ using pseq_def tree_fms_def by blast
	+
	+text \<open>If a formula is in the set of formulas on a path, there is some index on the path where that
	+ formula can be found in the sequent.\<close>
	+lemma tree_fms_in_pseq: \<open>p \<in> tree_fms steps \<Longrightarrow> \<exists>n. p \<in> set (pseq (steps !! n))\<close>
	+ unfolding pseq_def tree_fms_def using sset_range[of steps] by simp
	+
	+text \<open>If a path is saturated, so is any suffix of that path (since saturation is defined in terms of
	+ the always operator).\<close>
	+lemma Saturated_sdrop: \<open>Saturated steps \<Longrightarrow> Saturated (sdrop n steps)\<close>
	+ by (simp add: RuleSystem_Defs.Saturated_def alw_iff_sdrop saturated_def)
	+
	+text \<open>This is an abbreviation that determines whether a given rule is applied in a given state.\<close>
	+abbreviation \<open>is_rule r step \<equiv> snd step = r\<close>
	+
	+text \<open>If a path is saturated, it is always possible to find a state in which a given rule is applied.\<close>
	+lemma Saturated_ev_rule:
	+ assumes \<open>Saturated steps\<close>
	+ shows \<open>ev (holds (is_rule r)) (sdrop n steps)\<close>
	+proof -
	+ have \<open>Saturated (sdrop n steps)\<close>
	+ using \<open>Saturated steps\<close> Saturated_sdrop by fast
	+ moreover have \<open>r \<in> Prover.R\<close>
	+ by (metis rules_repeat snth_sset)
	+ ultimately have \<open>saturated r (sdrop n steps)\<close>
	+ unfolding Saturated_def by fast
	+ then show ?thesis
	+ unfolding saturated_def using always_enabledAtStep holds.elims(3) by blast
	+qed
	+
	+text \<open>On an escape path, the sequent is never an axiom (since that would end the branch, and escape
	+ paths are infinitely long).\<close>
	+lemma epath_never_branchDone:
	+ assumes \<open>epath steps\<close>
	+ shows \<open>alw (holds (not (branchDone o pseq))) steps\<close>
	+proof (rule ccontr)
	+ assume \<open>\<not> ?thesis\<close>
	+ then have \<open>ev (holds (branchDone o pseq)) steps\<close>
	+ by (simp add: alw_iff_sdrop ev_iff_sdrop)
	+ then obtain n where n: \<open>holds (branchDone o pseq) (sdrop n steps)\<close>
	+ using sdrop_wait by blast
	+ let ?suf = \<open>sdrop n steps\<close>
	+ have \<open>\<forall>r A. effect r (A, pseq (shd ?suf)) = {\|\|}\<close>
	+ unfolding effect_def using n by simp
	+ moreover have \<open>epath ?suf\<close>
	+ using \<open>epath steps\<close> epath_sdrop by blast
	+ then have \<open>\<forall>r A. \<exists>z' r'. z' \|\<in>\| effect r (A, pseq (shd ?suf)) \<and> shd (stl ?suf) = (z', r')\<close>
	+ using epath_effect by (metis calculation prod.exhaust_sel pseq_def)
	+ ultimately show False
	+ by blast
	+qed
	+
	+text \<open>Finally we arrive at the main result of this theory:
	+ The set of formulas on a saturated escape path form a Hintikka set.
	+
	+ The proof basically says that, given a formula, we can find some index into the path where a rule
	+ is applied to decompose that formula into the parts needed for the Hintikka set.
	+ The lemmas above are used to guarantee that the formula does not disappear (and that the branch
	+ does not end) before the rule is applied, and that the correct formulas are generated by the
	+ effect function when the rule is finally applied.
	+ For Beta rules, only one of the constituent formulas need to be on the path, since the path runs
	+ along only one of the two branches.
	+ For Gamma and Delta rules, the construction of the list of terms in each state guarantees that
	+ the formulas are instantiated with terms in the Hintikka set.\<close>
	+lemma escape_path_Hintikka:
	+ assumes \<open>epath steps\<close> and \<open>Saturated steps\<close>
	+ shows \<open>Hintikka (tree_fms steps)\<close>
	+ (is \<open>Hintikka ?H\<close>)
	+proof
	+ fix n ts
	+ assume pre: \<open>Pre n ts \<in> ?H\<close>
	+ then obtain m where m: \<open>Pre n ts \<in> set (pseq (shd (sdrop m steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+
	+ show \<open>Neg (Pre n ts) \<notin> ?H\<close>
	+ proof
	+ assume \<open>Neg (Pre n ts) \<in> ?H\<close>
	+ then obtain k where k: \<open>Neg (Pre n ts) \<in> set (pseq (shd (sdrop k steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+
	+ let ?pre = \<open>stake (m + k) steps\<close>
	+ let ?suf = \<open>sdrop (m + k) steps\<close>
	+
	+ have
	+ 1: \<open>\<not> affects r (Pre n ts)\<close> and
	+ 2: \<open>\<not> affects r (Neg (Pre n ts))\<close> for r
	+ unfolding affects_def by (cases r, simp_all)+
	+
	+ have \<open>list_all (not (\<lambda>step. affects (snd step) (Pre n ts))) ?pre\<close>
	+ unfolding list_all_def using 1 by (induct ?pre) simp_all
	+ then have p: \<open>Pre n ts \<in> set (pseq (shd ?suf))\<close>
	+ using \<open>epath steps\<close> epath_preserves_unaffected m epath_sdrop
	+ by (metis (no_types, lifting) list.pred_mono_strong list_all_append
	+ sdrop_add stake_add stake_sdrop)
	+
	+ have \<open>list_all (not (\<lambda>step. affects (snd step) (Neg (Pre n ts)))) ?pre\<close>
	+ unfolding list_all_def using 2 by (induct ?pre) simp_all
	+ then have np: \<open>Neg (Pre n ts) \<in> set (pseq (shd ?suf))\<close>
	+ using \<open>epath steps\<close> epath_preserves_unaffected k epath_sdrop
	+ by (smt (verit, best) add.commute list.pred_mono_strong list_all_append sdrop_add
	+ stake_add stake_sdrop)
	+
	+ have \<open>holds (branchDone o pseq) ?suf\<close>
	+ using p np branchDone_contradiction by auto
	+ moreover have \<open>\<not> holds (branchDone o pseq) ?suf\<close>
	+ using \<open>epath steps\<close> epath_never_branchDone by (simp add: alw_iff_sdrop)
	+ ultimately show False
	+ by blast
	+ qed
	+next
	+ fix p q
	+ assume \<open>Dis p q \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = AlphaDis
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately have \<open>p \<in> set z'\<close> \<open>q \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce+
	+
	+ then show \<open>p \<in> ?H \<and> q \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
	+ sset_shift stl_sset subset_eq)
	+next
	+ fix p q
	+ assume \<open>Imp p q \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = AlphaImp
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately have \<open>Neg p \<in> set z'\<close> \<open>q \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce+
	+
	+ then show \<open>Neg p \<in> ?H \<and> q \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
	+ sset_shift stl_sset subset_eq)
	+next
	+ fix p q
	+ assume \<open>Neg (Con p q) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = AlphaCon
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately have \<open>Neg p \<in> set z'\<close> \<open>Neg q \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce+
	+
	+ then show \<open>Neg p \<in> ?H \<and> Neg q \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
	+ sset_shift stl_sset subset_eq)
	+next
	+ fix p q
	+ assume \<open>Con p q \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = BetaCon
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately consider \<open>p \<in> set z'\<close> \| \<open>q \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce
	+
	+ then show \<open>p \<in> ?H \<or> q \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
	+ sset_shift stl_sset subset_eq)
	+next
	+ fix p q
	+ assume \<open>Neg (Imp p q) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = BetaImp
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately consider \<open>p \<in> set z'\<close> \| \<open>Neg q \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce
	+
	+ then show \<open>p \<in> ?H \<or> Neg q \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
	+ sset_shift stl_sset subset_eq)
	+next
	+ fix p q
	+ assume \<open>Neg (Dis p q) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = BetaDis
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately consider \<open>Neg p \<in> set z'\<close> \| \<open>Neg q \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce
	+
	+ then show \<open>Neg p \<in> ?H \<or> Neg q \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
	+ sset_shift stl_sset subset_eq)
	+next
	+ fix p
	+ assume \<open>Exi p \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+
	+ let ?r = GammaExi
	+
	+ show \<open>\<forall>t \<in> terms ?H. sub 0 t p \<in> ?H\<close>
	+ proof
	+ fix t
	+ assume t: \<open>t \<in> terms ?H\<close>
	+ show \<open>sub 0 t p \<in> ?H\<close>
	+ proof -
	+ have \<open>\<exists>m. t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
	+ proof (cases \<open>(\<Union>f \<in> ?H. set (subtermFm f)) = {}\<close>)
	+ case True
	+ moreover have \<open>\<forall>p \<in> set (pseq (shd steps)). p \<in> ?H\<close>
	+ unfolding tree_fms_def by (metis pseq_in_tree_fms shd_sset tree_fms_def)
	+ ultimately have \<open>\<forall>p \<in> set (pseq (shd steps)). subtermFm p = []\<close>
	+ by simp
	+ then have \<open>concat (map subtermFm (pseq (shd steps))) = []\<close>
	+ by (induct \<open>pseq (shd steps)\<close>) simp_all
	+ then have \<open>subterms (pseq (shd steps)) = [Fun 0 []]\<close>
	+ unfolding subterms_def by (metis list.simps(4) remdups_eq_nil_iff)
	+ then show ?thesis
	+ using True t unfolding terms_def
	+ by (metis empty_iff insert_iff list.set_intros(1) sdrop.simps(1))
	+ next
	+ case False
	+ then obtain pt where pt: \<open>t \<in> set (subtermFm pt)\<close> \<open>pt \<in> ?H\<close>
	+ using t unfolding terms_def by (metis (no_types, lifting) UN_E)
	+ then obtain m where m: \<open>pt \<in> set (pseq (shd (sdrop m steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ then show ?thesis
	+ using pt(1) set_subterms by fastforce
	+ qed
	+ then obtain m where \<open>t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
	+ by blast
	+ then have \<open>t \<in> set (ptms (shd (stl (sdrop m steps))))\<close>
	+ using epath_stl_ptms epath_sdrop \<open>epath steps\<close>
	+ by (metis (no_types, opaque_lifting) Un_iff set_append set_remdups)
	+ moreover have \<open>epath (stl (sdrop m steps))\<close>
	+ using epath_sdrop \<open>epath steps\<close> by (meson epath.cases)
	+ ultimately have \<open>\<forall>k \<ge> m. t \<in> set (ptms (shd (stl (sdrop k steps))))\<close>
	+ using epath_sdrop_ptms by (metis (no_types, lifting) le_Suc_ex sdrop_add sdrop_stl subsetD)
	+ then have above: \<open>\<forall>k > m. t \<in> set (ptms (shd (sdrop k steps)))\<close>
	+ by (metis Nat.lessE less_irrefl_nat less_trans_Suc linorder_not_less sdrop_simps(2))
	+
	+ let ?pre = \<open>stake (n + m + 1) steps\<close>
	+ let ?suf = \<open>sdrop (n + m + 1) steps\<close>
	+
	+ have *: \<open>\<not> affects r ?f\<close> for r
	+ unfolding affects_def by (cases r, simp_all)+
	+
	+ have \<open>ev (holds (is_rule ?r)) ?suf\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf k where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>pre = stake k ?suf\<close> \<open>suf = sdrop k ?suf\<close>
	+ using ev_prefix_sdrop by blast
	+
	+ have k: \<open>\<exists>k > m. suf = sdrop k steps\<close>
	+ using ori by (meson le_add2 less_add_one order_le_less_trans sdrop_add trans_less_add1)
	+
	+ have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) ?pre\<close>
	+ unfolding list_all_def using * by (induct ?pre) simp_all
	+ then have \<open>?f \<in> set (pseq (shd ?suf))\<close>
	+ using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop
	+ by (metis (no_types, lifting) list.pred_mono_strong list_all_append
	+ sdrop_add stake_add stake_sdrop)
	+ then have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop * ori
	+ by (metis (no_types, lifting) list.pred_mono_strong pre stake_sdrop)
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by blast
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close>
	+ \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+
	+ moreover have \<open>t \<in> set (ptms (shd suf))\<close>
	+ using above k by (meson le_add2 less_add_one order_le_less_trans)
	+ ultimately have \<open>sub 0 t p \<in> set z'\<close>
	+ using parts_in_effect[where A=\<open>ptms (shd suf)\<close>] unfolding parts_def by fastforce
	+ then show ?thesis
	+ using k pseq_in_tree_fms z'(2)
	+ by (metis Pair_inject in_mono prod.collapse pseq_def shd_sset sset_sdrop stl_sset)
	+ qed
	+ qed
	+next
	+ fix p
	+ assume \<open>Neg (Uni p) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+
	+ let ?r = GammaUni
	+
	+ show \<open>\<forall>t \<in> terms ?H. Neg (sub 0 t p) \<in> ?H\<close>
	+ proof
	+ fix t
	+ assume t: \<open>t \<in> terms ?H\<close>
	+ show \<open>Neg (sub 0 t p) \<in> ?H\<close>
	+ proof -
	+ have \<open>\<exists>m. t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
	+ proof (cases \<open>(\<Union>f \<in> ?H. set (subtermFm f)) = {}\<close>)
	+ case True
	+ moreover have \<open>\<forall>p \<in> set (pseq (shd steps)). p \<in> ?H\<close>
	+ unfolding tree_fms_def by (metis pseq_in_tree_fms shd_sset tree_fms_def)
	+ ultimately have \<open>\<forall>p \<in> set (pseq (shd steps)). subtermFm p = []\<close>
	+ by simp
	+ then have \<open>concat (map subtermFm (pseq (shd steps))) = []\<close>
	+ by (induct \<open>pseq (shd steps)\<close>) simp_all
	+ then have \<open>subterms (pseq (shd steps)) = [Fun 0 []]\<close>
	+ unfolding subterms_def by (metis list.simps(4) remdups_eq_nil_iff)
	+ then show ?thesis
	+ using True t unfolding terms_def
	+ by (metis empty_iff insert_iff list.set_intros(1) sdrop.simps(1))
	+ next
	+ case False
	+ then obtain pt where pt: \<open>t \<in> set (subtermFm pt)\<close> \<open>pt \<in> ?H\<close>
	+ using t unfolding terms_def by (metis (no_types, lifting) UN_E)
	+ then obtain m where m: \<open>pt \<in> set (pseq (shd (sdrop m steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ then show ?thesis
	+ using pt(1) set_subterms by fastforce
	+ qed
	+ then obtain m where \<open>t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
	+ by blast
	+ then have \<open>t \<in> set (ptms (shd (stl (sdrop m steps))))\<close>
	+ using epath_stl_ptms epath_sdrop \<open>epath steps\<close>
	+ by (metis (no_types, lifting) Un_iff set_append set_remdups)
	+ moreover have \<open>epath (stl (sdrop m steps))\<close>
	+ using epath_sdrop \<open>epath steps\<close> by (meson epath.cases)
	+ ultimately have \<open>\<forall>k \<ge> m. t \<in> set (ptms (shd (stl (sdrop k steps))))\<close>
	+ using epath_sdrop_ptms by (metis (no_types, lifting) le_Suc_ex sdrop_add sdrop_stl subsetD)
	+ then have above: \<open>\<forall>k > m. t \<in> set (ptms (shd (sdrop k steps)))\<close>
	+ by (metis Nat.lessE less_irrefl_nat less_trans_Suc linorder_not_less sdrop_simps(2))
	+
	+ let ?pre = \<open>stake (n + m + 1) steps\<close>
	+ let ?suf = \<open>sdrop (n + m + 1) steps\<close>
	+
	+ have *: \<open>\<not> affects r ?f\<close> for r
	+ unfolding affects_def by (cases r, simp_all)+
	+
	+ have \<open>ev (holds (is_rule ?r)) ?suf\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf k where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>pre = stake k ?suf\<close> \<open>suf = sdrop k ?suf\<close>
	+ using ev_prefix_sdrop by blast
	+
	+ have k: \<open>\<exists>k > m. suf = sdrop k steps\<close>
	+ using ori by (meson le_add2 less_add_one order_le_less_trans sdrop_add trans_less_add1)
	+
	+ have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) ?pre\<close>
	+ unfolding list_all_def using * by (induct ?pre) simp_all
	+ then have \<open>?f \<in> set (pseq (shd ?suf))\<close>
	+ using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop
	+ by (metis (no_types, lifting) list.pred_mono_strong list_all_append
	+ sdrop_add stake_add stake_sdrop)
	+ then have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop * ori
	+ by (metis (no_types, lifting) list.pred_mono_strong pre stake_sdrop)
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by blast
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close>
	+ \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+
	+ moreover have \<open>t \<in> set (ptms (shd suf))\<close>
	+ using above k by (meson le_add2 less_add_one order_le_less_trans)
	+ ultimately have \<open>Neg (sub 0 t p) \<in> set z'\<close>
	+ using parts_in_effect[where A=\<open>ptms (shd suf)\<close>] unfolding parts_def by fastforce
	+ then show ?thesis
	+ using k pseq_in_tree_fms z'(2)
	+ by (metis Pair_inject in_mono prod.collapse pseq_def shd_sset sset_sdrop stl_sset)
	+ qed
	+ qed
	+next
	+ fix p
	+ assume \<open>Uni p \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = DeltaUni
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately obtain C where
	+ C: \<open>set (ptms (shd suf)) \<subseteq> set C\<close> \<open>sub 0 (Fun (generateNew C) []) p \<in> set z'\<close>
	+ using parts_in_effect[where B=B and z'=\<open>z'\<close> and z=\<open>pseq (shd suf)\<close> and r=\<open>?r\<close> and p=\<open>Uni p\<close>]
	+ unfolding parts_def by auto
	+ then have *: \<open>sub 0 (Fun (generateNew C) []) p \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, lifting) Pair_inject Un_iff in_mono prod.collapse pseq_def shd_sset
	+ sset_sdrop sset_shift stl_sset)
	+ let ?t = \<open>Fun (generateNew C) []\<close>
	+ show \<open>\<exists>t \<in> terms ?H. sub 0 t p \<in> ?H\<close>
	+ proof (cases \<open>?t \<in> set (subtermFm (sub 0 ?t p))\<close>)
	+ case True
	+ then have \<open>?t \<in> terms ?H\<close>
	+ unfolding terms_def using * by (metis UN_I empty_iff)
	+ then show ?thesis
	+ using * by blast
	+ next
	+ case False
	+ then have \<open>sub 0 t p = sub 0 ?t p\<close> for t
	+ using sub_const_transfer by metis
	+ moreover have \<open>terms ?H \<noteq> {}\<close>
	+ unfolding terms_def by simp
	+ then have \<open>\<exists>t. t \<in> terms ?H\<close>
	+ by blast
	+ ultimately show ?thesis
	+ using * by metis
	+ qed
	+next
	+ fix p
	+ assume \<open>Neg (Exi p) \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = DeltaExi
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately obtain C where
	+ C: \<open>set (ptms (shd suf)) \<subseteq> set C\<close> \<open>Neg (sub 0 (Fun (generateNew C) []) p) \<in> set z'\<close>
	+ using parts_in_effect[where B=B and z'=z' and z=\<open>pseq (shd suf)\<close> and r=\<open>?r\<close> and p=\<open>Neg (Exi p)\<close>]
	+ unfolding parts_def by auto
	+ then have *: \<open>Neg (sub 0 (Fun (generateNew C) []) p) \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, lifting) Pair_inject Un_iff in_mono prod.collapse pseq_def shd_sset
	+ sset_sdrop sset_shift stl_sset)
	+ let ?t = \<open>Fun (generateNew C) []\<close>
	+ show \<open>\<exists>t \<in> terms ?H. Neg (sub 0 t p) \<in> ?H\<close>
	+ proof (cases \<open>?t \<in> set (subtermFm (Neg (sub 0 ?t p)))\<close>)
	+ case True
	+ then have \<open>?t \<in> terms ?H\<close>
	+ unfolding terms_def using * by (metis UN_I empty_iff)
	+ then show ?thesis
	+ using * by blast
	+ next
	+ case False
	+ then have \<open>Neg (sub 0 t p) = Neg (sub 0 ?t p)\<close> for t
	+ using sub_const_transfer by (metis subtermFm.simps(7))
	+ moreover have \<open>terms ?H \<noteq> {}\<close>
	+ unfolding terms_def by simp
	+ then have \<open>\<exists>t. t \<in> terms ?H\<close>
	+ by blast
	+ ultimately show ?thesis
	+ using * by metis
	+ qed
	+next
	+ fix p
	+ assume \<open>Neg (Neg p) \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
	+ then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
	+ using tree_fms_in_pseq by auto
	+ let ?steps = \<open>sdrop n steps\<close>
	+ let ?r = NegNeg
	+ have \<open>ev (holds (is_rule ?r)) ?steps\<close>
	+ using \<open>Saturated steps\<close> Saturated_ev_rule by blast
	+ then obtain pre suf where
	+ pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
	+ suf: \<open>holds (is_rule ?r) suf\<close> and
	+ ori: \<open>?steps = pre @- suf\<close>
	+ using ev_prefix by blast
	+
	+ have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
	+ unfolding affects_def by (cases r) simp_all
	+ then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
	+ using pre by simp
	+ moreover have \<open>epath (pre @- suf)\<close>
	+ using \<open>epath steps\<close> epath_sdrop ori by metis
	+ ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
	+ using epath_preserves_unaffected n ori by metis
	+
	+ moreover have \<open>epath suf\<close>
	+ using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
	+ then obtain B z' r' where
	+ z': \<open>(B, z') \|\<in>\| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
	+ using suf epath_effect unfolding pseq_def ptms_def
	+ by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
	+ ultimately have \<open>p \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce
	+
	+ then show \<open>p \<in> ?H\<close>
	+ using z'(2) ori pseq_in_tree_fms
	+ by (metis (no_types, lifting) Pair_inject Un_iff in_mono prod.collapse pseq_def shd_sset
	+ sset_sdrop sset_shift stl_sset)
	+qed
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/Export.thy b/thys/FOL_Seq_Calc2/Export.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Export.thy
	@@ -0,0 +1,48 @@
	+section \<open>Export\<close>
	+
	+theory Export
	+ imports Prover
	+begin
	+
	+text \<open>In this theory, we make the prover executable using the code interpretation of the abstract
	+completeness framework and the Isabelle to Haskell code generator.\<close>
	+
	+text \<open>To actually execute the prover, we need to lazily evaluate the stream of rules to apply.
	+Otherwise, we will never actually get to a result.\<close>
	+code_lazy_type stream
	+
	+text \<open>We would also like to make the evaluation of streams a bit more efficient.\<close>
	+declare Stream.smember_code [code del]
	+lemma [code]: "Stream.smember x (y ## s) = (x = y \<or> Stream.smember x s)"
	+ unfolding Stream.smember_def by auto
	+
	+text \<open>To export code to Haskell, we need to specify that functions on the option type should be
	+ exported into the equivalent functions on the Maybe monad.\<close>
	+code_printing
	+ constant the \<rightharpoonup> (Haskell) "MaybeExt.fromJust"
	+\| constant Option.is_none \<rightharpoonup> (Haskell) "MaybeExt.isNothing"
	+
	+text \<open>To use the Maybe monad, we need to import it, so we add a shim to do so in every module.\<close>
	+code_printing code_module MaybeExt \<rightharpoonup> (Haskell)
	+ \<open>module MaybeExt(fromJust, isNothing) where
	+ import Data.Maybe(fromJust, isNothing);\<close>
	+
	+text \<open>The default export setup will create a cycle of module imports, so we roll most of the
	+ theories into one module when exporting to Haskell to prevent this.\<close>
	+code_identifier
	+ code_module Stream \<rightharpoonup> (Haskell) Prover
	+\| code_module Prover \<rightharpoonup> (Haskell) Prover
	+\| code_module Export \<rightharpoonup> (Haskell) Prover
	+\| code_module Option \<rightharpoonup> (Haskell) Prover
	+\| code_module MaybeExt \<rightharpoonup> (Haskell) Prover
	+\| code_module Abstract_Completeness \<rightharpoonup> (Haskell) Prover
	+
	+text \<open>Finally, we define an executable version of the prover using the code interpretation from the
	+ framework, and a version where the list of terms is initially empty.\<close>
	+definition \<open>secavTreeCode \<equiv> i.mkTree (\<lambda>r s. Some (effect r s)) rules\<close>
	+definition \<open>secavProverCode \<equiv> \<lambda>z . secavTreeCode ([], z)\<close>
	+
	+text \<open>We then export this version of the prover into Haskell.\<close>
	+export_code open secavProverCode in Haskell
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FOL_Seq_Calc2/Hintikka.thy b/thys/FOL_Seq_Calc2/Hintikka.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Hintikka.thy
	@@ -0,0 +1,33 @@
	+section \<open>Hintikka sets for SeCaV\<close>
	+
	+theory Hintikka
	+ imports Prover
	+begin
	+
	+text \<open>In this theory, we define the concept of a Hintikka set for SeCaV formulas.
	+ The definition mirrors the SeCaV proof system such that Hintikka sets are downwards closed with
	+ respect to the proof system.\<close>
	+
	+text \<open>This defines the set of all terms in a set of formulas (containing \<open>Fun 0 []\<close> if it would
	+ otherwise be empty).\<close>
	+definition
	+ \<open>terms H \<equiv> if (\<Union>p \<in> H. set (subtermFm p)) = {} then {Fun 0 []}
	+ else (\<Union>p \<in> H. set (subtermFm p))\<close>
	+
	+locale Hintikka =
	+ fixes H :: \<open>fm set\<close>
	+ assumes
	+ Basic: \<open>Pre n ts \<in> H \<Longrightarrow> Neg (Pre n ts) \<notin> H\<close> and
	+ AlphaDis: \<open>Dis p q \<in> H \<Longrightarrow> p \<in> H \<and> q \<in> H\<close> and
	+ AlphaImp: \<open>Imp p q \<in> H \<Longrightarrow> Neg p \<in> H \<and> q \<in> H\<close> and
	+ AlphaCon: \<open>Neg (Con p q) \<in> H \<Longrightarrow> Neg p \<in> H \<and> Neg q \<in> H\<close> and
	+ BetaCon: \<open>Con p q \<in> H \<Longrightarrow> p \<in> H \<or> q \<in> H\<close> and
	+ BetaImp: \<open>Neg (Imp p q) \<in> H \<Longrightarrow> p \<in> H \<or> Neg q \<in> H\<close> and
	+ BetaDis: \<open>Neg (Dis p q) \<in> H \<Longrightarrow> Neg p \<in> H \<or> Neg q \<in> H\<close> and
	+ GammaExi: \<open>Exi p \<in> H \<Longrightarrow> \<forall>t \<in> terms H. sub 0 t p \<in> H\<close> and
	+ GammaUni: \<open>Neg (Uni p) \<in> H \<Longrightarrow> \<forall>t \<in> terms H. Neg (sub 0 t p) \<in> H\<close> and
	+ DeltaUni: \<open>Uni p \<in> H \<Longrightarrow> \<exists>t \<in> terms H. sub 0 t p \<in> H\<close> and
	+ DeltaExi: \<open>Neg (Exi p) \<in> H \<Longrightarrow> \<exists>t \<in> terms H. Neg (sub 0 t p) \<in> H\<close> and
	+ Neg: \<open>Neg (Neg p) \<in> H \<Longrightarrow> p \<in> H\<close>
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/LICENSE b/thys/FOL_Seq_Calc2/LICENSE
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/LICENSE
	@@ -0,0 +1,674 @@
	+ GNU GENERAL PUBLIC LICENSE
	+ Version 3, 29 June 2007
	+
	+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
	+ Everyone is permitted to copy and distribute verbatim copies
	+ of this license document, but changing it is not allowed.
	+
	+ Preamble
	+
	+ The GNU General Public License is a free, copyleft license for
	+software and other kinds of works.
	+
	+ The licenses for most software and other practical works are designed
	+to take away your freedom to share and change the works. By contrast,
	+the GNU General Public License is intended to guarantee your freedom to
	+share and change all versions of a program--to make sure it remains free
	+software for all its users. We, the Free Software Foundation, use the
	+GNU General Public License for most of our software; it applies also to
	+any other work released this way by its authors. You can apply it to
	+your programs, too.
	+
	+ When we speak of free software, we are referring to freedom, not
	+price. Our General Public Licenses are designed to make sure that you
	+have the freedom to distribute copies of free software (and charge for
	+them if you wish), that you receive source code or can get it if you
	+want it, that you can change the software or use pieces of it in new
	+free programs, and that you know you can do these things.
	+
	+ To protect your rights, we need to prevent others from denying you
	+these rights or asking you to surrender the rights. Therefore, you have
	+certain responsibilities if you distribute copies of the software, or if
	+you modify it: responsibilities to respect the freedom of others.
	+
	+ For example, if you distribute copies of such a program, whether
	+gratis or for a fee, you must pass on to the recipients the same
	+freedoms that you received. You must make sure that they, too, receive
	+or can get the source code. And you must show them these terms so they
	+know their rights.
	+
	+ Developers that use the GNU GPL protect your rights with two steps:
	+(1) assert copyright on the software, and (2) offer you this License
	+giving you legal permission to copy, distribute and/or modify it.
	+
	+ For the developers' and authors' protection, the GPL clearly explains
	+that there is no warranty for this free software. For both users' and
	+authors' sake, the GPL requires that modified versions be marked as
	+changed, so that their problems will not be attributed erroneously to
	+authors of previous versions.
	+
	+ Some devices are designed to deny users access to install or run
	+modified versions of the software inside them, although the manufacturer
	+can do so. This is fundamentally incompatible with the aim of
	+protecting users' freedom to change the software. The systematic
	+pattern of such abuse occurs in the area of products for individuals to
	+use, which is precisely where it is most unacceptable. Therefore, we
	+have designed this version of the GPL to prohibit the practice for those
	+products. If such problems arise substantially in other domains, we
	+stand ready to extend this provision to those domains in future versions
	+of the GPL, as needed to protect the freedom of users.
	+
	+ Finally, every program is threatened constantly by software patents.
	+States should not allow patents to restrict development and use of
	+software on general-purpose computers, but in those that do, we wish to
	+avoid the special danger that patents applied to a free program could
	+make it effectively proprietary. To prevent this, the GPL assures that
	+patents cannot be used to render the program non-free.
	+
	+ The precise terms and conditions for copying, distribution and
	+modification follow.
	+
	+ TERMS AND CONDITIONS
	+
	+ 0. Definitions.
	+
	+ "This License" refers to version 3 of the GNU General Public License.
	+
	+ "Copyright" also means copyright-like laws that apply to other kinds of
	+works, such as semiconductor masks.
	+
	+ "The Program" refers to any copyrightable work licensed under this
	+License. Each licensee is addressed as "you". "Licensees" and
	+"recipients" may be individuals or organizations.
	+
	+ To "modify" a work means to copy from or adapt all or part of the work
	+in a fashion requiring copyright permission, other than the making of an
	+exact copy. The resulting work is called a "modified version" of the
	+earlier work or a work "based on" the earlier work.
	+
	+ A "covered work" means either the unmodified Program or a work based
	+on the Program.
	+
	+ To "propagate" a work means to do anything with it that, without
	+permission, would make you directly or secondarily liable for
	+infringement under applicable copyright law, except executing it on a
	+computer or modifying a private copy. Propagation includes copying,
	+distribution (with or without modification), making available to the
	+public, and in some countries other activities as well.
	+
	+ To "convey" a work means any kind of propagation that enables other
	+parties to make or receive copies. Mere interaction with a user through
	+a computer network, with no transfer of a copy, is not conveying.
	+
	+ An interactive user interface displays "Appropriate Legal Notices"
	+to the extent that it includes a convenient and prominently visible
	+feature that (1) displays an appropriate copyright notice, and (2)
	+tells the user that there is no warranty for the work (except to the
	+extent that warranties are provided), that licensees may convey the
	+work under this License, and how to view a copy of this License. If
	+the interface presents a list of user commands or options, such as a
	+menu, a prominent item in the list meets this criterion.
	+
	+ 1. Source Code.
	+
	+ The "source code" for a work means the preferred form of the work
	+for making modifications to it. "Object code" means any non-source
	+form of a work.
	+
	+ A "Standard Interface" means an interface that either is an official
	+standard defined by a recognized standards body, or, in the case of
	+interfaces specified for a particular programming language, one that
	+is widely used among developers working in that language.
	+
	+ The "System Libraries" of an executable work include anything, other
	+than the work as a whole, that (a) is included in the normal form of
	+packaging a Major Component, but which is not part of that Major
	+Component, and (b) serves only to enable use of the work with that
	+Major Component, or to implement a Standard Interface for which an
	+implementation is available to the public in source code form. A
	+"Major Component", in this context, means a major essential component
	+(kernel, window system, and so on) of the specific operating system
	+(if any) on which the executable work runs, or a compiler used to
	+produce the work, or an object code interpreter used to run it.
	+
	+ The "Corresponding Source" for a work in object code form means all
	+the source code needed to generate, install, and (for an executable
	+work) run the object code and to modify the work, including scripts to
	+control those activities. However, it does not include the work's
	+System Libraries, or general-purpose tools or generally available free
	+programs which are used unmodified in performing those activities but
	+which are not part of the work. For example, Corresponding Source
	+includes interface definition files associated with source files for
	+the work, and the source code for shared libraries and dynamically
	+linked subprograms that the work is specifically designed to require,
	+such as by intimate data communication or control flow between those
	+subprograms and other parts of the work.
	+
	+ The Corresponding Source need not include anything that users
	+can regenerate automatically from other parts of the Corresponding
	+Source.
	+
	+ The Corresponding Source for a work in source code form is that
	+same work.
	+
	+ 2. Basic Permissions.
	+
	+ All rights granted under this License are granted for the term of
	+copyright on the Program, and are irrevocable provided the stated
	+conditions are met. This License explicitly affirms your unlimited
	+permission to run the unmodified Program. The output from running a
	+covered work is covered by this License only if the output, given its
	+content, constitutes a covered work. This License acknowledges your
	+rights of fair use or other equivalent, as provided by copyright law.
	+
	+ You may make, run and propagate covered works that you do not
	+convey, without conditions so long as your license otherwise remains
	+in force. You may convey covered works to others for the sole purpose
	+of having them make modifications exclusively for you, or provide you
	+with facilities for running those works, provided that you comply with
	+the terms of this License in conveying all material for which you do
	+not control copyright. Those thus making or running the covered works
	+for you must do so exclusively on your behalf, under your direction
	+and control, on terms that prohibit them from making any copies of
	+your copyrighted material outside their relationship with you.
	+
	+ Conveying under any other circumstances is permitted solely under
	+the conditions stated below. Sublicensing is not allowed; section 10
	+makes it unnecessary.
	+
	+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
	+
	+ No covered work shall be deemed part of an effective technological
	+measure under any applicable law fulfilling obligations under article
	+11 of the WIPO copyright treaty adopted on 20 December 1996, or
	+similar laws prohibiting or restricting circumvention of such
	+measures.
	+
	+ When you convey a covered work, you waive any legal power to forbid
	+circumvention of technological measures to the extent such circumvention
	+is effected by exercising rights under this License with respect to
	+the covered work, and you disclaim any intention to limit operation or
	+modification of the work as a means of enforcing, against the work's
	+users, your or third parties' legal rights to forbid circumvention of
	+technological measures.
	+
	+ 4. Conveying Verbatim Copies.
	+
	+ You may convey verbatim copies of the Program's source code as you
	+receive it, in any medium, provided that you conspicuously and
	+appropriately publish on each copy an appropriate copyright notice;
	+keep intact all notices stating that this License and any
	+non-permissive terms added in accord with section 7 apply to the code;
	+keep intact all notices of the absence of any warranty; and give all
	+recipients a copy of this License along with the Program.
	+
	+ You may charge any price or no price for each copy that you convey,
	+and you may offer support or warranty protection for a fee.
	+
	+ 5. Conveying Modified Source Versions.
	+
	+ You may convey a work based on the Program, or the modifications to
	+produce it from the Program, in the form of source code under the
	+terms of section 4, provided that you also meet all of these conditions:
	+
	+ a) The work must carry prominent notices stating that you modified
	+ it, and giving a relevant date.
	+
	+ b) The work must carry prominent notices stating that it is
	+ released under this License and any conditions added under section
	+ 7. This requirement modifies the requirement in section 4 to
	+ "keep intact all notices".
	+
	+ c) You must license the entire work, as a whole, under this
	+ License to anyone who comes into possession of a copy. This
	+ License will therefore apply, along with any applicable section 7
	+ additional terms, to the whole of the work, and all its parts,
	+ regardless of how they are packaged. This License gives no
	+ permission to license the work in any other way, but it does not
	+ invalidate such permission if you have separately received it.
	+
	+ d) If the work has interactive user interfaces, each must display
	+ Appropriate Legal Notices; however, if the Program has interactive
	+ interfaces that do not display Appropriate Legal Notices, your
	+ work need not make them do so.
	+
	+ A compilation of a covered work with other separate and independent
	+works, which are not by their nature extensions of the covered work,
	+and which are not combined with it such as to form a larger program,
	+in or on a volume of a storage or distribution medium, is called an
	+"aggregate" if the compilation and its resulting copyright are not
	+used to limit the access or legal rights of the compilation's users
	+beyond what the individual works permit. Inclusion of a covered work
	+in an aggregate does not cause this License to apply to the other
	+parts of the aggregate.
	+
	+ 6. Conveying Non-Source Forms.
	+
	+ You may convey a covered work in object code form under the terms
	+of sections 4 and 5, provided that you also convey the
	+machine-readable Corresponding Source under the terms of this License,
	+in one of these ways:
	+
	+ a) Convey the object code in, or embodied in, a physical product
	+ (including a physical distribution medium), accompanied by the
	+ Corresponding Source fixed on a durable physical medium
	+ customarily used for software interchange.
	+
	+ b) Convey the object code in, or embodied in, a physical product
	+ (including a physical distribution medium), accompanied by a
	+ written offer, valid for at least three years and valid for as
	+ long as you offer spare parts or customer support for that product
	+ model, to give anyone who possesses the object code either (1) a
	+ copy of the Corresponding Source for all the software in the
	+ product that is covered by this License, on a durable physical
	+ medium customarily used for software interchange, for a price no
	+ more than your reasonable cost of physically performing this
	+ conveying of source, or (2) access to copy the
	+ Corresponding Source from a network server at no charge.
	+
	+ c) Convey individual copies of the object code with a copy of the
	+ written offer to provide the Corresponding Source. This
	+ alternative is allowed only occasionally and noncommercially, and
	+ only if you received the object code with such an offer, in accord
	+ with subsection 6b.
	+
	+ d) Convey the object code by offering access from a designated
	+ place (gratis or for a charge), and offer equivalent access to the
	+ Corresponding Source in the same way through the same place at no
	+ further charge. You need not require recipients to copy the
	+ Corresponding Source along with the object code. If the place to
	+ copy the object code is a network server, the Corresponding Source
	+ may be on a different server (operated by you or a third party)
	+ that supports equivalent copying facilities, provided you maintain
	+ clear directions next to the object code saying where to find the
	+ Corresponding Source. Regardless of what server hosts the
	+ Corresponding Source, you remain obligated to ensure that it is
	+ available for as long as needed to satisfy these requirements.
	+
	+ e) Convey the object code using peer-to-peer transmission, provided
	+ you inform other peers where the object code and Corresponding
	+ Source of the work are being offered to the general public at no
	+ charge under subsection 6d.
	+
	+ A separable portion of the object code, whose source code is excluded
	+from the Corresponding Source as a System Library, need not be
	+included in conveying the object code work.
	+
	+ A "User Product" is either (1) a "consumer product", which means any
	+tangible personal property which is normally used for personal, family,
	+or household purposes, or (2) anything designed or sold for incorporation
	+into a dwelling. In determining whether a product is a consumer product,
	+doubtful cases shall be resolved in favor of coverage. For a particular
	+product received by a particular user, "normally used" refers to a
	+typical or common use of that class of product, regardless of the status
	+of the particular user or of the way in which the particular user
	+actually uses, or expects or is expected to use, the product. A product
	+is a consumer product regardless of whether the product has substantial
	+commercial, industrial or non-consumer uses, unless such uses represent
	+the only significant mode of use of the product.
	+
	+ "Installation Information" for a User Product means any methods,
	+procedures, authorization keys, or other information required to install
	+and execute modified versions of a covered work in that User Product from
	+a modified version of its Corresponding Source. The information must
	+suffice to ensure that the continued functioning of the modified object
	+code is in no case prevented or interfered with solely because
	+modification has been made.
	+
	+ If you convey an object code work under this section in, or with, or
	+specifically for use in, a User Product, and the conveying occurs as
	+part of a transaction in which the right of possession and use of the
	+User Product is transferred to the recipient in perpetuity or for a
	+fixed term (regardless of how the transaction is characterized), the
	+Corresponding Source conveyed under this section must be accompanied
	+by the Installation Information. But this requirement does not apply
	+if neither you nor any third party retains the ability to install
	+modified object code on the User Product (for example, the work has
	+been installed in ROM).
	+
	+ The requirement to provide Installation Information does not include a
	+requirement to continue to provide support service, warranty, or updates
	+for a work that has been modified or installed by the recipient, or for
	+the User Product in which it has been modified or installed. Access to a
	+network may be denied when the modification itself materially and
	+adversely affects the operation of the network or violates the rules and
	+protocols for communication across the network.
	+
	+ Corresponding Source conveyed, and Installation Information provided,
	+in accord with this section must be in a format that is publicly
	+documented (and with an implementation available to the public in
	+source code form), and must require no special password or key for
	+unpacking, reading or copying.
	+
	+ 7. Additional Terms.
	+
	+ "Additional permissions" are terms that supplement the terms of this
	+License by making exceptions from one or more of its conditions.
	+Additional permissions that are applicable to the entire Program shall
	+be treated as though they were included in this License, to the extent
	+that they are valid under applicable law. If additional permissions
	+apply only to part of the Program, that part may be used separately
	+under those permissions, but the entire Program remains governed by
	+this License without regard to the additional permissions.
	+
	+ When you convey a copy of a covered work, you may at your option
	+remove any additional permissions from that copy, or from any part of
	+it. (Additional permissions may be written to require their own
	+removal in certain cases when you modify the work.) You may place
	+additional permissions on material, added by you to a covered work,
	+for which you have or can give appropriate copyright permission.
	+
	+ Notwithstanding any other provision of this License, for material you
	+add to a covered work, you may (if authorized by the copyright holders of
	+that material) supplement the terms of this License with terms:
	+
	+ a) Disclaiming warranty or limiting liability differently from the
	+ terms of sections 15 and 16 of this License; or
	+
	+ b) Requiring preservation of specified reasonable legal notices or
	+ author attributions in that material or in the Appropriate Legal
	+ Notices displayed by works containing it; or
	+
	+ c) Prohibiting misrepresentation of the origin of that material, or
	+ requiring that modified versions of such material be marked in
	+ reasonable ways as different from the original version; or
	+
	+ d) Limiting the use for publicity purposes of names of licensors or
	+ authors of the material; or
	+
	+ e) Declining to grant rights under trademark law for use of some
	+ trade names, trademarks, or service marks; or
	+
	+ f) Requiring indemnification of licensors and authors of that
	+ material by anyone who conveys the material (or modified versions of
	+ it) with contractual assumptions of liability to the recipient, for
	+ any liability that these contractual assumptions directly impose on
	+ those licensors and authors.
	+
	+ All other non-permissive additional terms are considered "further
	+restrictions" within the meaning of section 10. If the Program as you
	+received it, or any part of it, contains a notice stating that it is
	+governed by this License along with a term that is a further
	+restriction, you may remove that term. If a license document contains
	+a further restriction but permits relicensing or conveying under this
	+License, you may add to a covered work material governed by the terms
	+of that license document, provided that the further restriction does
	+not survive such relicensing or conveying.
	+
	+ If you add terms to a covered work in accord with this section, you
	+must place, in the relevant source files, a statement of the
	+additional terms that apply to those files, or a notice indicating
	+where to find the applicable terms.
	+
	+ Additional terms, permissive or non-permissive, may be stated in the
	+form of a separately written license, or stated as exceptions;
	+the above requirements apply either way.
	+
	+ 8. Termination.
	+
	+ You may not propagate or modify a covered work except as expressly
	+provided under this License. Any attempt otherwise to propagate or
	+modify it is void, and will automatically terminate your rights under
	+this License (including any patent licenses granted under the third
	+paragraph of section 11).
	+
	+ However, if you cease all violation of this License, then your
	+license from a particular copyright holder is reinstated (a)
	+provisionally, unless and until the copyright holder explicitly and
	+finally terminates your license, and (b) permanently, if the copyright
	+holder fails to notify you of the violation by some reasonable means
	+prior to 60 days after the cessation.
	+
	+ Moreover, your license from a particular copyright holder is
	+reinstated permanently if the copyright holder notifies you of the
	+violation by some reasonable means, this is the first time you have
	+received notice of violation of this License (for any work) from that
	+copyright holder, and you cure the violation prior to 30 days after
	+your receipt of the notice.
	+
	+ Termination of your rights under this section does not terminate the
	+licenses of parties who have received copies or rights from you under
	+this License. If your rights have been terminated and not permanently
	+reinstated, you do not qualify to receive new licenses for the same
	+material under section 10.
	+
	+ 9. Acceptance Not Required for Having Copies.
	+
	+ You are not required to accept this License in order to receive or
	+run a copy of the Program. Ancillary propagation of a covered work
	+occurring solely as a consequence of using peer-to-peer transmission
	+to receive a copy likewise does not require acceptance. However,
	+nothing other than this License grants you permission to propagate or
	+modify any covered work. These actions infringe copyright if you do
	+not accept this License. Therefore, by modifying or propagating a
	+covered work, you indicate your acceptance of this License to do so.
	+
	+ 10. Automatic Licensing of Downstream Recipients.
	+
	+ Each time you convey a covered work, the recipient automatically
	+receives a license from the original licensors, to run, modify and
	+propagate that work, subject to this License. You are not responsible
	+for enforcing compliance by third parties with this License.
	+
	+ An "entity transaction" is a transaction transferring control of an
	+organization, or substantially all assets of one, or subdividing an
	+organization, or merging organizations. If propagation of a covered
	+work results from an entity transaction, each party to that
	+transaction who receives a copy of the work also receives whatever
	+licenses to the work the party's predecessor in interest had or could
	+give under the previous paragraph, plus a right to possession of the
	+Corresponding Source of the work from the predecessor in interest, if
	+the predecessor has it or can get it with reasonable efforts.
	+
	+ You may not impose any further restrictions on the exercise of the
	+rights granted or affirmed under this License. For example, you may
	+not impose a license fee, royalty, or other charge for exercise of
	+rights granted under this License, and you may not initiate litigation
	+(including a cross-claim or counterclaim in a lawsuit) alleging that
	+any patent claim is infringed by making, using, selling, offering for
	+sale, or importing the Program or any portion of it.
	+
	+ 11. Patents.
	+
	+ A "contributor" is a copyright holder who authorizes use under this
	+License of the Program or a work on which the Program is based. The
	+work thus licensed is called the contributor's "contributor version".
	+
	+ A contributor's "essential patent claims" are all patent claims
	+owned or controlled by the contributor, whether already acquired or
	+hereafter acquired, that would be infringed by some manner, permitted
	+by this License, of making, using, or selling its contributor version,
	+but do not include claims that would be infringed only as a
	+consequence of further modification of the contributor version. For
	+purposes of this definition, "control" includes the right to grant
	+patent sublicenses in a manner consistent with the requirements of
	+this License.
	+
	+ Each contributor grants you a non-exclusive, worldwide, royalty-free
	+patent license under the contributor's essential patent claims, to
	+make, use, sell, offer for sale, import and otherwise run, modify and
	+propagate the contents of its contributor version.
	+
	+ In the following three paragraphs, a "patent license" is any express
	+agreement or commitment, however denominated, not to enforce a patent
	+(such as an express permission to practice a patent or covenant not to
	+sue for patent infringement). To "grant" such a patent license to a
	+party means to make such an agreement or commitment not to enforce a
	+patent against the party.
	+
	+ If you convey a covered work, knowingly relying on a patent license,
	+and the Corresponding Source of the work is not available for anyone
	+to copy, free of charge and under the terms of this License, through a
	+publicly available network server or other readily accessible means,
	+then you must either (1) cause the Corresponding Source to be so
	+available, or (2) arrange to deprive yourself of the benefit of the
	+patent license for this particular work, or (3) arrange, in a manner
	+consistent with the requirements of this License, to extend the patent
	+license to downstream recipients. "Knowingly relying" means you have
	+actual knowledge that, but for the patent license, your conveying the
	+covered work in a country, or your recipient's use of the covered work
	+in a country, would infringe one or more identifiable patents in that
	+country that you have reason to believe are valid.
	+
	+ If, pursuant to or in connection with a single transaction or
	+arrangement, you convey, or propagate by procuring conveyance of, a
	+covered work, and grant a patent license to some of the parties
	+receiving the covered work authorizing them to use, propagate, modify
	+or convey a specific copy of the covered work, then the patent license
	+you grant is automatically extended to all recipients of the covered
	+work and works based on it.
	+
	+ A patent license is "discriminatory" if it does not include within
	+the scope of its coverage, prohibits the exercise of, or is
	+conditioned on the non-exercise of one or more of the rights that are
	+specifically granted under this License. You may not convey a covered
	+work if you are a party to an arrangement with a third party that is
	+in the business of distributing software, under which you make payment
	+to the third party based on the extent of your activity of conveying
	+the work, and under which the third party grants, to any of the
	+parties who would receive the covered work from you, a discriminatory
	+patent license (a) in connection with copies of the covered work
	+conveyed by you (or copies made from those copies), or (b) primarily
	+for and in connection with specific products or compilations that
	+contain the covered work, unless you entered into that arrangement,
	+or that patent license was granted, prior to 28 March 2007.
	+
	+ Nothing in this License shall be construed as excluding or limiting
	+any implied license or other defenses to infringement that may
	+otherwise be available to you under applicable patent law.
	+
	+ 12. No Surrender of Others' Freedom.
	+
	+ If conditions are imposed on you (whether by court order, agreement or
	+otherwise) that contradict the conditions of this License, they do not
	+excuse you from the conditions of this License. If you cannot convey a
	+covered work so as to satisfy simultaneously your obligations under this
	+License and any other pertinent obligations, then as a consequence you may
	+not convey it at all. For example, if you agree to terms that obligate you
	+to collect a royalty for further conveying from those to whom you convey
	+the Program, the only way you could satisfy both those terms and this
	+License would be to refrain entirely from conveying the Program.
	+
	+ 13. Use with the GNU Affero General Public License.
	+
	+ Notwithstanding any other provision of this License, you have
	+permission to link or combine any covered work with a work licensed
	+under version 3 of the GNU Affero General Public License into a single
	+combined work, and to convey the resulting work. The terms of this
	+License will continue to apply to the part which is the covered work,
	+but the special requirements of the GNU Affero General Public License,
	+section 13, concerning interaction through a network will apply to the
	+combination as such.
	+
	+ 14. Revised Versions of this License.
	+
	+ The Free Software Foundation may publish revised and/or new versions of
	+the GNU General Public License from time to time. Such new versions will
	+be similar in spirit to the present version, but may differ in detail to
	+address new problems or concerns.
	+
	+ Each version is given a distinguishing version number. If the
	+Program specifies that a certain numbered version of the GNU General
	+Public License "or any later version" applies to it, you have the
	+option of following the terms and conditions either of that numbered
	+version or of any later version published by the Free Software
	+Foundation. If the Program does not specify a version number of the
	+GNU General Public License, you may choose any version ever published
	+by the Free Software Foundation.
	+
	+ If the Program specifies that a proxy can decide which future
	+versions of the GNU General Public License can be used, that proxy's
	+public statement of acceptance of a version permanently authorizes you
	+to choose that version for the Program.
	+
	+ Later license versions may give you additional or different
	+permissions. However, no additional obligations are imposed on any
	+author or copyright holder as a result of your choosing to follow a
	+later version.
	+
	+ 15. Disclaimer of Warranty.
	+
	+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
	+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
	+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
	+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
	+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
	+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
	+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
	+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
	+
	+ 16. Limitation of Liability.
	+
	+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
	+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
	+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
	+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
	+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
	+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
	+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
	+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
	+SUCH DAMAGES.
	+
	+ 17. Interpretation of Sections 15 and 16.
	+
	+ If the disclaimer of warranty and limitation of liability provided
	+above cannot be given local legal effect according to their terms,
	+reviewing courts shall apply local law that most closely approximates
	+an absolute waiver of all civil liability in connection with the
	+Program, unless a warranty or assumption of liability accompanies a
	+copy of the Program in return for a fee.
	+
	+ END OF TERMS AND CONDITIONS
	+
	+ How to Apply These Terms to Your New Programs
	+
	+ If you develop a new program, and you want it to be of the greatest
	+possible use to the public, the best way to achieve this is to make it
	+free software which everyone can redistribute and change under these terms.
	+
	+ To do so, attach the following notices to the program. It is safest
	+to attach them to the start of each source file to most effectively
	+state the exclusion of warranty; and each file should have at least
	+the "copyright" line and a pointer to where the full notice is found.
	+
	+ <one line to give the program's name and a brief idea of what it does.>
	+ Copyright (C) <year> <name of author>
	+
	+ This program is free software: you can redistribute it and/or modify
	+ it under the terms of the GNU General Public License as published by
	+ the Free Software Foundation, either version 3 of the License, or
	+ (at your option) any later version.
	+
	+ This program is distributed in the hope that it will be useful,
	+ but WITHOUT ANY WARRANTY; without even the implied warranty of
	+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	+ GNU General Public License for more details.
	+
	+ You should have received a copy of the GNU General Public License
	+ along with this program. If not, see <http://www.gnu.org/licenses/>.
	+
	+Also add information on how to contact you by electronic and paper mail.
	+
	+ If the program does terminal interaction, make it output a short
	+notice like this when it starts in an interactive mode:
	+
	+ <program> Copyright (C) <year> <name of author>
	+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
	+ This is free software, and you are welcome to redistribute it
	+ under certain conditions; type `show c' for details.
	+
	+The hypothetical commands `show w' and `show c' should show the appropriate
	+parts of the General Public License. Of course, your program's commands
	+might be different; for a GUI interface, you would use an "about box".
	+
	+ You should also get your employer (if you work as a programmer) or school,
	+if any, to sign a "copyright disclaimer" for the program, if necessary.
	+For more information on this, and how to apply and follow the GNU GPL, see
	+<http://www.gnu.org/licenses/>.
	+
	+ The GNU General Public License does not permit incorporating your program
	+into proprietary programs. If your program is a subroutine library, you
	+may consider it more useful to permit linking proprietary applications with
	+the library. If this is what you want to do, use the GNU Lesser General
	+Public License instead of this License. But first, please read
	+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
	diff --git a/thys/FOL_Seq_Calc2/Makefile b/thys/FOL_Seq_Calc2/Makefile
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Makefile
	@@ -0,0 +1,24 @@
	+ISABELLE := .
	+ISABELLE_EXE := isabelle
	+HASKELL := haskell
	+EXPORT := $(HASKELL)/prover
	+APP := $(HASKELL)/app
	+LIB := $(HASKELL)/lib
	+ISABELLE_SOURCES = $(wildcard $(ISABELLE)/*.thy)
	+
	+.PHONY: clean test
	+
	+build: $(EXPORT)/%.hs
	+ cabal build
	+
	+test:
	+ cabal test
	+ rm -rf test-tmp
	+
	+$(EXPORT)/%.hs: $(ISABELLE_SOURCES) $(ISABELLE)/ROOT
	+ $(ISABELLE_EXE) export -d $(ISABELLE) -x "SeCaV_Prover:*.hs" -p 3 -O $(EXPORT) SeCaV_Prover
	+
	+clean:
	+ rm -rf $(EXPORT)
	+ rm -rf $(ISABELLE)/output
	+ cabal clean
	diff --git a/thys/FOL_Seq_Calc2/Prover.thy b/thys/FOL_Seq_Calc2/Prover.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Prover.thy
	@@ -0,0 +1,191 @@
	+chapter \<open>The prover\<close>
	+
	+section \<open>Proof search procedure\<close>
	+
	+theory Prover
	+ imports SeCaV
	+ "HOL-Library.Stream"
	+ Abstract_Completeness.Abstract_Completeness
	+ Abstract_Soundness.Finite_Proof_Soundness
	+ "HOL-Library.Countable"
	+ "HOL-Library.Code_Lazy"
	+begin
	+
	+text \<open>This theory defines the actual proof search procedure.\<close>
	+
	+subsection \<open>Datatypes\<close>
	+
	+text \<open>A sequent is a list of formulas\<close>
	+type_synonym sequent = \<open>fm list\<close>
	+
	+text \<open>We introduce a number of rules to prove sequents.
	+ These rules mirror the proof system of SeCaV, but are higher-level in the sense that they apply to
	+ all formulas in the sequent at once. This obviates the need for the structural Ext rule.
	+ There is also no Basic rule, since this is implicit in the prover.\<close>
	+datatype rule
	+ = AlphaDis \| AlphaImp \| AlphaCon
	+ \| BetaCon \| BetaImp \| BetaDis
	+ \| DeltaUni \| DeltaExi
	+ \| NegNeg
	+ \| GammaExi \| GammaUni
	+
	+subsection \<open>Auxiliary functions\<close>
	+
	+text \<open>Before defining what the rules do, we need to define a number of auxiliary functions needed
	+ for the semantics of the rules.\<close>
	+
	+text \<open>listFunTm is a list of function and constant names in a term\<close>
	+primrec listFunTm :: \<open>tm \<Rightarrow> nat list\<close> and listFunTms :: \<open>tm list \<Rightarrow> nat list\<close>where
	+ \<open>listFunTm (Fun n ts) = n # listFunTms ts\<close>
	+\| \<open>listFunTm (Var n) = []\<close>
	+\| \<open>listFunTms [] = []\<close>
	+\| \<open>listFunTms (t # ts) = listFunTm t @ listFunTms ts\<close>
	+
	+text \<open>generateNew uses the \<open>listFunTms\<close> function to obtain a fresh function index\<close>
	+definition generateNew :: \<open>tm list \<Rightarrow> nat\<close> where
	+ \<open>generateNew ts \<equiv> 1 + foldr max (listFunTms ts) 0\<close>
	+
	+text \<open>subtermTm returns a list of all terms occurring within a term\<close>
	+primrec subtermTm :: \<open>tm \<Rightarrow> tm list\<close> where
	+ \<open>subtermTm (Fun n ts) = Fun n ts # remdups (concat (map subtermTm ts))\<close>
	+\| \<open>subtermTm (Var n) = [Var n]\<close>
	+
	+text \<open>subtermFm returns a list of all terms occurring within a formula\<close>
	+primrec subtermFm :: \<open>fm \<Rightarrow> tm list\<close> where
	+ \<open>subtermFm (Pre _ ts) = concat (map subtermTm ts)\<close>
	+\| \<open>subtermFm (Imp p q) = subtermFm p @ subtermFm q\<close>
	+\| \<open>subtermFm (Dis p q) = subtermFm p @ subtermFm q\<close>
	+\| \<open>subtermFm (Con p q) = subtermFm p @ subtermFm q\<close>
	+\| \<open>subtermFm (Exi p) = subtermFm p\<close>
	+\| \<open>subtermFm (Uni p) = subtermFm p\<close>
	+\| \<open>subtermFm (Neg p) = subtermFm p\<close>
	+
	+text \<open>subtermFms returns a list of all terms occurring within a list of formulas\<close>
	+abbreviation \<open>subtermFms z \<equiv> concat (map subtermFm z)\<close>
	+
	+text \<open>subterms returns a list of all terms occurring within a sequent.
	+ This is used to determine which terms to instantiate Gamma-formulas with.
	+ We must always be able to instantiate Gamma-formulas, so if there are no terms in the sequent,
	+ the function simply returns a list containing the first function.\<close>
	+definition subterms :: \<open>sequent \<Rightarrow> tm list\<close> where
	+ \<open>subterms z \<equiv> case remdups (subtermFms z) of
	+ [] \<Rightarrow> [Fun 0 []]
	+ \| ts \<Rightarrow> ts\<close>
	+
	+text \<open>We need to be able to detect if a sequent is an axiom to know whether a branch of the proof
	+ is done. The disjunct \<open>Neg (Neg p) \<in> set z\<close> is not necessary for the prover, but makes the proof
	+ of the lemma \<open>branchDone_contradiction\<close> easier.\<close>
	+fun branchDone :: \<open>sequent \<Rightarrow> bool\<close> where
	+ \<open>branchDone [] = False\<close>
	+\| \<open>branchDone (Neg p # z) = (p \<in> set z \<or> Neg (Neg p) \<in> set z \<or> branchDone z)\<close>
	+\| \<open>branchDone (p # z) = (Neg p \<in> set z \<or> branchDone z)\<close>
	+
	+subsection \<open>Effects of rules\<close>
	+
	+text \<open>This defines the resulting formulas when applying a rule to a single formula.
	+ This definition mirrors the semantics of SeCaV.
	+ If the rule and the formula do not match, the resulting formula is simply the original formula.
	+ Parameter A should be the list of terms on the branch.\<close>
	+definition parts :: \<open>tm list \<Rightarrow> rule \<Rightarrow> fm \<Rightarrow> fm list list\<close> where
	+ \<open>parts A r f = (case (r, f) of
	+ (NegNeg, Neg (Neg p)) \<Rightarrow> [[p]]
	+ \| (AlphaImp, Imp p q) \<Rightarrow> [[Neg p, q]]
	+ \| (AlphaDis, Dis p q) \<Rightarrow> [[p, q]]
	+ \| (AlphaCon, Neg (Con p q)) \<Rightarrow> [[Neg p, Neg q]]
	+ \| (BetaImp, Neg (Imp p q)) \<Rightarrow> [[p], [Neg q]]
	+ \| (BetaDis, Neg (Dis p q)) \<Rightarrow> [[Neg p], [Neg q]]
	+ \| (BetaCon, Con p q) \<Rightarrow> [[p], [q]]
	+ \| (DeltaExi, Neg (Exi p)) \<Rightarrow> [[Neg (sub 0 (Fun (generateNew A) []) p)]]
	+ \| (DeltaUni, Uni p) \<Rightarrow> [[sub 0 (Fun (generateNew A) []) p]]
	+ \| (GammaExi, Exi p) \<Rightarrow> [Exi p # map (\<lambda>t. sub 0 t p) A]
	+ \| (GammaUni, Neg (Uni p)) \<Rightarrow> [Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A]
	+ \| _ \<Rightarrow> [[f]])\<close>
	+
	+text \<open>This function defines the Cartesian product of two lists.
	+ This is needed to create the list of branches created when applying a beta rule.\<close>
	+primrec list_prod :: \<open>'a list list \<Rightarrow> 'a list list \<Rightarrow> 'a list list\<close> where
	+ \<open>list_prod _ [] = []\<close>
	+\| \<open>list_prod hs (t # ts) = map (\<lambda>h. h @ t) hs @ list_prod hs ts\<close>
	+
	+text \<open>This function computes the children of a node in the proof tree.
	+ For Alpha rules, Delta rules and Gamma rules, there will be only one sequent, which is the result
	+ of applying the rule to every formula in the current sequent.
	+ For Beta rules, the proof tree will branch into two branches once for each formula in the sequent
	+ that matches the rule, which results in \<open>2\<^sup>n\<close> branches (created using \<^text>\<open>list_prod\<close>).
	+ The list of terms in the sequent needs to be updated after applying the rule to each formula since
	+ Delta rules and Gamma rules may introduce new terms.
	+ Note that any formulas that don't match the rule are left unchanged in the new sequent.\<close>
	+primrec children :: \<open>tm list \<Rightarrow> rule \<Rightarrow> sequent \<Rightarrow> sequent list\<close> where
	+ \<open>children _ _ [] = [[]]\<close>
	+\| \<open>children A r (p # z) =
	+ (let hs = parts A r p; A' = remdups (A @ subtermFms (concat hs))
	+ in list_prod hs (children A' r z))\<close>
	+
	+text \<open>The proof state is the combination of a list of terms and a sequent.\<close>
	+type_synonym state = \<open>tm list \<times> sequent\<close>
	+
	+text \<open>This function defines the effect of applying a rule to a proof state.
	+ If the sequent is an axiom, the effect is to end the branch of the proof tree, so an empty set of
	+ child branches is returned.
	+ Otherwise, we compute the children generated by applying the rule to the current proof state,
	+ then add any new subterms to the proof states of the children.\<close>
	+primrec effect :: \<open>rule \<Rightarrow> state \<Rightarrow> state fset\<close> where
	+ \<open>effect r (A, z) =
	+ (if branchDone z then {\|\|} else
	+ fimage (\<lambda>z'. (remdups (A @ subterms z @ subterms z'), z'))
	+ (fset_of_list (children (remdups (A @ subtermFms z)) r z)))\<close>
	+
	+subsection \<open>The rule stream\<close>
	+
	+text \<open>We need to define an infinite stream of rules that the prover should try to apply.
	+ Since rules simply do nothing if they don't fit the formulas in the sequent, the rule stream is
	+ just all rules in the order: Alpha, Delta, Beta, Gamma, which guarantees completeness.\<close>
	+definition \<open>rulesList \<equiv> [
	+ NegNeg, AlphaImp, AlphaDis, AlphaCon,
	+ DeltaExi, DeltaUni,
	+ BetaImp, BetaDis, BetaCon,
	+ GammaExi, GammaUni
	+]\<close>
	+
	+text \<open>By cycling the list of all rules we obtain an infinite stream with every rule occurring
	+ infinitely often.\<close>
	+definition rules where
	+ \<open>rules = cycle rulesList\<close>
	+
	+subsection \<open>Abstract completeness\<close>
	+
	+text \<open>We write effect as a relation to use it with the abstract completeness framework.\<close>
	+definition eff where
	+ \<open>eff \<equiv> \<lambda>r s ss. effect r s = ss\<close>
	+
	+text \<open>To use the framework, we need to prove enabledness.
	+ This is trivial because all of our rules are always enabled and simply do nothing if they don't
	+ match the formulas.\<close>
	+lemma all_rules_enabled: \<open>\<forall>st. \<forall>r \<in> i.R (cycle rulesList). \<exists>sl. eff r st sl\<close>
	+ unfolding eff_def by blast
	+
	+text \<open>The first step of the framework is to prove that our prover fits the framework.\<close>
	+interpretation RuleSystem eff rules UNIV
	+ unfolding rules_def RuleSystem_def
	+ using all_rules_enabled stream.set_sel(1)
	+ by blast
	+
	+text \<open>Next, we need to prove that our rules are persistent.
	+ This is also trivial, since all of our rules are always enabled.\<close>
	+lemma all_rules_persistent: \<open>\<forall>r. r \<in> R \<longrightarrow> per r\<close>
	+ by (metis all_rules_enabled enabled_def per_def rules_def)
	+
	+text \<open>We can then prove that our prover fully fits the framework.\<close>
	+interpretation PersistentRuleSystem eff rules UNIV
	+ unfolding PersistentRuleSystem_def RuleSystem_def PersistentRuleSystem_axioms_def
	+ using all_rules_persistent enabled_R
	+ by blast
	+
	+text \<open>We can then use the framework to define the prover.
	+ The mkTree function applies the rules to build the proof tree using the effect relation, but the
	+ prover is not actually executable yet.\<close>
	+definition \<open>secavProver \<equiv> mkTree rules\<close>
	+
	+abbreviation \<open>rootSequent t \<equiv> snd (fst (root t))\<close>
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/ProverLemmas.thy b/thys/FOL_Seq_Calc2/ProverLemmas.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/ProverLemmas.thy
	@@ -0,0 +1,552 @@
	+section \<open>Lemmas about the prover\<close>
	+
	+theory ProverLemmas imports Prover begin
	+
	+text \<open>This theory contains a number of lemmas about the prover.
	+ We will need these when proving soundness and completeness.\<close>
	+
	+subsection \<open>SeCaV lemmas\<close>
	+text \<open>We need a few lemmas about the SeCaV system.\<close>
	+
	+text \<open>Incrementing variable indices does not change the function names in term or a list of terms.\<close>
	+lemma paramst_liftt [simp]:
	+ \<open>paramst (liftt t) = paramst t\<close> \<open>paramsts (liftts ts) = paramsts ts\<close>
	+ by (induct t and ts rule: liftt.induct liftts.induct) auto
	+
	+text \<open>Subterms do not contain any functions except those in the original term\<close>
	+lemma paramst_sub_term:
	+ \<open>paramst (sub_term m s t) \<subseteq> paramst s \<union> paramst t\<close>
	+ \<open>paramsts (sub_list m s l) \<subseteq> paramst s \<union> paramsts l\<close>
	+ by (induct t and l rule: sub_term.induct sub_list.induct) auto
	+
	+text \<open>Substituting a variable for a term does not introduce function names not in that term\<close>
	+lemma params_sub: \<open>params (sub m t p) \<subseteq> paramst t \<union> params p\<close>
	+proof (induct p arbitrary: m t)
	+ case (Pre x1 x2)
	+ then show ?case
	+ using paramst_sub_term(2) by simp
	+qed fastforce+
	+
	+abbreviation \<open>paramss z \<equiv> \<Union>p \<in> set z. params p\<close>
	+
	+text \<open>If a function name is fresh, it is not in the list of function names in the sequent\<close>
	+lemma news_paramss: \<open>news i z \<longleftrightarrow> i \<notin> paramss z\<close>
	+ by (induct z) auto
	+
	+text \<open>If a list of terms is a subset of another, the set of function names in it is too\<close>
	+lemma paramsts_subset: \<open>set A \<subseteq> set B \<Longrightarrow> paramsts A \<subseteq> paramsts B\<close>
	+ by (induct A) auto
	+
	+text \<open>Substituting a variable by a term does not change the depth of a formula
	+ (only the term size changes)\<close>
	+lemma size_sub [simp]: \<open>size (sub i t p) = size p\<close>
	+ by (induct p arbitrary: i t) auto
	+
	+subsection \<open>Fairness\<close>
	+text \<open>While fairness of the rule stream should be pretty trivial (since we are simply repeating a
	+ static list of rules forever), the proof is a bit involved.\<close>
	+
	+text \<open>This function tells us what rule comes next in the stream.\<close>
	+primrec next_rule :: \<open>rule \<Rightarrow> rule\<close> where
	+ \<open>next_rule NegNeg = AlphaImp\<close>
	+\| \<open>next_rule AlphaImp = AlphaDis\<close>
	+\| \<open>next_rule AlphaDis = AlphaCon\<close>
	+\| \<open>next_rule AlphaCon = DeltaExi\<close>
	+\| \<open>next_rule DeltaExi = DeltaUni\<close>
	+\| \<open>next_rule DeltaUni = BetaImp\<close>
	+\| \<open>next_rule BetaImp = BetaDis\<close>
	+\| \<open>next_rule BetaDis = BetaCon\<close>
	+\| \<open>next_rule BetaCon = GammaExi\<close>
	+\| \<open>next_rule GammaExi = GammaUni\<close>
	+\| \<open>next_rule GammaUni = NegNeg\<close>
	+
	+text \<open>This function tells us the index of a rule in the list of rules to repeat.\<close>
	+primrec rule_index :: \<open>rule \<Rightarrow> nat\<close> where
	+ \<open>rule_index NegNeg = 0\<close>
	+\| \<open>rule_index AlphaImp = 1\<close>
	+\| \<open>rule_index AlphaDis = 2\<close>
	+\| \<open>rule_index AlphaCon = 3\<close>
	+\| \<open>rule_index DeltaExi = 4\<close>
	+\| \<open>rule_index DeltaUni = 5\<close>
	+\| \<open>rule_index BetaImp = 6\<close>
	+\| \<open>rule_index BetaDis = 7\<close>
	+\| \<open>rule_index BetaCon = 8\<close>
	+\| \<open>rule_index GammaExi = 9\<close>
	+\| \<open>rule_index GammaUni = 10\<close>
	+
	+text \<open>The list of rules does not have any duplicates.
	+ This is important because we can then look up rules by their index.\<close>
	+lemma distinct_rulesList: \<open>distinct rulesList\<close>
	+ unfolding rulesList_def by simp
	+
	+text \<open>If you cycle a list, it repeats every \<open>length\<close> elements.\<close>
	+lemma cycle_nth: \<open>xs \<noteq> [] \<Longrightarrow> cycle xs !! n = xs ! (n mod length xs)\<close>
	+ by (metis cycle.sel(1) hd_rotate_conv_nth rotate_conv_mod sdrop_cycle sdrop_simps(1))
	+
	+text \<open>The rule index function can actually be used to look up rules in the list.\<close>
	+lemma nth_rule_index: \<open>rulesList ! (rule_index r) = r\<close>
	+ unfolding rulesList_def by (cases r) simp_all
	+
	+lemma rule_index_bnd: \<open>rule_index r < length rulesList\<close>
	+ unfolding rulesList_def by (cases r) simp_all
	+
	+lemma unique_rule_index:
	+ assumes \<open>n < length rulesList\<close> \<open>rulesList ! n = r\<close>
	+ shows \<open>n = rule_index r\<close>
	+ using assms nth_rule_index distinct_rulesList rule_index_bnd nth_eq_iff_index_eq by metis
	+
	+text \<open>The rule indices repeat in the stream each cycle.\<close>
	+lemma rule_index_mod:
	+ assumes \<open>rules !! n = r\<close>
	+ shows \<open>n mod length rulesList = rule_index r\<close>
	+proof -
	+ have *: \<open>rulesList ! (n mod length rulesList) = r\<close>
	+ using assms cycle_nth unfolding rules_def rulesList_def by (metis list.distinct(1))
	+ then show ?thesis
	+ using distinct_rulesList * unique_rule_index
	+ by (cases r) (metis length_greater_0_conv list.discI rulesList_def
	+ unique_euclidean_semiring_numeral_class.pos_mod_bound)+
	+qed
	+
	+text \<open>We need some lemmas about the modulo function to show that the rules repeat at the right rate.\<close>
	+lemma mod_hit:
	+ fixes k :: nat
	+ assumes \<open>0 < k\<close>
	+ shows \<open>\<forall>i < k. \<exists>n > m. n mod k = i\<close>
	+proof safe
	+ fix i
	+ let ?n = \<open>(1 + m) * k + i\<close>
	+ assume \<open>i < k\<close>
	+ then have \<open>?n mod k = i\<close>
	+ by (metis mod_less mod_mult_self3)
	+ moreover have \<open>?n > m\<close>
	+ using assms
	+ by (metis One_nat_def Suc_eq_plus1_left Suc_leI add.commute add_lessD1 less_add_one
	+ mult.right_neutral nat_mult_less_cancel1 order_le_less trans_less_add1 zero_less_one)
	+ ultimately show \<open>\<exists>n > m. n mod k = i\<close>
	+ by fast
	+qed
	+
	+lemma mod_suff:
	+ assumes \<open>\<forall>(n :: nat) > m. P (n mod k)\<close> \<open>0 < k\<close>
	+ shows \<open>\<forall>i < k. P i\<close>
	+ using assms mod_hit by blast
	+
	+text \<open>It is always possible to find an index after some point that results in any given rule.\<close>
	+lemma rules_repeat: \<open>\<exists>n > m. rules !! n = r\<close>
	+proof (rule ccontr)
	+ assume \<open>\<not> (\<exists>n > m. rules !! n = r)\<close>
	+ then have \<open>\<not> (\<exists>n > m. n mod length rulesList = rule_index r)\<close>
	+ using rule_index_mod nth_rule_index by metis
	+ then have \<open>\<forall>n > m. n mod length rulesList \<noteq> rule_index r\<close>
	+ by blast
	+ moreover have \<open>length rulesList > 0\<close>
	+ unfolding rulesList_def by simp
	+ ultimately have \<open>\<forall>k < length rulesList. k \<noteq> rule_index r\<close>
	+ using mod_suff[where P=\<open>\<lambda>a. a \<noteq> rule_index r\<close>] by blast
	+ then show False
	+ using rule_index_bnd by blast
	+qed
	+
	+text \<open>It is possible to find such an index no matter where in the stream we start.\<close>
	+lemma rules_repeat_sdrop: \<open>\<exists>n. (sdrop k rules) !! n = r\<close>
	+ using rules_repeat by (metis less_imp_add_positive sdrop_snth)
	+
	+text \<open>Using the lemma above, we prove that the stream of rules is fair by coinduction.\<close>
	+lemma fair_rules: \<open>fair rules\<close>
	+proof -
	+ { fix r assume \<open>r \<in> R\<close>
	+ then obtain m where r: \<open>r = rules !! m\<close> unfolding sset_range by blast
	+ { fix n :: nat and rs let ?rules = \<open>\<lambda>n. sdrop n rules\<close>
	+ assume \<open>n > 0\<close>
	+ then have \<open>alw (ev (holds ((=) r))) (rs @- ?rules n)\<close>
	+ proof (coinduction arbitrary: n rs)
	+ case alw
	+ show ?case
	+ proof (rule exI[of _ \<open>rs @- ?rules n\<close>], safe)
	+ show \<open>\<exists>n' rs'. stl (rs @- ?rules n) = rs' @- ?rules n' \<and> n' > 0\<close>
	+ proof (cases rs)
	+ case Nil then show ?thesis unfolding alw
	+ by (metis sdrop_simps(2) shift.simps(1) zero_less_Suc)
	+ qed (auto simp: alw intro: exI[of _ n])
	+ next
	+ have \<open>ev (holds ((=) r)) (sdrop n rules)\<close>
	+ unfolding ev_holds_sset using rules_repeat_sdrop by (metis snth_sset)
	+ then show \<open>ev (holds ((=) r)) (rs @- sdrop n rules)\<close>
	+ unfolding ev_holds_sset by simp
	+ qed
	+ qed
	+ }
	+ }
	+ then show \<open>fair rules\<close> unfolding fair_def
	+ by (metis (full_types) alw_iff_sdrop ev_holds_sset neq0_conv order_refl sdrop.simps(1)
	+ stake_sdrop)
	+qed
	+
	+subsection \<open>Substitution\<close>
	+text \<open>We need some lemmas about substitution of variables for terms for the Delta and Gamma rules.\<close>
	+
	+text \<open>If a term is a subterm of another, so are all of its subterms.\<close>
	+lemma subtermTm_le: \<open>t \<in> set (subtermTm s) \<Longrightarrow> set (subtermTm t) \<subseteq> set (subtermTm s)\<close>
	+ by (induct s) auto
	+
	+text \<open>Trying to substitute a variable that is not in the term does nothing (contrapositively).\<close>
	+lemma sub_term_const_transfer:
	+ \<open>sub_term m (Fun a []) t \<noteq> sub_term m s t \<Longrightarrow>
	+ Fun a [] \<in> set (subtermTm (sub_term m (Fun a []) t))\<close>
	+ \<open>sub_list m (Fun a []) ts \<noteq> sub_list m s ts \<Longrightarrow>
	+ Fun a [] \<in> (\<Union>t \<in> set (sub_list m (Fun a []) ts). set (subtermTm t))\<close>
	+proof (induct t and ts rule: sub_term.induct sub_list.induct)
	+ case (Var x)
	+ then show ?case
	+ by (metis list.set_intros(1) sub_term.simps(1) subtermTm.simps(1))
	+qed auto
	+
	+text \<open>If substituting different terms makes a difference, then the substitution has an effect.\<close>
	+lemma sub_const_transfer:
	+ assumes \<open>sub m (Fun a []) p \<noteq> sub m t p\<close>
	+ shows \<open>Fun a [] \<in> set (subtermFm (sub m (Fun a []) p))\<close>
	+ using assms
	+proof (induct p arbitrary: m t)
	+ case (Pre i l)
	+ then show ?case
	+ using sub_term_const_transfer(2) by simp
	+qed auto
	+
	+text \<open>If the list of subterms is empty for all formulas in a sequent, constant 0 is used instead.\<close>
	+lemma set_subterms:
	+ fixes z
	+ defines \<open>ts \<equiv> \<Union>p \<in> set z. set (subtermFm p)\<close>
	+ shows \<open>set (subterms z) = (if ts = {} then {Fun 0 []} else ts)\<close>
	+proof -
	+ have *: \<open>set (remdups (concat (map subtermFm z))) = (\<Union>p \<in> set z. set (subtermFm p))\<close>
	+ by (induct z) auto
	+ then show ?thesis
	+ proof (cases \<open>ts = {}\<close>)
	+ case True
	+ then show ?thesis
	+ unfolding subterms_def ts_def using *
	+ by (metis list.simps(15) list.simps(4) set_empty)
	+ next
	+ case False
	+ then show ?thesis
	+ unfolding subterms_def ts_def using *
	+ by (metis empty_set list.exhaust list.simps(5))
	+ qed
	+qed
	+
	+text \<open>The parameters and the subterm functions respect each other.\<close>
	+lemma paramst_subtermTm:
	+ \<open>\<forall>i \<in> paramst t. \<exists>l. Fun i l \<in> set (subtermTm t)\<close>
	+ \<open>\<forall>i \<in> paramsts ts. \<exists>l. Fun i l \<in> (\<Union>t \<in> set ts. set (subtermTm t))\<close>
	+ by (induct t and ts rule: paramst.induct paramsts.induct) fastforce+
	+
	+lemma params_subtermFm: \<open>\<forall>i \<in> params p. \<exists>l. Fun i l \<in> set (subtermFm p)\<close>
	+proof (induct p)
	+ case (Pre x1 x2)
	+ then show ?case
	+ using paramst_subtermTm by simp
	+qed auto
	+
	+lemma subtermFm_subset_params: \<open>set (subtermFm p) \<subseteq> set A \<Longrightarrow> params p \<subseteq> paramsts A\<close>
	+ using params_subtermFm by force
	+
	+subsection \<open>Custom cases\<close>
	+text \<open>Some proofs are more efficient with some custom case lemmas.\<close>
	+
	+lemma Neg_exhaust
	+ [case_names Pre Imp Dis Con Exi Uni NegPre NegImp NegDis NegCon NegExi NegUni NegNeg]:
	+ assumes
	+ \<open>\<And>i ts. x = Pre i ts \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. x = Imp p q \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. x = Dis p q \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. x = Con p q \<Longrightarrow> P\<close>
	+ \<open>\<And>p. x = Exi p \<Longrightarrow> P\<close>
	+ \<open>\<And>p. x = Uni p \<Longrightarrow> P\<close>
	+ \<open>\<And>i ts. x = Neg (Pre i ts) \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. x = Neg (Imp p q) \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. x = Neg (Dis p q) \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. x = Neg (Con p q) \<Longrightarrow> P\<close>
	+ \<open>\<And>p. x = Neg (Exi p) \<Longrightarrow> P\<close>
	+ \<open>\<And>p. x = Neg (Uni p) \<Longrightarrow> P\<close>
	+ \<open>\<And>p. x = Neg (Neg p) \<Longrightarrow> P\<close>
	+ shows P
	+ using assms
	+proof (induct x)
	+ case (Neg p)
	+ then show ?case
	+ by (cases p) simp_all
	+qed simp_all
	+
	+lemma parts_exhaust
	+ [case_names AlphaDis AlphaImp AlphaCon BetaDis BetaImp BetaCon
	+ DeltaUni DeltaExi NegNeg GammaExi GammaUni Other]:
	+ assumes
	+ \<open>\<And>p q. r = AlphaDis \<Longrightarrow> x = Dis p q \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. r = AlphaImp \<Longrightarrow> x = Imp p q \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. r = AlphaCon \<Longrightarrow> x = Neg (Con p q) \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. r = BetaDis \<Longrightarrow> x = Neg (Dis p q) \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. r = BetaImp \<Longrightarrow> x = Neg (Imp p q) \<Longrightarrow> P\<close>
	+ \<open>\<And>p q. r = BetaCon \<Longrightarrow> x = Con p q \<Longrightarrow> P\<close>
	+ \<open>\<And>p. r = DeltaUni \<Longrightarrow> x = Uni p \<Longrightarrow> P\<close>
	+ \<open>\<And>p. r = DeltaExi \<Longrightarrow> x = Neg (Exi p) \<Longrightarrow> P\<close>
	+ \<open>\<And>p. r = NegNeg \<Longrightarrow> x = Neg (Neg p) \<Longrightarrow> P\<close>
	+ \<open>\<And>p. r = GammaExi \<Longrightarrow> x = Exi p \<Longrightarrow> P\<close>
	+ \<open>\<And>p. r = GammaUni \<Longrightarrow> x = Neg (Uni p) \<Longrightarrow> P\<close>
	+ \<open>\<forall>A. parts A r x = [[x]] \<Longrightarrow> P\<close>
	+ shows P
	+ using assms
	+proof (cases r)
	+ case BetaCon
	+ then show ?thesis
	+ using assms
	+ proof (cases x rule: Neg_exhaust)
	+ case (Con p q)
	+ then show ?thesis
	+ using BetaCon assms by blast
	+ qed (simp_all add: parts_def)
	+next
	+ case BetaImp
	+ then show ?thesis
	+ using assms
	+ proof (cases x rule: Neg_exhaust)
	+ case (NegImp p q)
	+ then show ?thesis
	+ using BetaImp assms by blast
	+ qed (simp_all add: parts_def)
	+next
	+ case DeltaUni
	+ then show ?thesis
	+ using assms
	+ proof (cases x rule: Neg_exhaust)
	+ case (Uni p)
	+ then show ?thesis
	+ using DeltaUni assms by fast
	+ qed (simp_all add: parts_def)
	+next
	+ case DeltaExi
	+ then show ?thesis
	+ using assms
	+ proof (cases x rule: Neg_exhaust)
	+ case (NegExi p)
	+ then show ?thesis
	+ using DeltaExi assms by fast
	+ qed (simp_all add: parts_def)
	+next
	+ case n: NegNeg
	+ then show ?thesis
	+ using assms
	+ proof (cases x rule: Neg_exhaust)
	+ case (NegNeg p)
	+ then show ?thesis
	+ using n assms by fast
	+ qed (simp_all add: parts_def)
	+next
	+ case GammaExi
	+ then show ?thesis
	+ using assms
	+ proof (cases x rule: Neg_exhaust)
	+ case (Exi p)
	+ then show ?thesis
	+ using GammaExi assms by fast
	+ qed (simp_all add: parts_def)
	+next
	+ case GammaUni
	+ then show ?thesis
	+ using assms
	+ proof (cases x rule: Neg_exhaust)
	+ case (NegUni p)
	+ then show ?thesis
	+ using GammaUni assms by fast
	+ qed (simp_all add: parts_def)
	+qed (cases x rule: Neg_exhaust, simp_all add: parts_def)+
	+
	+subsection \<open>Unaffected formulas\<close>
	+text \<open>We need some lemmas to show that formulas to which rules do not apply are not lost.\<close>
	+
	+text \<open>This function returns True if the rule applies to the formula, and False otherwise.\<close>
	+definition affects :: \<open>rule \<Rightarrow> fm \<Rightarrow> bool\<close> where
	+ \<open>affects r p \<equiv> case (r, p) of
	+ (AlphaDis, Dis _ _) \<Rightarrow> True
	+ \| (AlphaImp, Imp _ _) \<Rightarrow> True
	+ \| (AlphaCon, Neg (Con _ _)) \<Rightarrow> True
	+ \| (BetaCon, Con _ _) \<Rightarrow> True
	+ \| (BetaImp, Neg (Imp _ _)) \<Rightarrow> True
	+ \| (BetaDis, Neg (Dis _ _)) \<Rightarrow> True
	+ \| (DeltaUni, Uni _) \<Rightarrow> True
	+ \| (DeltaExi, Neg (Exi _)) \<Rightarrow> True
	+ \| (NegNeg, Neg (Neg _)) \<Rightarrow> True
	+ \| (GammaExi, Exi _) \<Rightarrow> False
	+ \| (GammaUni, Neg (Uni _)) \<Rightarrow> False
	+ \| (_, _) \<Rightarrow> False\<close>
	+
	+text \<open>If a rule does not affect a formula, that formula will be in the sequent obtained after
	+ applying the rule.\<close>
	+lemma parts_preserves_unaffected:
	+ assumes \<open>\<not> affects r p\<close> \<open>z' \<in> set (parts A r p)\<close>
	+ shows \<open>p \<in> set z'\<close>
	+ using assms unfolding affects_def
	+ by (cases r p rule: parts_exhaust) (simp_all add: parts_def)
	+
	+text \<open>The \<open>list_prod\<close> function computes the Cartesian product.\<close>
	+lemma list_prod_is_cartesian:
	+ \<open>set (list_prod hs ts) = {h @ t \|h t. h \<in> set hs \<and> t \<in> set ts}\<close>
	+ by (induct ts) auto
	+
	+text \<open>The \<open>children\<close> function produces the Cartesian product of the branches from the first formula
	+and the branches from the rest of the sequent.\<close>
	+lemma set_children_Cons:
	+ \<open>set (children A r (p # z)) =
	+ {hs @ ts \|hs ts. hs \<in> set (parts A r p) \<and>
	+ ts \<in> set (children (remdups (A @ subtermFms (concat (parts A r p)))) r z)}\<close>
	+ using list_prod_is_cartesian by (metis children.simps(2))
	+
	+text \<open>The \<open>children\<close> function does not change unaffected formulas.\<close>
	+lemma children_preserves_unaffected:
	+ assumes \<open>p \<in> set z\<close> \<open>\<not> affects r p\<close> \<open>z' \<in> set (children A r z)\<close>
	+ shows \<open>p \<in> set z'\<close>
	+ using assms parts_preserves_unaffected set_children_Cons
	+ by (induct z arbitrary: A z') auto
	+
	+text \<open>The \<open>effect\<close> function does not change unaffected formulas.\<close>
	+lemma effect_preserves_unaffected:
	+ assumes \<open>p \<in> set z\<close> and \<open>\<not> affects r p\<close> and \<open>(B, z') \|\<in>\| effect r (A, z)\<close>
	+ shows \<open>p \<in> set z'\<close>
	+ using assms children_preserves_unaffected
	+ unfolding effect_def
	+ by (smt (verit, best) Pair_inject femptyE fimageE fset_of_list_elem old.prod.case)
	+
	+subsection \<open>Affected formulas\<close>
	+text \<open>We need some lemmas to show that formulas to which rules do apply are decomposed into their
	+ constituent parts correctly.\<close>
	+
	+text \<open>If a formula occurs in a sequent on a child branch generated by \<open>children\<close>, it was part of
	+ the current sequent.\<close>
	+lemma parts_in_children:
	+ assumes \<open>p \<in> set z\<close> \<open>z' \<in> set (children A r z)\<close>
	+ shows \<open>\<exists>B xs. set A \<subseteq> set B \<and> xs \<in> set (parts B r p) \<and> set xs \<subseteq> set z'\<close>
	+ using assms
	+proof (induct z arbitrary: A z')
	+ case (Cons a _)
	+ then show ?case
	+ proof (cases \<open>a = p\<close>)
	+ case True
	+ then show ?thesis
	+ using Cons(3) set_children_Cons by fastforce
	+ next
	+ case False
	+ then show ?thesis
	+ using Cons set_children_Cons
	+ by (smt (verit, del_insts) le_sup_iff mem_Collect_eq set_ConsD set_append set_remdups subset_trans sup_ge2)
	+ qed
	+qed simp
	+
	+text \<open>If \<open>effect\<close> contains something, then the input sequent is not an axiom.\<close>
	+lemma ne_effect_not_branchDone: \<open>(B, z') \|\<in>\| effect r (A, z) \<Longrightarrow> \<not> branchDone z\<close>
	+ by (cases \<open>branchDone z\<close>) simp_all
	+
	+text \<open>The \<open>effect\<close> function decomposes formulas in the sequent using the \<open>parts\<close> function.
	+ (Unless the sequent is an axiom, in which case no child branches are generated.)\<close>
	+lemma parts_in_effect:
	+ assumes \<open>p \<in> set z\<close> and \<open>(B, z') \|\<in>\| effect r (A, z)\<close>
	+ shows \<open>\<exists>C xs. set A \<subseteq> set C \<and> xs \<in> set (parts C r p) \<and> set xs \<subseteq> set z'\<close>
	+ using assms parts_in_children ne_effect_not_branchDone
	+ by (smt (verit, ccfv_threshold) Pair_inject effect.simps fimageE fset_of_list_elem le_sup_iff
	+ set_append set_remdups)
	+
	+text \<open>Specifically, this applied to the double negation elimination rule and the GammaUni rule.\<close>
	+corollary \<open>Neg (Neg p) \<in> set z \<Longrightarrow> (B, z') \|\<in>\| effect NegNeg (A, z) \<Longrightarrow> p \<in> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce
	+
	+corollary \<open>Neg (Uni p) \<in> set z \<Longrightarrow> (B, z') \|\<in>\| effect GammaUni (A, z) \<Longrightarrow>
	+ set (map (\<lambda>t. Neg (sub 0 t p)) A) \<subseteq> set z'\<close>
	+ using parts_in_effect unfolding parts_def by fastforce
	+
	+text \<open>If the sequent is not an axiom, and the rule and sequent match, all of the child branches
	+ generated by \<open>children\<close> will be included in the proof tree.\<close>
	+lemma eff_children:
	+ assumes \<open>\<not> branchDone z\<close> \<open>eff r (A, z) ss\<close>
	+ shows \<open>\<forall>z' \<in> set (children (remdups (A @ subtermFms z)) r z). \<exists>B. (B, z') \|\<in>\| ss\<close>
	+ using assms unfolding eff_def using fset_of_list_elem by fastforce
	+
	+subsection \<open>Generating new function names\<close>
	+text \<open>We need to show that the \<open>generateNew\<close> function actually generates new function names.
	+ This requires a few lemmas about the interplay between \<open>max\<close> and \<open>foldr\<close>.\<close>
	+
	+lemma foldr_max:
	+ fixes xs :: \<open>nat list\<close>
	+ shows \<open>foldr max xs 0 = (if xs = [] then 0 else Max (set xs))\<close>
	+ by (induct xs) simp_all
	+
	+lemma Suc_max_new:
	+ fixes xs :: \<open>nat list\<close>
	+ shows \<open>Suc (foldr max xs 0) \<notin> set xs\<close>
	+proof (cases xs)
	+ case (Cons x xs)
	+ then have \<open>foldr max (x # xs) 0 = Max (set (x # xs))\<close>
	+ using foldr_max by simp
	+ then show ?thesis
	+ using Cons by (metis List.finite_set Max.insert add_0 empty_iff list.set(2) max_0_1(2)
	+ n_not_Suc_n nat_add_max_left plus_1_eq_Suc remdups.simps(2) set_remdups)
	+qed simp
	+
	+lemma listFunTm_paramst: \<open>set (listFunTm t) = paramst t\<close> \<open>set (listFunTms ts) = paramsts ts\<close>
	+ by (induct t and ts rule: paramst.induct paramsts.induct) auto
	+
	+subsection \<open>Finding axioms\<close>
	+
	+text \<open>The \<open>branchDone\<close> function correctly determines whether a sequent is an axiom.\<close>
	+lemma branchDone_contradiction: \<open>branchDone z \<longleftrightarrow> (\<exists>p. p \<in> set z \<and> Neg p \<in> set z)\<close>
	+ by (induct z rule: branchDone.induct) auto
	+
	+subsection \<open>Subterms\<close>
	+text \<open>We need a few lemmas about the behaviour of our subterm functions.\<close>
	+
	+text \<open>Any term is a subterm of itself.\<close>
	+lemma subtermTm_refl [simp]: \<open>t \<in> set (subtermTm t)\<close>
	+ by (induct t) simp_all
	+
	+text \<open>The arguments of a predicate are subterms of it.\<close>
	+lemma subterm_Pre_refl: \<open>set ts \<subseteq> set (subtermFm (Pre n ts))\<close>
	+ by (induct ts) auto
	+
	+text \<open>The arguments of function are subterms of it.\<close>
	+lemma subterm_Fun_refl: \<open>set ts \<subseteq> set (subtermTm (Fun n ts))\<close>
	+ by (induct ts) auto
	+
	+text \<open>This function computes the predicates in a formula.
	+ We will use this function to help prove the final lemma in this section.\<close>
	+primrec preds :: \<open>fm \<Rightarrow> fm set\<close> where
	+ \<open>preds (Pre n ts) = {Pre n ts}\<close>
	+\| \<open>preds (Imp p q) = preds p \<union> preds q\<close>
	+\| \<open>preds (Dis p q) = preds p \<union> preds q\<close>
	+\| \<open>preds (Con p q) = preds p \<union> preds q\<close>
	+\| \<open>preds (Exi p) = preds p\<close>
	+\| \<open>preds (Uni p) = preds p\<close>
	+\| \<open>preds (Neg p) = preds p\<close>
	+
	+text \<open>If a term is a subterm of a formula, it is a subterm of some predicate in the formula.\<close>
	+lemma subtermFm_preds: \<open>t \<in> set (subtermFm p) \<longleftrightarrow> (\<exists>pre \<in> preds p. t \<in> set (subtermFm pre))\<close>
	+ by (induct p) auto
	+
	+lemma preds_shape: \<open>pre \<in> preds p \<Longrightarrow> \<exists>n ts. pre = Pre n ts\<close>
	+ by (induct p) auto
	+
	+text \<open>If a function is a subterm of a formula, so are the arguments of that function.\<close>
	+lemma fun_arguments_subterm:
	+ assumes \<open>Fun n ts \<in> set (subtermFm p)\<close>
	+ shows \<open>set ts \<subseteq> set (subtermFm p)\<close>
	+proof -
	+ obtain pre where pre: \<open>pre \<in> preds p\<close> \<open>Fun n ts \<in> set (subtermFm pre)\<close>
	+ using assms subtermFm_preds by blast
	+ then obtain n' ts' where \<open>pre = Pre n' ts'\<close>
	+ using preds_shape by blast
	+ then have \<open>set ts \<subseteq> set (subtermFm pre)\<close>
	+ using subtermTm_le pre by force
	+ then have \<open>set ts \<subseteq> set (subtermFm p)\<close>
	+ using pre subtermFm_preds by blast
	+ then show ?thesis
	+ by blast
	+qed
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/README.md b/thys/FOL_Seq_Calc2/README.md
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/README.md
	@@ -0,0 +1,232 @@
	+# SeCaV Prover
	+This is an automated theorem prover for the SeCaV system for first-order logic with functions.
	+
	+It has been formally verified to be sound and complete, which means that it will never pretend to have proven an invalid formula, and that it will prove any valid formula if given enough time.
	+The SeCaV Prover produces human-readable proofs in the SeCaV system, which means that users can verify the proofs by hand, and study them to understand why a formula is valid.
	+
	+The prover is implemented and verified in Isabelle, with some supporting functions implemented in Haskell.
	+
	+## Installation
	+You can download an executable binary version of the prover from the [release section](https://github.com/fkj/secav-prover/releases) of the development repository, or you can compile one yourself.
	+
	+### Compilation
	+The prover is implemented in Isabelle and Haskell.
	+
	+To compile the prover, you will need the following:
	+* [The Isabelle proof assistant (isabelle)](https://isabelle.in.tum.de/)
	+* [The Glasgow Haskell compiler (ghc)](https://www.haskell.org/ghc/)
	+* [The Cabal build system (cabal)](https://www.haskell.org/cabal/)
	+* [The Make build system (make)](https://www.gnu.org/software/make/)
	+
	+If you are on a Linux system, most of these can probably be installed through the package manager of your distribution.
	+Otherwise, you will have to manually install each of them following the instructions on the pages linked above.
	+If you are on Windows, you may additionally want a Cygwin installation to get a Unix-like environment.
	+
	+Additionally, the [Archive of Formal Proof](https://www.isa-afp.org/) must be installed and available to Isabelle.
	+The ["Using Entries"](https://www.isa-afp.org/using.html) section of the linked page contains instructions on how to do this.
	+
	+If all of these are available, the prover can be compiled by invoking `make`.
	+This will first build the Isabelle theory, which involves checking the proofs of soundness and completeness, then exporting the prover into Haskell code.
	+The Cabal build system will then be called on to compile and link the exported code with the supporting (hand-written) Haskell code.
	+This will produce an executable binary somewhere in the `dist-newstyle` folder.
	+
	+You can test that the prover works correctly by invoking `make test`.
	+This will start two automated test suites consisting of integration tests for soundness and completeness.
	+Since the Isabelle implementation of the prover has been formally verified to be sound and complete, these tests are mostly for the Haskell parts of the prover.
	+Note that especially the completeness test suite may take quite a while to run since it involves processing many Isabelle theories.
	+
	+You can now run the prover through the `cabal run` command, e.g.
	+```
	+cabal run secav-prover -- "Imp P P"
	+```
	+In the usage examples below, simply replace `secav-prover` with `cabal run secav-prover --` to obtain equivalent results.
	+
	+If you want to, you can also install the prover using the command `cabal install secav-prover`.
	+The command `secav-prover` should then become available on your PATH.
	+
	+## Usage
	+The prover can be run by providing it with a formula in SeCaV Unshortener syntax, e.g.:
	+```
	+secav-prover "Imp P P"
	+```
	+If the formula is valid, the prover will then output a proof of the formula in SeCaV Unshortener syntax on standard output.
	+If the formula is not valid, the prover will loop forever, possibly printing parts of the failed proof tree as it goes.
	+For proof-theoretical reasons, there is generally no way to determine whether the prover is working on a proof that may still finish or is in an infinite loop.
	+For small formulas, however, the prover should finish very quickly if the formula is valid.
	+
	+If you would like the proof in Isabelle syntax instead, you may give a filename to write an Isabelle proof to using the `-i` (or `--isabelle`) switch, e.g.:
	+```
	+secav-prover "Imp P P" -i Proof.thy
	+```
	+The generated file can then be opened in Isabelle to verify the proof.
	+To do so, the SeCaV theory must be available to Isabelle, e.g. by placing a copy of the `SeCaV.thy` file in the same folder as the generated file.
	+
	+## Organisation of the repository
	+The implementation of the prover is split into two main parts: the top folder contains the implementation of the proof search procedure itself as well as the formal proofs of soundness and completeness in Isabelle files (`.thy`), while the `haskell` folder contains implementations of supporting functions such as parsing and code generation.
	+
	+The top folder contains the following theories:
	+* `SeCaV.thy` contains the definition of the Sequent Calculus Verifier system, which is the logic we are working in, and a soundness theorem for the proof system
	+* `Sequent1.thy` is a shim theory for linking the AFP theory to the `Sequent_Calculus_Verifier` theory
	+* `Sequent_Calculus_Verifier.thy` contains a completeness result for the SeCaV proof system
	+* `Prover.thy` contains the definition of the proof search procedure
	+* `Export.thy` contains the configuration of the Isabelle-to-Haskell code generator for the proof search procedure
	+* `ProverLemmas.thy` contains formal proofs of a number of useful properties of the proof search procedure
	+* `Hintikka.thy` contains a definition of Hintikka sets for SeCaV formulas
	+* `EPathHintikka.thy` contains formal proof that the sets of formulas in infinite proof trees produced by the proof search procedure are Hintikka sets
	+* `Usemantics.thy` contains a definition of an alternative bounded semantics for SeCaV, which is used in the completeness proof
	+* `Countermodel.thy` contains a formal proof that an infinite proof tree produced by the proof search procedure gives rise to a countermodel of the formula given to the procedure
	+* `Soundness.thy` contains a formal proof of the soundness of the proof search procedure
	+* `Completeness.thy` contains a formal proof of the completeness of the proof search procedure
	+* `Results.thy` contains a summary of our theorems as well as some extra results linking the proof system, the SeCaV semantics, and the bounded semantics
	+
	+The `haskell` folder initially contains two subfolders:
	+* `lib` contains a parser for SeCaV Unshortener syntax, an Unshortener to SeCaV/Isabelle syntax, and a procedure for converting proof trees into SeCaV Unshortener proofs
	+* `app` contains a definition of the command line interface of the prover
	+
	+The Isabelle code generation will create a third subfolder, `prover`, which contains the generated proof search procedure in Haskell.
	+
	+The `test` folder contains the definitions of the automated test suites for soundness and completeness.
	+The files `secav-prover.cabal` and `Setup.hs` are used to configure the Cabal build system.
	+The file `.hlint.yaml` is used to configure the HLint tool to ignore the generated Haskell code.
	+
	+## Examples
	+A very simple example is the one used above:
	+```
	+> secav-prover "Imp P P"
	+
	+Imp P P
	+
	+AlphaImp
	+ Neg P
	+ P
	+Ext
	+ P
	+ Neg P
	+Basic
	+```
	+
	+If we add the `--isabelle Imp.thy` option, we instead obtain a file containing:
	+```
	+theory Imp imports SeCaV begin
	+
	+proposition \<open>P \<longrightarrow> P\<close> by metis
	+
	+text \<open>
	+ Predicate numbers
	+
	+ 0 = P
	+ \<close>
	+
	+lemma \<open>\<tturnstile>
	+ [
	+ Imp (Pre 0 []) (Pre 0 [])
	+ ]
	+ \<close>
	+proof -
	+ from AlphaImp have ?thesis if \<open>\<tturnstile>
	+ [
	+ Neg (Pre 0 []),
	+ Pre 0 []
	+ ]
	+ \<close>
	+ using that by simp
	+ with Ext have ?thesis if \<open>\<tturnstile>
	+ [
	+ Pre 0 [],
	+ Neg (Pre 0 [])
	+ ]
	+ \<close>
	+ using that by simp
	+ with Basic show ?thesis
	+ by simp
	+qed
	+
	+end
	+```
	+
	+The prover works in first-order logic with functions, so we can also try:
	+```
	+> secav-prover "Imp (Uni p[0]) (Exi (p[f[0]]))"
	+Imp (Uni (p [0])) (Exi (p [f[0]]))
	+
	+AlphaImp
	+ Neg (Uni (p [0]))
	+ Exi (p [f[0]])
	+Ext
	+ Exi (p [f[0]])
	+ Exi (p [f[0]])
	+ Neg (Uni (p [0]))
	+GammaExi[f[0]]
	+ p [f[f[0]]]
	+ Exi (p [f[0]])
	+ Neg (Uni (p [0]))
	+Ext
	+ Exi (p [f[0]])
	+ Exi (p [f[0]])
	+ Neg (Uni (p [0]))
	+ p [f[f[0]]]
	+GammaExi[0]
	+ p [f[0]]
	+ Exi (p [f[0]])
	+ Neg (Uni (p [0]))
	+ p [f[f[0]]]
	+Ext
	+ Neg (Uni (p [0]))
	+ Neg (Uni (p [0]))
	+ Exi (p [f[0]])
	+ p [f[f[0]]]
	+ p [f[0]]
	+GammaUni[f[f[0]]]
	+ Neg (p [f[f[0]]])
	+ Neg (Uni (p [0]))
	+ Exi (p [f[0]])
	+ p [f[f[0]]]
	+ p [f[0]]
	+Ext
	+ Neg (Uni (p [0]))
	+ Neg (Uni (p [0]))
	+ Exi (p [f[0]])
	+ p [f[f[0]]]
	+ p [f[0]]
	+ Neg (p [f[f[0]]])
	+GammaUni[f[0]]
	+ Neg (p [f[0]])
	+ Neg (Uni (p [0]))
	+ Exi (p [f[0]])
	+ p [f[f[0]]]
	+ p [f[0]]
	+ Neg (p [f[f[0]]])
	+Ext
	+ Neg (Uni (p [0]))
	+ Neg (Uni (p [0]))
	+ Exi (p [f[0]])
	+ p [f[f[0]]]
	+ p [f[0]]
	+ Neg (p [f[f[0]]])
	+ Neg (p [f[0]])
	+GammaUni[0]
	+ Neg (p [0])
	+ Neg (Uni (p [0]))
	+ Exi (p [f[0]])
	+ p [f[f[0]]]
	+ p [f[0]]
	+ Neg (p [f[f[0]]])
	+ Neg (p [f[0]])
	+Ext
	+ p [f[f[0]]]
	+ p [f[0]]
	+ Neg (Uni (p [0]))
	+ Neg (p [f[f[0]]])
	+ Neg (p [f[0]])
	+ Neg (p [0])
	+ Exi (p [f[0]])
	+Basic
	+```
	+
	+## Authors and license
	+Developers:
	+* [Asta Halkjær From](http://people.compute.dtu.dk/ahfrom/)
	+* [Frederik Krogsdal Jacobsen](http://people.compute.dtu.dk/fkjac/)
	+
	+The prover is licensed under the GNU General Public License, version 3.0.
	+See the `LICENSE` file for the text of the license.
	diff --git a/thys/FOL_Seq_Calc2/ROOT b/thys/FOL_Seq_Calc2/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/ROOT
	@@ -0,0 +1,25 @@
	+chapter AFP
	+
	+session FOL_Seq_Calc2 (AFP) = "HOL-Library" +
	+ options [timeout = 300]
	+ sessions
	+ Collections
	+ Abstract_Completeness
	+ Abstract_Soundness
	+ FOL_Seq_Calc1
	+ theories
	+ SeCaV
	+ Sequent1
	+ Sequent_Calculus_Verifier
	+ Prover
	+ Export
	+ ProverLemmas
	+ Hintikka
	+ EPathHintikka
	+ Usemantics
	+ Countermodel
	+ Soundness
	+ Completeness
	+ Results
	+ document_files
	+ "root.tex"
	diff --git a/thys/FOL_Seq_Calc2/Results.thy b/thys/FOL_Seq_Calc2/Results.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Results.thy
	@@ -0,0 +1,98 @@
	+section \<open>Results\<close>
	+
	+theory Results imports Soundness Completeness Sequent_Calculus_Verifier begin
	+
	+text \<open>In this theory, we collect our soundness and completeness results and prove some extra results
	+ linking the SeCaV proof system, the usual semantics of SeCaV, and our bounded semantics.\<close>
	+
	+subsection \<open>Alternate semantics\<close>
	+
	+text \<open>The existence of a finite, well-formed proof tree with a formula at its root implies that the
	+ formula is valid under our bounded semantics.\<close>
	+corollary prover_soundness_usemantics:
	+ assumes \<open>tfinite t\<close> \<open>wf t\<close> \<open>is_env u e\<close> \<open>is_fdenot u f\<close>
	+ shows \<open>\<exists>p \<in> set (rootSequent t). usemantics u e f g p\<close>
	+ using assms prover_soundness_SeCaV sound_usemantics by blast
	+
	+text \<open>The prover returns a finite, well-formed proof tree if and only if the sequent to be proved is
	+ valid under our bounded semantics.\<close>
	+theorem prover_usemantics:
	+ fixes A :: \<open>tm list\<close> and z :: \<open>fm list\<close>
	+ defines \<open>t \<equiv> secavProver (A, z)\<close>
	+ shows \<open>tfinite t \<and> wf t \<longleftrightarrow> uvalid z\<close>
	+ using assms prover_soundness_usemantics prover_completeness_usemantics
	+ unfolding secavProver_def by fastforce
	+
	+text \<open>The prover returns a finite, well-formed proof tree for a single formula if and only if the
	+ formula is valid under our bounded semantics.\<close>
	+corollary
	+ fixes p :: fm
	+ defines \<open>t \<equiv> secavProver ([], [p])\<close>
	+ shows \<open>tfinite t \<and> wf t \<longleftrightarrow> uvalid [p]\<close>
	+ using assms prover_usemantics by simp
	+
	+subsection \<open>SeCaV\<close>
	+
	+text \<open>The prover returns a finite, well-formed proof tree if and only if the sequent to be proven is
	+ provable in the SeCaV proof system.\<close>
	+theorem prover_SeCaV:
	+ fixes A :: \<open>tm list\<close> and z :: \<open>fm list\<close>
	+ defines \<open>t \<equiv> secavProver (A, z)\<close>
	+ shows \<open>tfinite t \<and> wf t \<longleftrightarrow> (\<tturnstile> z)\<close>
	+ using assms prover_soundness_SeCaV prover_completeness_SeCaV
	+ unfolding secavProver_def by fastforce
	+
	+text \<open>The prover returns a finite, well-formed proof tree if and only if the single formula to be
	+ proven is provable in the SeCaV proof system.\<close>
	+corollary
	+ fixes p :: fm
	+ defines \<open>t \<equiv> secavProver ([], [p])\<close>
	+ shows \<open>tfinite t \<and> wf t \<longleftrightarrow> (\<tturnstile> [p])\<close>
	+ using assms prover_SeCaV by blast
	+
	+subsection \<open>Semantics\<close>
	+
	+text \<open>If the prover returns a finite, well-formed proof tree, some formula in the sequent at the
	+ root of the tree is valid under the usual SeCaV semantics.\<close>
	+corollary prover_soundness_semantics:
	+ assumes \<open>tfinite t\<close> \<open>wf t\<close>
	+ shows \<open>\<exists>p \<in> set (rootSequent t). semantics e f g p\<close>
	+ using assms prover_soundness_SeCaV sound by blast
	+
	+text \<open>If the prover returns a finite, well-formed proof tree, the single formula in the sequent at
	+ the root of the tree is valid under the usual SeCaV semantics.\<close>
	+corollary
	+ assumes \<open>tfinite t\<close> \<open>wf t\<close> \<open>snd (fst (root t)) = [p]\<close>
	+ shows \<open>semantics e f g p\<close>
	+ using assms prover_soundness_SeCaV complete_sound(2) by metis
	+
	+text \<open>If a formula is valid under the usual SeCaV semantics, the prover will return a finite,
	+ well-formed proof tree with the formula at its root when called on it.\<close>
	+corollary prover_completeness_semantics:
	+ fixes A :: \<open>tm list\<close>
	+ assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. semantics e f g p\<close>
	+ defines \<open>t \<equiv> secavProver (A, [p])\<close>
	+ shows \<open>fst (root t) = (A, [p]) \<and> wf t \<and> tfinite t\<close>
	+proof -
	+ have \<open>\<tturnstile> [p]\<close>
	+ using assms complete_sound(1) by blast
	+ then show ?thesis
	+ using assms prover_completeness_SeCaV by blast
	+qed
	+
	+text \<open>The prover produces a finite, well-formed proof tree for a formula if and only if that formula
	+ is valid under the usual SeCaV semantics.\<close>
	+theorem prover_semantics:
	+ fixes A :: \<open>tm list\<close> and p :: fm
	+ defines \<open>t \<equiv> secavProver (A, [p])\<close>
	+ shows \<open>tfinite t \<and> wf t \<longleftrightarrow> (\<forall>(e :: nat \<Rightarrow> nat hterm) f g. semantics e f g p)\<close>
	+ using assms prover_soundness_semantics prover_completeness_semantics
	+ unfolding secavProver_def by fastforce
	+
	+text \<open>Validity in the two semantics (in the proper universes) coincide.\<close>
	+theorem semantics_usemantics:
	+ \<open>(\<forall>(e :: nat \<Rightarrow> nat hterm) f g. semantics e f g p) \<longleftrightarrow>
	+ (\<forall>(u :: tm set) e f g. is_env u e \<longrightarrow> is_fdenot u f \<longrightarrow> usemantics u e f g p)\<close>
	+ using prover_semantics prover_usemantics by simp
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/SeCaV.thy b/thys/FOL_Seq_Calc2/SeCaV.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/SeCaV.thy
	@@ -0,0 +1,354 @@
	+chapter SeCaV
	+
	+(*
	+ Author: Jørgen Villadsen, DTU Compute, 2020
	+ Contributors: Stefan Berghofer, Asta Halkjær From, Alexander Birch Jensen & Anders Schlichtkrull
	+*)
	+
	+section \<open>Sequent Calculus Verifier (SeCaV)\<close>
	+
	+theory SeCaV imports Main begin
	+
	+section \<open>Syntax: Terms / Formulas\<close>
	+
	+datatype tm = Fun nat \<open>tm list\<close> \| Var nat
	+
	+datatype fm = Pre nat \<open>tm list\<close> \| Imp fm fm \| Dis fm fm \| Con fm fm \| Exi fm \| Uni fm \| Neg fm
	+
	+section \<open>Semantics: Terms / Formulas\<close>
	+
	+definition \<open>shift e v x \<equiv> \<lambda>n. if n < v then e n else if n = v then x else e (n - 1)\<close>
	+
	+primrec semantics_term and semantics_list where
	+ \<open>semantics_term e f (Var n) = e n\<close> \|
	+ \<open>semantics_term e f (Fun i l) = f i (semantics_list e f l)\<close> \|
	+ \<open>semantics_list e f [] = []\<close> \|
	+ \<open>semantics_list e f (t # l) = semantics_term e f t # semantics_list e f l\<close>
	+
	+primrec semantics where
	+ \<open>semantics e f g (Pre i l) = g i (semantics_list e f l)\<close> \|
	+ \<open>semantics e f g (Imp p q) = (semantics e f g p \<longrightarrow> semantics e f g q)\<close> \|
	+ \<open>semantics e f g (Dis p q) = (semantics e f g p \<or> semantics e f g q)\<close> \|
	+ \<open>semantics e f g (Con p q) = (semantics e f g p \<and> semantics e f g q)\<close> \|
	+ \<open>semantics e f g (Exi p) = (\<exists>x. semantics (shift e 0 x) f g p)\<close> \|
	+ \<open>semantics e f g (Uni p) = (\<forall>x. semantics (shift e 0 x) f g p)\<close> \|
	+ \<open>semantics e f g (Neg p) = (\<not> semantics e f g p)\<close>
	+
	+\<comment> \<open>Test\<close>
	+
	+corollary \<open>semantics e f g (Imp (Pre 0 []) (Pre 0 []))\<close>
	+ by simp
	+
	+lemma \<open>\<not> semantics e f g (Neg (Imp (Pre 0 []) (Pre 0 [])))\<close>
	+ by simp
	+
	+section \<open>Auxiliary Functions\<close>
	+
	+primrec new_term and new_list where
	+ \<open>new_term c (Var n) = True\<close> \|
	+ \<open>new_term c (Fun i l) = (if i = c then False else new_list c l)\<close> \|
	+ \<open>new_list c [] = True\<close> \|
	+ \<open>new_list c (t # l) = (if new_term c t then new_list c l else False)\<close>
	+
	+primrec new where
	+ \<open>new c (Pre i l) = new_list c l\<close> \|
	+ \<open>new c (Imp p q) = (if new c p then new c q else False)\<close> \|
	+ \<open>new c (Dis p q) = (if new c p then new c q else False)\<close> \|
	+ \<open>new c (Con p q) = (if new c p then new c q else False)\<close> \|
	+ \<open>new c (Exi p) = new c p\<close> \|
	+ \<open>new c (Uni p) = new c p\<close> \|
	+ \<open>new c (Neg p) = new c p\<close>
	+
	+primrec news where
	+ \<open>news c [] = True\<close> \|
	+ \<open>news c (p # z) = (if new c p then news c z else False)\<close>
	+
	+primrec inc_term and inc_list where
	+ \<open>inc_term (Var n) = Var (n + 1)\<close> \|
	+ \<open>inc_term (Fun i l) = Fun i (inc_list l)\<close> \|
	+ \<open>inc_list [] = []\<close> \|
	+ \<open>inc_list (t # l) = inc_term t # inc_list l\<close>
	+
	+primrec sub_term and sub_list where
	+ \<open>sub_term v s (Var n) = (if n < v then Var n else if n = v then s else Var (n - 1))\<close> \|
	+ \<open>sub_term v s (Fun i l) = Fun i (sub_list v s l)\<close> \|
	+ \<open>sub_list v s [] = []\<close> \|
	+ \<open>sub_list v s (t # l) = sub_term v s t # sub_list v s l\<close>
	+
	+primrec sub where
	+ \<open>sub v s (Pre i l) = Pre i (sub_list v s l)\<close> \|
	+ \<open>sub v s (Imp p q) = Imp (sub v s p) (sub v s q)\<close> \|
	+ \<open>sub v s (Dis p q) = Dis (sub v s p) (sub v s q)\<close> \|
	+ \<open>sub v s (Con p q) = Con (sub v s p) (sub v s q)\<close> \|
	+ \<open>sub v s (Exi p) = Exi (sub (v + 1) (inc_term s) p)\<close> \|
	+ \<open>sub v s (Uni p) = Uni (sub (v + 1) (inc_term s) p)\<close> \|
	+ \<open>sub v s (Neg p) = Neg (sub v s p)\<close>
	+
	+primrec member where
	+ \<open>member p [] = False\<close> \|
	+ \<open>member p (q # z) = (if p = q then True else member p z)\<close>
	+
	+primrec ext where
	+ \<open>ext y [] = True\<close> \|
	+ \<open>ext y (p # z) = (if member p y then ext y z else False)\<close>
	+
	+\<comment> \<open>Simplifications\<close>
	+
	+lemma member [iff]: \<open>member p z \<longleftrightarrow> p \<in> set z\<close>
	+ by (induct z) simp_all
	+
	+lemma ext [iff]: \<open>ext y z \<longleftrightarrow> set z \<subseteq> set y\<close>
	+ by (induct z) simp_all
	+
	+section \<open>Sequent Calculus\<close>
	+
	+inductive sequent_calculus (\<open>\<tturnstile> _\<close> 0) where
	+ \<open>\<tturnstile> p # z\<close> if \<open>member (Neg p) z\<close> \|
	+ \<open>\<tturnstile> Dis p q # z\<close> if \<open>\<tturnstile> p # q # z\<close> \|
	+ \<open>\<tturnstile> Imp p q # z\<close> if \<open>\<tturnstile> Neg p # q # z\<close> \|
	+ \<open>\<tturnstile> Neg (Con p q) # z\<close> if \<open>\<tturnstile> Neg p # Neg q # z\<close> \|
	+ \<open>\<tturnstile> Con p q # z\<close> if \<open>\<tturnstile> p # z\<close> and \<open>\<tturnstile> q # z\<close> \|
	+ \<open>\<tturnstile> Neg (Imp p q) # z\<close> if \<open>\<tturnstile> p # z\<close> and \<open>\<tturnstile> Neg q # z\<close> \|
	+ \<open>\<tturnstile> Neg (Dis p q) # z\<close> if \<open>\<tturnstile> Neg p # z\<close> and \<open>\<tturnstile> Neg q # z\<close> \|
	+ \<open>\<tturnstile> Exi p # z\<close> if \<open>\<tturnstile> sub 0 t p # z\<close> \|
	+ \<open>\<tturnstile> Neg (Uni p) # z\<close> if \<open>\<tturnstile> Neg (sub 0 t p) # z\<close> \|
	+ \<open>\<tturnstile> Uni p # z\<close> if \<open>\<tturnstile> sub 0 (Fun i []) p # z\<close> and \<open>news i (p # z)\<close> \|
	+ \<open>\<tturnstile> Neg (Exi p) # z\<close> if \<open>\<tturnstile> Neg (sub 0 (Fun i []) p) # z\<close> and \<open>news i (p # z)\<close> \|
	+ \<open>\<tturnstile> Neg (Neg p) # z\<close> if \<open>\<tturnstile> p # z\<close> \|
	+ \<open>\<tturnstile> y\<close> if \<open>\<tturnstile> z\<close> and \<open>ext y z\<close>
	+
	+\<comment> \<open>Test\<close>
	+
	+corollary \<open>\<tturnstile> [Imp (Pre 0 []) (Pre 0 [])]\<close>
	+ using sequent_calculus.intros(1,3,13) ext.simps member.simps(2) by metis
	+
	+section \<open>Shorthands\<close>
	+
	+lemmas Basic = sequent_calculus.intros(1)
	+
	+lemmas AlphaDis = sequent_calculus.intros(2)
	+lemmas AlphaImp = sequent_calculus.intros(3)
	+lemmas AlphaCon = sequent_calculus.intros(4)
	+
	+lemmas BetaCon = sequent_calculus.intros(5)
	+lemmas BetaImp = sequent_calculus.intros(6)
	+lemmas BetaDis = sequent_calculus.intros(7)
	+
	+lemmas GammaExi = sequent_calculus.intros(8)
	+lemmas GammaUni = sequent_calculus.intros(9)
	+
	+lemmas DeltaUni = sequent_calculus.intros(10)
	+lemmas DeltaExi = sequent_calculus.intros(11)
	+
	+lemmas Neg = sequent_calculus.intros(12)
	+
	+lemmas Ext = sequent_calculus.intros(13)
	+
	+\<comment> \<open>Test\<close>
	+
	+lemma \<open>\<tturnstile>
	+ [
	+ Imp (Pre 0 []) (Pre 0 [])
	+ ]
	+ \<close>
	+proof -
	+ from AlphaImp have ?thesis if \<open>\<tturnstile>
	+ [
	+ Neg (Pre 0 []),
	+ Pre 0 []
	+ ]
	+ \<close>
	+ using that by simp
	+ with Ext have ?thesis if \<open>\<tturnstile>
	+ [
	+ Pre 0 [],
	+ Neg (Pre 0 [])
	+ ]
	+ \<close>
	+ using that by simp
	+ with Basic show ?thesis
	+ by simp
	+qed
	+
	+section \<open>Appendix: Soundness\<close>
	+
	+subsection \<open>Increment Function\<close>
	+
	+primrec liftt :: \<open>tm \<Rightarrow> tm\<close> and liftts :: \<open>tm list \<Rightarrow> tm list\<close> where
	+ \<open>liftt (Var i) = Var (Suc i)\<close> \|
	+ \<open>liftt (Fun a ts) = Fun a (liftts ts)\<close> \|
	+ \<open>liftts [] = []\<close> \|
	+ \<open>liftts (t # ts) = liftt t # liftts ts\<close>
	+
	+subsection \<open>Parameters: Terms\<close>
	+
	+primrec paramst :: \<open>tm \<Rightarrow> nat set\<close> and paramsts :: \<open>tm list \<Rightarrow> nat set\<close> where
	+ \<open>paramst (Var n) = {}\<close> \|
	+ \<open>paramst (Fun a ts) = {a} \<union> paramsts ts\<close> \|
	+ \<open>paramsts [] = {}\<close> \|
	+ \<open>paramsts (t # ts) = (paramst t \<union> paramsts ts)\<close>
	+
	+lemma p0 [simp]: \<open>paramsts ts = \<Union>(set (map paramst ts))\<close>
	+ by (induct ts) simp_all
	+
	+primrec paramst' :: \<open>tm \<Rightarrow> nat set\<close> where
	+ \<open>paramst' (Var n) = {}\<close> \|
	+ \<open>paramst' (Fun a ts) = {a} \<union> \<Union>(set (map paramst' ts))\<close>
	+
	+lemma p1 [simp]: \<open>paramst' t = paramst t\<close>
	+ by (induct t) simp_all
	+
	+subsection \<open>Parameters: Formulas\<close>
	+
	+primrec params :: \<open>fm \<Rightarrow> nat set\<close> where
	+ \<open>params (Pre b ts) = paramsts ts\<close> \|
	+ \<open>params (Imp p q) = params p \<union> params q\<close> \|
	+ \<open>params (Dis p q) = params p \<union> params q\<close> \|
	+ \<open>params (Con p q) = params p \<union> params q\<close> \|
	+ \<open>params (Exi p) = params p\<close> \|
	+ \<open>params (Uni p) = params p\<close> \|
	+ \<open>params (Neg p) = params p\<close>
	+
	+primrec params' :: \<open>fm \<Rightarrow> nat set\<close> where
	+ \<open>params' (Pre b ts) = \<Union>(set (map paramst' ts))\<close> \|
	+ \<open>params' (Imp p q) = params' p \<union> params' q\<close> \|
	+ \<open>params' (Dis p q) = params' p \<union> params' q\<close> \|
	+ \<open>params' (Con p q) = params' p \<union> params' q\<close> \|
	+ \<open>params' (Exi p) = params' p\<close> \|
	+ \<open>params' (Uni p) = params' p\<close> \|
	+ \<open>params' (Neg p) = params' p\<close>
	+
	+lemma p2 [simp]: \<open>params' p = params p\<close>
	+ by (induct p) simp_all
	+
	+fun paramst'' :: \<open>tm \<Rightarrow> nat set\<close> where
	+ \<open>paramst'' (Var n) = {}\<close> \|
	+ \<open>paramst'' (Fun a ts) = {a} \<union> (\<Union>t \<in> set ts. paramst'' t)\<close>
	+
	+lemma p1' [simp]: \<open>paramst'' t = paramst t\<close>
	+ by (induct t) simp_all
	+
	+fun params'' :: \<open>fm \<Rightarrow> nat set\<close> where
	+ \<open>params'' (Pre b ts) = (\<Union>t \<in> set ts. paramst'' t)\<close> \|
	+ \<open>params'' (Imp p q) = params'' p \<union> params'' q\<close> \|
	+ \<open>params'' (Dis p q) = params'' p \<union> params'' q\<close> \|
	+ \<open>params'' (Con p q) = params'' p \<union> params'' q\<close> \|
	+ \<open>params'' (Exi p) = params'' p\<close> \|
	+ \<open>params'' (Uni p) = params'' p\<close> \|
	+ \<open>params'' (Neg p) = params'' p\<close>
	+
	+lemma p2' [simp]: \<open>params'' p = params p\<close>
	+ by (induct p) simp_all
	+
	+subsection \<open>Update Lemmas\<close>
	+
	+lemma upd_lemma' [simp]:
	+ \<open>n \<notin> paramst t \<Longrightarrow> semantics_term e (f(n := z)) t = semantics_term e f t\<close>
	+ \<open>n \<notin> paramsts ts \<Longrightarrow> semantics_list e (f(n := z)) ts = semantics_list e f ts\<close>
	+ by (induct t and ts rule: paramst.induct paramsts.induct) auto
	+
	+lemma upd_lemma [iff]: \<open>n \<notin> params p \<Longrightarrow> semantics e (f(n := z)) g p \<longleftrightarrow> semantics e f g p\<close>
	+ by (induct p arbitrary: e) simp_all
	+
	+subsection \<open>Substitution\<close>
	+
	+primrec substt :: \<open>tm \<Rightarrow> tm \<Rightarrow> nat \<Rightarrow> tm\<close> and substts :: \<open>tm list \<Rightarrow> tm \<Rightarrow> nat \<Rightarrow> tm list\<close> where
	+ \<open>substt (Var i) s k = (if k < i then Var (i - 1) else if i = k then s else Var i)\<close> \|
	+ \<open>substt (Fun a ts) s k = Fun a (substts ts s k)\<close> \|
	+ \<open>substts [] s k = []\<close> \|
	+ \<open>substts (t # ts) s k = substt t s k # substts ts s k\<close>
	+
	+primrec subst :: \<open>fm \<Rightarrow> tm \<Rightarrow> nat \<Rightarrow> fm\<close> where
	+ \<open>subst (Pre b ts) s k = Pre b (substts ts s k)\<close> \|
	+ \<open>subst (Imp p q) s k = Imp (subst p s k) (subst q s k)\<close> \|
	+ \<open>subst (Dis p q) s k = Dis (subst p s k) (subst q s k)\<close> \|
	+ \<open>subst (Con p q) s k = Con (subst p s k) (subst q s k)\<close> \|
	+ \<open>subst (Exi p) s k = Exi (subst p (liftt s) (Suc k))\<close> \|
	+ \<open>subst (Uni p) s k = Uni (subst p (liftt s) (Suc k))\<close> \|
	+ \<open>subst (Neg p) s k = Neg (subst p s k)\<close>
	+
	+lemma shift_eq [simp]: \<open>i = j \<Longrightarrow> (shift e i T) j = T\<close> for i :: nat
	+ unfolding shift_def by simp
	+
	+lemma shift_gt [simp]: \<open>j < i \<Longrightarrow> (shift e i T) j = e j\<close> for i :: nat
	+ unfolding shift_def by simp
	+
	+lemma shift_lt [simp]: \<open>i < j \<Longrightarrow> (shift e i T) j = e (j - 1)\<close> for i :: nat
	+ unfolding shift_def by simp
	+
	+lemma shift_commute [simp]: \<open>shift (shift e i U) 0 T = shift (shift e 0 T) (Suc i) U\<close>
	+ unfolding shift_def by force
	+
	+lemma subst_lemma' [simp]:
	+ \<open>semantics_term e f (substt t u i) = semantics_term (shift e i (semantics_term e f u)) f t\<close>
	+ \<open>semantics_list e f (substts ts u i) = semantics_list (shift e i (semantics_term e f u)) f ts\<close>
	+ by (induct t and ts rule: substt.induct substts.induct) simp_all
	+
	+lemma lift_lemma [simp]:
	+ \<open>semantics_term (shift e 0 x) f (liftt t) = semantics_term e f t\<close>
	+ \<open>semantics_list (shift e 0 x) f (liftts ts) = semantics_list e f ts\<close>
	+ by (induct t and ts rule: liftt.induct liftts.induct) simp_all
	+
	+lemma subst_lemma [iff]:
	+ \<open>semantics e f g (subst a t i) \<longleftrightarrow> semantics (shift e i (semantics_term e f t)) f g a\<close>
	+ by (induct a arbitrary: e i t) simp_all
	+
	+subsection \<open>Auxiliary Lemmas\<close>
	+
	+lemma s1 [iff]: \<open>new_term c t \<longleftrightarrow> (c \<notin> paramst t)\<close> \<open>new_list c l \<longleftrightarrow> (c \<notin> paramsts l)\<close>
	+ by (induct t and l rule: new_term.induct new_list.induct) simp_all
	+
	+lemma s2 [iff]: \<open>new c p \<longleftrightarrow> (c \<notin> params p)\<close>
	+ by (induct p) simp_all
	+
	+lemma s3 [iff]: \<open>news c z \<longleftrightarrow> list_all (\<lambda>p. c \<notin> params p) z\<close>
	+ by (induct z) simp_all
	+
	+lemma s4 [simp]: \<open>inc_term t = liftt t\<close> \<open>inc_list l = liftts l\<close>
	+ by (induct t and l rule: inc_term.induct inc_list.induct) simp_all
	+
	+lemma s5 [simp]: \<open>sub_term v s t = substt t s v\<close> \<open>sub_list v s l = substts l s v\<close>
	+ by (induct t and l rule: inc_term.induct inc_list.induct) simp_all
	+
	+lemma s6 [simp]: \<open>sub v s p = subst p s v\<close>
	+ by (induct p arbitrary: v s) simp_all
	+
	+subsection \<open>Soundness\<close>
	+
	+theorem sound: \<open>\<tturnstile> z \<Longrightarrow> \<exists>p \<in> set z. semantics e f g p\<close>
	+proof (induct arbitrary: f rule: sequent_calculus.induct)
	+ case (10 i p z)
	+ then show ?case
	+ proof (cases \<open>\<forall>x. semantics e (f(i := \<lambda>_. x)) g (sub 0 (Fun i []) p)\<close>)
	+ case False
	+ moreover have \<open>list_all (\<lambda>p. i \<notin> params p) z\<close>
	+ using 10 by simp
	+ ultimately show ?thesis
	+ using 10 Ball_set insert_iff list.set(2) upd_lemma by metis
	+ qed simp
	+next
	+ case (11 i p z)
	+ then show ?case
	+ proof (cases \<open>\<forall>x. semantics e (f(i := \<lambda>_. x)) g (Neg (sub 0 (Fun i []) p))\<close>)
	+ case False
	+ moreover have \<open>list_all (\<lambda>p. i \<notin> params p) z\<close>
	+ using 11 by simp
	+ ultimately show ?thesis
	+ using 11 Ball_set insert_iff list.set(2) upd_lemma by metis
	+ qed simp
	+qed force+
	+
	+corollary \<open>\<tturnstile> z \<Longrightarrow> \<exists>p. member p z \<and> semantics e f g p\<close>
	+ using sound by force
	+
	+corollary \<open>\<tturnstile> [p] \<Longrightarrow> semantics e f g p\<close>
	+ using sound by force
	+
	+corollary \<open>\<not> (\<tturnstile> [])\<close>
	+ using sound by force
	+
	+section \<open>Reference\<close>
	+
	+text \<open>Mordechai Ben-Ari (Springer 2012): Mathematical Logic for Computer Science (Third Edition)\<close>
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/Sequent1.thy b/thys/FOL_Seq_Calc2/Sequent1.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Sequent1.thy
	@@ -0,0 +1,7 @@
	+theory Sequent1 imports "FOL_Seq_Calc1.Sequent"
	+begin
	+
	+text \<open>This theory exists exclusively as a shim to link the AFP theory imported here
	+ to the \<open>Sequent_Calculus_Verifier\<close> theory.\<close>
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/Sequent_Calculus_Verifier.thy b/thys/FOL_Seq_Calc2/Sequent_Calculus_Verifier.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Sequent_Calculus_Verifier.thy
	@@ -0,0 +1,101 @@
	+(*
	+ Author: Jørgen Villadsen, DTU Compute, 2020
	+*)
	+
	+section \<open>Appendix: Completeness\<close>
	+
	+theory Sequent_Calculus_Verifier imports Sequent1 SeCaV begin
	+
	+primrec from_tm and from_tm_list where
	+ \<open>from_tm (Var n) = FOL_Fitting.Var n\<close> \|
	+ \<open>from_tm (Fun a ts) = App a (from_tm_list ts)\<close> \|
	+ \<open>from_tm_list [] = []\<close> \|
	+ \<open>from_tm_list (t # ts) = from_tm t # from_tm_list ts\<close>
	+
	+primrec from_fm where
	+ \<open>from_fm (Pre b ts) = Pred b (from_tm_list ts)\<close> \|
	+ \<open>from_fm (Con p q) = And (from_fm p) (from_fm q)\<close> \|
	+ \<open>from_fm (Dis p q) = Or (from_fm p) (from_fm q)\<close> \|
	+ \<open>from_fm (Imp p q) = Impl (from_fm p) (from_fm q)\<close> \|
	+ \<open>from_fm (Neg p) = FOL_Fitting.Neg (from_fm p)\<close> \|
	+ \<open>from_fm (Uni p) = Forall (from_fm p)\<close> \|
	+ \<open>from_fm (Exi p) = Exists (from_fm p)\<close>
	+
	+primrec to_tm and to_tm_list where
	+ \<open>to_tm (FOL_Fitting.Var n) = Var n\<close> \|
	+ \<open>to_tm (App a ts) = Fun a (to_tm_list ts)\<close> \|
	+ \<open>to_tm_list [] = []\<close> \|
	+ \<open>to_tm_list (t # ts) = to_tm t # to_tm_list ts\<close>
	+
	+primrec to_fm where
	+ \<open>to_fm \<bottom> = Neg (Imp (Pre 0 []) (Pre 0 []))\<close> \|
	+ \<open>to_fm \<top> = Imp (Pre 0 []) (Pre 0 [])\<close> \|
	+ \<open>to_fm (Pred b ts) = Pre b (to_tm_list ts)\<close> \|
	+ \<open>to_fm (And p q) = Con (to_fm p) (to_fm q)\<close> \|
	+ \<open>to_fm (Or p q) = Dis (to_fm p) (to_fm q)\<close> \|
	+ \<open>to_fm (Impl p q) = Imp (to_fm p) (to_fm q)\<close> \|
	+ \<open>to_fm (FOL_Fitting.Neg p) = Neg (to_fm p)\<close> \|
	+ \<open>to_fm (Forall p) = Uni (to_fm p)\<close> \|
	+ \<open>to_fm (Exists p) = Exi (to_fm p)\<close>
	+
	+theorem to_from_tm [simp]: \<open>to_tm (from_tm t) = t\<close> \<open>to_tm_list (from_tm_list ts) = ts\<close>
	+ by (induct t and ts rule: from_tm.induct from_tm_list.induct) simp_all
	+
	+theorem to_from_fm [simp]: \<open>to_fm (from_fm p) = p\<close>
	+ by (induct p) simp_all
	+
	+lemma Truth [simp]: \<open>\<tturnstile> Imp (Pre 0 []) (Pre 0 []) # z\<close>
	+ using AlphaImp Basic Ext ext.simps member.simps(2) by metis
	+
	+lemma paramst [simp]:
	+ \<open>FOL_Fitting.new_term c t = new_term c (to_tm t)\<close>
	+ \<open>FOL_Fitting.new_list c l = new_list c (to_tm_list l)\<close>
	+ by (induct t and l rule: FOL_Fitting.paramst.induct FOL_Fitting.paramsts.induct) simp_all
	+
	+lemma params [iff]: \<open>FOL_Fitting.new c p \<longleftrightarrow> new c (to_fm p)\<close>
	+ by (induct p) simp_all
	+
	+lemma list_params [iff]: \<open>FOL_Fitting.news c z \<longleftrightarrow> news c (map to_fm z)\<close>
	+ by (induct z) simp_all
	+
	+lemma liftt [simp]:
	+ \<open>to_tm (FOL_Fitting.liftt t) = inc_term (to_tm t)\<close>
	+ \<open>to_tm_list (FOL_Fitting.liftts l) = inc_list (to_tm_list l)\<close>
	+ by (induct t and l rule: FOL_Fitting.liftt.induct FOL_Fitting.liftts.induct) simp_all
	+
	+lemma substt [simp]:
	+ \<open>to_tm (FOL_Fitting.substt t s v) = sub_term v (to_tm s) (to_tm t)\<close>
	+ \<open>to_tm_list (FOL_Fitting.substts l s v) = sub_list v (to_tm s) (to_tm_list l)\<close>
	+ by (induct t and l rule: FOL_Fitting.substt.induct FOL_Fitting.substts.induct) simp_all
	+
	+lemma subst [simp]: \<open>to_fm (FOL_Fitting.subst A t s) = sub s (to_tm t) (to_fm A)\<close>
	+ by (induct A arbitrary: t s) simp_all
	+
	+lemma sim: \<open>(\<turnstile> x) \<Longrightarrow> (\<tturnstile> (map to_fm x))\<close>
	+ by (induct rule: SC.induct) (force intro: sequent_calculus.intros)+
	+
	+lemma evalt [simp]:
	+ \<open>semantics_term e f t = evalt e f (from_tm t)\<close>
	+ \<open>semantics_list e f ts = evalts e f (from_tm_list ts)\<close>
	+ by (induct t and ts rule: from_tm.induct from_tm_list.induct) simp_all
	+
	+lemma shift [simp]: \<open>shift e 0 x = e\<langle>0:x\<rangle>\<close>
	+ unfolding shift_def FOL_Fitting.shift_def by simp
	+
	+lemma semantics [iff]: \<open>semantics e f g p \<longleftrightarrow> eval e f g (from_fm p)\<close>
	+ by (induct p arbitrary: e) simp_all
	+
	+abbreviation valid ("\<then> _" 0) where
	+ \<open>(\<then> p) \<equiv> \<forall>(e :: _ \<Rightarrow> nat hterm) f g. semantics e f g p\<close>
	+
	+theorem complete_sound: \<open>\<then> p \<Longrightarrow> \<tturnstile> [p]\<close> \<open>\<tturnstile> [q] \<Longrightarrow> semantics e f g q\<close>
	+ by (metis to_from_fm sim semantics list.map SC_completeness) (use sound in force)
	+
	+corollary \<open>(\<then> p) \<longleftrightarrow> (\<tturnstile> [p])\<close>
	+ using complete_sound by fast
	+
	+section \<open>Reference\<close>
	+
	+text \<open>Asta Halkjær From (2019): Sequent Calculus \<^url>\<open>https://www.isa-afp.org/entries/FOL_Seq_Calc1.html\<close>\<close>
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/Setup.hs b/thys/FOL_Seq_Calc2/Setup.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Setup.hs
	@@ -0,0 +1,2 @@
	+import Distribution.Simple
	+main = defaultMain
	diff --git a/thys/FOL_Seq_Calc2/Soundness.thy b/thys/FOL_Seq_Calc2/Soundness.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Soundness.thy
	@@ -0,0 +1,323 @@
	+section \<open>Soundness\<close>
	+
	+theory Soundness
	+ imports ProverLemmas
	+begin
	+
	+text \<open>In this theory, we prove that the prover is sound with regards to the SeCaV proof system
	+ using the abstract soundness framework.\<close>
	+
	+text \<open>If some suffix of the sequents in all of the children of a state are provable, so is some
	+ suffix of the sequent in the current state, with the prefix in each sequent being the same.
	+ (As a side condition, the lists of terms need to be compatible.)\<close>
	+lemma SeCaV_children_pre:
	+ assumes \<open>\<forall>z' \<in> set (children A r z). (\<tturnstile> pre @ z')\<close>
	+ and \<open>paramss (pre @ z) \<subseteq> paramsts A\<close>
	+ shows \<open>\<tturnstile> pre @ z\<close>
	+ using assms
	+proof (induct z arbitrary: pre A)
	+ case Nil
	+ then show ?case
	+ by simp
	+next
	+ case (Cons p z)
	+ then have ih: \<open>\<forall>z' \<in> set (children A r z). (\<tturnstile> pre @ z') \<Longrightarrow> (\<tturnstile> pre @ z)\<close>
	+ if \<open>paramss (pre @ z) \<subseteq> paramsts A\<close> for pre A
	+ using that by simp
	+
	+ let ?A = \<open>remdups (A @ subtermFms (concat (parts A r p)))\<close>
	+
	+ have A: \<open>paramss (pre @ p # z) \<subseteq> paramsts ?A\<close>
	+ using paramsts_subset Cons.prems(2) by fastforce
	+
	+ have \<open>\<forall>z' \<in> set (list_prod (parts A r p) (children ?A r z)). (\<tturnstile> pre @ z')\<close>
	+ using Cons.prems by (metis children.simps(2))
	+ then have \<open>\<forall>z' \<in> {hs @ ts \|hs ts. hs \<in> set (parts A r p) \<and> ts \<in> set (children ?A r z)}.
	+ (\<tturnstile> pre @ z')\<close>
	+ using list_prod_is_cartesian by blast
	+ then have *:
	+ \<open>\<forall>hs \<in> set (parts A r p). \<forall>ts \<in> set (children ?A r z). (\<tturnstile> pre @ hs @ ts)\<close>
	+ by blast
	+ then show ?case
	+ proof (cases r p rule: parts_exhaust)
	+ case (AlphaDis p q)
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # q # z')\<close>
	+ using * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p, q]) @ z')\<close>
	+ by simp
	+ then have \<open>\<tturnstile> pre @ p # q # z\<close>
	+ using AlphaDis ih[where pre=\<open>pre @ [p, q]\<close> and A=\<open>?A\<close>] A by simp
	+ then have \<open>\<tturnstile> p # q # pre @ z\<close>
	+ using Ext by simp
	+ then have \<open>\<tturnstile> Dis p q # pre @ z\<close>
	+ using SeCaV.AlphaDis by blast
	+ then show ?thesis
	+ using AlphaDis Ext by simp
	+ next
	+ case (AlphaImp p q)
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg p # q # z')\<close>
	+ using * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg p, q]) @ z')\<close>
	+ by simp
	+ then have \<open>\<tturnstile> pre @ Neg p # q # z\<close>
	+ using AlphaImp ih[where pre=\<open>pre @ [Neg p, q]\<close> and A=\<open>?A\<close>] A by simp
	+ then have \<open>\<tturnstile> Neg p # q # pre @ z\<close>
	+ using Ext by simp
	+ then have \<open>\<tturnstile> Imp p q # pre @ z\<close>
	+ using SeCaV.AlphaImp by blast
	+ then show ?thesis
	+ using AlphaImp Ext by simp
	+ next
	+ case (AlphaCon p q)
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg p # Neg q # z')\<close>
	+ using * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg p, Neg q]) @ z')\<close>
	+ by simp
	+ then have \<open>\<tturnstile> pre @ Neg p # Neg q # z\<close>
	+ using AlphaCon ih[where pre=\<open>pre @ [Neg p, Neg q]\<close> and A=\<open>?A\<close>] A by simp
	+ then have \<open>\<tturnstile> Neg p # Neg q # pre @ z\<close>
	+ using Ext by simp
	+ then have \<open>\<tturnstile> Neg (Con p q) # pre @ z\<close>
	+ using SeCaV.AlphaCon by blast
	+ then show ?thesis
	+ using AlphaCon Ext by simp
	+ next
	+ case (BetaCon p q)
	+ then have
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # z')\<close>
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ q # z')\<close>
	+ using * unfolding parts_def by simp_all
	+ then have
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [q]) @ z')\<close>
	+ by simp_all
	+ then have \<open>\<tturnstile> pre @ p # z\<close> \<open>\<tturnstile> pre @ q # z\<close>
	+ using BetaCon ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp_all
	+ then have \<open>\<tturnstile> p # pre @ z\<close> \<open>\<tturnstile> q # pre @ z\<close>
	+ using Ext by simp_all
	+ then have \<open>\<tturnstile> Con p q # pre @ z\<close>
	+ using SeCaV.BetaCon by blast
	+ then show ?thesis
	+ using BetaCon Ext by simp
	+ next
	+ case (BetaImp p q)
	+ then have
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # z')\<close>
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg q # z')\<close>
	+ using * unfolding parts_def by simp_all
	+ then have
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg q]) @ z')\<close>
	+ by simp_all
	+ then have \<open>\<tturnstile> pre @ p # z\<close> \<open>\<tturnstile> pre @ Neg q # z\<close>
	+ using BetaImp ih ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp_all
	+ then have \<open>\<tturnstile> p # pre @ z\<close> \<open>\<tturnstile> Neg q # pre @ z\<close>
	+ using Ext by simp_all
	+ then have \<open>\<tturnstile> Neg (Imp p q) # pre @ z\<close>
	+ using SeCaV.BetaImp by blast
	+ then show ?thesis
	+ using BetaImp Ext by simp
	+ next
	+ case (BetaDis p q)
	+ then have
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg p # z')\<close>
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg q # z')\<close>
	+ using * unfolding parts_def by simp_all
	+ then have
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg p]) @ z')\<close>
	+ \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg q]) @ z')\<close>
	+ by simp_all
	+ then have \<open>\<tturnstile> pre @ Neg p # z\<close> \<open>\<tturnstile> pre @ Neg q # z\<close>
	+ using BetaDis ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp_all
	+ then have \<open>\<tturnstile> Neg p # pre @ z\<close> \<open>\<tturnstile> Neg q # pre @ z\<close>
	+ using Ext by simp_all
	+ then have \<open>\<tturnstile> Neg (Dis p q) # pre @ z\<close>
	+ using SeCaV.BetaDis by blast
	+ then show ?thesis
	+ using BetaDis Ext by simp
	+ next
	+ case (DeltaUni p)
	+ let ?i = \<open>generateNew A\<close>
	+ have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ sub 0 (Fun ?i []) p # z')\<close>
	+ using DeltaUni * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [sub 0 (Fun ?i []) p]) @ z')\<close>
	+ by simp
	+ moreover have \<open>set (subtermFm (sub 0 (Fun ?i []) p)) \<subseteq> set ?A\<close>
	+ using DeltaUni unfolding parts_def by simp
	+ then have \<open>params (sub 0 (Fun ?i []) p) \<subseteq> paramsts ?A\<close>
	+ using subtermFm_subset_params by blast
	+ ultimately have \<open>\<tturnstile> pre @ sub 0 (Fun ?i []) p # z\<close>
	+ using DeltaUni ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp
	+ then have \<open>\<tturnstile> sub 0 (Fun ?i []) p # pre @ z\<close>
	+ using Ext by simp
	+ moreover have \<open>?i \<notin> paramsts A\<close>
	+ by (induct A) (metis Suc_max_new generateNew_def listFunTm_paramst(2) plus_1_eq_Suc)+
	+ then have \<open>news ?i (p # pre @ z)\<close>
	+ using DeltaUni Cons.prems(2) news_paramss by auto
	+ ultimately have \<open>\<tturnstile> Uni p # pre @ z\<close>
	+ using SeCaV.DeltaUni by blast
	+ then show ?thesis
	+ using DeltaUni Ext by simp
	+ next
	+ case (DeltaExi p)
	+ let ?i = \<open>generateNew A\<close>
	+ have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg (sub 0 (Fun ?i []) p) # z')\<close>
	+ using DeltaExi * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg (sub 0 (Fun ?i []) p)]) @ z')\<close>
	+ by simp
	+ moreover have \<open>set (subtermFm (sub 0 (Fun ?i []) p)) \<subseteq> set ?A\<close>
	+ using DeltaExi unfolding parts_def by simp
	+ then have \<open>params (sub 0 (Fun ?i []) p) \<subseteq> paramsts ?A\<close>
	+ using subtermFm_subset_params by blast
	+ ultimately have \<open>\<tturnstile> pre @ Neg (sub 0 (Fun ?i []) p) # z\<close>
	+ using DeltaExi ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp
	+ then have \<open>\<tturnstile> Neg (sub 0 (Fun ?i []) p) # pre @ z\<close>
	+ using Ext by simp
	+ moreover have \<open>?i \<notin> paramsts A\<close>
	+ by (induct A) (metis Suc_max_new generateNew_def listFunTm_paramst(2) plus_1_eq_Suc)+
	+ then have \<open>news ?i (p # pre @ z)\<close>
	+ using DeltaExi Cons.prems(2) news_paramss by auto
	+ ultimately have \<open>\<tturnstile> Neg (Exi p) # pre @ z\<close>
	+ using SeCaV.DeltaExi by blast
	+ then show ?thesis
	+ using DeltaExi Ext by simp
	+ next
	+ case (NegNeg p)
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # z')\<close>
	+ using * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
	+ by simp
	+ then have \<open>\<tturnstile> pre @ p # z\<close>
	+ using NegNeg ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp
	+ then have \<open>\<tturnstile> p # pre @ z\<close>
	+ using Ext by simp
	+ then have \<open>\<tturnstile> Neg (Neg p) # pre @ z\<close>
	+ using SeCaV.Neg by blast
	+ then show ?thesis
	+ using NegNeg Ext by simp
	+ next
	+ case (GammaExi p)
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Exi p # map (\<lambda>t. sub 0 t p) A @ z')\<close>
	+ using * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> ((pre @ Exi p # map (\<lambda>t. sub 0 t p) A) @ z'))\<close>
	+ by simp
	+ moreover have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts A \<union> params p\<close>
	+ using params_sub by fastforce
	+ then have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts ?A\<close>
	+ using GammaExi A by fastforce
	+ then have \<open>paramss (map (\<lambda>t. sub 0 t p) A) \<subseteq> paramsts ?A\<close>
	+ by auto
	+ ultimately have \<open>\<tturnstile> pre @ Exi p # map (\<lambda>t. sub 0 t p) A @ z\<close>
	+ using GammaExi ih[where pre=\<open>pre @ Exi p # map _ A\<close> and A=\<open>?A\<close>] A by simp
	+ moreover have \<open>ext (map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z)
	+ (pre @ Exi p # map (\<lambda>t. sub 0 t p) A @ z)\<close>
	+ by auto
	+ ultimately have \<open>\<tturnstile> map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z\<close>
	+ using Ext by blast
	+ then have \<open>\<tturnstile> Exi p # pre @ z\<close>
	+ proof (induct A)
	+ case Nil
	+ then show ?case
	+ by simp
	+ next
	+ case (Cons a A)
	+ then have \<open>\<tturnstile> Exi p # map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z\<close>
	+ using SeCaV.GammaExi by simp
	+ then have \<open>\<tturnstile> map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z\<close>
	+ using Ext by simp
	+ then show ?case
	+ using Cons.hyps by blast
	+ qed
	+ then show ?thesis
	+ using GammaExi Ext by simp
	+ next
	+ case (GammaUni p)
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ z')\<close>
	+ using * unfolding parts_def by simp
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> ((pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A) @ z'))\<close>
	+ by simp
	+ moreover have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts A \<union> params p\<close>
	+ using params_sub by fastforce
	+ then have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts ?A\<close>
	+ using GammaUni A by fastforce
	+ then have \<open>paramss (map (\<lambda>t. sub 0 t p) A) \<subseteq> paramsts ?A\<close>
	+ by auto
	+ ultimately have \<open>\<tturnstile> pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ z\<close>
	+ using GammaUni ih[where pre=\<open>pre @ Neg (Uni p) # map _ A\<close> and A=\<open>?A\<close>] A by simp
	+ moreover have \<open>ext (map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z)
	+ (pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ z)\<close>
	+ by auto
	+ ultimately have \<open>\<tturnstile> map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z\<close>
	+ using Ext by blast
	+ then have \<open>\<tturnstile> Neg (Uni p) # pre @ z\<close>
	+ proof (induct A)
	+ case Nil
	+ then show ?case
	+ by simp
	+ next
	+ case (Cons a A)
	+ then have \<open>\<tturnstile> Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z\<close>
	+ using SeCaV.GammaUni by simp
	+ then have \<open>\<tturnstile> map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z\<close>
	+ using Ext by simp
	+ then show ?case
	+ using Cons.hyps by blast
	+ qed
	+ then show ?thesis
	+ using GammaUni Ext by simp
	+ next
	+ case Other
	+ then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
	+ using * by simp
	+ then show ?thesis
	+ using ih[where pre=\<open>pre @ [p]\<close> and A=\<open>?A\<close>] A by simp
	+ qed
	+qed
	+
	+text \<open>As a special case, the prefix can be empty.\<close>
	+corollary SeCaV_children:
	+ assumes \<open>\<forall>z' \<in> set (children A r z). (\<tturnstile> z')\<close> and \<open>paramss z \<subseteq> paramsts A\<close>
	+ shows \<open>\<tturnstile> z\<close>
	+ using SeCaV_children_pre assms by (metis append_Nil)
	+
	+text \<open>Using this lemma, we can instantiate the abstract soundness framework.\<close>
	+interpretation Soundness eff rules UNIV \<open>\<lambda>_ (A, z). (\<tturnstile> z)\<close>
	+ unfolding Soundness_def
	+proof safe
	+ fix r A z ss S
	+ assume r_enabled: \<open>eff r (A, z) ss\<close>
	+
	+ assume \<open>\<forall>s'. s' \|\<in>\| ss \<longrightarrow> (\<forall>S \<in> UNIV. case s' of (A, z) \<Rightarrow> \<tturnstile> z)\<close>
	+ then have next_sound: \<open>\<forall>B z. (B, z) \|\<in>\| ss \<longrightarrow> (\<tturnstile> z)\<close>
	+ by simp
	+
	+ show \<open>\<tturnstile> z\<close>
	+ proof (cases \<open>branchDone z\<close>)
	+ case True
	+ then obtain p where \<open>p \<in> set z\<close> \<open>Neg p \<in> set z\<close>
	+ using branchDone_contradiction by blast
	+ then show ?thesis
	+ using Ext Basic by fastforce
	+ next
	+ case False
	+ let ?A = \<open>remdups (A @ subtermFms z)\<close>
	+ have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> z')\<close>
	+ using False r_enabled eff_children next_sound by blast
	+ moreover have \<open>set (subtermFms z) \<subseteq> set ?A\<close>
	+ by simp
	+ then have \<open>paramss z \<subseteq> paramsts ?A\<close>
	+ using subtermFm_subset_params by fastforce
	+ ultimately show \<open>\<tturnstile> z\<close>
	+ using SeCaV_children by blast
	+ qed
	+qed
	+
	+text \<open>Using the result from the abstract soundness framework, we can finally state our soundness
	+ result: for a finite, well-formed proof tree, the sequent at the root of the tree is provable in
	+ the SeCaV proof system.\<close>
	+theorem prover_soundness_SeCaV:
	+ assumes \<open>tfinite t\<close> and \<open>wf t\<close>
	+ shows \<open>\<tturnstile> rootSequent t\<close>
	+ using assms soundness by fastforce
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/Usemantics.thy b/thys/FOL_Seq_Calc2/Usemantics.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/Usemantics.thy
	@@ -0,0 +1,94 @@
	+section \<open>Bounded semantics\<close>
	+
	+theory Usemantics imports SeCaV begin
	+
	+text \<open>In this theory, we define an alternative semantics for SeCaV formulas where the quantifiers
	+ are bounded to terms in a specific set.
	+ This is needed to construct a countermodel from a Hintikka set.\<close>
	+
	+text \<open>This function defines the semantics, which are bounded by the set \<open>u\<close>.\<close>
	+primrec usemantics where
	+ \<open>usemantics u e f g (Pre i l) = g i (semantics_list e f l)\<close>
	+\| \<open>usemantics u e f g (Imp p q) = (usemantics u e f g p \<longrightarrow> usemantics u e f g q)\<close>
	+\| \<open>usemantics u e f g (Dis p q) = (usemantics u e f g p \<or> usemantics u e f g q)\<close>
	+\| \<open>usemantics u e f g (Con p q) = (usemantics u e f g p \<and> usemantics u e f g q)\<close>
	+\| \<open>usemantics u e f g (Exi p) = (\<exists>x \<in> u. usemantics u (SeCaV.shift e 0 x) f g p)\<close>
	+\| \<open>usemantics u e f g (Uni p) = (\<forall>x \<in> u. usemantics u (SeCaV.shift e 0 x) f g p)\<close>
	+\| \<open>usemantics u e f g (Neg p) = (\<not> usemantics u e f g p)\<close>
	+
	+text \<open>An environment is well-formed if the variables are actually in the quantifier set \<open>u\<close>.\<close>
	+definition is_env :: \<open>'a set \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool\<close> where
	+ \<open>is_env u e \<equiv> \<forall>n. e n \<in> u\<close>
	+
	+text \<open>A function interpretation is well-formed if it is closed in the quantifier set \<open>u\<close>.\<close>
	+definition is_fdenot :: \<open>'a set \<Rightarrow> (nat \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> bool\<close> where
	+ \<open>is_fdenot u f \<equiv> \<forall>i l. list_all (\<lambda>x. x \<in> u) l \<longrightarrow> f i l \<in> u\<close>
	+
	+text \<open>If we choose to quantify over the universal set, we obtain the usual semantics\<close>
	+lemma usemantics_UNIV: \<open>usemantics UNIV e f g p \<longleftrightarrow> semantics e f g p\<close>
	+ by (induct p arbitrary: e) auto
	+
	+text \<open>If a function name \<open>n\<close> is not in a formula, it does not matter whether it is in
	+ the function interpretation or not.\<close>
	+lemma uupd_lemma [iff]: \<open>n \<notin> params p \<Longrightarrow> usemantics u e (f(n := x)) g p \<longleftrightarrow> usemantics u e f g p\<close>
	+ by (induct p arbitrary: e) simp_all
	+
	+text \<open>The semantics of substituting variable i by term t in formula a are well-defined\<close>
	+lemma usubst_lemma [iff]:
	+ \<open>usemantics u e f g (subst a t i) \<longleftrightarrow> usemantics u (SeCaV.shift e i (semantics_term e f t)) f g a\<close>
	+ by (induct a arbitrary: e i t) simp_all
	+
	+subsubsection \<open>Soundness of SeCaV with regards to the bounded semantics\<close>
	+text \<open>We would like to prove that the SeCaV proof system is sound under the bounded semantics.\<close>
	+
	+text \<open>If the environment and the function interpretation are well-formed, the semantics of terms
	+ are in the quantifier set \<open>u\<close>.\<close>
	+lemma usemantics_term [simp]:
	+ assumes \<open>is_env u e\<close> \<open>is_fdenot u f\<close>
	+ shows \<open>semantics_term e f t \<in> u\<close> \<open>list_all (\<lambda>x. x \<in> u) (semantics_list e f ts)\<close>
	+ using assms by (induct t and ts rule: semantics_term.induct semantics_list.induct)
	+ (simp_all add: is_env_def is_fdenot_def)
	+
	+text \<open>If a function interpretation is well-formed, replacing the value by one in the quantifier set
	+ results in a well-formed function interpretation.\<close>
	+lemma is_fdenot_shift [simp]: \<open>is_fdenot u f \<Longrightarrow> x \<in> u \<Longrightarrow> is_fdenot u (f(i := \<lambda>_. x))\<close>
	+ unfolding is_fdenot_def SeCaV.shift_def by simp
	+
	+text \<open>If a sequent is provable in the SeCaV proof system and the environment
	+ and function interpretation are well-formed, the sequent is valid under the bounded semantics.\<close>
	+theorem sound_usemantics:
	+ assumes \<open>\<tturnstile> z\<close> and \<open>is_env u e\<close> and \<open>is_fdenot u f\<close>
	+ shows \<open>\<exists>p \<in> set z. usemantics u e f g p\<close>
	+ using assms
	+proof (induct arbitrary: f rule: sequent_calculus.induct)
	+ case (10 i p z)
	+ then show ?case
	+ proof (cases \<open>\<forall>x \<in> u. usemantics u e (f(i := \<lambda>_. x)) g (sub 0 (Fun i []) p)\<close>)
	+ case False
	+ moreover have \<open>\<forall>x \<in> u. \<exists>p \<in> set (sub 0 (Fun i []) p # z). usemantics u e (f(i := \<lambda>_. x)) g p\<close>
	+ using 10 is_fdenot_shift by metis
	+ ultimately have \<open>\<exists>x \<in> u. \<exists>p \<in> set z. usemantics u e (f(i := \<lambda>_. x)) g p\<close>
	+ by fastforce
	+ moreover have \<open>list_all (\<lambda>p. i \<notin> params p) z\<close>
	+ using 10 by simp
	+ ultimately show ?thesis
	+ using 10 Ball_set insert_iff list.set(2) uupd_lemma by metis
	+ qed simp
	+next
	+ case (11 i p z)
	+ then show ?case
	+ proof (cases \<open>\<forall>x \<in> u. usemantics u e (f(i := \<lambda>_. x)) g (Neg (sub 0 (Fun i []) p))\<close>)
	+ case False
	+ moreover have
	+ \<open>\<forall>x \<in> u. \<exists>p \<in> set (Neg (sub 0 (Fun i []) p) # z). usemantics u e (f(i := \<lambda>_. x)) g p\<close>
	+ using 11 is_fdenot_shift by metis
	+ ultimately have \<open>\<exists>x \<in> u. \<exists>p \<in> set z. usemantics u e (f(i := \<lambda>_. x)) g p\<close>
	+ by fastforce
	+ moreover have \<open>list_all (\<lambda>p. i \<notin> params p) z\<close>
	+ using 11 by simp
	+ ultimately show ?thesis
	+ using 11 Ball_set insert_iff list.set(2) uupd_lemma by metis
	+ qed simp
	+qed fastforce+
	+
	+end
	diff --git a/thys/FOL_Seq_Calc2/document/root.tex b/thys/FOL_Seq_Calc2/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/document/root.tex
	@@ -0,0 +1,68 @@
	+\documentclass[11pt,a4paper]{report}
	+\usepackage{isabelle,isabellesym}
	+
	+% further packages required for unusual symbols (see also
	+% isabellesym.sty), use only when needed
	+
	+\usepackage{amssymb}
	+ %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
	+ %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
	+ %\<triangleq>, \<yen>, \<lozenge>
	+
	+%\usepackage{eurosym}
	+ %for \<euro>
	+
	+%\usepackage[only,bigsqcap]{stmaryrd}
	+ %for \<Sqinter>
	+
	+%\usepackage{eufrak}
	+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
	+
	+%\usepackage{textcomp}
	+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	+ %\<currency>
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+% for uniform font size
	+%\renewcommand{\isastyle}{\isastyleminor}
	+
	+
	+\begin{document}
	+
	+\title{A Sequent Calculus Prover for First-Order Logic with Functions}
	+\author{Asta Halkjær From \and Frederik Krogsdal Jacobsen}
	+\maketitle
	+
	+\begin{abstract}
	+ We formalize an automated theorem prover for first-order logic with functions.
	+ The proof search procedure is based on sequent calculus and we verify its soundness and completeness using the Abstract Soundness and Abstract Completeness theories.
	+ Our analytic completeness proof covers both open and closed formulas.
	+ Since our deterministic prover considers only the subset of terms relevant to proving a given sequent, we do so as well when building a countermodel from a failed proof.
	+ We formally connect our prover with the proof system and semantics of the existing SeCaV system.
	+ In particular, the prover's output can be post-processed in Haskell to generate human-readable SeCaV proofs which are also machine-verifiable proof certificates.
	+\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/FOL_Seq_Calc2/haskell/app/Main.hs b/thys/FOL_Seq_Calc2/haskell/app/Main.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/app/Main.hs
	@@ -0,0 +1,67 @@
	+module Main where
	+
	+import Options.Applicative
	+ ( optional,
	+ (<**>),
	+ argument,
	+ fullDesc,
	+ header,
	+ help,
	+ info,
	+ long,
	+ metavar,
	+ progDesc,
	+ short,
	+ str,
	+ strOption,
	+ execParser,
	+ helper,
	+ Parser )
	+import ProofExtractor
	+ ( expandMultiRules, removeNoopRules, extSurgery, initExtract )
	+import Prover ( secavProverCode )
	+import SeCaVTranslator ( genInit )
	+import ShortParser ( programParser, sequentParser )
	+import System.FilePath (takeBaseName)
	+import Unshortener (genFile)
	+
	+data Arguments = Arguments
	+ { formula :: String
	+ , isabelle :: Maybe String
	+ }
	+
	+arguments :: Parser Arguments
	+arguments = Arguments
	+ <$> argument str (metavar "FORMULA" <> help "Formula to attempt to prove")
	+ <*> optional (strOption
	+ $ long "isabelle"
	+ <> short 'i'
	+ <> metavar "FILENAME"
	+ <> help "Output an Isabelle proof in FILENAME")
	+
	+main :: IO ()
	+main = run =<< execParser opts
	+ where
	+ opts = info (arguments <**> helper)
	+ ( fullDesc
	+ <> progDesc "Attempt to prove the first-order formula FORMULA"
	+ <> header "secav-prover - a prover for SeCaV" )
	+
	+run :: Arguments -> IO ()
	+run (Arguments f i) =
	+ case sequentParser f of
	+ Left e -> print e
	+ Right s ->
	+ let (formulas, names) = genInit s in
	+ let proofTree = secavProverCode formulas in
	+ let shortProof = initExtract names $ removeNoopRules $ extSurgery $ removeNoopRules $ expandMultiRules proofTree in
	+ case i of
	+ Just file ->
	+ let parse = programParser shortProof in
	+ case parse of
	+ Left e -> print e
	+ Right ast ->
	+ let isabelleProof = genFile (takeBaseName file) ast in
	+ writeFile file isabelleProof
	+ Nothing ->
	+ putStrLn shortProof
	diff --git a/thys/FOL_Seq_Calc2/haskell/lib/ProofExtractor.hs b/thys/FOL_Seq_Calc2/haskell/lib/ProofExtractor.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/lib/ProofExtractor.hs
	@@ -0,0 +1,423 @@
	+{-# LANGUAGE FlexibleInstances #-}
	+
	+module ProofExtractor where
	+
	+import Arith ( Nat(Nat), zero_nat )
	+import qualified Data.Bimap as Map
	+import Control.Monad.State (evalState, get, modify)
	+import Data.List (genericReplicate, intercalate)
	+import FSet ( Fset(Abs_fset) )
	+import Prover ( Rule(..), Tree(..), generateNew)
	+import ProverInstances()
	+import SeCaV ( Fm(..), Tm(..), sub )
	+import Set ( Set(Set, Coset) )
	+import ShortAST (funCount, NameGen, NameState(existingFuns, existingPres) )
	+
	+-- These are the "real" rules of SeCaV that we want to end up with
	+data SeCaVRule
	+ = RBasic
	+ \| RAlphaDis
	+ \| RAlphaImp
	+ \| RAlphaCon
	+ \| RBetaCon
	+ \| RBetaImp
	+ \| RBetaDis
	+ \| RGammaExi Tm
	+ \| RGammaUni Tm
	+ \| RDeltaUni
	+ \| RDeltaExi
	+ \| RNeg
	+ \| RExt
	+ deriving (Show)
	+
	+instance Show (Set (Tree ([Fm], SeCaVRule))) where
	+ show (Set s) = show s
	+ show (Coset s) = show s
	+
	+instance Show (Fset (Tree ([Fm], SeCaVRule))) where
	+ show (Abs_fset s) = show s
	+
	+instance Show (Tree ([Fm], SeCaVRule)) where
	+ show (Node (fs, r) t) = show fs <> " " <> show r <> "\n" <> show t
	+
	+-- These functions get every first and every second element of a list, respectively
	+-- They are used to split the cartesian product of branches from Beta rules into binary trees
	+first :: [a] -> [a]
	+first [] = []
	+first (x : xs) = x : second xs
	+
	+second :: [a] -> [a]
	+second [] = []
	+second (_ : xs) = first xs
	+
	+-- Expansion of the alpha, delta, and double negation elimination rules
	+expandAlphaDelta :: Tree (([Tm], [Fm]), Rule) -> Int -> Tree ([Fm], SeCaVRule)
	+expandAlphaDelta (Node ((terms, f : fs), rule) (Abs_fset (Set [current]))) n =
	+ let (srule, applied) = case (rule, f) of
	+ (AlphaDis, Dis p q) -> (RAlphaDis, [p, q])
	+ (AlphaCon, Neg (Con p q)) -> (RAlphaCon, [Neg p, Neg q])
	+ (AlphaImp, Imp p q) -> (RAlphaImp, [Neg p, q])
	+ (NegNeg, Neg (Neg p)) -> (RNeg, [p])
	+ (DeltaUni, Uni p) -> (RDeltaUni, [SeCaV.sub Arith.zero_nat (SeCaV.Fun (generateNew terms) []) p])
	+ (DeltaExi, Neg (Exi p)) -> (RDeltaExi, [Neg (SeCaV.sub Arith.zero_nat (SeCaV.Fun (generateNew terms) []) p)])
	+ (AlphaDis, x) -> (RAlphaDis, [x])
	+ (AlphaCon, x) -> (RAlphaCon, [x])
	+ (AlphaImp, x) -> (RAlphaImp, [x])
	+ (DeltaUni, x) -> (RDeltaUni, [x])
	+ (DeltaExi, x) -> (RDeltaExi, [x])
	+ (NegNeg, x) -> (RNeg, [x])
	+ _ -> error "expandAlphaDelta must only be called on Alpha, Neg or Delta rules." in
	+ let extRule = if n == 1
	+ then Node (applied ++ fs, RExt) (Abs_fset (Set [expandMultiRules current]))
	+ else Node (applied ++ fs, RExt) (Abs_fset (Set [expandAlphaDelta (Node ((terms, fs ++ applied), rule) (Abs_fset (Set [current]))) (n - 1)])) in
	+ Node (f : fs, srule) (Abs_fset (Set [extRule]))
	+expandAlphaDelta (Node ((_, []), _) _) _ = error "The sequent must never be empty."
	+expandAlphaDelta (Node ((_, _), _) (Abs_fset (Coset _))) _ = error "The proof tree must not include cosets."
	+expandAlphaDelta (Node ((_, _), _) (Abs_fset (Set _))) _ = error "Alpha, Neg, and Delta rules must produce exactly one branch."
	+
	+betaNonRuleN :: Rule -> Fm -> [Fm] -> [Tm] -> [Tree (([Tm], [Fm]), Rule)] -> Int -> Tree ([Fm], SeCaVRule)
	+betaNonRuleN rule f fs terms rest n = Node (f : fs, RExt) (Abs_fset (Set [expandBeta (Node ((terms, fs ++ [f]), rule) (Abs_fset (Set rest))) (n - 1)]))
	+
	+betaRuleN :: Rule -> Fm -> [Fm] -> [Tm] -> [Tree (([Tm], [Fm]), Rule)] -> Int -> Tree ([Fm], SeCaVRule)
	+betaRuleN rule f fs terms branches n = Node (f : fs, RExt) (Abs_fset (Set [expandBeta (Node ((terms, fs ++ [f]), rule) (Abs_fset (Set branches))) (n - 1)]))
	+
	+betaRule1 :: Fm -> [Fm] -> Tree (([Tm], [Fm]), Rule) -> Tree ([Fm], SeCaVRule)
	+betaRule1 f fs branch = Node (f : fs, RExt) (Abs_fset (Set [expandMultiRules branch]))
	+
	+-- Expansion of BetaCon rule
	+-- The prover creates the product of all beta rules as branches, so we need to reassemble the branches into a binary tree
	+expandBeta :: Tree (([Tm], [Fm]), Rule) -> Int -> Tree ([Fm], SeCaVRule)
	+expandBeta (Node ((_, Con p q : fs), BetaCon) (Abs_fset (Set [b1, b2]))) 1 =
	+ let branch1 = betaRule1 p fs b1 in
	+ let branch2 = betaRule1 q fs b2 in
	+ Node (Con p q : fs, RBetaCon) (Abs_fset (Set [branch1, branch2]))
	+expandBeta (Node ((_, Neg (Imp p q) : fs), BetaImp) (Abs_fset (Set [b1, b2]))) 1 =
	+ let branch1 = betaRule1 p fs b1 in
	+ let branch2 = betaRule1 (Neg q) fs b2 in
	+ Node (Neg (Imp p q) : fs, RBetaImp) (Abs_fset (Set [branch1, branch2]))
	+expandBeta (Node ((_, Neg (Dis p q) : fs), BetaDis) (Abs_fset (Set [b1, b2]))) 1 =
	+ let branch1 = betaRule1 (Neg p) fs b1 in
	+ let branch2 = betaRule1 (Neg q) fs b2 in
	+ Node (Neg (Dis p q) : fs, RBetaDis) (Abs_fset (Set [branch1, branch2]))
	+expandBeta (Node ((_, f : fs), BetaCon) (Abs_fset (Set [current]))) 1 =
	+ let extRule = Node (f : fs, RExt) (Abs_fset (Set [expandMultiRules current])) in
	+ Node (f : fs, RBetaCon) (Abs_fset (Set [extRule]))
	+expandBeta (Node ((_, f : fs), BetaImp) (Abs_fset (Set [current]))) 1 =
	+ let extRule = Node (f : fs, RExt) (Abs_fset (Set [expandMultiRules current])) in
	+ Node (f : fs, RBetaImp) (Abs_fset (Set [extRule]))
	+expandBeta (Node ((_, f : fs), BetaDis) (Abs_fset (Set [current]))) 1 =
	+ let extRule = Node (f : fs, RExt) (Abs_fset (Set [expandMultiRules current])) in
	+ Node (f : fs, RBetaDis) (Abs_fset (Set [extRule]))
	+expandBeta (Node ((terms, Con p q : fs), BetaCon) (Abs_fset (Set branches))) n =
	+ let branch1 = betaRuleN BetaCon p fs terms (first branches) n in
	+ let branch2 = betaRuleN BetaImp q fs terms (second branches) n in
	+ Node (Con p q : fs, RBetaCon) (Abs_fset (Set [branch1, branch2]))
	+expandBeta (Node ((terms, Neg (Imp p q) : fs), BetaImp) (Abs_fset (Set branches))) n =
	+ let branch1 = betaRuleN BetaImp p fs terms (first branches) n in
	+ let branch2 = betaRuleN BetaImp (Neg q) fs terms (second branches) n in
	+ Node (Neg (Imp p q) : fs, RBetaImp) (Abs_fset (Set [branch1, branch2]))
	+expandBeta (Node ((terms, Neg (Dis p q) : fs), BetaDis) (Abs_fset (Set branches))) n =
	+ let branch1 = betaRuleN BetaDis (Neg p) fs terms (first branches) n in
	+ let branch2 = betaRuleN BetaDis (Neg q) fs terms (second branches) n in
	+ Node (Neg (Dis p q) : fs, RBetaDis) (Abs_fset (Set [branch1, branch2]))
	+expandBeta (Node ((terms, f : fs), BetaCon) (Abs_fset (Set rest))) n =
	+ let extRule = betaNonRuleN BetaCon f fs terms rest n in
	+ Node (f : fs, RBetaCon) (Abs_fset (Set [extRule]))
	+expandBeta (Node ((terms, f : fs), BetaImp) (Abs_fset (Set rest))) n =
	+ let extRule = betaNonRuleN BetaImp f fs terms rest n in
	+ Node (f : fs, RBetaImp) (Abs_fset (Set [extRule]))
	+expandBeta (Node ((terms, f : fs), BetaDis) (Abs_fset (Set rest))) n =
	+ let extRule = betaNonRuleN BetaDis f fs terms rest n in
	+ Node (f : fs, RBetaDis) (Abs_fset (Set [extRule]))
	+expandBeta (Node ((_, []), _) _) _ = error "The sequent must never be empty."
	+expandBeta (Node ((_, _), _) (Abs_fset (Coset _))) _ = error "The proof tree must not include cosets."
	+expandBeta (Node ((_, _), _) (Abs_fset (Set []))) _ = error "Beta rules must always produce at least one branch."
	+expandBeta (Node ((_, _), _) (Abs_fset (Set [_]))) _ = error "expandBeta must only be called on Beta rules."
	+expandBeta (Node ((_, _), _) (Abs_fset (Set [_, _]))) _ = error "expandBeta must only be called on Beta rules."
	+expandBeta (Node ((_, _), _) (Abs_fset (Set (_ : _ : _ : _)))) _ = error "Beta must never produce more than two branches."
	+
	+-- Expansion of GammaExi rule
	+-- Here we have a counter for the sequent formulas (ns) and a counter for the terms (nt) since we need to instantiate each formula with each term
	+expandGammaExi :: Tree (([Tm], [Fm]), Rule) -> Int -> Int -> Tree ([Fm], SeCaVRule)
	+expandGammaExi (Node ((t : _, Exi p : fs), GammaExi) (Abs_fset (Set [current]))) 1 1 =
	+ let applied = SeCaV.sub Arith.zero_nat t p in
	+ let extRule = Node (applied : Exi p : fs, RExt) (Abs_fset (Set [expandMultiRules current])) in
	+ let gammaRule = Node (Exi p : Exi p : fs, RGammaExi t) (Abs_fset (Set [extRule])) in
	+ Node (Exi p : fs, RExt) (Abs_fset (Set [gammaRule]))
	+expandGammaExi (Node ((t : ts, Exi p : fs), GammaExi) (Abs_fset (Set [current]))) ns 1 =
	+ let applied = SeCaV.sub Arith.zero_nat t p in
	+ let extRule = Node (applied : Exi p : fs, RExt) (Abs_fset (Set [expandGammaExi (Node ((ts ++ [t], fs ++ [applied, Exi p]), GammaExi) (Abs_fset (Set [current]))) (ns - 1) (length (t : ts))])) in
	+ let gammaRule = Node (Exi p : Exi p : fs, RGammaExi t) (Abs_fset (Set [extRule])) in
	+ Node (Exi p : fs, RExt) (Abs_fset (Set [gammaRule]))
	+expandGammaExi (Node ((t : ts, Exi p : fs), GammaExi) (Abs_fset (Set [current]))) ns nt =
	+ let applied = SeCaV.sub Arith.zero_nat t p in
	+ let extRule = Node (applied : Exi p : fs, RExt) (Abs_fset (Set [expandGammaExi (Node ((ts ++ [t], Exi p : fs ++ [applied]), GammaExi) (Abs_fset (Set [current]))) ns (nt - 1)])) in
	+ let gammaRule = Node (Exi p : Exi p : fs, RGammaExi t) (Abs_fset (Set [extRule])) in
	+ Node (Exi p : fs, RExt) (Abs_fset (Set [gammaRule]))
	+expandGammaExi (Node ((t : _, f : fs), GammaExi) (Abs_fset (Set [current]))) 1 _ =
	+ let extRule = Node (f : fs, RExt) (Abs_fset (Set [expandMultiRules current])) in
	+ Node (f : fs, RGammaExi t) (Abs_fset (Set [extRule]))
	+expandGammaExi (Node ((t : ts, f : fs), GammaExi) (Abs_fset (Set [current]))) ns nt =
	+ let extRule = Node (f : fs, RExt) (Abs_fset (Set [expandGammaExi (Node ((t : ts, fs ++ [f]), GammaExi) (Abs_fset (Set [current]))) (ns - 1) nt])) in
	+ Node (f : fs, RGammaExi t) (Abs_fset (Set [extRule]))
	+expandGammaExi (Node ((_, []), _) _) _ _ = error "The sequent must never be empty."
	+expandGammaExi (Node ((_, _), _) (Abs_fset (Coset _))) _ _ = error "The proof tree must not include cosets."
	+expandGammaExi (Node ((_, _), _) (Abs_fset (Set [_]))) _ _ = error "expandGammaExi must only be called on GammaExi rules."
	+expandGammaExi (Node ((_, _), _) (Abs_fset (Set []))) _ _ = error "GammaExi rules must produce exactly one branch."
	+expandGammaExi (Node ((_, _), _) (Abs_fset (Set (_ : _ : _)))) _ _ = error "GammaExi rules must produce exactly one branch."
	+
	+-- Expansion of GammaUni rule
	+-- Here we have a counter for the sequent formulas (ns) and a counter for the terms (nt) since we need to instantiate each formula with each term
	+expandGammaUni :: Tree (([Tm], [Fm]), Rule) -> Int -> Int -> Tree ([Fm], SeCaVRule)
	+expandGammaUni (Node ((t : _, Neg (Uni p) : fs), GammaUni) (Abs_fset (Set [current]))) 1 1 =
	+ let applied = Neg (SeCaV.sub Arith.zero_nat t p) in
	+ let extRule = Node (applied : Neg (Uni p) : fs, RExt) (Abs_fset (Set [expandMultiRules current])) in
	+ let gammaRule = Node (Neg (Uni p) : Neg (Uni p) : fs, RGammaUni t) (Abs_fset (Set [extRule])) in
	+ Node (Neg (Uni p) : fs, RExt) (Abs_fset (Set [gammaRule]))
	+expandGammaUni (Node ((t : ts, Neg (Uni p) : fs), GammaUni) (Abs_fset (Set [current]))) ns 1 =
	+ let applied = Neg (SeCaV.sub Arith.zero_nat t p) in
	+ let extRule = Node (applied : Neg (Uni p) : fs, RExt) (Abs_fset (Set [expandGammaUni (Node ((ts ++ [t], fs ++ [applied, Neg (Uni p)]), GammaUni) (Abs_fset (Set [current]))) (ns - 1) (length (t : ts))])) in
	+ let gammaRule = Node (Neg (Uni p) : Neg (Uni p) : fs, RGammaUni t) (Abs_fset (Set [extRule])) in
	+ Node (Neg (Uni p) : fs, RExt) (Abs_fset (Set [gammaRule]))
	+expandGammaUni (Node ((t : ts, Neg (Uni p) : fs), GammaUni) (Abs_fset (Set [current]))) ns nt =
	+ let applied = Neg (SeCaV.sub Arith.zero_nat t p) in
	+ let extRule = Node (applied : Neg (Uni p) : fs, RExt) (Abs_fset (Set [expandGammaUni (Node ((ts ++ [t], Neg (Uni p) : fs ++ [applied]), GammaUni) (Abs_fset (Set [current]))) ns (nt - 1)])) in
	+ let gammaRule = Node (Neg (Uni p) : Neg (Uni p) : fs, RGammaUni t) (Abs_fset (Set [extRule])) in
	+ Node (Neg (Uni p) : fs, RExt) (Abs_fset (Set [gammaRule]))
	+expandGammaUni (Node ((t : _, f : fs), GammaUni) (Abs_fset (Set [current]))) 1 _ =
	+ let extRule = Node (f : fs, RExt) (Abs_fset (Set [expandMultiRules current])) in
	+ Node (f : fs, RGammaUni t) (Abs_fset (Set [extRule]))
	+expandGammaUni (Node ((t : ts, f : fs), GammaUni) (Abs_fset (Set [current]))) ns nt =
	+ let extRule = Node (f : fs, RExt) (Abs_fset (Set [expandGammaUni (Node ((t : ts, fs ++ [f]), GammaUni) (Abs_fset (Set [current]))) (ns - 1) nt])) in
	+ Node (f : fs, RGammaUni t) (Abs_fset (Set [extRule]))
	+expandGammaUni (Node ((_, []), _) _) _ _ = error "The sequent must never be empty."
	+expandGammaUni (Node ((_, _), _) (Abs_fset (Coset _))) _ _ = error "The proof tree must not include cosets."
	+expandGammaUni (Node ((_, _), _) (Abs_fset (Set [_]))) _ _ = error "expandGammaUni must only be called on GammaUni rules."
	+expandGammaUni (Node ((_, _), _) (Abs_fset (Set []))) _ _ = error "GammaUni rules must produce exactly one branch."
	+expandGammaUni (Node ((_, _), _) (Abs_fset (Set (_ : _ : _)))) _ _ = error "GammaUni rules must produce exactly one branch."
	+
	+-- This function moves the positive part of a Basic pair in the front of the sequent to allow the Basic rule to be applied
	+-- WARNING: This will loop forever if there is no Basic pair (P and Neg P) in the sequent
	+sortSequent :: [Fm] -> [Fm]
	+sortSequent [] = []
	+sortSequent (x : xs) = if Neg x `elem` xs then x : xs else sortSequent (xs ++ [x])
	+
	+-- This adds an Ext rule to move the Basic pair in position, then a Basic rule to end a branch
	+addBasicRule :: Tree (([Tm], [Fm]), Rule) -> Tree ([Fm], SeCaVRule)
	+addBasicRule (Node ((_, sequent), _) (Abs_fset (Set []))) =
	+ let basicRule = Node (sortSequent sequent, RBasic) (Abs_fset (Set [])) in
	+ Node (sequent, RExt) (Abs_fset (Set [basicRule]))
	+addBasicRule (Node ((_, _), _) (Abs_fset (Coset _))) = error "The proof tree must not include cosets."
	+addBasicRule (Node ((_, _), _) (Abs_fset (Set _))) = error "Basic rules must only be used to close branches."
	+
	+-- This function takes the rules from the prover and expands them into separate SeCaV applications for each formula in the sequent with Ext's in between
	+-- Gamma rules are expanded for each formula and for each term
	+-- Note that after this function, rules are still applied to all formulas, even those that do not fit the rule
	+expandMultiRules :: Tree (([Tm], [Fm]), Rule) -> Tree ([Fm], SeCaVRule)
	+expandMultiRules node@(Node _ (Abs_fset (Set []))) = addBasicRule node
	+expandMultiRules node@(Node ((_, sequent), AlphaDis) _) = expandAlphaDelta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), AlphaCon) _) = expandAlphaDelta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), AlphaImp) _) = expandAlphaDelta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), NegNeg) _) = expandAlphaDelta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), BetaCon) _) = expandBeta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), BetaImp) _) = expandBeta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), BetaDis) _) = expandBeta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), DeltaUni) _) = expandAlphaDelta node (length sequent)
	+expandMultiRules node@(Node ((_, sequent), DeltaExi) _) = expandAlphaDelta node (length sequent)
	+expandMultiRules node@(Node ((terms, sequent), GammaExi) _) = expandGammaExi node (length sequent) (length terms)
	+expandMultiRules node@(Node ((terms, sequent), GammaUni) _) = expandGammaUni node (length sequent) (length terms)
	+
	+-- This function removes all rule applications that do nothing (which includes all wrong rule applications)
	+-- It should be called both before and after the extSurgery function to be sure to remove all extraneous Ext rules
	+removeNoopRules :: Tree ([Fm], SeCaVRule) -> Tree ([Fm], SeCaVRule)
	+removeNoopRules node@(Node (_, _) (Abs_fset (Set []))) = node
	+removeNoopRules (Node (s1, r1) (Abs_fset (Set [Node (s2, r2) (Abs_fset (Set rest))]))) =
	+ if s1 == s2
	+ then removeNoopRules (Node (s2, r2) (Abs_fset (Set rest)))
	+ else Node (s1, r1) (Abs_fset (Set [removeNoopRules (Node (s2, r2) (Abs_fset (Set rest)))]))
	+removeNoopRules (Node (s, r) (Abs_fset (Set rest))) = Node (s, r) (Abs_fset (Set (map removeNoopRules rest)))
	+removeNoopRules (Node (_, _) (Abs_fset (Coset _))) = error "The proof tree must not include cosets."
	+
	+-- This function collapses successive applications of the Ext rule to a single application
	+-- A lot of these will appear after eliminating rules that are applied to wrong formulas, so this shortens the proof quite a bit
	+extSurgery :: Tree ([Fm], SeCaVRule) -> Tree ([Fm], SeCaVRule)
	+extSurgery node@(Node (_, RExt) (Abs_fset (Set []))) = node
	+extSurgery (Node (sequent, RExt) (Abs_fset (Set [Node (_, RExt) next@(Abs_fset (Set []))]))) =
	+ Node (sequent, RExt) next
	+extSurgery (Node (sequent, RExt) (Abs_fset (Set [Node (_, RExt) (Abs_fset (Set [current]))]))) =
	+ extSurgery $ Node (sequent, RExt) (Abs_fset (Set [current]))
	+extSurgery (Node (sequent, RExt) (Abs_fset (Set [Node (_, RExt) (Abs_fset (Set [current, next]))]))) =
	+ extSurgery $ Node (sequent, RExt) (Abs_fset (Set [current, next]))
	+extSurgery node@(Node (_, _) (Abs_fset (Set []))) = node
	+extSurgery (Node (s, r) (Abs_fset (Set [current]))) = Node (s, r) (Abs_fset (Set [extSurgery current]))
	+extSurgery (Node (s, r) (Abs_fset (Set [current, next]))) = Node (s, r) (Abs_fset (Set [extSurgery current, extSurgery next]))
	+extSurgery (Node _ (Abs_fset (Set (_ : _ : _ : _)))) = error "No proof rule should generate more than two branches."
	+extSurgery (Node _ (Abs_fset (Coset _))) = error "No proof rule should generate a coset of branches."
	+
	+initExtract :: NameState -> Tree ([Fm], SeCaVRule) -> String
	+initExtract names tree = evalState (extract tree) names
	+
	+extract :: Tree ([Fm], SeCaVRule) -> NameGen String
	+extract (Node (sequent, rule) (Abs_fset (Set []))) = do
	+ s <- extractSequent sequent
	+ r <- extractRule rule
	+ pure $ s <> "\n\n" <> r <> "\n"
	+extract (Node (sequent, rule) (Abs_fset (Set [current]))) = do
	+ s <- extractSequent sequent
	+ r <- extractRule rule
	+ c <- extract' [] current
	+ pure $ s <> "\n\n" <> r <> "\n" <> c
	+extract (Node (sequent, rule) (Abs_fset (Set [current, next]))) = do
	+ s <- extractSequent sequent
	+ r <- extractRule rule
	+ c <- extract' [extractNextSequent next] current
	+ n <- extract' [] next
	+ pure $ s <> "\n\n" <> r <> "\n" <> c <> n
	+extract _ =
	+ error "By the pricking of my thumbs, something wicked this way comes..."
	+
	+extract' :: [[Fm]] -> Tree ([Fm], SeCaVRule) -> NameGen String
	+extract' other (Node (sequent, rule) (Abs_fset (Set []))) = do
	+ s <- extractSequent' sequent
	+ ss <- extractOtherSequents other
	+ r <- extractRule rule
	+ pure $ s <> (if null other then "" else "\n+\n" <> ss) <> "\n" <> r <> "\n"
	+extract' other (Node (sequent, rule) (Abs_fset (Set [current]))) = do
	+ s <- extractSequent' sequent
	+ ss <- extractOtherSequents other
	+ r <- extractRule rule
	+ c <- extract' other current
	+ pure $ s <> (if null other then "" else "\n+\n" <> ss) <> "\n" <> r <> "\n" <> c
	+extract' other (Node (sequent, rule) (Abs_fset (Set [current, next]))) = do
	+ s <- extractSequent' sequent
	+ ss <- extractOtherSequents other
	+ r <- extractRule rule
	+ n <- extract' (extractNextSequent next : other) current
	+ c <- extract' other next
	+ pure $ s <> (if null other then "" else "\n+\n" <> ss) <> "\n" <> r <> "\n" <> n <> c
	+extract' _ _ =
	+ error "By the pricking of my thumbs, something wicked this way comes..."
	+
	+extractNextSequent :: Tree ([Fm], SeCaVRule) -> [Fm]
	+extractNextSequent (Node (sequent, _) _) = sequent
	+
	+extractOtherSequents :: [[Fm]] -> NameGen String
	+extractOtherSequents [] = pure ""
	+extractOtherSequents [x] = extractSequent' x
	+extractOtherSequents (x:xs) = do
	+ s <- extractSequent' x
	+ ss <- extractOtherSequents xs
	+ pure $ s <> "\n+\n" <> ss
	+
	+extractSequent :: [Fm] -> NameGen String
	+extractSequent [] = pure ""
	+extractSequent [x] = extractFormula x
	+extractSequent (x:xs) = do
	+ f <- extractFormula x
	+ s <- extractSequent xs
	+ pure $ f <> "\n" <> s
	+
	+extractSequent' :: [Fm] -> NameGen String
	+extractSequent' [] = pure ""
	+extractSequent' [x] = do
	+ f <- extractFormula x
	+ pure $ " " <> f
	+extractSequent' (x:xs) = do
	+ f <- extractFormula x
	+ s <- extractSequent' xs
	+ pure $ " " <> f <> "\n" <> s
	+
	+genName :: Integer -> String
	+genName x \| x < 0 = "?"
	+genName 0 = "a"
	+genName 1 = "b"
	+genName 2 = "c"
	+genName 3 = "d"
	+genName 4 = "e"
	+genName 5 = "f"
	+genName x = "g" <> genericReplicate (x - 5) '\''
	+
	+genFunName :: Integer -> NameGen String
	+genFunName n = do
	+ s <- get
	+ case Map.lookupR n (existingFuns s) of
	+ Just name -> pure name
	+ Nothing -> do
	+ let nameNum = until (\x -> Map.notMemberR x (existingFuns s)) (+ 1) 0
	+ let name = genName nameNum
	+ _ <- modify (\st -> st { funCount = funCount s + 1
	+ , existingFuns = Map.insert name n (existingFuns s)
	+ })
	+ pure $ genName nameNum
	+
	+extractTerm :: Tm -> NameGen String
	+extractTerm (SeCaV.Fun (Nat n) []) = genFunName n
	+extractTerm (SeCaV.Fun (Nat n) ts) = do
	+ fName <- genFunName n
	+ termNames <- traverse extractTerm ts
	+ pure $ fName <> "[" <> intercalate ", " termNames <> "]"
	+extractTerm (SeCaV.Var n) = pure $ show n
	+
	+dropEnd :: Int -> String -> String
	+dropEnd n = reverse . drop n . reverse
	+
	+extractFormula :: Fm -> NameGen String
	+extractFormula (SeCaV.Pre (Nat n) []) = do
	+ s <- get
	+ pure $ existingPres s Map.!> n
	+extractFormula (SeCaV.Pre (Nat n) ts) = do
	+ s <- get
	+ termNames <- traverse extractTerm ts
	+ pure $ existingPres s Map.!> n <> " [" <> intercalate ", " termNames <> "]"
	+extractFormula f = do
	+ form <- extractFormula' f
	+ pure $ drop 1 $ dropEnd 1 form
	+
	+extractFormula' :: Fm -> NameGen String
	+extractFormula' (SeCaV.Pre (Nat n) []) = do
	+ s <- get
	+ pure $ existingPres s Map.!> n
	+extractFormula' (SeCaV.Pre (Nat n) ts) = do
	+ s <- get
	+ termNames <- traverse extractTerm ts
	+ pure $ "(" <> existingPres s Map.!> n <> " [" <> intercalate ", " termNames <> "])"
	+extractFormula' (SeCaV.Imp a b) = do
	+ formA <- extractFormula' a
	+ formB <- extractFormula' b
	+ pure $ "(Imp " <> formA <> " " <> formB <> ")"
	+extractFormula' (SeCaV.Dis a b) = do
	+ formA <- extractFormula' a
	+ formB <- extractFormula' b
	+ pure $ "(Dis " <> formA <> " " <> formB <> ")"
	+extractFormula' (SeCaV.Con a b) = do
	+ formA <- extractFormula' a
	+ formB <- extractFormula' b
	+ pure $ "(Con " <> formA <> " " <> formB <> ")"
	+extractFormula' (SeCaV.Exi f) = do
	+ form <- extractFormula' f
	+ pure $ "(Exi " <> form <> ")"
	+extractFormula' (SeCaV.Uni f) = do
	+ form <- extractFormula' f
	+ pure $ "(Uni " <> form <> ")"
	+extractFormula' (SeCaV.Neg f) = do
	+ form <- extractFormula' f
	+ pure $ "(Neg " <> form <> ")"
	+
	+extractRule :: SeCaVRule -> NameGen String
	+extractRule RBasic = pure "Basic"
	+extractRule RAlphaDis = pure "AlphaDis"
	+extractRule RAlphaImp = pure "AlphaImp"
	+extractRule RAlphaCon = pure "AlphaCon"
	+extractRule RBetaCon = pure"BetaCon"
	+extractRule RBetaImp = pure "BetaImp"
	+extractRule RBetaDis = pure "BetaDis"
	+extractRule (RGammaUni t) = do
	+ termName <- extractTerm t
	+ pure $ "GammaUni[" <> termName <> "]"
	+extractRule (RGammaExi t) = do
	+ termName <- extractTerm t
	+ pure $ "GammaExi[" <> termName <> "]"
	+extractRule RDeltaUni = pure "DeltaUni"
	+extractRule RDeltaExi = pure "DeltaExi"
	+extractRule RNeg = pure "NegNeg"
	+extractRule RExt = pure "Ext"
	diff --git a/thys/FOL_Seq_Calc2/haskell/lib/ProverInstances.hs b/thys/FOL_Seq_Calc2/haskell/lib/ProverInstances.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/lib/ProverInstances.hs
	@@ -0,0 +1,46 @@
	+{-# LANGUAGE StandaloneDeriving #-}
	+{-# LANGUAGE FlexibleInstances #-}
	+{-# OPTIONS_GHC -Wno-orphans #-}
	+
	+module ProverInstances where
	+
	+import Arith(Nat(..))
	+import FSet(Fset(..))
	+import Prover(Rule(..), Tree(..))
	+import SeCaV(Tm(..), Fm(..))
	+import Set(Set(..))
	+
	+instance Show Nat where
	+ show (Nat x) = show x
	+
	+instance Show Tm where
	+ show (Fun n ts) = "F" <> show n <> " " <> show ts
	+ show (Var n) = "V" <> show n
	+
	+instance Show Fm where
	+ show (Pre n ts) = "P" <> show n <> " " <> show ts
	+ show (Imp f1 f2) = "(" <> show f1 <> ") → (" <> show f2 <> ")"
	+ show (Dis f1 f2) = "(" <> show f1 <> ") ∨ (" <> show f2 <> ")"
	+ show (Con f1 f2) = "(" <> show f1 <> ") ∧ (" <> show f2 <> ")"
	+ show (Exi f) = "∃(" <> show f <> ")"
	+ show (Uni f) = "∀(" <> show f <> ")"
	+ show (Neg f) = "¬(" <> show f <> ")"
	+
	+deriving instance Show Rule
	+
	+instance Show (Set ([Tm], [Fm])) where
	+ show (Set s) = show s
	+ show (Coset s) = show s
	+
	+instance Show (Set (Tree (([Tm], [Fm]), Rule))) where
	+ show (Set s) = show s
	+ show (Coset s) = show s
	+
	+instance Show (Fset ([Tm], [Fm])) where
	+ show (Abs_fset s) = show s
	+
	+instance Show (Fset (Tree (([Tm], [Fm]), Rule))) where
	+ show (Abs_fset s) = show s
	+
	+instance Show (Tree (([Tm], [Fm]), Rule)) where
	+ show (Node (fs, r) t) = show fs <> " " <> show r <> "\n" <> show t
	diff --git a/thys/FOL_Seq_Calc2/haskell/lib/SeCaVTranslator.hs b/thys/FOL_Seq_Calc2/haskell/lib/SeCaVTranslator.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/lib/SeCaVTranslator.hs
	@@ -0,0 +1,81 @@
	+module SeCaVTranslator where
	+
	+import Arith ( Nat(..) )
	+import Control.Monad.State
	+ ( liftM2, modify, runState, MonadState(get) )
	+import qualified Data.Bimap as Map
	+import SeCaV ( Fm(..), Tm(..) )
	+import ShortAST as AST
	+ ( NameGen, NameState(..), Formula(..), Term(..), Index, Name )
	+
	+genInit :: [Formula] -> ([Fm], NameState)
	+genInit fs =
	+ let initState = NameState
	+ { preCount = 0
	+ , funCount = 0
	+ , existingPres = Map.empty
	+ , existingFuns = Map.empty
	+ }
	+ in runState (genSequent fs) initState
	+
	+genSequent :: [Formula] -> NameGen [Fm]
	+genSequent = foldr (liftM2 (:) . genFormula) (pure [])
	+
	+genFormula :: Formula -> NameGen Fm
	+genFormula (AST.Pre n l) = do
	+ preName <- genPreName n
	+ termNames <- traverse genTerm l
	+ pure $ SeCaV.Pre preName termNames
	+genFormula (AST.Imp a b) = do
	+ fa <- genFormula a
	+ fb <- genFormula b
	+ pure $ SeCaV.Imp fa fb
	+genFormula (AST.Dis a b) = do
	+ fa <- genFormula a
	+ fb <- genFormula b
	+ pure $ SeCaV.Dis fa fb
	+genFormula (AST.Con a b) = do
	+ fa <- genFormula a
	+ fb <- genFormula b
	+ pure $ SeCaV.Con fa fb
	+genFormula (AST.Exi f) = do
	+ ff <- genFormula f
	+ pure $ SeCaV.Exi ff
	+genFormula (AST.Uni f) = do
	+ ff <- genFormula f
	+ pure $ SeCaV.Uni ff
	+genFormula (AST.Neg f) = do
	+ ff <- genFormula f
	+ pure $ SeCaV.Neg ff
	+
	+genTerm :: Term -> NameGen Tm
	+genTerm (AST.Fun n l) = do
	+ fName <- genFunName n
	+ termNames <- traverse genTerm l
	+ pure $ SeCaV.Fun fName termNames
	+genTerm (AST.Var n) = pure $ SeCaV.Var $ Nat n
	+
	+genIndex :: Index -> NameGen Nat
	+genIndex n = pure $ Nat n
	+
	+genFunName :: Name -> NameGen Nat
	+genFunName n = do
	+ s <- get
	+ case Map.lookup n (existingFuns s) of
	+ Just index -> pure $ Nat index
	+ Nothing -> do
	+ _ <- modify (\st -> st { funCount = funCount s + 1
	+ , existingFuns = Map.insert n (funCount s) (existingFuns s)
	+ })
	+ pure $ Nat $ funCount s
	+
	+genPreName :: Name -> NameGen Nat
	+genPreName n = do
	+ s <- get
	+ case Map.lookup n (existingPres s) of
	+ Just index -> pure $ Nat index
	+ Nothing -> do
	+ _ <- modify (\st -> st { preCount = preCount s + 1
	+ , existingPres = Map.insert n (preCount s) (existingPres s)
	+ })
	+ pure $ Nat $ preCount s
	diff --git a/thys/FOL_Seq_Calc2/haskell/lib/ShortAST.hs b/thys/FOL_Seq_Calc2/haskell/lib/ShortAST.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/lib/ShortAST.hs
	@@ -0,0 +1,67 @@
	+module ShortAST where
	+
	+import Control.Monad.State ( State )
	+import Data.Bimap ( Bimap )
	+
	+type Name = String
	+type Index = Integer
	+
	+data Term
	+ = Fun Name [Term]
	+ \| Var Index
	+ deriving (Show)
	+
	+data Formula
	+ = Pre Name [Term]
	+ \| Imp Formula Formula
	+ \| Dis Formula Formula
	+ \| Con Formula Formula
	+ \| Exi Formula
	+ \| Uni Formula
	+ \| Neg Formula
	+ deriving (Show)
	+
	+data ShortRule
	+ = SBasic
	+ \| SAlphaDis
	+ \| SAlphaImp
	+ \| SAlphaCon
	+ \| SBetaCon
	+ \| SBetaImp
	+ \| SBetaDis
	+ \| SGammaExi (Maybe Term)
	+ \| SGammaUni (Maybe Term)
	+ \| SDeltaUni
	+ \| SDeltaExi
	+ \| SNeg
	+ \| SExt
	+ deriving (Show)
	+
	+data Application
	+ = Application ShortRule [[Formula]]
	+ deriving (Show)
	+
	+data Intertext
	+ = Section (Maybe String)
	+ \| Text (Maybe String)
	+ deriving (Show)
	+
	+data Proof
	+ = Proof [Intertext] Formula [Application]
	+ deriving (Show)
	+
	+data Program = Program [Proof] [Intertext]
	+ deriving (Show)
	+
	+data NameState = NameState
	+ { preCount :: Integer
	+ , funCount :: Integer
	+ , existingPres :: Bimap Name Integer
	+ , existingFuns :: Bimap Name Integer
	+ }
	+
	+type NameGen a = State NameState a
	+
	+newtype BoundNameState = BoundNameState { depth :: Integer }
	+
	+type BoundNameGen a = State BoundNameState a
	diff --git a/thys/FOL_Seq_Calc2/haskell/lib/ShortLexer.hs b/thys/FOL_Seq_Calc2/haskell/lib/ShortLexer.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/lib/ShortLexer.hs
	@@ -0,0 +1,75 @@
	+module ShortLexer where
	+
	+import Control.Applicative ( Alternative((<\|>)) )
	+import Control.Monad.Identity (Identity)
	+import Text.Parsec (ParsecT)
	+import Text.Parsec.Char ( alphaNum, letter, oneOf )
	+import Text.Parsec.Language ( emptyDef )
	+import Text.Parsec.Token
	+ ( GenLanguageDef(commentStart, commentEnd, commentLine,
	+ nestedComments, identStart, identLetter, opStart, opLetter,
	+ reservedNames, reservedOpNames, caseSensitive),
	+ LanguageDef,
	+ makeTokenParser,
	+ GenTokenParser(TokenParser, parens, identifier, integer, brackets,
	+ commaSep, stringLiteral, commaSep1, reserved, reservedOp,
	+ whiteSpace) )
	+
	+languageDef :: LanguageDef st
	+languageDef = emptyDef
	+ { commentStart = "(*"
	+ , commentEnd = "*)"
	+ , commentLine = ""
	+ , nestedComments = False
	+ , identStart = letter
	+ , identLetter = alphaNum <\|> oneOf ['_', '\'']
	+ , opStart = oneOf ['+', '-', '#']
	+ , opLetter = oneOf ['+', '-', '#']
	+ , reservedNames = [ "Var"
	+ , "Imp"
	+ , "Dis"
	+ , "Con"
	+ , "Exi"
	+ , "Uni"
	+ , "Neg"
	+ , "Basic"
	+ , "AlphaDis"
	+ , "AlphaImp"
	+ , "AlphaCon"
	+ , "BetaCon"
	+ , "BetaImp"
	+ , "BetaDis"
	+ , "GammaExi"
	+ , "GammaUni"
	+ , "DeltaUni"
	+ , "DeltaExi"
	+ , "NegNeg"
	+ , "Ext"
	+ ]
	+ , reservedOpNames = ["+", "-", "#"]
	+ , caseSensitive = True
	+ }
	+
	+mParens :: ParsecT String u Identity a -> ParsecT String u Identity a
	+mIdentifier :: ParsecT String u Identity String
	+mInteger :: ParsecT String u Identity Integer
	+mBrackets :: ParsecT String u Identity a -> ParsecT String u Identity a
	+mCommaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]
	+mStringLiteral :: ParsecT String u Identity String
	+mCommaSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]
	+mReserved :: String -> ParsecT String u Identity ()
	+mReservedOp :: String -> ParsecT String u Identity ()
	+mWhiteSpace :: ParsecT String u Identity ()
	+
	+TokenParser
	+ { parens = mParens
	+ , identifier = mIdentifier
	+ , integer = mInteger
	+ , brackets = mBrackets
	+ , commaSep = mCommaSep
	+ , stringLiteral = mStringLiteral
	+ , commaSep1 = mCommaSep1
	+ , reserved = mReserved
	+ , reservedOp = mReservedOp
	+ , whiteSpace = mWhiteSpace
	+ } = makeTokenParser languageDef
	diff --git a/thys/FOL_Seq_Calc2/haskell/lib/ShortParser.hs b/thys/FOL_Seq_Calc2/haskell/lib/ShortParser.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/lib/ShortParser.hs
	@@ -0,0 +1,243 @@
	+module ShortParser where
	+
	+import Data.Function (fix)
	+import ShortAST
	+ ( Program(..),
	+ Proof(..),
	+ Intertext(..),
	+ Application(..),
	+ ShortRule(..),
	+ Formula(..),
	+ Term(..),
	+ Index,
	+ Name )
	+import ShortLexer
	+ ( mParens,
	+ mIdentifier,
	+ mInteger,
	+ mBrackets,
	+ mCommaSep,
	+ mStringLiteral,
	+ mCommaSep1,
	+ mReserved,
	+ mReservedOp,
	+ mWhiteSpace )
	+import Text.Parsec
	+ ( choice,
	+ eof,
	+ many1,
	+ option,
	+ optionMaybe,
	+ sepBy,
	+ (<?>),
	+ many,
	+ parse,
	+ try,
	+ ParseError,
	+ Parsec )
	+
	+type SParser a = Parsec String () a
	+
	+name :: SParser Name
	+name = mIdentifier
	+
	+index :: SParser Index
	+index = mInteger
	+
	+fun :: SParser Term
	+fun = do
	+ f <- name
	+ args <- option [] termList
	+ pure $ Fun f args
	+
	+var :: SParser Term
	+var = Var <$> index
	+
	+term :: SParser Term
	+term = fix allTerms
	+ where
	+ allTerms _ = choice
	+ [ fun
	+ , var
	+ ] <?> "a function name or a variable"
	+
	+termList :: SParser [Term]
	+termList = fix $ const (mBrackets $ mCommaSep term)
	+
	+-- Parsing of formulas
	+predicate :: SParser Formula
	+predicate = Pre <$> name <*> option [] termList
	+
	+implication :: SParser Formula
	+implication = fix $ const $ mReserved "Imp" > (Imp <$> formula <> formula)
	+
	+disjunction :: SParser Formula
	+disjunction = fix $ const $ mReserved "Dis" > (Dis <$> formula <> formula)
	+
	+conjunction :: SParser Formula
	+conjunction = fix $ const $ mReserved "Con" > (Con <$> formula <> formula)
	+
	+existential :: SParser Formula
	+existential = fix $ const $ mReserved "Exi" *> (Exi <$> formula)
	+
	+universal :: SParser Formula
	+universal = fix $ const $ mReserved "Uni" *> (Uni <$> formula)
	+
	+negation :: SParser Formula
	+negation = fix $ const $ mReserved "Neg" *> (Neg <$> formula)
	+
	+formula :: SParser Formula
	+formula = fix allFormulas
	+ where
	+ allFormulas _ = choice
	+ [ predicate
	+ , implication
	+ , disjunction
	+ , conjunction
	+ , existential
	+ , universal
	+ , negation
	+ , mParens formula
	+ ] <?> "a formula"
	+
	+
	+sequent :: SParser [Formula]
	+sequent = mCommaSep1 formula
	+
	+-- Parsing of proof rules
	+basic :: SParser ShortRule
	+basic = do
	+ mReserved "Basic"
	+ pure SBasic
	+
	+alphaDis :: SParser ShortRule
	+alphaDis = do
	+ mReserved "AlphaDis"
	+ pure SAlphaDis
	+
	+alphaImp :: SParser ShortRule
	+alphaImp = do
	+ mReserved "AlphaImp"
	+ pure SAlphaImp
	+
	+alphaCon :: SParser ShortRule
	+alphaCon = do
	+ mReserved "AlphaCon"
	+ pure SAlphaCon
	+
	+betaDis :: SParser ShortRule
	+betaDis = do
	+ mReserved "BetaDis"
	+ pure SBetaDis
	+
	+betaImp :: SParser ShortRule
	+betaImp = do
	+ mReserved "BetaImp"
	+ pure SBetaImp
	+
	+betaCon :: SParser ShortRule
	+betaCon = do
	+ mReserved "BetaCon"
	+ pure SBetaCon
	+
	+gammaExi :: SParser ShortRule
	+gammaExi = do
	+ mReserved "GammaExi"
	+ t <- optionMaybe (mBrackets term)
	+ pure $ SGammaExi t
	+
	+gammaUni :: SParser ShortRule
	+gammaUni = do
	+ mReserved "GammaUni"
	+ t <- optionMaybe (mBrackets term)
	+ pure $ SGammaUni t
	+
	+deltaUni :: SParser ShortRule
	+deltaUni = do
	+ mReserved "DeltaUni"
	+ pure SDeltaUni
	+
	+deltaExi :: SParser ShortRule
	+deltaExi = do
	+ mReserved "DeltaExi"
	+ pure SDeltaExi
	+
	+ext :: SParser ShortRule
	+ext = do
	+ mReserved "Ext"
	+ pure SExt
	+
	+neg :: SParser ShortRule
	+neg = do
	+ mReserved "NegNeg"
	+ pure SNeg
	+
	+rule :: SParser ShortRule
	+rule = fix allRules
	+ where
	+ allRules _ = choice
	+ [ basic
	+ , alphaDis
	+ , alphaImp
	+ , alphaCon
	+ , betaDis
	+ , betaImp
	+ , betaCon
	+ , gammaExi
	+ , gammaUni
	+ , deltaUni
	+ , deltaExi
	+ , neg
	+ , ext
	+ ] <?> "a proof rule"
	+
	+-- Parsing of rule applications
	+application :: SParser Application
	+application = do
	+ r <- rule
	+ l <- many formula `sepBy` mReservedOp "+"
	+ pure $ Application r l
	+
	+section :: SParser Intertext
	+section = do
	+ mReservedOp "#"
	+ t <- optionMaybe mStringLiteral
	+ pure $ Section t
	+
	+text :: SParser Intertext
	+text = do
	+ mReservedOp "-"
	+ t <- optionMaybe mStringLiteral
	+ pure $ Text t
	+
	+intertext :: SParser Intertext
	+intertext = choice [section, text]
	+
	+-- Parsing of proofs
	+proof :: SParser Proof
	+proof = do
	+ t <- many1 intertext
	+ f <- formula
	+ l <- many1 application
	+ pure $ Proof t f l
	+
	+firstProof :: SParser Proof
	+firstProof = do
	+ t <- many intertext
	+ f <- formula
	+ l <- many1 application
	+ pure $ Proof t f l
	+
	+-- Parsing of whole files
	+program :: SParser Program
	+program = do
	+ first <- firstProof
	+ l <- many $ try proof
	+ t <- many intertext
	+ pure $ Program (first:l) t
	+
	+programParser :: String -> Either ParseError Program
	+programParser = parse (mWhiteSpace > program < eof) ""
	+
	+sequentParser :: String -> Either ParseError [Formula]
	+sequentParser = parse (mWhiteSpace > sequent < eof) ""
	diff --git a/thys/FOL_Seq_Calc2/haskell/lib/Unshortener.hs b/thys/FOL_Seq_Calc2/haskell/lib/Unshortener.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/haskell/lib/Unshortener.hs
	@@ -0,0 +1,288 @@
	+module Unshortener where
	+
	+import Control.Monad.State (get, modify, put, runState, evalState)
	+import Data.Bimap as Map
	+ ( empty, insert, lookup, null, toList, Bimap )
	+import Data.List
	+ ( null, genericReplicate, intercalate, sortBy, uncons )
	+import ShortAST
	+ ( BoundNameGen,
	+ BoundNameState(..),
	+ NameGen,
	+ NameState(NameState, existingFuns, funCount, existingPres,
	+ preCount),
	+ Program(..),
	+ Proof(..),
	+ Intertext(..),
	+ Application(..),
	+ ShortRule(..),
	+ Formula(..),
	+ Term(..),
	+ Index,
	+ Name )
	+
	+initialBoundNameState :: BoundNameState
	+initialBoundNameState = BoundNameState { depth = 0 }
	+
	+dropEnd :: Integer -> String -> String
	+dropEnd n = reverse . drop (fromIntegral n) . reverse
	+
	+unsnoc :: [a] -> Maybe ([a], a)
	+unsnoc [] = Nothing
	+unsnoc [x] = Just ([], x)
	+unsnoc (x:xs) = Just (x:a, b)
	+ where Just (a,b) = unsnoc xs
	+
	+genBoundName :: Integer -> String
	+genBoundName x \| x < 0 = "?"
	+genBoundName 0 = "x"
	+genBoundName 1 = "y"
	+genBoundName 2 = "z"
	+genBoundName 3 = "u"
	+genBoundName 4 = "v"
	+genBoundName 5 = "w"
	+genBoundName x = "w" <> genericReplicate (x - 5) '\''
	+
	+genPropFormula :: Formula -> BoundNameGen String
	+genPropFormula (Pre n l) = do
	+ termNames <- traverse genPropTerm l
	+ pure $ if Data.List.null l then n else n <> " " <> unwords termNames
	+genPropFormula f = drop 1 . dropEnd 1 <$> genPropFormula' f
	+
	+genPropFormula' :: Formula -> BoundNameGen String
	+genPropFormula' (Pre n l) = do
	+ termNames <- traverse genPropTerm l
	+ pure $ if Data.List.null l then n else "(" <> n <> " " <> unwords termNames <> ")"
	+genPropFormula' (Imp a b) = do
	+ fa <- genPropFormula' a
	+ fb <- genPropFormula' b
	+ pure $ "(" <> fa <> " \\<longrightarrow> " <> fb <> ")"
	+genPropFormula' (Dis a b) = do
	+ fa <- genPropFormula' a
	+ fb <- genPropFormula' b
	+ pure $ "(" <> fa <> " \\<or> " <> fb <> ")"
	+genPropFormula' (Con a b) = do
	+ fa <- genPropFormula' a
	+ fb <- genPropFormula' b
	+ pure $ "(" <> fa <> " \\<and> " <> fb <> ")"
	+genPropFormula' (Exi f) = do
	+ s <- get
	+ let name = genBoundName (depth s)
	+ _ <- modify (\st -> st { depth = depth s + 1 })
	+ ff <- genPropFormula' f
	+ _ <- put s
	+ pure $ "(" <> "\\<exists>" <> name <> ". " <> ff <> ")"
	+genPropFormula' (Uni f) = do
	+ s <- get
	+ let name = genBoundName (depth s)
	+ _ <- modify (\st -> st { depth = depth s + 1 })
	+ ff <- genPropFormula' f
	+ _ <- put s
	+ pure $ "(" <> "\\<forall>" <> name <> ". " <> ff <> ")"
	+genPropFormula' (Neg f) = do
	+ ff <- genPropFormula' f
	+ pure $ "(" <> "\\<not>" <> ff <> ")"
	+
	+genPropTerm :: Term -> BoundNameGen String
	+genPropTerm (Fun n l) = do
	+ termNames <- traverse genPropTerm l
	+ pure $ if Data.List.null l then n else "(" <> n <> " " <> unwords termNames <> ")"
	+genPropTerm (Var n) \| n < 0 = pure "?"
	+genPropTerm (Var n) = do
	+ s <- get
	+ let relativeIndex = depth s - n - 1
	+ pure $ genBoundName relativeIndex
	+
	+mappingList :: Map.Bimap Name Integer -> [(Name, Integer)]
	+mappingList m =
	+ let l = Map.toList m in
	+ sortBy cmp l
	+ where
	+ cmp a b =
	+ let i1 = snd a in
	+ let i2 = snd b in
	+ compare i1 i2
	+
	+genNameMappings :: Map.Bimap Name Integer -> String -> String
	+genNameMappings m name =
	+ let l = mappingList m in
	+ let mappings = genNameMap <$> l in
	+ " " <> name <> "\n\n " <> intercalate "\n\n " mappings
	+
	+genNameMap :: (Name, Integer) -> String
	+genNameMap t =
	+ let n = fst t in
	+ let i = snd t in
	+ show i <> " = " <> n
	+
	+genProgram :: Program -> String
	+genProgram (Program l t) =
	+ let proofs = genProofInit <$> l in
	+ let proofText = intercalate "\n\n" proofs in
	+ proofText <> "\n\n" <> genIntertexts t
	+
	+genIntertext :: Intertext -> String
	+genIntertext (Section Nothing) = "\n"
	+genIntertext (Section (Just t)) = "section \\<open>" <> t <> "\\<close>\n\n"
	+genIntertext (Text Nothing) = ""
	+genIntertext (Text (Just t)) = "text \\<open>" <> t <> "\\<close>\n\n"
	+
	+genIntertexts :: [Intertext] -> String
	+genIntertexts titles =
	+ intercalate "" $ genIntertext <$> titles
	+
	+genProofInit :: Proof -> String
	+genProofInit p@(Proof t f _) =
	+ let initState = NameState
	+ { preCount = 0
	+ , funCount = 0
	+ , existingPres = empty
	+ , existingFuns = empty
	+ } in
	+ let result = runState (genProof p) initState in
	+ let prop = evalState (genPropFormula f) initialBoundNameState in
	+ let text = fst result in
	+ let finalState = snd result in
	+ genIntertexts t <>
	+ "proposition \\<open>" <> prop <> "\\<close> by metis" <> "\n\ntext \\<open>\n" <>
	+ genNameMappings (existingPres finalState) "Predicate numbers" <>
	+ "\n" <> (if not $ Map.null (existingFuns finalState)
	+ then genNameMappings (existingFuns finalState) "Function numbers" <> "\n"
	+ else "") <> " \\<close>\n" <> text
	+
	+genProof :: Proof -> NameGen String
	+genProof (Proof _ f l) =
	+ let formula = genFormula f in
	+ let gr = genApplicationRule in
	+ let gf = genApplicationFormulas in
	+ let midRule r = do
	+ grr <- gr r
	+ gfr <- gf r
	+ pure $ "\n with " <> grr <> " have ?thesis " <> gfr <> "\n using that by simp" in
	+ do
	+ form <- formula
	+ rules <- case uncons l of
	+ Just (first, rest) ->
	+ (case unsnoc rest of
	+ Just (middle, lastf) -> do
	+ grf <- gr first
	+ gff <- gf first
	+ grl <- gr lastf
	+ middleRules <- traverse midRule middle
	+ pure $ if Data.List.null middle
	+ then
	+ "\n from " <> grf <> " have ?thesis " <> gff <> "\n using that by simp" <> "\n with " <> grl <> " show ?thesis\n by simp"
	+ else
	+ "\n from " <> grf <> " have ?thesis " <> gff <> "\n using that by simp" <> intercalate "" middleRules <> "\n with " <> grl <> " show ?thesis\n by simp"
	+ Nothing -> do
	+ grf <- gr first
	+ pure ("\n from " <> grf <> " show ?thesis\n by simp")
	+ )
	+ Nothing -> pure ""
	+ pure $ "\nlemma \\<open>\\<tturnstile>\n [\n " <> form <> "\n ]\n \\<close>\nproof -" <> rules <> "\nqed"
	+
	+genApplicationRule :: Application -> NameGen String
	+genApplicationRule (Application r _) = genRule r
	+
	+genApplicationFormulas :: Application -> NameGen String
	+genApplicationFormulas (Application _ l) =
	+ let restApp a = do
	+ formulas <- traverse genFormula a
	+ pure $ " and \\<open>\\<tturnstile>\n [\n " <> intercalate ",\n " formulas <> "\n ]\n \\<close>" in
	+ case uncons l of
	+ Nothing -> pure ""
	+ Just (first, rest) -> do
	+ firstF <- traverse genFormula first
	+ restF <- traverse restApp rest
	+ pure $ "if \\<open>\\<tturnstile>\n [\n " <> intercalate ",\n " firstF <> "\n ]\n \\<close>" <> intercalate "" restF
	+
	+genRule :: ShortRule -> NameGen String
	+genRule SBasic = pure "Basic"
	+genRule SAlphaDis = pure "AlphaDis"
	+genRule SAlphaImp = pure "AlphaImp"
	+genRule SAlphaCon = pure "AlphaCon"
	+genRule SBetaCon = pure "BetaCon"
	+genRule SBetaImp = pure "BetaImp"
	+genRule SBetaDis = pure "BetaDis"
	+genRule (SGammaExi Nothing) = pure "GammaExi"
	+genRule (SGammaExi (Just t)) = do
	+ term <- genTerm t
	+ pure $ "GammaExi[where t=\\<open>" <> term <> "\\<close>]"
	+genRule (SGammaUni Nothing) = pure "GammaUni"
	+genRule (SGammaUni (Just t)) = do
	+ term <- genTerm t
	+ pure $ "GammaUni[where t=\\<open>" <> term <> "\\<close>]"
	+genRule SDeltaUni = pure "DeltaUni"
	+genRule SDeltaExi = pure "DeltaExi"
	+genRule SNeg = pure "Neg"
	+genRule SExt = pure "Ext"
	+
	+genFormula :: Formula -> NameGen String
	+genFormula f = drop 1 . dropEnd 1 <$> genFormula' f
	+
	+genFormula' :: Formula -> NameGen String
	+genFormula' (Pre n l) = do
	+ preName <- genPreName n
	+ termNames <- traverse genTerm l
	+ pure $ "(" <> "Pre " <> preName <> " [" <> intercalate ", " termNames <> "])"
	+genFormula' (Imp a b) = do
	+ fa <- genFormula' a
	+ fb <- genFormula' b
	+ pure $ "(" <> "Imp " <> fa <> " " <> fb <> ")"
	+genFormula' (Dis a b) = do
	+ fa <- genFormula' a
	+ fb <- genFormula' b
	+ pure $ "(" <> "Dis " <> fa <> " " <> fb <> ")"
	+genFormula' (Con a b) = do
	+ fa <- genFormula' a
	+ fb <- genFormula' b
	+ pure $ "(" <> "Con " <> fa <> " " <> fb <> ")"
	+genFormula' (Exi f) = do
	+ ff <- genFormula' f
	+ pure $ "(" <> "Exi " <> ff <> ")"
	+genFormula' (Uni f) = do
	+ ff <- genFormula' f
	+ pure $ "(" <> "Uni " <> ff <> ")"
	+genFormula' (Neg f) = do
	+ ff <- genFormula' f
	+ pure $ "(" <> "Neg " <> ff <> ")"
	+
	+genTerm :: Term -> NameGen String
	+genTerm (Fun n l) = do
	+ fName <- genFunName n
	+ termNames <- traverse genTerm l
	+ pure $ "Fun " <> fName <> " [" <> intercalate ", " termNames <> "]"
	+genTerm (Var n) = do
	+ index <- genIndex n
	+ pure $ "Var " <> index
	+
	+genIndex :: Index -> NameGen String
	+genIndex n = pure $ show n
	+
	+genFunName :: Name -> NameGen String
	+genFunName n = do
	+ s <- get
	+ case Map.lookup n (existingFuns s) of
	+ Just index -> pure $ show index
	+ Nothing -> do
	+ _ <- modify (\st -> st { funCount = funCount s + 1
	+ , existingFuns = Map.insert n (funCount s) (existingFuns s)
	+ })
	+ pure $ show (funCount s)
	+
	+genPreName :: Name -> NameGen String
	+genPreName n = do
	+ s <- get
	+ case Map.lookup n (existingPres s) of
	+ Just index -> pure $ show index
	+ Nothing -> do
	+ _ <- modify (\st -> st { preCount = preCount s + 1
	+ , existingPres = Map.insert n (preCount s) (existingPres s)
	+ })
	+ pure $ show (preCount s)
	+
	+genFile :: String -> Program -> String
	+genFile name p =
	+ "theory " <> name <> " imports SeCaV begin\n\n"
	+ <> genProgram p
	+ <> "\n\nend"
	diff --git a/thys/FOL_Seq_Calc2/secav-prover.cabal b/thys/FOL_Seq_Calc2/secav-prover.cabal
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/secav-prover.cabal
	@@ -0,0 +1,86 @@
	+cabal-version: 2.4
	+name: secav-prover
	+version: 1.0.0.0
	+synopsis: Prover for the SeCaV system
	+license: GPL-3.0-only
	+license-file: LICENSE
	+author: Frederik Krogsdal Jacobsen
	+maintainer: fkjacobsen@gmail.com
	+category: Math
	+description: An automated theorem prover for the SeCaV system of first-order logic.
	+build-type: Simple
	+
	+source-repository head
	+ type: git
	+ location: git://github.com/fkj/secav-prover.git
	+
	+library prover
	+ exposed-modules: Arith
	+ , FSet
	+ , Prover
	+ , SeCaV
	+ , Set
	+ other-modules: Lazy
	+ , List
	+ , MaybeExt
	+ , Orderings
	+ , Product_Type
	+ , HOL
	+ build-depends: base
	+ hs-source-dirs: haskell/prover
	+ default-language: Haskell2010
	+
	+library interface
	+ exposed-modules: ProofExtractor
	+ , ProverInstances
	+ , ShortAST
	+ , SeCaVTranslator
	+ , ShortLexer
	+ , ShortParser
	+ , Unshortener
	+ build-depends: base ^>=4.14.0.0
	+ , prover
	+ , parsec
	+ , bimap
	+ , mtl
	+ hs-source-dirs: haskell/lib
	+ default-language: Haskell2010
	+ ghc-options: -Wall
	+
	+test-suite completeness
	+ type: detailed-0.9
	+ test-module: Runner
	+ other-modules: Tests
	+ build-depends: base ^>=4.14.0.0
	+ , Cabal >= 1.9.2
	+ , process
	+ , directory
	+ , mtl
	+ , prover
	+ , interface
	+ hs-source-dirs: test/completeness
	+ default-language: Haskell2010
	+
	+test-suite soundness
	+ type: detailed-0.9
	+ test-module: Runner
	+ other-modules: Tests
	+ build-depends: base ^>=4.14.0.0
	+ , Cabal >= 1.9.2
	+ , process
	+ , mtl
	+ , prover
	+ , interface
	+ hs-source-dirs: test/soundness
	+ default-language: Haskell2010
	+
	+executable secav-prover
	+ main-is: Main.hs
	+ build-depends: base ^>=4.14.0.0
	+ , prover
	+ , interface
	+ , filepath
	+ , optparse-applicative
	+ hs-source-dirs: haskell/app
	+ default-language: Haskell2010
	+ ghc-options: -Wall
	diff --git a/thys/FOL_Seq_Calc2/test/completeness/ROOT b/thys/FOL_Seq_Calc2/test/completeness/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/test/completeness/ROOT
	@@ -0,0 +1,7 @@
	+session Prover_Test (FKJ) = "HOL-Library" +
	+ options [timeout = 300]
	+ sessions
	+ Collections
	+ theories
	+ SeCaV
	+ Test
	\ No newline at end of file
	diff --git a/thys/FOL_Seq_Calc2/test/completeness/Runner.hs b/thys/FOL_Seq_Calc2/test/completeness/Runner.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/test/completeness/Runner.hs
	@@ -0,0 +1,71 @@
	+module Runner (tests) where
	+
	+import Distribution.TestSuite
	+ ( Progress (Finished),
	+ Result (Fail, Pass),
	+ Test (Test),
	+ TestInstance (TestInstance, name, options, run, setOption, tags),
	+ )
	+import ProofExtractor (initExtract, extSurgery, removeNoopRules, expandMultiRules)
	+import Prover (secavProverCode)
	+import SeCaVTranslator (genInit)
	+import ShortParser (programParser, sequentParser)
	+import System.Directory
	+ ( copyFile,
	+ createDirectoryIfMissing,
	+ removeDirectoryRecursive,
	+ )
	+import System.Exit (ExitCode (ExitFailure, ExitSuccess))
	+import System.Process (readProcessWithExitCode)
	+import System.Timeout (timeout)
	+import Tests (testcases)
	+import Unshortener (genFile)
	+
	+tests :: IO [Test]
	+tests = do
	+ let testDir = "test-tmp"
	+ setup testDir
	+ let testResults = map (createTest testDir) testcases
	+ pure testResults
	+
	+setup :: String -> IO ()
	+setup = createDirectoryIfMissing False
	+
	+tearDown :: String -> IO ()
	+tearDown = removeDirectoryRecursive
	+
	+createTest :: String -> (String, String) -> Test
	+createTest topdir (testDir, f) =
	+ let test testDir f =
	+ TestInstance
	+ { run = Finished <$> performTest (topdir <> "/" <> testDir) f,
	+ name = f,
	+ tags = [],
	+ options = [],
	+ setOption = \_ _ -> Right $ test testDir f
	+ }
	+ in Test $ test testDir f
	+
	+performTest :: String -> String -> IO Result
	+performTest testDir f = do
	+ createDirectoryIfMissing False testDir
	+ copyFile "isabelle/SeCaV.thy" $ testDir <> "/SeCaV.thy"
	+ copyFile "test/completeness/ROOT" $ testDir <> "/ROOT"
	+
	+ let parse = sequentParser f
	+ case parse of
	+ Left e -> pure $ Fail $ show e
	+ Right fm -> do
	+ let (formula, names) = genInit fm
	+ let proofTree = secavProverCode formula
	+ let shortProof = initExtract names $ removeNoopRules $ extSurgery $ removeNoopRules $ expandMultiRules proofTree
	+ let proofParse = programParser shortProof
	+ case proofParse of
	+ Left e -> pure $ Fail $ show e
	+ Right proofAst -> do
	+ let isabelleProof = genFile "Test" proofAst
	+ writeFile (testDir <> "/Test.thy") isabelleProof
	+ (exit, _, error) <- readProcessWithExitCode "isabelle" ["build", "-D", testDir] []
	+ case exit of
	+ ExitFailure _ -> pure $ Fail error
	+ ExitSuccess -> pure Pass
	diff --git a/thys/FOL_Seq_Calc2/test/completeness/Tests.hs b/thys/FOL_Seq_Calc2/test/completeness/Tests.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/test/completeness/Tests.hs
	@@ -0,0 +1,26 @@
	+module Tests where
	+
	+testcases :: [(String, String)]
	+testcases =
	+ [ ("true", "Imp a a")
	+ , ("false", "Neg (Neg (Imp a a))")
	+ , ("negations", "Imp (Neg p) (Neg (Neg (Neg p)))")
	+ , ("excludedMiddle", "Dis a (Neg a)")
	+ , ("excludedMiddle2", "Dis (Neg a) a")
	+ , ("impNeg", "Dis p (Imp p q)")
	+ , ("extraCon", "Imp (Con p q) (Imp r (Con p r))")
	+ , ("bigCon", "Con (Con (Imp a a) (Imp b b)) (Con (Imp c c) (Imp d d))")
	+ , ("deMorganUni", "Imp (Neg (Uni p[0])) (Exi (Neg (p[0])))")
	+ , ("deMorganExi", "Imp (Neg (Exi p[0])) (Uni (Neg (p[0])))")
	+ , ("ex7.2a", "Imp (Con (Uni p[0]) (Uni q[0])) (Uni (Con p[0] q[0]))")
	+ , ("ex7.2b", "Imp (Uni (Imp p[0] q[0])) (Imp (Uni p[0]) (Uni q[0]))")
	+ , ("ex7.3a", "Con (Imp (Exi (Imp A[0] B[0])) (Imp (Uni A[0]) (Exi B[0]))) (Imp (Imp (Uni A[0]) (Exi B[0])) (Exi (Imp A[0] B[0])))")
	+ , ("ex7.3b", "Imp (Imp (Exi A[0]) (Uni B[0])) (Uni (Imp A[0] B[0]))")
	+ , ("ex7.3c", "Imp (Uni (Dis A[0] B[0])) (Dis (Uni A[0]) (Exi B[0]))")
	+ , ("ex7.3d", "Imp (Uni (Imp A[0] B[0])) (Imp (Exi A[0]) (Exi B[0]))")
	+ , ("ex8.5", "Con (Imp (Uni (Imp p[0] q)) (Uni (Imp (Neg q) (Neg p[0])))) (Imp (Uni (Imp (Neg q) (Neg p[0]))) (Uni (Imp p[0] q)))")
	+ , ("ex8.6", "Imp (Uni (Con (Imp p[0] q[0]) (Imp q[0] p[0]))) (Con (Imp (Uni p[0]) (Uni q[0])) (Imp (Uni q[0]) (Uni p[0])))")
	+ , ("ex8.8a", "Con (Imp (Uni (Imp A B[0])) (Imp A (Uni B[0]))) (Imp (Imp A (Uni B[0])) (Uni (Imp A B[0])))")
	+ , ("ex8.8b", "Con (Imp (Exi (Imp A B[0])) (Imp A (Exi B[0]))) (Imp (Imp A (Exi B[0])) (Exi (Imp A B[0])))")
	+ , ("ex9.4a", "Imp (Uni A[0, f[0]]) (Uni (Exi A[1,0]))")
	+ ]
	diff --git a/thys/FOL_Seq_Calc2/test/soundness/Runner.hs b/thys/FOL_Seq_Calc2/test/soundness/Runner.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/test/soundness/Runner.hs
	@@ -0,0 +1,45 @@
	+module Runner (tests) where
	+
	+import Distribution.TestSuite
	+ ( Progress (Finished),
	+ Result (Fail, Pass),
	+ Test (Test),
	+ TestInstance (TestInstance, name, options, run, setOption, tags),
	+ )
	+import ProofExtractor (initExtract)
	+import Prover (secavProverCode)
	+import SeCaVTranslator (genInit)
	+import ShortParser (programParser, sequentParser)
	+import System.Exit (ExitCode (ExitFailure, ExitSuccess))
	+import System.Process (readProcessWithExitCode)
	+import System.Timeout (timeout)
	+import Tests (testcases)
	+import Unshortener (genFile)
	+
	+tests :: IO [Test]
	+tests = do
	+ let testResults = map createTest testcases
	+ pure testResults
	+
	+createTest :: (String, String) -> Test
	+createTest (_, f) =
	+ let test f =
	+ TestInstance
	+ { run = Finished <$> performTest f,
	+ name = f,
	+ tags = [],
	+ options = [],
	+ setOption = \_ _ -> Right $ test f
	+ }
	+ in Test $ test f
	+
	+performTest :: String -> IO Result
	+performTest f = do
	+ let parse = sequentParser f
	+ case parse of
	+ Left e -> pure $ Fail $ show e
	+ Right fm -> do
	+ (exit, _, error) <- readProcessWithExitCode "timeout" ["10s", "cabal", "run", "secav-prover", "--", f] []
	+ case exit of
	+ ExitFailure 124 -> pure Pass
	+ e -> pure $ Fail $ "proof succeeded on invalid formula" <> show e
	diff --git a/thys/FOL_Seq_Calc2/test/soundness/Tests.hs b/thys/FOL_Seq_Calc2/test/soundness/Tests.hs
	new file mode 100644
	--- /dev/null
	+++ b/thys/FOL_Seq_Calc2/test/soundness/Tests.hs
	@@ -0,0 +1,31 @@
	+module Tests where
	+
	+testcases :: [(String, String)]
	+testcases =
	+ [ ("imp", "Imp a b"),
	+ ("con", "Con a a"),
	+ ("p", "p"),
	+ ("functions", "p[a, f[a], f[f[a]]]"),
	+ ("ImpDisCon", "Imp (Dis p q) (Con p q)"),
	+ ("UniExi", "Imp (Exi p[0]) (Uni p[0])"),
	+ ("LEM-dual", "Con p (Neg p)"),
	+ ("negBasic", "Neg (Dis p p)"),
	+ ("negImp", "Neg (Imp p p)"),
	+ ("wrongImp", "Imp (Imp q (Imp p q)) p"),
	+ ("tripleNeg", "Neg (Neg (Neg (Dis p (Neg p))))"),
	+ ("doubleNeg", "Neg (Neg p)"),
	+ ("DisCon", "Dis (Con a b) (Con b a)"),
	+ ("WrongPre", "Imp (Uni p[0]) q[a]"),
	+ ("WrongFun", "Imp p[a] p[b]"),
	+ ("WrongUniVar", "Imp (Uni p[1]) p[a]"),
	+ ("ExiNotUni", "Imp (Exi p[0]) p[a]"),
	+ ("notAbsorb1", "Neg (Imp (Con p (Dis p q)) p)"),
	+ ("notAbsorb2", "Neg (Imp (Dis p (Con p q)) p)"),
	+ ("ex7.2b", "Imp (Imp (Uni p[0]) (Uni q[0])) (Uni (Imp p[0] q[0]))"),
	+ ("ex7.4b", "Imp (Uni (Imp A[0] B[0])) (Imp (Exi A[0]) (Uni B[0]))"),
	+ ("ex7.4c", "Imp (Dis (Uni A[0]) (Exi B[0])) (Uni (Dis A[0] B[0]))"),
	+ ("ex7.4d", "Imp (Imp (Exi A[0]) (Exi B[0])) (Uni (Imp A[0] B[0]))"),
	+ ("ex7.9", "Imp (Imp (Uni p[0]) (Uni q[0])) (Uni (Imp p[0] q[0]))"),
	+ ("ex9.4", "Imp (Uni (Exi A[1,0])) (Uni A[0, f[0]])"),
	+ ("multiDelta", "Dis (Uni P[0]) (Uni (Neg P[0]))")
	+ ]
	diff --git a/thys/FO_Theory_Rewriting/Closure/Context_Extensions.thy b/thys/FO_Theory_Rewriting/Closure/Context_Extensions.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Closure/Context_Extensions.thy
	@@ -0,0 +1,933 @@
	+theory Context_Extensions
	+ imports Regular_Tree_Relations.Ground_Ctxt
	+ Regular_Tree_Relations.Ground_Closure
	+ Ground_MCtxt
	+begin
	+
	+section \<open>Multihole context and context closures over predicates\<close>
	+
	+definition gctxtex_onp where
	+ "gctxtex_onp P \<R> = {(C\<langle>s\<rangle>\<^sub>G, C\<langle>t\<rangle>\<^sub>G) \| C s t. P C \<and> (s, t) \<in> \<R>}"
	+
	+definition gmctxtex_onp where
	+ "gmctxtex_onp P \<R> = {(fill_gholes C ss, fill_gholes C ts) \| C ss ts.
	+ num_gholes C = length ss \<and> length ss = length ts \<and> P C \<and> (\<forall> i < length ts. (ss ! i , ts ! i) \<in> \<R>)}"
	+
	+definition compatible_p where
	+ "compatible_p P Q \<equiv> (\<forall> C. P C \<longrightarrow> Q (gmctxt_of_gctxt C))"
	+
	+subsection \<open>Elimination and introduction rules for the extensions\<close>
	+
	+lemma gctxtex_onpE [elim]:
	+ assumes "(s, t) \<in> gctxtex_onp P \<R>"
	+ obtains C u v where "s = C\<langle>u\<rangle>\<^sub>G" "t = C\<langle>v\<rangle>\<^sub>G" "P C" "(u, v) \<in> \<R>"
	+ using assms unfolding gctxtex_onp_def by auto
	+
	+lemma gctxtex_onp_neq_rootE [elim]:
	+ assumes "(GFun f ss, GFun g ts) \<in> gctxtex_onp P \<R>" and "f \<noteq> g"
	+ shows "(GFun f ss, GFun g ts) \<in> \<R>"
	+proof -
	+ obtain C u v where "GFun f ss = C\<langle>u\<rangle>\<^sub>G" "GFun g ts = C\<langle>v\<rangle>\<^sub>G" "(u, v) \<in> \<R>"
	+ using assms(1) by auto
	+ then show ?thesis using assms(2)
	+ by (cases C) auto
	+qed
	+
	+lemma gctxtex_onp_neq_lengthE [elim]:
	+ assumes "(GFun f ss, GFun g ts) \<in> gctxtex_onp P \<R>" and "length ss \<noteq> length ts"
	+ shows "(GFun f ss, GFun g ts) \<in> \<R>"
	+proof -
	+ obtain C u v where "GFun f ss = C\<langle>u\<rangle>\<^sub>G" "GFun g ts = C\<langle>v\<rangle>\<^sub>G" "(u, v) \<in> \<R>"
	+ using assms(1) by auto
	+ then show ?thesis using assms(2)
	+ by (cases C) auto
	+qed
	+
	+lemma gmctxtex_onpE [elim]:
	+ assumes "(s, t) \<in> gmctxtex_onp P \<R>"
	+ obtains C us vs where "s = fill_gholes C us" "t = fill_gholes C vs" "num_gholes C = length us"
	+ "length us = length vs" "P C" "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
	+ using assms unfolding gmctxtex_onp_def by auto
	+
	+lemma gmctxtex_onpE2 [elim]:
	+ assumes "(s, t) \<in> gmctxtex_onp P \<R>"
	+ obtains C us vs where "s =\<^sub>G\<^sub>f (C, us)" "t =\<^sub>G\<^sub>f (C, vs)"
	+ "P C" "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
	+ using gmctxtex_onpE[OF assms] by (metis eq_gfill.intros)
	+
	+lemma gmctxtex_onp_neq_rootE [elim]:
	+ assumes "(GFun f ss, GFun g ts) \<in> gmctxtex_onp P \<R>" and "f \<noteq> g"
	+ shows "(GFun f ss, GFun g ts) \<in> \<R>"
	+proof -
	+ obtain C us vs where "GFun f ss = fill_gholes C us" "GFun g ts = fill_gholes C vs"
	+ "num_gholes C = length us" "length us = length vs" "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
	+ using assms(1) by auto
	+ then show ?thesis using assms(2)
	+ by (cases C; cases us; cases vs) auto
	+qed
	+
	+lemma gmctxtex_onp_neq_lengthE [elim]:
	+ assumes "(GFun f ss, GFun g ts) \<in> gmctxtex_onp P \<R>" and "length ss \<noteq> length ts"
	+ shows "(GFun f ss, GFun g ts) \<in> \<R>"
	+proof -
	+ obtain C us vs where "GFun f ss = fill_gholes C us" "GFun g ts = fill_gholes C vs"
	+ "num_gholes C = length us" "length us = length vs" "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
	+ using assms(1) by auto
	+ then show ?thesis using assms(2)
	+ by (cases C; cases us; cases vs) auto
	+qed
	+
	+lemma gmctxtex_onp_listE:
	+ assumes "\<forall> i < length ts. (ss ! i, ts ! i) \<in> gmctxtex_onp Q \<R>" "length ss = length ts"
	+ obtains Ds sss tss where "length ts = length Ds" "length Ds = length sss" "length sss = length tss"
	+ "\<forall> i < length tss. length (sss ! i) = length (tss ! i)" "\<forall> D \<in> set Ds. Q D"
	+ "\<forall> i < length tss. ss ! i =\<^sub>G\<^sub>f (Ds ! i, sss ! i)" "\<forall> i < length tss. ts ! i =\<^sub>G\<^sub>f (Ds ! i, tss ! i)"
	+ "\<forall> i < length (concat tss). (concat sss ! i, concat tss ! i) \<in> \<R>"
	+proof -
	+ let ?P = "\<lambda> W i. ss ! i =\<^sub>G\<^sub>f (fst W, fst (snd W)) \<and> ts ! i =\<^sub>G\<^sub>f (fst W, snd (snd W)) \<and>
	+ Q (fst W) \<and> (\<forall> i < length (snd (snd W)). (fst (snd W) ! i, snd (snd W) ! i) \<in> \<R>)"
	+ have "\<forall> i < length ts. \<exists> x. ?P x i" using assms gmctxtex_onpE2[of "ss ! i" "ts ! i" Q \<R> for i]
	+ by auto metis
	+ from Ex_list_of_length_P[OF this] obtain W where
	+ P: "length W = length ts" "\<forall> i < length ts. ?P (W ! i) i" by blast
	+ define Ds sss tss where "Ds \<equiv> map fst W" and "sss \<equiv> map (fst \<circ> snd) W" and "tss \<equiv> map (snd \<circ> snd) W"
	+ from P have len: "length ts = length Ds" "length Ds = length sss" "length sss = length tss" and
	+ pred: "\<forall> D \<in> set Ds. Q D" and
	+ split: "\<forall> i < length Ds. ss ! i =\<^sub>G\<^sub>f (Ds ! i, sss ! i) \<and> ts ! i =\<^sub>G\<^sub>f (Ds ! i, tss ! i)"and
	+ rec: "\<forall>i < length Ds. \<forall> j < length (tss ! i). (sss ! i ! j, tss ! i ! j) \<in> \<R>"
	+ using assms(2) by (auto simp: Ds_def sss_def tss_def dest!: in_set_idx)
	+ from len split have inn: "\<forall> i < length tss. length (sss ! i) = length (tss ! i)"
	+ by auto (metis eqgfE(2))
	+ from inn len rec have "\<forall> i < length (concat tss). (concat sss ! i, concat tss ! i) \<in> \<R>"
	+ by (intro concat_nth_nthI) auto
	+ then show "(\<And>Ds sss tss. length ts = length Ds \<Longrightarrow> length Ds = length sss \<Longrightarrow> length sss = length tss \<Longrightarrow>
	+ \<forall>i<length tss. length (sss ! i) = length (tss ! i) \<Longrightarrow> \<forall>D\<in>set Ds. Q D \<Longrightarrow>
	+ \<forall>i<length tss. ss ! i =\<^sub>G\<^sub>f (Ds ! i, sss ! i) \<Longrightarrow> \<forall>i<length tss. ts ! i =\<^sub>G\<^sub>f (Ds ! i, tss ! i) \<Longrightarrow>
	+ \<forall>i<length (concat tss). (concat sss ! i, concat tss ! i) \<in> \<R> \<Longrightarrow> thesis) \<Longrightarrow> thesis"
	+ using pred split inn len by auto
	+qed
	+
	+lemma gmctxtex_onp_doubleE [elim]:
	+ assumes "(s, t) \<in> gmctxtex_onp P (gmctxtex_onp Q \<R>)"
	+ obtains C Ds ss ts us vs where "s =\<^sub>G\<^sub>f (C, ss)" "t =\<^sub>G\<^sub>f (C, ts)" "P C" "\<forall> D \<in> set Ds. Q D"
	+ "num_gholes C = length Ds" "length Ds = length ss" "length ss = length ts" "length ts = length us" "length us = length vs"
	+ "\<forall> i < length Ds. ss ! i =\<^sub>G\<^sub>f (Ds ! i, us ! i) \<and> ts ! i =\<^sub>G\<^sub>f (Ds ! i, vs ! i)"
	+ "\<forall> i < length Ds. \<forall> j < length (vs ! i). (us ! i ! j, vs ! i ! j) \<in> \<R>"
	+proof -
	+ from gmctxtex_onpE2[OF assms] obtain C ss ts where
	+ split: "s =\<^sub>G\<^sub>f (C, ss)" "t =\<^sub>G\<^sub>f (C, ts)" and
	+ len: "num_gholes C = length ss" "length ss = length ts" and
	+ pred: "P C" and rec: "\<forall> i < length ts. (ss ! i, ts ! i) \<in> gmctxtex_onp Q \<R>"
	+ by (metis eqgfE(2))
	+ let ?P = "\<lambda> W i. ss ! i =\<^sub>G\<^sub>f (fst W, fst (snd W)) \<and> ts ! i =\<^sub>G\<^sub>f (fst W, snd (snd W)) \<and>
	+ Q (fst W) \<and> (\<forall> i < length (snd (snd W)). (fst (snd W) ! i, snd (snd W) ! i) \<in> \<R>)"
	+ have "\<forall> i < length ts. \<exists> x. ?P x i" using rec gmctxtex_onpE2[of "ss ! i" "ts ! i" Q \<R> for i]
	+ by auto metis
	+ from Ex_list_of_length_P[OF this] obtain W where
	+ P: "length W = length ts" "\<forall> i < length ts. ?P (W ! i) i" by blast
	+ define Ds us vs where "Ds \<equiv> map fst W" and "us \<equiv> map (fst \<circ> snd) W" and "vs \<equiv> map (snd \<circ> snd) W"
	+ from P have len': "length Ds = length ss" "length ss = length ts" "length ts = length us" "length us = length vs" and
	+ pred': "\<forall> D \<in> set Ds. Q D" and
	+ split': "\<forall> i < length Ds. ss ! i =\<^sub>G\<^sub>f (Ds ! i, us ! i) \<and> ts ! i =\<^sub>G\<^sub>f (Ds ! i, vs ! i)"and
	+ rec': "\<forall>i < length Ds. \<forall> j < length (vs ! i). (us ! i ! j, vs ! i ! j) \<in> \<R>"
	+ using len by (auto simp: Ds_def us_def vs_def dest!: in_set_idx)
	+ from len' len have "num_gholes C = length Ds" by simp
	+ from this split pred pred' len' split' rec' len
	+ show "(\<And>C ss ts Ds us vs. s =\<^sub>G\<^sub>f (C, ss) \<Longrightarrow> t =\<^sub>G\<^sub>f (C, ts) \<Longrightarrow> P C \<Longrightarrow>
	+ \<forall>D\<in>set Ds. Q D \<Longrightarrow> num_gholes C = length Ds \<Longrightarrow> length Ds = length ss \<Longrightarrow> length ss = length ts \<Longrightarrow>
	+ length ts = length us \<Longrightarrow> length us = length vs \<Longrightarrow>
	+ \<forall>i<length Ds. ss ! i =\<^sub>G\<^sub>f (Ds ! i, us ! i) \<and> ts ! i =\<^sub>G\<^sub>f (Ds ! i, vs ! i) \<Longrightarrow>
	+ \<forall>i<length Ds. \<forall>j<length (vs ! i). (us ! i ! j, vs ! i ! j) \<in> \<R> \<Longrightarrow> thesis) \<Longrightarrow> thesis"
	+ by blast
	+qed
	+
	+lemma gctxtex_onpI [intro]:
	+ assumes "P C" and "(s, t) \<in> \<R>"
	+ shows "(C\<langle>s\<rangle>\<^sub>G, C\<langle>t\<rangle>\<^sub>G) \<in> gctxtex_onp P \<R>"
	+ using assms by (auto simp: gctxtex_onp_def)
	+
	+lemma gmctxtex_onpI [intro]:
	+ assumes "P C" and "num_gholes C = length us" and "length us = length vs"
	+ and "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
	+ shows "(fill_gholes C us, fill_gholes C vs) \<in> gmctxtex_onp P \<R>"
	+ using assms unfolding gmctxtex_onp_def
	+ by force
	+
	+lemma gmctxtex_onp_arg_monoI:
	+ assumes "P GMHole"
	+ shows "\<R> \<subseteq> gmctxtex_onp P \<R>" using assms
	+proof (intro subsetI)
	+ fix s assume mem: "s \<in> \<R>"
	+ have *: "(fill_gholes GMHole [fst s], fill_gholes GMHole [snd s]) = s" by auto
	+ have "(fill_gholes GMHole [fst s], fill_gholes GMHole [snd s]) \<in> gmctxtex_onp P \<R>"
	+ by (intro gmctxtex_onpI) (auto simp: assms mem)
	+ then show "s \<in> gmctxtex_onp P \<R>" unfolding * .
	+qed
	+
	+lemma gmctxtex_onpI2 [intro]:
	+ assumes "P C" and "s =\<^sub>G\<^sub>f (C, ss)" "t =\<^sub>G\<^sub>f (C, ts)"
	+ and "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>"
	+ shows "(s, t) \<in> gmctxtex_onp P \<R>"
	+ using eqgfE[OF assms(2)] eqgfE[OF assms(3)]
	+ using gmctxtex_onpI[of P, OF assms(1) _ _ assms(4)]
	+ by (simp add: \<open>num_gholes C = length ss\<close>)
	+
	+lemma gctxtex_onp_hold_cond [simp]:
	+ "(s, t) \<in> gctxtex_onp P \<R> \<Longrightarrow> groot s \<noteq> groot t \<Longrightarrow> P \<box>\<^sub>G"
	+ "(s, t) \<in> gctxtex_onp P \<R> \<Longrightarrow> length (gargs s) \<noteq> length (gargs t) \<Longrightarrow> P \<box>\<^sub>G"
	+ by (auto elim!: gctxtex_onpE, case_tac C; auto)+
	+
	+subsection \<open>Monotonicity rules for the extensions\<close>
	+
	+lemma gctxtex_onp_rel_mono:
	+ "\<L> \<subseteq> \<R> \<Longrightarrow> gctxtex_onp P \<L> \<subseteq> gctxtex_onp P \<R>"
	+ unfolding gctxtex_onp_def by auto
	+
	+lemma gmctxtex_onp_rel_mono:
	+ "\<L> \<subseteq> \<R> \<Longrightarrow> gmctxtex_onp P \<L> \<subseteq> gmctxtex_onp P \<R>"
	+ unfolding gmctxtex_onp_def
	+ by auto (metis subsetD)
	+
	+lemma compatible_p_gctxtex_gmctxtex_subseteq [dest]:
	+ "compatible_p P Q \<Longrightarrow> gctxtex_onp P \<R> \<subseteq> gmctxtex_onp Q \<R>"
	+ unfolding compatible_p_def
	+ by (auto simp: apply_gctxt_fill_gholes gmctxtex_onpI)
	+
	+lemma compatible_p_mono1:
	+ "P \<le> R \<Longrightarrow> compatible_p R Q \<Longrightarrow> compatible_p P Q"
	+ unfolding compatible_p_def by auto
	+
	+lemma compatible_p_mono2:
	+ "Q \<le> R \<Longrightarrow> compatible_p P Q \<Longrightarrow> compatible_p P R"
	+ unfolding compatible_p_def by auto
	+
	+lemma gctxtex_onp_mono [intro]:
	+ "P \<le> Q \<Longrightarrow> gctxtex_onp P \<R> \<subseteq> gctxtex_onp Q \<R>"
	+ by auto
	+
	+lemma gctxtex_onp_mem:
	+ "P \<le> Q \<Longrightarrow> (s, t) \<in> gctxtex_onp P \<R> \<Longrightarrow> (s, t) \<in> gctxtex_onp Q \<R>"
	+ by auto
	+
	+lemma gmctxtex_onp_mono [intro]:
	+ "P \<le> Q \<Longrightarrow> gmctxtex_onp P \<R> \<subseteq> gmctxtex_onp Q \<R>"
	+ by (auto elim!: gmctxtex_onpE)
	+
	+lemma gmctxtex_onp_mem:
	+ "P \<le> Q \<Longrightarrow> (s, t) \<in> gmctxtex_onp P \<R> \<Longrightarrow> (s, t) \<in> gmctxtex_onp Q \<R>"
	+ by (auto dest!: gmctxtex_onp_mono)
	+
	+lemma gctxtex_eqI [intro]:
	+ "P = Q \<Longrightarrow> \<R> = \<L> \<Longrightarrow> gctxtex_onp P \<R> = gctxtex_onp Q \<L>"
	+ by auto
	+
	+lemma gmctxtex_eqI [intro]:
	+ "P = Q \<Longrightarrow> \<R> = \<L> \<Longrightarrow> gmctxtex_onp P \<R> = gmctxtex_onp Q \<L>"
	+ by auto
	+
	+subsection \<open>Relation swap and converse\<close>
	+
	+lemma swap_gctxtex_onp:
	+ "gctxtex_onp P (prod.swap ` \<R>) = prod.swap ` gctxtex_onp P \<R>"
	+ by (auto simp: gctxtex_onp_def image_def) force+
	+
	+lemma swap_gmctxtex_onp:
	+ "gmctxtex_onp P (prod.swap ` \<R>) = prod.swap ` gmctxtex_onp P \<R>"
	+ by (auto simp: gmctxtex_onp_def image_def) force+
	+
	+lemma converse_gctxtex_onp:
	+ "(gctxtex_onp P \<R>)\<inverse> = gctxtex_onp P (\<R>\<inverse>)"
	+ by (auto simp: gctxtex_onp_def)
	+
	+lemma converse_gmctxtex_onp:
	+ "(gmctxtex_onp P \<R>)\<inverse> = gmctxtex_onp P (\<R>\<inverse>)"
	+ by (auto simp: gmctxtex_onp_def) force+
	+
	+subsection \<open>Subset equivalence for context extensions over predicates\<close>
	+
	+lemma gctxtex_onp_closure_predI:
	+ assumes "\<And> C s t. P C \<Longrightarrow> (s, t) \<in> \<R> \<Longrightarrow> (C\<langle>s\<rangle>\<^sub>G, C\<langle>t\<rangle>\<^sub>G) \<in> \<R>"
	+ shows "gctxtex_onp P \<R> \<subseteq> \<R>"
	+ using assms by auto
	+
	+lemma gmctxtex_onp_closure_predI:
	+ assumes "\<And> C ss ts. P C \<Longrightarrow> num_gholes C = length ss \<Longrightarrow> length ss = length ts \<Longrightarrow>
	+ (\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>) \<Longrightarrow> (fill_gholes C ss, fill_gholes C ts) \<in> \<R>"
	+ shows "gmctxtex_onp P \<R> \<subseteq> \<R>"
	+ using assms by auto
	+
	+lemma gctxtex_onp_closure_predE:
	+ assumes "gctxtex_onp P \<R> \<subseteq> \<R>"
	+ shows "\<And> C s t. P C \<Longrightarrow> (s, t) \<in> \<R> \<Longrightarrow> (C\<langle>s\<rangle>\<^sub>G, C\<langle>t\<rangle>\<^sub>G) \<in> \<R>"
	+ using assms by auto
	+
	+lemma gctxtex_closure [intro]:
	+ "P \<box>\<^sub>G \<Longrightarrow> \<R> \<subseteq> gctxtex_onp P \<R>"
	+ by (auto simp: gctxtex_onp_def) force
	+
	+lemma gmctxtex_closure [intro]:
	+ assumes "P GMHole"
	+ shows "\<R> \<subseteq> (gmctxtex_onp P \<R>)"
	+proof -
	+ {fix s t assume "(s, t) \<in> \<R>" then have "(s, t) \<in> gmctxtex_onp P \<R>"
	+ using gmctxtex_onpI[of P GMHole "[s]" "[t]"] assms by auto}
	+ then show ?thesis by auto
	+qed
	+
	+lemma gctxtex_pred_cmp_subseteq:
	+ assumes "\<And> C D. P C \<Longrightarrow> Q D \<Longrightarrow> Q (C \<circ>\<^sub>G\<^sub>c D)"
	+ shows "gctxtex_onp P (gctxtex_onp Q \<R>) \<subseteq> gctxtex_onp Q \<R>"
	+ using assms by (auto simp: gctxtex_onp_def) (metis ctxt_ctxt_compose)
	+
	+lemma gctxtex_pred_cmp_subseteq2:
	+ assumes "\<And> C D. P C \<Longrightarrow> Q D \<Longrightarrow> P (C \<circ>\<^sub>G\<^sub>c D)"
	+ shows "gctxtex_onp P (gctxtex_onp Q \<R>) \<subseteq> gctxtex_onp P \<R>"
	+ using assms by (auto simp: gctxtex_onp_def) (metis ctxt_ctxt_compose)
	+
	+lemma gmctxtex_pred_cmp_subseteq:
	+ assumes "\<And> C D. C \<le> D \<Longrightarrow> P C \<Longrightarrow> (\<forall> Ds \<in> set (sup_gmctxt_args C D). Q Ds) \<Longrightarrow> Q D"
	+ shows "gmctxtex_onp P (gmctxtex_onp Q \<R>) \<subseteq> gmctxtex_onp Q \<R>" (is "?Ls \<subseteq> ?Rs")
	+proof -
	+ {fix s t assume "(s, t) \<in> ?Ls"
	+ then obtain C Ds ss ts us vs where
	+ split: "s =\<^sub>G\<^sub>f (C, ss)" "t =\<^sub>G\<^sub>f (C, ts)" and
	+ len: "num_gholes C = length Ds" "length Ds = length ss" "length ss = length ts"
	+ "length ts = length us" "length us = length vs" and
	+ pred: "P C" "\<forall> D \<in> set Ds. Q D" and
	+ split': "\<forall> i < length Ds. ss ! i =\<^sub>G\<^sub>f (Ds ! i, us ! i) \<and> ts ! i =\<^sub>G\<^sub>f (Ds ! i, vs ! i)" and
	+ rec: " \<forall>i<length Ds. \<forall>j<length (vs ! i). (us ! i ! j, vs ! i ! j) \<in> \<R>"
	+ by auto
	+ from pred(2) assms[OF _ pred(1), of "fill_gholes_gmctxt C Ds"] len
	+ have P: "Q (fill_gholes_gmctxt C Ds)"
	+ by (simp add: fill_gholes_gmctxt_less_eq)
	+ have mem: "\<forall> i < length (concat vs). (concat us ! i, concat vs ! i) \<in> \<R>"
	+ using rec split' len
	+ by (intro concat_nth_nthI) (auto, metis eqgfE(2))
	+ have "(s, t) \<in> ?Rs" using split' split len
	+ by (intro gmctxtex_onpI2[of Q, OF P _ _ mem])
	+ (metis eqgfE(1) fill_gholes_gmctxt_sound)+}
	+ then show ?thesis by auto
	+qed
	+
	+lemma gmctxtex_pred_cmp_subseteq2:
	+ assumes "\<And> C D. C \<le> D \<Longrightarrow> P C \<Longrightarrow> (\<forall> Ds \<in> set (sup_gmctxt_args C D). Q Ds) \<Longrightarrow> P D"
	+ shows "gmctxtex_onp P (gmctxtex_onp Q \<R>) \<subseteq> gmctxtex_onp P \<R>" (is "?Ls \<subseteq> ?Rs")
	+proof -
	+ {fix s t assume "(s, t) \<in> ?Ls"
	+ then obtain C Ds ss ts us vs where
	+ split: "s =\<^sub>G\<^sub>f (C, ss)" "t =\<^sub>G\<^sub>f (C, ts)" and
	+ len: "num_gholes C = length Ds" "length Ds = length ss" "length ss = length ts"
	+ "length ts = length us" "length us = length vs" and
	+ pred: "P C" "\<forall> D \<in> set Ds. Q D" and
	+ split': "\<forall> i < length Ds. ss ! i =\<^sub>G\<^sub>f (Ds ! i, us ! i) \<and> ts ! i =\<^sub>G\<^sub>f (Ds ! i, vs ! i)" and
	+ rec: " \<forall>i<length Ds. \<forall>j<length (vs ! i). (us ! i ! j, vs ! i ! j) \<in> \<R>"
	+ by auto
	+ from pred(2) assms[OF _ pred(1), of "fill_gholes_gmctxt C Ds"] len
	+ have P: "P (fill_gholes_gmctxt C Ds)"
	+ by (simp add: fill_gholes_gmctxt_less_eq)
	+ have mem: "\<forall> i < length (concat vs). (concat us ! i, concat vs ! i) \<in> \<R>" using rec split' len
	+ by (intro concat_nth_nthI) (auto, metis eqgfE(2))
	+ have "(s, t) \<in> ?Rs" using split' split len
	+ by (intro gmctxtex_onpI2[of P, OF P _ _ mem])
	+ (metis eqgfE(1) fill_gholes_gmctxt_sound)+}
	+ then show ?thesis by auto
	+qed
	+
	+lemma gctxtex_onp_idem [simp]:
	+ assumes "P \<box>\<^sub>G" and "\<And> C D. P C \<Longrightarrow> Q D \<Longrightarrow> Q (C \<circ>\<^sub>G\<^sub>c D)"
	+ shows "gctxtex_onp P (gctxtex_onp Q \<R>) = gctxtex_onp Q \<R>" (is "?Ls = ?Rs")
	+ by (simp add: assms gctxtex_pred_cmp_subseteq gctxtex_closure subset_antisym)
	+
	+lemma gctxtex_onp_idem2 [simp]:
	+ assumes "Q \<box>\<^sub>G" and "\<And> C D. P C \<Longrightarrow> Q D \<Longrightarrow> P (C \<circ>\<^sub>G\<^sub>c D)"
	+ shows "gctxtex_onp P (gctxtex_onp Q \<R>) = gctxtex_onp P \<R>" (is "?Ls = ?Rs")
	+ using gctxtex_pred_cmp_subseteq2[of P Q, OF assms(2)]
	+ using gctxtex_closure[of Q, OF assms(1)] in_mono
	+ by auto fastforce
	+
	+lemma gmctxtex_onp_idem [simp]:
	+ assumes "P GMHole"
	+ and "\<And> C D. C \<le> D \<Longrightarrow> P C \<Longrightarrow> (\<forall> Ds \<in> set (sup_gmctxt_args C D). Q Ds) \<Longrightarrow> Q D"
	+ shows "gmctxtex_onp P (gmctxtex_onp Q \<R>) = gmctxtex_onp Q \<R>"
	+ using gmctxtex_pred_cmp_subseteq[of P Q \<R>] gmctxtex_closure[of P] assms
	+ by auto
	+
	+subsection \<open>@{const gmctxtex_onp} subset equivalence @{const gctxtex_onp} transitive closure\<close>
	+
	+text \<open>The following definition demands that if we arbitrarily fill a multihole context C with terms
	+ induced by signature F such that one hole remains then the predicate Q holds\<close>
	+definition "gmctxt_p_inv C \<F> Q \<equiv> (\<forall> D. gmctxt_closing C D \<longrightarrow> num_gholes D = 1 \<longrightarrow> funas_gmctxt D \<subseteq> \<F>
	+ \<longrightarrow> Q (gctxt_of_gmctxt D))"
	+
	+lemma gmctxt_p_invE:
	+ "gmctxt_p_inv C \<F> Q \<Longrightarrow> C \<le> D \<Longrightarrow> ghole_poss D \<subseteq> ghole_poss C \<Longrightarrow> num_gholes D = 1 \<Longrightarrow>
	+ funas_gmctxt D \<subseteq> \<F> \<Longrightarrow> Q (gctxt_of_gmctxt D)"
	+ unfolding gmctxt_closing_def gmctxt_p_inv_def
	+ using less_eq_gmctxt_prime by blast
	+
	+lemma gmctxt_closing_gmctxt_p_inv_comp:
	+ "gmctxt_closing C D \<Longrightarrow> gmctxt_p_inv C \<F> Q \<Longrightarrow> gmctxt_p_inv D \<F> Q"
	+ unfolding gmctxt_closing_def gmctxt_p_inv_def
	+ by auto (meson less_eq_gmctxt_prime order_trans)
	+
	+lemma GMHole_gmctxt_p_inv_GHole [simp]:
	+ "gmctxt_p_inv GMHole \<F> Q \<Longrightarrow> Q \<box>\<^sub>G"
	+ by (auto dest: gmctxt_p_invE)
	+
	+
	+lemma gmctxtex_onp_gctxtex_onp_trancl:
	+ assumes sig: "\<And> C. P C \<Longrightarrow> 0 < num_gholes C \<and> funas_gmctxt C \<subseteq> \<F>" "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ and "\<And> C. P C \<Longrightarrow> gmctxt_p_inv C \<F> Q"
	+ shows "gmctxtex_onp P \<R> \<subseteq> (gctxtex_onp Q \<R>)\<^sup>+"
	+proof
	+ fix s t assume "(s, t) \<in> gmctxtex_onp P \<R>"
	+ then obtain C ss ts where
	+ split: "s = fill_gholes C ss" "t = fill_gholes C ts" and
	+ inv: "num_gholes C = length ss" "num_gholes C = length ts" and
	+ pred: "P C" and rec: "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>"
	+ by auto
	+ from pred have "0 < num_gholes C" "funas_gmctxt C \<subseteq> \<F>" using sig by auto
	+ from this inv assms(3)[OF pred] rec show "(s, t) \<in> (gctxtex_onp Q \<R>)\<^sup>+" unfolding split
	+ proof (induct "num_gholes C" arbitrary: C ss ts)
	+ case (Suc x) note IS = this then show ?case
	+ proof (cases C)
	+ case GMHole then show ?thesis
	+ using IS(2-) gctxtex_closure unfolding gmctxt_p_inv_def gmctxt_closing_def
	+ by (metis One_nat_def fill_gholes_GMHole gctxt_of_gmctxt.simps(1)
	+ gmctxt_order_bot.bot.extremum_unique less_eq_gmctxt_prime num_gholes.simps(1) r_into_trancl' subsetD subsetI)
	+ next
	+ case [simp]: (GMFun f Cs) note IS = IS[unfolded GMFun]
	+ let ?rep = "\<lambda> x. replicate (num_gholes (GMFun f Cs) - 1) x"
	+ let ?Ds1 = "?rep GMHole @ [gmctxt_of_gterm (last ss)]"
	+ let ?Ds2 = "map gmctxt_of_gterm (butlast ts) @ [GMHole]"
	+ let ?D1 = "fill_gholes_gmctxt (GMFun f Cs) ?Ds1"
	+ let ?D2 = "fill_gholes_gmctxt (GMFun f Cs) ?Ds2"
	+ have holes: "num_gholes (GMFun f Cs) = length ?Ds1" "num_gholes (GMFun f Cs) = length ?Ds2"
	+ using IS(2, 5, 6) by auto
	+ from holes(2) have [simp]: "num_gholes ?D2 = Suc 0"
	+ by (auto simp: num_gholes_fill_gholes_gmctxt simp del: fill_gholes_gmctxt.simps)
	+ from holes(1) have h: "x = num_gholes ?D1" using IS(2)
	+ by (auto simp: num_gholes_fill_gholes_gmctxt simp del: fill_gholes_gmctxt.simps)
	+ from holes have less: "GMFun f Cs \<le> ?D1" "GMFun f Cs \<le> ?D2"
	+ by (auto simp del: fill_gholes_gmctxt.simps intro: fill_gholes_gmctxt_less_eq)
	+ have "ghole_poss ?D1 \<subseteq> ghole_poss (GMFun f Cs)" using less(1) IS(2, 3)
	+ by (intro fill_gholes_gmctxt_ghole_poss_subseteq) (auto simp: nth_append)
	+ then have ext: "gmctxt_p_inv ?D1 \<F> Q" using less(1) IS(7)
	+ using gmctxt_closing_def gmctxt_closing_gmctxt_p_inv_comp less_eq_gmctxt_prime
	+ by blast
	+ have split_last_D1_ss: "fill_gholes C (butlast ts @ [last ss]) =\<^sub>G\<^sub>f (?D1, concat (map (\<lambda> x. [x]) (butlast ts) @ [[]]))"
	+ using holes(1) IS(2, 5, 6) unfolding GMFun
	+ by (intro fill_gholes_gmctxt_sound)
	+ (auto simp: nth_append eq_gfill.simps nth_butlast)
	+ have split_last_D2_ss: "fill_gholes C (butlast ts @ [last ss]) =\<^sub>G\<^sub>f (?D2, concat (?rep [] @ [[last ss]]))"
	+ using holes(2) IS(2, 5, 6) unfolding GMFun
	+ by (intro fill_gholes_gmctxt_sound) (auto simp: nth_append
	+ eq_gfill.simps nth_butlast last_conv_nth intro: last_nthI)
	+ have split_last_ts: "fill_gholes C ts =\<^sub>G\<^sub>f (?D2, concat (?rep [] @ [[last ts]]))"
	+ using holes(2) IS(2, 5, 6) unfolding GMFun
	+ by (intro fill_gholes_gmctxt_sound) (auto simp: nth_append
	+ eq_gfill.simps nth_butlast last_conv_nth intro: last_nthI)
	+ from eqgfE[OF split_last_ts] have last_eq: "fill_gholes C ts = fill_gholes ?D2 [last ts]"
	+ by (auto simp del: fill_gholes.simps fill_gholes_gmctxt.simps)
	+ have trans: "fill_gholes ?D1 (butlast ts) = fill_gholes ?D2 [last ss]"
	+ using eqgfE[OF split_last_D1_ss] eqgfE[OF split_last_D2_ss]
	+ by (auto simp del: fill_gholes.simps fill_gholes_gmctxt.simps)
	+ have "ghole_poss ?D2 \<subseteq> ghole_poss (GMFun f Cs)" using less(2) IS(2, 3, 6)
	+ by (intro fill_gholes_gmctxt_ghole_poss_subseteq) (auto simp: nth_append)
	+ then have "Q (gctxt_of_gmctxt ?D2)" using less(2)
	+ using subsetD[OF assms(2)] IS(2 - 6, 8) holes(2)
	+ by (intro gmctxt_p_invE[OF IS(7)])
	+ (auto simp del: fill_gholes_gmctxt.simps simp: num_gholes_fill_gholes_gmctxt
	+ in_set_conv_nth \<T>\<^sub>G_equivalent_def nth_butlast, metis less_SucI subsetD)
	+ from gctxtex_onpI[of Q _ "last ss" "last ts" \<R>, OF this] IS(2, 3, 5, 6, 8)
	+ have mem: "(fill_gholes ?D2 [last ss], fill_gholes ?D2 [last ts]) \<in> gctxtex_onp Q \<R>"
	+ using fill_gholes_apply_gctxt[of ?D2 "last ss"]
	+ using fill_gholes_apply_gctxt[of ?D2 "last ts"]
	+ by (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps)
	+ (metis IS(2) IS(3) append_butlast_last_id diff_Suc_1 length_butlast
	+ length_greater_0_conv lessI nth_append_length)
	+ show ?thesis
	+ proof (cases x)
	+ case 0 then show ?thesis using mem IS(2 - 6) eqgfE[OF split_last_D2_ss] last_eq
	+ by (cases ss; cases ts)
	+ (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps,
	+ metis IS(3, 5) length_0_conv less_not_refl)
	+ next
	+ case [simp]: (Suc nat)
	+ have "fill_gholes C ss =\<^sub>G\<^sub>f (?D1, concat (map (\<lambda> x. [x]) (butlast ss) @ [[]]))"
	+ using holes(1) IS(2, 5, 6) unfolding GMFun
	+ by (intro fill_gholes_gmctxt_sound)
	+ (auto simp del: fill_gholes_gmctxt.simps fill_gholes.simps
	+ simp: nth_append nth_butlast eq_gfill.intros last_nthI)
	+ from eqgfE[OF this] have l: "fill_gholes C ss = fill_gholes ?D1 (butlast ss)"
	+ by (auto simp del: fill_gholes_gmctxt.simps fill_gholes.simps)
	+ from IS(1)[OF h _ _ _ _ ext, of "butlast ss" "butlast ts"] IS(2-) holes(2) h assms(2)
	+ have "(fill_gholes ?D1 (butlast ss), fill_gholes ?D1 (butlast ts)) \<in> (gctxtex_onp Q \<R>)\<^sup>+"
	+ by (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps
	+ simp: \<T>\<^sub>G_equivalent_def)
	+ (smt Suc.prems(1) Suc.prems(4) diff_Suc_1 last_conv_nth length_butlast
	+ length_greater_0_conv lessI less_SucI mem_Sigma_iff nth_butlast sig(2) subset_iff \<T>\<^sub>G_funas_gterm_conv)
	+ then have "(fill_gholes ?D1 (butlast ss), fill_gholes ?D2 [last ts]) \<in> (gctxtex_onp Q \<R>)\<^sup>+"
	+ using mem unfolding trans
	+ by (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps)
	+ then show ?thesis unfolding last_eq l
	+ by (auto simp del: fill_gholes_gmctxt.simps fill_gholes.simps)
	+ qed
	+ qed
	+ qed auto
	+qed
	+
	+lemma gmctxtex_onp_gctxtex_onp_rtrancl:
	+ assumes sig: "\<And> C. P C \<Longrightarrow> funas_gmctxt C \<subseteq> \<F>" "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ and "\<And> C D. P C \<Longrightarrow> gmctxt_p_inv C \<F> Q"
	+ shows "gmctxtex_onp P \<R> \<subseteq> (gctxtex_onp Q \<R>)\<^sup>*"
	+proof
	+ fix s t assume "(s, t) \<in> gmctxtex_onp P \<R>"
	+ then obtain C ss ts where
	+ split: "s = fill_gholes C ss" "t = fill_gholes C ts" and
	+ inv: "num_gholes C = length ss" "num_gholes C = length ts" and
	+ pred: "P C" and rec: "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>"
	+ by auto
	+ then show "(s, t) \<in> (gctxtex_onp Q \<R>)\<^sup>*"
	+ proof (cases "num_gholes C")
	+ case 0 then show ?thesis using inv unfolding split
	+ by auto
	+ next
	+ case (Suc nat)
	+ from split inv pred rec assms
	+ have "(s, t) \<in> gmctxtex_onp (\<lambda> C. P C \<and> 0 < num_gholes C) \<R>" unfolding split
	+ by auto (metis (no_types, lifting) Suc gmctxtex_onpI zero_less_Suc)
	+ moreover have "gmctxtex_onp (\<lambda> C. P C \<and> 0 < num_gholes C) \<R> \<subseteq> (gctxtex_onp Q \<R>)\<^sup>+" using assms
	+ by (intro gmctxtex_onp_gctxtex_onp_trancl) auto
	+ ultimately show ?thesis by auto
	+ qed
	+qed
	+
	+lemma rtrancl_gmctxtex_onp_rtrancl_gctxtex_onp_eq:
	+ assumes sig: "\<And> C. P C \<Longrightarrow> funas_gmctxt C \<subseteq> \<F>" "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ and "\<And> C D. P C \<Longrightarrow> gmctxt_p_inv C \<F> Q"
	+ and "compatible_p Q P"
	+ shows "(gmctxtex_onp P \<R>)\<^sup>* = (gctxtex_onp Q \<R>)\<^sup>" (is "?Ls\<^sup> = ?Rs\<^sup>*")
	+proof -
	+ from assms(4) have "?Rs \<subseteq> ?Ls" by auto
	+ then have "?Rs\<^sup>* \<subseteq> ?Ls\<^sup>*"
	+ by (simp add: rtrancl_mono)
	+ moreover from gmctxtex_onp_gctxtex_onp_rtrancl[OF assms(1 - 3), of P]
	+ have "?Ls\<^sup>* \<subseteq> ?Rs\<^sup>*"
	+ by (simp add: rtrancl_subset_rtrancl)
	+ ultimately show ?thesis by blast
	+qed
	+
	+subsection \<open>Extensions to reflexive transitive closures\<close>
	+
	+lemma gctxtex_onp_substep_trancl:
	+ assumes "gctxtex_onp P \<R> \<subseteq> \<R>"
	+ shows "gctxtex_onp P (\<R>\<^sup>+) \<subseteq> \<R>\<^sup>+"
	+proof -
	+ {fix s t assume "(s, t) \<in> gctxtex_onp P (\<R>\<^sup>+)"
	+ then obtain C u v where rec: "(u, v) \<in> \<R>\<^sup>+" "P C" and t: "s = C\<langle>u\<rangle>\<^sub>G" "t = C\<langle>v\<rangle>\<^sub>G"
	+ by auto
	+ from rec have "(s, t) \<in> \<R>\<^sup>+" unfolding t
	+ proof (induct)
	+ case (base y)
	+ then show ?case using assms by auto
	+ next
	+ case (step y z)
	+ from assms step(2, 4) have "(C\<langle>y\<rangle>\<^sub>G, C\<langle>z\<rangle>\<^sub>G) \<in> \<R>" by auto
	+ then show ?case using step by auto
	+ qed}
	+ then show ?thesis by auto
	+qed
	+
	+lemma gctxtex_onp_substep_rtrancl:
	+ assumes "gctxtex_onp P \<R> \<subseteq> \<R>"
	+ shows "gctxtex_onp P (\<R>\<^sup>) \<subseteq> \<R>\<^sup>"
	+ using gctxtex_onp_substep_trancl[OF assms]
	+ by (smt gctxtex_onpE gctxtex_onpI rtrancl_eq_or_trancl subrelI subset_eq)
	+
	+lemma gctxtex_onp_substep_trancl_diff_pred [intro]:
	+ assumes "\<And> C D. P C \<Longrightarrow> Q D \<Longrightarrow> Q (D \<circ>\<^sub>G\<^sub>c C)"
	+ shows "gctxtex_onp Q ((gctxtex_onp P \<R>)\<^sup>+) \<subseteq> (gctxtex_onp Q \<R>)\<^sup>+"
	+proof
	+ fix s t assume "(s, t) \<in> gctxtex_onp Q ((gctxtex_onp P \<R>)\<^sup>+)"
	+ from gctxtex_onpE[OF this] obtain C u v where
	+ *: "s = C\<langle>u\<rangle>\<^sub>G" "t = C\<langle>v\<rangle>\<^sub>G" and inv: "Q C" and mem: "(u, v) \<in> (gctxtex_onp P \<R>)\<^sup>+"
	+ by blast
	+ show "(s, t) \<in> (gctxtex_onp Q \<R>)\<^sup>+" using mem * inv
	+ proof (induct arbitrary: s t)
	+ case (base y)
	+ then show ?case using assms
	+ by (auto elim!: gctxtex_onpE intro!: r_into_trancl) (metis ctxt_ctxt_compose gctxtex_onpI)
	+ next
	+ case (step y z)
	+ from step(2) have "(C\<langle>y\<rangle>\<^sub>G, C\<langle>z\<rangle>\<^sub>G) \<in> gctxtex_onp Q \<R>"
	+ using assms[OF _ step(6)]
	+ by (auto elim!: gctxtex_onpE) (metis ctxt_ctxt_compose gctxtex_onpI)
	+ then show ?case using step(3)[of s "C\<langle>y\<rangle>\<^sub>G"] step(1, 2, 4-)
	+ by auto
	+ qed
	+qed
	+
	+lemma gctxtcl_pres_trancl:
	+ assumes "(s, t) \<in> \<R>\<^sup>+" and "gctxtex_onp P \<R> \<subseteq> \<R>" and "P C"
	+ shows "(C\<langle>s\<rangle>\<^sub>G, C\<langle>t\<rangle>\<^sub>G) \<in> \<R>\<^sup>+"
	+ using gctxtex_onp_substep_trancl [OF assms(2)] assms(1, 3)
	+ by auto
	+
	+lemma gctxtcl_pres_rtrancl:
	+ assumes "(s, t) \<in> \<R>\<^sup>*" and "gctxtex_onp P \<R> \<subseteq> \<R>" and "P C"
	+ shows "(C\<langle>s\<rangle>\<^sub>G, C\<langle>t\<rangle>\<^sub>G) \<in> \<R>\<^sup>*"
	+ using assms(1) gctxtcl_pres_trancl[OF _ assms(2, 3)]
	+ unfolding rtrancl_eq_or_trancl
	+ by (cases "s = t") auto
	+
	+
	+lemma gmctxtex_onp_substep_trancl:
	+ assumes "gmctxtex_onp P \<R> \<subseteq> \<R>"
	+ and "Id_on (snd ` \<R>) \<subseteq> \<R>"
	+ shows "gmctxtex_onp P (\<R>\<^sup>+) \<subseteq> \<R>\<^sup>+"
	+proof -
	+ {fix s t assume "(s, t) \<in> gmctxtex_onp P (\<R>\<^sup>+)"
	+ from gmctxtex_onpE[OF this] obtain C us vs where
	+ *: "s = fill_gholes C us" "t = fill_gholes C vs" and
	+ len: "num_gholes C = length us" "length us = length vs" and
	+ inv: "P C" "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>\<^sup>+" by auto
	+ have "(s, t) \<in> \<R>\<^sup>+" using len(2) inv(2) len(1) inv(1) unfolding *
	+ proof (induction rule: trancl_list_induct)
	+ case (base xs ys)
	+ then have "(fill_gholes C xs, fill_gholes C ys) \<in> \<R>" using assms(1)
	+ by blast
	+ then show ?case by auto
	+ next
	+ case (step xs ys i z)
	+ have sub: "set ys \<subseteq> snd ` \<R>" using step(1, 2)
	+ by (auto simp: image_def) (metis in_set_idx snd_conv tranclD2)
	+ from step have lft: "(fill_gholes C xs, fill_gholes C ys) \<in> \<R>\<^sup>+" by auto
	+ have "(fill_gholes C ys, fill_gholes C (ys[i := z])) \<in> gmctxtex_onp P \<R>"
	+ using step(3, 4) sub assms step(1, 6)
	+ by (intro gmctxtex_onpI[of P, OF step(7), of ys "ys[i := z]" \<R>])
	+ (simp add: Id_on_eqI nth_list_update subset_iff)+
	+ then have "(fill_gholes C ys, fill_gholes C (ys[i := z])) \<in> \<R>" using assms(1) by blast
	+ then show ?case using lft by auto
	+ qed}
	+ then show ?thesis by auto
	+qed
	+
	+lemma gmctxtex_onp_substep_tranclE:
	+ assumes "trans \<R>" and "gmctxtex_onp Q \<R> O \<R> \<subseteq> \<R>" and "\<R> O gmctxtex_onp Q \<R> \<subseteq> \<R>"
	+ and "\<And> p C. P C \<Longrightarrow> p \<in> poss_gmctxt C \<Longrightarrow> Q (subgm_at C p)"
	+ and "\<And> C D. P C \<Longrightarrow> P D \<Longrightarrow> (C, D) \<in> comp_gmctxt \<Longrightarrow> P (C \<sqinter> D)"
	+ shows "(gmctxtex_onp P \<R>)\<^sup>+ = gmctxtex_onp P \<R>" (is "?Ls = ?Rs")
	+proof
	+ show "?Rs \<subseteq> ?Ls" using trancl_mono_set by fastforce
	+next
	+ {fix s t assume "(s, t) \<in> ?Ls" then have "(s, t) \<in> ?Rs"
	+ proof induction
	+ case (step t u)
	+ from step(3) obtain C us vs where
	+ *: "s = fill_gholes C us" "t = fill_gholes C vs" and
	+ l: "num_gholes C = length us" "length us = length vs" and
	+ inv: "P C" "\<forall>i<length vs. (us ! i, vs ! i) \<in> \<R>"
	+ by auto
	+ from step(2) obtain D xs ys where
	+ **: "t = fill_gholes D xs" "u = fill_gholes D ys" and
	+ l': "num_gholes D = length xs" "length xs = length ys" and
	+ inv': "P D" "\<forall>i<length ys. (xs ! i, ys ! i) \<in> \<R>"
	+ by auto
	+ let ?C' = "C \<sqinter> D"
	+ let ?sss = "unfill_gholes ?C' s" let ?uss = "unfill_gholes ?C' u"
	+ have less: "?C' \<le> gmctxt_of_gterm s" "?C' \<le> gmctxt_of_gterm u"
	+ using eq_gfill.intros eqgf_less_eq inf.coboundedI1 inf.coboundedI2 l(1) l'(1)
	+ unfolding * ** unfolding l'(2)
	+ by metis+
	+ from (2) *(1) have comp: "(C, D) \<in> comp_gmctxt" using l l'
	+ using eqgf_comp_gmctxt by fastforce
	+ then have P: "P ?C'" using inv(1) inv'(1) assms(5) by blast
	+ moreover have l'': "num_gholes ?C' = length ?sss" "length ?sss = length ?uss"
	+ using less by auto
	+ moreover have fill: "fill_gholes ?C' ?sss = s" "fill_gholes ?C' ?uss = u"
	+ using less by (simp add: fill_unfill_gholes)+
	+ moreover have "\<forall> i < length ?uss. (?sss ! i, ?uss ! i) \<in> \<R>"
	+ proof (rule, rule)
	+ fix i assume i: "i < length (unfill_gholes ?C' u)"
	+ then obtain p where pos: "p \<in> ghole_poss ?C'"
	+ "unfill_gholes ?C' s ! i = gsubt_at (fill_gholes ?C' ?sss) p"
	+ "unfill_gholes ?C' u ! i = gsubt_at (fill_gholes ?C' ?uss) p"
	+ using fill l'' fill_gholes_ghole_poss
	+ by (metis eq_gfill.intros ghole_poss_ghole_poss_list_conv length_ghole_poss_list_num_gholes nth_mem)
	+ from comp_gmctxt_inf_ghole_poss_cases[OF comp pos(1)]
	+ consider (a) "p \<in> ghole_poss C \<and> p \<in> ghole_poss D" \|
	+ (b) "p \<in> ghole_poss C \<and> p \<in> poss_gmctxt D" \|
	+ (c) "p \<in> ghole_poss D \<and> p \<in> poss_gmctxt C" by blast
	+ then show "(unfill_gholes ?C' s ! i, unfill_gholes ?C' u ! i) \<in> \<R>" unfolding pos fill
	+ proof cases
	+ case a
	+ then show "(gsubt_at s p, gsubt_at u p) \<in> \<R>"
	+ using assms(1) (2) l l' inv(2) inv'(2) unfolding **
	+ using ghole_poss_nth_subt_at
	+ by (metis ""(2) "*"(1) eq_gfill.intros trancl_id trancl_into_trancl2)
	+ next
	+ case b
	+ then have sp: "gsubt_at t p =\<^sub>G\<^sub>f (subgm_at D p, gmctxt_subtgm_at_fill_args p D xs)"
	+ "gsubt_at u p =\<^sub>G\<^sub>f (subgm_at D p, gmctxt_subtgm_at_fill_args p D ys)"
	+ using poss_gmctxt_fill_gholes_split[of _ D _ p] ** l'
	+ by force+
	+ have "(gsubt_at t p, gsubt_at u p) \<in> gmctxtex_onp Q \<R>" using inv'(2)
	+ using assms(4)[OF inv'(1) conjunct2[OF b]] eqgfE[OF sp(1)] eqgfE[OF sp(2)]
	+ by (auto simp: gmctxt_subtgm_at_fill_args_def intro!: gmctxtex_onpI)
	+ moreover have "(gsubt_at s p, gsubt_at t p) \<in> \<R>"
	+ using * l inv(2)
	+ using ghole_poss_nth_subt_at[OF _ conjunct1[OF b]]
	+ by auto (metis eq_gfill.intros)
	+ ultimately show "(gsubt_at s p, gsubt_at u p) \<in> \<R>"
	+ using assms(3) by auto
	+ next
	+ case c
	+ then have sp: "gsubt_at s p =\<^sub>G\<^sub>f (subgm_at C p, gmctxt_subtgm_at_fill_args p C us)"
	+ "gsubt_at t p =\<^sub>G\<^sub>f (subgm_at C p, gmctxt_subtgm_at_fill_args p C vs)"
	+ using poss_gmctxt_fill_gholes_split[of _ C _ p] * l
	+ by force+
	+ have "(gsubt_at s p, gsubt_at t p) \<in> gmctxtex_onp Q \<R>" using inv(2)
	+ using assms(4)[OF inv(1) conjunct2[OF c]] eqgfE[OF sp(1)] eqgfE[OF sp(2)]
	+ by (auto simp: gmctxt_subtgm_at_fill_args_def intro!: gmctxtex_onpI)
	+ moreover have "(gsubt_at t p, gsubt_at u p) \<in> \<R>"
	+ using ** l' inv'(2)
	+ using ghole_poss_nth_subt_at[OF _ conjunct1[OF c]]
	+ by auto (metis eq_gfill.intros)
	+ ultimately show "(gsubt_at s p, gsubt_at u p) \<in> \<R>"
	+ using assms(2) by auto
	+ qed
	+ qed
	+ ultimately show ?case by (metis gmctxtex_onpI)
	+ qed simp}
	+ then show "?Ls \<subseteq> ?Rs" by auto
	+qed
	+
	+subsection \<open>Restr to set, union and predicate distribution\<close>
	+
	+lemma Restr_gctxtex_onp_dist [simp]:
	+ "Restr (gctxtex_onp P \<R>) (\<T>\<^sub>G \<F>) =
	+ gctxtex_onp (\<lambda> C. funas_gctxt C \<subseteq> \<F> \<and> P C) (Restr \<R> (\<T>\<^sub>G \<F>))"
	+ by (auto simp: gctxtex_onp_def \<T>\<^sub>G_equivalent_def) blast
	+
	+lemma Restr_gmctxtex_onp_dist [simp]:
	+ "Restr (gmctxtex_onp P \<R>) (\<T>\<^sub>G \<F>) =
	+ gmctxtex_onp (\<lambda> C. funas_gmctxt C \<subseteq> \<F> \<and> P C) (Restr \<R> (\<T>\<^sub>G \<F>))"
	+ by (auto elim!: gmctxtex_onpE simp: \<T>\<^sub>G_equivalent_def SUP_le_iff gmctxtex_onpI)
	+ (metis in_set_idx subsetD)+
	+
	+
	+lemma Restr_id_subset_gmctxtex_onp [intro]:
	+ assumes "\<And> C. num_gholes C = 0 \<and> funas_gmctxt C \<subseteq> \<F> \<Longrightarrow> P C"
	+ shows "Restr Id (\<T>\<^sub>G \<F>) \<subseteq> gmctxtex_onp P \<R>"
	+proof
	+ fix s t assume "(s, t) \<in> Restr Id (\<T>\<^sub>G \<F>)"
	+ then show "(s, t) \<in> gmctxtex_onp P \<R>" using assms[of "gmctxt_of_gterm t"]
	+ using gmctxtex_onpI[of P "gmctxt_of_gterm t" "[]" "[]" \<R>]
	+ by (auto simp: \<T>\<^sub>G_equivalent_def)
	+qed
	+
	+lemma Restr_id_subset_gmctxtex_onp2 [intro]:
	+ assumes "\<And> f n. (f, n) \<in> \<F> \<Longrightarrow> P (GMFun f (replicate n GMHole))"
	+ and "\<And> C Ds. num_gholes C = length Ds \<Longrightarrow> P C \<Longrightarrow> \<forall> D \<in> set Ds. P D \<Longrightarrow> P (fill_gholes_gmctxt C Ds)"
	+ shows "Restr Id (\<T>\<^sub>G \<F>) \<subseteq> gmctxtex_onp P \<R>"
	+proof
	+ fix s t assume "(s, t) \<in> Restr Id (\<T>\<^sub>G \<F>)"
	+ then have *: "s = t" "t \<in> \<T>\<^sub>G \<F>" by auto
	+ have "P (gmctxt_of_gterm t)" using *(2)
	+ proof (induct)
	+ case (const a)
	+ show ?case using assms(1)[OF const] by auto
	+ next
	+ case (ind f n ss)
	+ let ?C = "GMFun f (replicate (length ss) GMHole)"
	+ have "P (fill_gholes_gmctxt ?C (map gmctxt_of_gterm ss))"
	+ using assms(1)[OF ind(1)] ind
	+ by (intro assms(2)) (auto simp: in_set_conv_nth)
	+ then show ?case
	+ by (metis fill_gholes_gmctxt_GMFun_replicate_length gmctxt_of_gterm.simps length_map)
	+ qed
	+ from gmctxtex_onpI[of P, OF this] show "(s, t) \<in> gmctxtex_onp P \<R>" unfolding *
	+ by auto
	+qed
	+
	+
	+lemma gctxtex_onp_union [simp]:
	+ "gctxtex_onp P (\<R> \<union> \<L>) = gctxtex_onp P \<R> \<union> gctxtex_onp P \<L>"
	+ by auto
	+
	+lemma gctxtex_onp_pred_dist:
	+ assumes "\<And> C. P C \<longleftrightarrow> Q C \<or> R C"
	+ shows "gctxtex_onp P \<R> = gctxtex_onp Q \<R> \<union> gctxtex_onp R \<R>"
	+ using assms by auto fastforce
	+
	+lemma gmctxtex_onp_pred_dist:
	+ assumes "\<And> C. P C \<longleftrightarrow> Q C \<or> R C"
	+ shows "gmctxtex_onp P \<R> = gmctxtex_onp Q \<R> \<union> gmctxtex_onp R \<R>"
	+ using assms by (auto elim!: gmctxtex_onpE)
	+
	+lemma trivial_gctxtex_onp [simp]: "gctxtex_onp (\<lambda> C. C = \<box>\<^sub>G) \<R> = \<R>"
	+ using gctxtex_closure by force
	+
	+lemma trivial_gmctxtex_onp [simp]: "gmctxtex_onp (\<lambda> C. C = GMHole) \<R> = \<R>"
	+proof
	+ show "gmctxtex_onp (\<lambda>C. C = GMHole) \<R> \<subseteq> \<R>"
	+ by (auto elim!: gmctxtex_onpE) force
	+next
	+ show "\<R> \<subseteq> gmctxtex_onp (\<lambda>C. C = GMHole) \<R>"
	+ by (intro gmctxtex_closure) auto
	+qed
	+
	+subsection \<open>Distribution of context closures over relation composition\<close>
	+
	+lemma gctxtex_onp_relcomp_inner:
	+ "gctxtex_onp P (\<R> O \<L>) \<subseteq> gctxtex_onp P \<R> O gctxtex_onp P \<L>"
	+ by auto
	+
	+lemma gmctxtex_onp_relcomp_inner:
	+ "gmctxtex_onp P (\<R> O \<L>) \<subseteq> gmctxtex_onp P \<R> O gmctxtex_onp P \<L>"
	+proof
	+ fix s t
	+ assume "(s, t) \<in> gmctxtex_onp P (\<R> O \<L>)"
	+ from gmctxtex_onpE[OF this] obtain C us vs where
	+ *: "s = fill_gholes C us" "t = fill_gholes C vs" and
	+ len: "num_gholes C = length us" "length us = length vs" and
	+ inv: "P C" "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R> O \<L>" by blast
	+ obtain zs where l: "length vs = length zs" and
	+ rel: "\<forall> i < length zs. (us ! i, zs ! i) \<in> \<R>" "\<forall> i < length zs. (zs ! i, vs ! i) \<in> \<L>"
	+ using len(2) inv(2) Ex_list_of_length_P[of _ "\<lambda> y i. (us ! i, y) \<in> \<R> \<and> (y, vs ! i) \<in> \<L>"]
	+ by (auto simp: relcomp_unfold) metis
	+ from len l rel inv have "(s, fill_gholes C zs) \<in> gmctxtex_onp P \<R>" unfolding *
	+ by auto
	+ moreover from len l rel inv have "(fill_gholes C zs, t) \<in> gmctxtex_onp P \<L>" unfolding *
	+ by auto
	+ ultimately show "(s, t) \<in> gmctxtex_onp P \<R> O gmctxtex_onp P \<L>"
	+ by auto
	+qed
	+
	+subsection \<open>Signature preserving and signature closed\<close>
	+
	+definition function_closed where
	+ "function_closed \<F> \<R> \<longleftrightarrow> (\<forall> f ss ts. (f, length ts) \<in> \<F> \<longrightarrow> 0 \<noteq> length ts \<longrightarrow>
	+ length ss = length ts \<longrightarrow> (\<forall> i. i < length ts \<longrightarrow> (ss ! i, ts ! i) \<in> \<R>) \<longrightarrow>
	+ (GFun f ss, GFun f ts) \<in> \<R>)"
	+
	+lemma function_closedD: "function_closed \<F> \<R> \<Longrightarrow>
	+ (f,length ts) \<in> \<F> \<Longrightarrow> 0 \<noteq> length ts \<Longrightarrow> length ss = length ts \<Longrightarrow>
	+ \<lbrakk>\<And> i. i < length ts \<Longrightarrow> (ss ! i, ts ! i) \<in> \<R>\<rbrakk> \<Longrightarrow>
	+ (GFun f ss, GFun f ts) \<in> \<R>"
	+ unfolding function_closed_def by blast
	+
	+lemma all_ctxt_closed_imp_function_closed:
	+ "all_ctxt_closed \<F> \<R> \<Longrightarrow> function_closed \<F> \<R>"
	+ unfolding all_ctxt_closed_def function_closed_def
	+ by auto
	+
	+lemma all_ctxt_closed_imp_reflx_on_sig:
	+ assumes "all_ctxt_closed \<F> \<R>"
	+ shows "Restr Id (\<T>\<^sub>G \<F>) \<subseteq> \<R>"
	+proof -
	+ {fix s assume "(s, s) \<in> Restr Id (\<T>\<^sub>G \<F>)" then have "(s, s) \<in> \<R>"
	+ proof (induction s)
	+ case (GFun f ts)
	+ then show ?case using all_ctxt_closedD[OF assms]
	+ by (auto simp: \<T>\<^sub>G_equivalent_def UN_subset_iff)
	+ qed}
	+ then show ?thesis by auto
	+qed
	+
	+lemma function_closed_un_id_all_ctxt_closed:
	+ "function_closed \<F> \<R> \<Longrightarrow> Restr Id (\<T>\<^sub>G \<F>) \<subseteq> \<R> \<Longrightarrow> all_ctxt_closed \<F> \<R>"
	+ unfolding all_ctxt_closed_def
	+ by (auto dest: function_closedD simp: subsetD)
	+
	+lemma gctxtex_onp_in_signature [intro]:
	+ assumes "\<And> C. P C \<Longrightarrow> funas_gctxt C \<subseteq> \<F>" "\<And> C. P C \<Longrightarrow> funas_gctxt C \<subseteq> \<G>"
	+ and "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<G>"
	+ shows "gctxtex_onp P \<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<G>" using assms
	+ by (auto simp: gctxtex_onp_def \<T>\<^sub>G_equivalent_def) blast+
	+
	+lemma gmctxtex_onp_in_signature [intro]:
	+ assumes "\<And> C. P C \<Longrightarrow> funas_gmctxt C \<subseteq> \<F>" "\<And> C. P C \<Longrightarrow> funas_gmctxt C \<subseteq> \<G>"
	+ and "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<G>"
	+ shows "gmctxtex_onp P \<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<G>" using assms
	+ by (auto simp: gmctxtex_onp_def \<T>\<^sub>G_equivalent_def in_set_conv_nth) force+
	+
	+lemma gctxtex_onp_in_signature_tranc [intro]:
	+ "gctxtex_onp P \<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F> \<Longrightarrow> (gctxtex_onp P \<R>)\<^sup>+ \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ by (auto simp: Restr_simps)
	+
	+lemma gmctxtex_onp_in_signature_tranc [intro]:
	+ "gmctxtex_onp P \<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F> \<Longrightarrow> (gmctxtex_onp P \<R>)\<^sup>+ \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ by (auto simp: Restr_simps)
	+
	+lemma gmctxtex_onp_fun_closed [intro!]:
	+ assumes "\<And> f n. (f, n) \<in> \<F> \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> P (GMFun f (replicate n GMHole))"
	+ and "\<And> C Ds. P C \<Longrightarrow> num_gholes C = length Ds \<Longrightarrow> 0 < num_gholes C \<Longrightarrow>
	+ \<forall> D \<in> set Ds. P D \<Longrightarrow> P (fill_gholes_gmctxt C Ds)"
	+ shows "function_closed \<F> (gmctxtex_onp P \<R>)" unfolding function_closed_def
	+proof (rule allI, intro allI, intro impI)
	+ fix f ss ts assume sig: "(f, length ts) \<in> \<F>"
	+ and len: "0 \<noteq> length ts" "length ss = length ts"
	+ and mem: "\<forall> i < length ts. (ss ! i, ts ! i) \<in> gmctxtex_onp P \<R>"
	+ let ?C = "GMFun f (replicate (length ts) GMHole)"
	+ from mem len obtain Ds sss tss where
	+ l': "length ts = length Ds" "length Ds = length sss" "length sss = length tss" and
	+ inn: "\<forall> i < length tss. length (sss ! i) = length (tss ! i)" and
	+ eq: "\<forall> i < length tss. ss ! i =\<^sub>G\<^sub>f (Ds ! i, sss ! i)" "\<forall> i < length tss. ts ! i =\<^sub>G\<^sub>f (Ds ! i, tss ! i)" and
	+ inv: "\<forall> i < length (concat tss). (concat sss ! i, concat tss ! i) \<in> \<R>" "\<forall> D \<in> set Ds. P D"
	+ by (auto elim!: gmctxtex_onp_listE)
	+ have *: "fill_gholes ?C ss = GFun f ss" "fill_gholes ?C ts = GFun f ts"
	+ using len assms(1) by (auto simp del: fill_gholes.simps)
	+ have s: "GFun f ss =\<^sub>G\<^sub>f (fill_gholes_gmctxt ?C Ds, concat sss)"
	+ using assms(1) l' eq(1) inn len inv(1) unfolding *[symmetric]
	+ by (intro fill_gholes_gmctxt_sound) auto
	+ have t: "GFun f ts =\<^sub>G\<^sub>f (fill_gholes_gmctxt ?C Ds, concat tss)"
	+ using assms(1) eq l' inn len inv(1) unfolding *[symmetric]
	+ by (intro fill_gholes_gmctxt_sound) auto
	+ then show "(GFun f ss, GFun f ts) \<in> gmctxtex_onp P \<R>"
	+ unfolding eqgfE[OF s] eqgfE[OF t]
	+ using eqgfE(2)[OF s] eqgfE(2)[OF t] sig len l' inv
	+ using assms(1)[OF sig] assms(2)[of "GMFun f (replicate (length ts) GMHole)" Ds]
	+ using gmctxtex_onpI[of P "fill_gholes_gmctxt (GMFun f (replicate (length ts) GMHole)) Ds" "concat sss" "concat tss" \<R>]
	+ by (auto simp del: fill_gholes_gmctxt.simps fill_gholes.simps)
	+qed
	+
	+declare subsetI[rule del]
	+lemma gmctxtex_onp_sig_closed [intro]:
	+ assumes "\<And> f n. (f, n) \<in> \<F> \<Longrightarrow> P (GMFun f (replicate n GMHole))"
	+ and "\<And> C Ds. num_gholes C = length Ds \<Longrightarrow> P C \<Longrightarrow> \<forall> D \<in> set Ds. P D \<Longrightarrow> P (fill_gholes_gmctxt C Ds)"
	+ shows "all_ctxt_closed \<F> (gmctxtex_onp P \<R>)" using assms
	+ by (intro function_closed_un_id_all_ctxt_closed) auto
	+declare subsetI[intro!]
	+
	+lemma gmctxt_cl_gmctxtex_onp_conv:
	+ "gmctxt_cl \<F> \<R> = gmctxtex_onp (\<lambda> C. funas_gmctxt C \<subseteq> \<F>) \<R>" (is "?Ls = ?Rs")
	+proof -
	+ have sig_cl: "all_ctxt_closed \<F> (?Rs)" by (intro gmctxtex_onp_sig_closed) auto
	+ {fix s t assume "(s, t) \<in> ?Ls" then have "(s, t) \<in> ?Rs"
	+ proof induct
	+ case (step ss ts f)
	+ then show ?case using all_ctxt_closedD[OF sig_cl]
	+ by force
	+ qed (intro subsetD[OF gmctxtex_onp_arg_monoI], auto)}
	+ moreover
	+ {fix s t assume "(s, t) \<in> ?Rs"
	+ from gmctxtex_onpE[OF this] obtain C us vs where
	+ terms: "s = fill_gholes C us" "t = fill_gholes C vs" and
	+ fill_inv: "num_gholes C = length us" "length us = length vs" and
	+ rel: "funas_gmctxt C \<subseteq> \<F>" "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>" by blast
	+ have "(s, t) \<in> ?Ls" unfolding terms using fill_inv rel
	+ proof (induct C arbitrary: us vs)
	+ case GMHole
	+ then show ?case using rel(2) by (cases vs; cases us) auto
	+ next
	+ case (GMFun f Ds)
	+ show ?case using GMFun(2-) unfolding partition_holes_fill_gholes_conv'
	+ by (intro all_ctxt_closedD[OF gmctxt_cl_is_all_ctxt_closed[of \<F> \<R>]])
	+ (auto simp: partition_by_nth_nth SUP_le_iff length_partition_gholes_nth intro!: GMFun(1))
	+ qed}
	+ ultimately show ?thesis by auto
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Closure/Context_RR2.thy b/thys/FO_Theory_Rewriting/Closure/Context_RR2.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Closure/Context_RR2.thy
	@@ -0,0 +1,188 @@
	+theory Context_RR2
	+ imports Context_Extensions
	+ Ground_MCtxt
	+ Regular_Tree_Relations.RRn_Automata
	+begin
	+
	+subsection \<open>Auxiliary lemmas\<close>
	+(* TODO Move *)
	+lemma gpair_gctxt:
	+ assumes "gpair s t = u"
	+ shows "(map_gctxt (\<lambda> f .(Some f, Some f)) C)\<langle>u\<rangle>\<^sub>G = gpair C\<langle>s\<rangle>\<^sub>G C\<langle>t\<rangle>\<^sub>G" using assms
	+ by (induct C arbitrary: s t u) (auto simp add: gpair_context1 comp_def map_funs_term_some_gpair intro!: nth_equalityI)
	+
	+lemma gpair_gctxt':
	+ assumes "gpair C\<langle>v\<rangle>\<^sub>G C\<langle>w\<rangle>\<^sub>G = u"
	+ shows "u = (map_gctxt (\<lambda> f .(Some f, Some f)) C)\<langle>gpair v w\<rangle>\<^sub>G"
	+ using assms by (simp add: gpair_gctxt)
	+
	+lemma gpair_gmctxt:
	+ assumes "\<forall> i < length us. gpair (ss ! i) (ts ! i) = us ! i"
	+ and "num_gholes C = length ss" "length ss = length ts" "length ts = length us"
	+ shows "fill_gholes (map_gmctxt (\<lambda>f . (Some f, Some f)) C) us = gpair (fill_gholes C ss) (fill_gholes C ts)"
	+ using assms
	+proof (induct C arbitrary: ss ts us)
	+ case GMHole
	+ then show ?case by (cases ss; cases ts; cases us) auto
	+next
	+ case (GMFun f Cs)
	+ show ?case using GMFun(2-)
	+ using GMFun(1)[OF nth_mem, of i "partition_gholes us Cs ! i" "partition_gholes ss Cs ! i" "partition_gholes ts Cs ! i" for i]
	+ using length_partition_gholes_nth[of Cs] partition_by_nth_nth[of "map num_gholes Cs" us]
	+ using partition_by_nth_nth[of "map num_gholes Cs" ss] partition_by_nth_nth[of "map num_gholes Cs" ts]
	+ by (auto simp: partition_holes_fill_gholes_conv' gpair_context1 simp del: fill_gholes.simps intro!: nth_equalityI)
	+ (simp add: length_partition_gholes_nth)
	+qed
	+(Finished Move section)
	+
	+
	+lemma gctxtex_onp_gpair_set_conv:
	+ "{gpair t u \|t u. (t, u) \<in> gctxtex_onp P \<R>} =
	+ {(map_gctxt (\<lambda> f .(Some f, Some f)) C)\<langle>s\<rangle>\<^sub>G \| C s. P C \<and> s \<in> {gpair t u \|t u. (t, u) \<in> \<R>}}" (is "?Ls = ?Rs")
	+proof
	+ show "?Ls \<subseteq> ?Rs" using gpair_gctxt'
	+ by (auto elim!: gctxtex_onpE) blast
	+next
	+ show "?Rs \<subseteq> ?Ls"
	+ by (auto simp add: gctxtex_onpI gpair_gctxt)
	+qed
	+
	+lemma gmctxtex_onp_gpair_set_conv:
	+ "{gpair t u \|t u. (t, u) \<in> gmctxtex_onp P \<R>} =
	+ {fill_gholes (map_gmctxt (\<lambda> f .(Some f, Some f)) C) ss \| C ss. num_gholes C = length ss \<and> P C \<and>
	+ (\<forall> i < length ss. ss ! i \<in> {gpair t u \|t u. (t, u) \<in> \<R>})}" (is "?Ls = ?Rs")
	+proof
	+ {fix u assume "u \<in> ?Ls" then obtain s t
	+ where *: "u = gpair s t" "(s, t) \<in> gmctxtex_onp P \<R>"
	+ by auto
	+ from gmctxtex_onpE[OF *(2)] obtain C us vs where
	+ **: "s = fill_gholes C us" "t = fill_gholes C vs" and
	+ inv: "num_gholes C = length us" "length us = length vs" "P C"
	+ "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
	+ by blast
	+ define ws where "ws \<equiv> map2 gpair us vs"
	+ from inv(1, 2) have "\<forall> i < length ws. gpair (us ! i) (vs ! i) = ws ! i"
	+ by(auto simp: ws_def)
	+ from gpair_gmctxt[OF this inv(1, 2)] inv
	+ have "u \<in> ?Rs" unfolding * **
	+ by (auto simp: ws_def intro!: exI[of _ ws] exI[of _ C])}
	+ then show "?Ls \<subseteq> ?Rs" by blast
	+next
	+ {fix u assume "u \<in> ?Rs" then obtain C ss where
	+ *: "u = fill_gholes (map_gmctxt (\<lambda>f. (Some f, Some f)) C) ss" and
	+ inv: "P C" "num_gholes C = length ss" "\<forall> i < length ss. \<exists> t u. ss ! i = gpair t u \<and> (t, u) \<in> \<R>"
	+ by auto
	+ define us where "us \<equiv> map gfst ss" define vs where "vs \<equiv> map gsnd ss"
	+ then have len: "length ss = length us" "length us = length vs" and
	+ rec: "\<forall> i < length ss. gpair (us ! i) (vs ! i) = ss ! i"
	+ "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
	+ by (auto simp: us_def vs_def) (metis gfst_gpair gsnd_gpair inv(3))+
	+ from len have l: "length vs = length ss" by auto
	+ have "u \<in> ?Ls" unfolding * using inv(2) len
	+ using gmctxtex_onpI[of P C us vs \<R>, OF inv(1) _ len(2) rec(2)]
	+ using gpair_gmctxt[OF rec(1) _ len(2) l, of C]
	+ by simp}
	+ then show "?Rs \<subseteq> ?Ls" by blast
	+qed
	+
	+
	+(* Results about lifting signature to RR2
	+ TODO rework, as this is not the RR2 signature more like
	+ the context signature, so closing a RR2 term under this signature
	+ leads a RR2 term
	+*)
	+
	+abbreviation "lift_sig_RR2 \<equiv> \<lambda> (f, n). ((Some f, Some f), n)"
	+abbreviation "lift_fun \<equiv> (\<lambda> f. (Some f, Some f))"
	+abbreviation "unlift_fst \<equiv> (\<lambda> f. the (fst f))"
	+abbreviation "unlift_snd \<equiv> (\<lambda> f. the (snd f))"
	+
	+lemma RR2_gterm_unlift_lift_id [simp]:
	+ "funas_gterm t \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> map_gterm (lift_fun \<circ> unlift_fst) t = t"
	+ by (induct t) (auto simp add: SUP_le_iff map_idI)
	+
	+lemma RR2_gterm_unlift_funas [simp]:
	+ "funas_gterm t \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> funas_gterm (map_gterm unlift_fst t) \<subseteq> \<F>"
	+ by (induct t) (auto simp add: SUP_le_iff map_idI)
	+
	+lemma gterm_funas_lift_RR2_funas [simp]:
	+ "funas_gterm t \<subseteq> \<F> \<Longrightarrow> funas_gterm (map_gterm lift_fun t) \<subseteq> lift_sig_RR2 ` \<F>"
	+ by (induct t) (auto simp add: SUP_le_iff map_idI)
	+
	+lemma RR2_gctxt_unlift_lift_id [simp, intro]:
	+ "funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> (map_gctxt (lift_fun \<circ> unlift_fst) C) = C"
	+ by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)
	+
	+lemma RR2_gctxt_unlift_funas [simp, intro]:
	+ "funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> funas_gctxt (map_gctxt unlift_fst C) \<subseteq> \<F>"
	+ by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)
	+
	+lemma gctxt_funas_lift_RR2_funas [simp, intro]:
	+ "funas_gctxt C \<subseteq> \<F> \<Longrightarrow> funas_gctxt (map_gctxt lift_fun C) \<subseteq> lift_sig_RR2 ` \<F>"
	+ by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)
	+
	+lemma RR2_gmctxt_unlift_lift_id [simp, intro]:
	+ "funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> (map_gmctxt (lift_fun \<circ> unlift_fst) C) = C"
	+ by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)
	+
	+lemma RR2_gmctxt_unlift_funas [simp, intro]:
	+ "funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> funas_gmctxt (map_gmctxt unlift_fst C) \<subseteq> \<F>"
	+ by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)
	+
	+lemma gmctxt_funas_lift_RR2_funas [simp, intro]:
	+ "funas_gmctxt C \<subseteq> \<F> \<Longrightarrow> funas_gmctxt (map_gmctxt lift_fun C) \<subseteq> lift_sig_RR2 ` \<F>"
	+ by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)
	+
	+lemma RR2_gctxt_cl_to_gctxt:
	+ assumes "\<And> C. P C \<Longrightarrow> funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F>"
	+ and "\<And> C. P C \<Longrightarrow> R (map_gctxt unlift_fst C)"
	+ and "\<And> C. R C \<Longrightarrow> P (map_gctxt lift_fun C)"
	+ shows "{C\<langle>s\<rangle>\<^sub>G \|C s. P C \<and> Q s} = {(map_gctxt lift_fun C)\<langle>s\<rangle>\<^sub>G \|C s. R C \<and> Q s}" (is "?Ls = ?Rs")
	+proof
	+ {fix u assume "u \<in> ?Ls" then obtain C s where
	+ *:"u = C\<langle>s\<rangle>\<^sub>G" and inv: "P C" "Q s" by blast
	+ then have "funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F>" using assms by auto
	+ from RR2_gctxt_unlift_lift_id[OF this] have "u \<in> ?Rs" using inv assms unfolding *
	+ by (auto intro!: exI[of _ "map_gctxt unlift_fst C"] exI[of _ s])}
	+ then show "?Ls \<subseteq> ?Rs" by blast
	+next
	+ {fix u assume "u \<in> ?Rs" then obtain C s where
	+ *:"u = (map_gctxt lift_fun C)\<langle>s\<rangle>\<^sub>G" and inv: "R C" "Q s"
	+ by blast
	+ have "u \<in> ?Ls" unfolding * using inv assms
	+ by (auto intro!: exI[of _ "map_gctxt lift_fun C"])}
	+ then show "?Rs \<subseteq> ?Ls" by blast
	+qed
	+
	+lemma RR2_gmctxt_cl_to_gmctxt:
	+ assumes "\<And> C. P C \<Longrightarrow> funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F>"
	+ and "\<And> C. P C \<Longrightarrow> R (map_gmctxt (\<lambda> f. the (fst f)) C)"
	+ and "\<And> C. R C \<Longrightarrow> P (map_gmctxt (\<lambda> f. (Some f, Some f)) C)"
	+ shows "{fill_gholes C ss \|C ss. num_gholes C = length ss \<and> P C \<and> (\<forall> i < length ss. Q (ss ! i))} =
	+ {fill_gholes (map_gmctxt (\<lambda>f. (Some f, Some f)) C) ss \|C ss. num_gholes C = length ss \<and>
	+ R C \<and> (\<forall> i < length ss. Q (ss ! i))}" (is "?Ls = ?Rs")
	+proof
	+ {fix u assume "u \<in> ?Ls" then obtain C ss where
	+ *:"u = fill_gholes C ss" and inv: "num_gholes C = length ss" "P C" "\<forall> i < length ss. Q (ss ! i)"
	+ by blast
	+ then have "funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F>" using assms by auto
	+ from RR2_gmctxt_unlift_lift_id[OF this] have "u \<in> ?Rs" using inv assms unfolding *
	+ by (auto intro!: exI[of _ "map_gmctxt unlift_fst C"] exI[of _ ss])}
	+ then show "?Ls \<subseteq> ?Rs" by blast
	+next
	+ {fix u assume "u \<in> ?Rs" then obtain C ss where
	+ *:"u = fill_gholes (map_gmctxt lift_fun C) ss" and inv: "num_gholes C = length ss" "R C"
	+ "\<forall> i < length ss. Q (ss ! i)"
	+ by blast
	+ have "u \<in> ?Ls" unfolding * using inv assms
	+ by (auto intro!: exI[of _ "map_gmctxt lift_fun C"])}
	+ then show "?Rs \<subseteq> ?Ls" by blast
	+qed
	+
	+lemma RR2_id_terms_gpair_set [simp]:
	+ "\<T>\<^sub>G (lift_sig_RR2 ` \<F>) = {gpair t u \|t u. (t, u) \<in> Restr Id (\<T>\<^sub>G \<F>)}"
	+ apply (auto simp: map_funs_term_some_gpair \<T>\<^sub>G_equivalent_def)
	+ apply (smt RR2_gterm_unlift_funas RR2_gterm_unlift_lift_id gterm.map_comp)
	+ using funas_gterm_map_gterm by blast
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Closure/GTT_RRn.thy b/thys/FO_Theory_Rewriting/Closure/GTT_RRn.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Closure/GTT_RRn.thy
	@@ -0,0 +1,157 @@
	+theory GTT_RRn
	+ imports Regular_Tree_Relations.GTT
	+ TA_Clousure_Const
	+ Context_RR2
	+ Lift_Root_Step
	+begin
	+
	+
	+section \<open>Connecting regular tree languages to set/relation specifications\<close>
	+abbreviation ggtt_lang where
	+ "ggtt_lang F G \<equiv> map_both gterm_of_term ` (Restr (gtt_lang_terms G) {t. funas_term t \<subseteq> fset F})"
	+
	+lemma ground_mctxt_map_vars_mctxt [simp]:
	+ "ground_mctxt (map_vars_mctxt f C) = ground_mctxt C"
	+ by (induct C) auto
	+
	+lemma root_single_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec \<A> (lift_root_step \<F> PRoot ESingle R)"
	+ using assms unfolding RR2_spec_def
	+ by (auto simp: lift_root_step.simps)
	+
	+lemma root_strictparallel_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec \<A> (lift_root_step \<F> PRoot EStrictParallel R)"
	+ using assms unfolding RR2_spec_def
	+ by (auto simp: lift_root_step.simps)
	+
	+lemma reflcl_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec (reflcl_reg (lift_sig_RR2 \|`\| \<F>) \<A>) (lift_root_step (fset \<F>) PRoot EParallel R)"
	+ unfolding RR2_spec_def \<L>_reflcl_reg
	+ unfolding lift_root_step.simps \<T>\<^sub>G_equivalent_def assms[unfolded RR2_spec_def]
	+ by (auto simp flip: \<T>\<^sub>G_equivalent_def)
	+
	+lemma parallel_closure_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec (parallel_closure_reg (lift_sig_RR2 \|`\| \<F>) \<A>) (lift_root_step (fset \<F>) PAny EParallel R)"
	+ unfolding RR2_spec_def parallelcl_gmctxt_lang lift_root_step.simps
	+ unfolding gmctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
	+ by (intro RR2_gmctxt_cl_to_gmctxt) auto
	+
	+lemma ctxt_closure_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec (ctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<A>) (lift_root_step (fset \<F>) PAny ESingle R)"
	+ unfolding RR2_spec_def gctxt_closure_lang lift_root_step.simps
	+ unfolding gctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
	+ by (intro RR2_gctxt_cl_to_gctxt) auto
	+
	+lemma mctxt_closure_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec (mctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<A>) (lift_root_step (fset \<F>) PAny EStrictParallel R)"
	+ unfolding RR2_spec_def gmctxt_closure_lang lift_root_step.simps
	+ unfolding gmctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def] conj_assoc
	+ by (intro RR2_gmctxt_cl_to_gmctxt[where ?P = "\<lambda> C. 0 < num_gholes C \<and> funas_gmctxt C \<subseteq> fset (lift_sig_RR2 \|`\| \<F>)" and
	+ ?R = "\<lambda> C. 0 < num_gholes C \<and> funas_gmctxt C \<subseteq> fset \<F>", unfolded conj_assoc]) auto
	+
	+lemma nhole_ctxt_closure_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec (nhole_ctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<A>) (lift_root_step (fset \<F>) PNonRoot ESingle R)"
	+ unfolding RR2_spec_def nhole_ctxtcl_lang lift_root_step.simps
	+ unfolding gctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
	+ by (intro RR2_gctxt_cl_to_gctxt[where
	+ ?P = "\<lambda> C. C \<noteq> \<box>\<^sub>G \<and> funas_gctxt C \<subseteq> fset (lift_sig_RR2 \|`\| \<F>)", unfolded conj_assoc]) auto
	+
	+lemma nhole_mctxt_closure_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec (nhole_mctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<A>) (lift_root_step (fset \<F>) PNonRoot EStrictParallel R)"
	+ unfolding RR2_spec_def nhole_gmctxt_closure_lang lift_root_step.simps
	+ unfolding gmctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
	+ by (intro RR2_gmctxt_cl_to_gmctxt[where
	+ ?P = "\<lambda> C. 0 < num_gholes C \<and> C \<noteq> GMHole \<and> funas_gmctxt C \<subseteq> fset (lift_sig_RR2 \|`\| \<F>)", unfolded conj_assoc])
	+ auto
	+
	+lemma nhole_mctxt_reflcl_automaton:
	+ assumes "RR2_spec \<A> R"
	+ shows "RR2_spec (nhole_mctxt_reflcl_reg (lift_sig_RR2 \|`\| \<F>) \<A>) (lift_root_step (fset \<F>) PNonRoot EParallel R)"
	+ using nhole_mctxt_closure_automaton[OF assms, of \<F>]
	+ unfolding RR2_spec_def lift_root_step_Parallel_conv nhole_mctxt_reflcl_lang
	+ by (auto simp flip: \<T>\<^sub>G_equivalent_def)
	+
	+definition GTT_to_RR2_root :: "('q, 'f) gtt \<Rightarrow> (_, 'f option \<times> 'f option) ta" where
	+ "GTT_to_RR2_root \<G> = pair_automaton (fst \<G>) (snd \<G>)"
	+
	+definition GTT_to_RR2_root_reg where
	+ "GTT_to_RR2_root_reg \<G> = Reg (map_both Some \|`\| fId_on (gtt_states \<G>)) (GTT_to_RR2_root \<G>)"
	+
	+lemma GTT_to_RR2_root:
	+ "RR2_spec (GTT_to_RR2_root_reg \<G>) (agtt_lang \<G>)"
	+proof -
	+ { fix s assume "s \<in> \<L> (GTT_to_RR2_root_reg \<G>)"
	+ then obtain q where q: "q \|\<in>\| fin (GTT_to_RR2_root_reg \<G>)" "q \|\<in>\| ta_der (GTT_to_RR2_root \<G>) (term_of_gterm s)"
	+ by (auto simp: \<L>_def gta_lang_def GTT_to_RR2_root_reg_def gta_der_def)
	+ then obtain q' where [simp]: "q = (Some q', Some q')" using q(1) by (auto simp: GTT_to_RR2_root_reg_def)
	+ have "\<exists>t u q. s = gpair t u \<and> q \|\<in>\| ta_der (fst \<G>) (term_of_gterm t) \<and> q \|\<in>\| ta_der (snd \<G>) (term_of_gterm u)"
	+ using fsubsetD[OF ta_der_mono' q(2), of "pair_automaton (fst \<G>) (snd \<G>)"]
	+ by (auto simp: GTT_to_RR2_root_def dest!: from_ta_der_pair_automaton(4))
	+ } moreover
	+ { fix t u q assume q: "q \|\<in>\| ta_der (fst \<G>) (term_of_gterm t)" "q \|\<in>\| ta_der (snd \<G>) (term_of_gterm u)"
	+ have "lift_fun q \|\<in>\| map_both Some \|`\| fId_on (\<Q> (fst \<G>) \|\<union>\| \<Q> (snd \<G>))"
	+ using q[THEN fsubsetD[OF ground_ta_der_states[OF ground_term_of_gterm]]]
	+ by (auto simp: fimage_iff fBex_def)
	+ then have "gpair t u \<in> \<L> (GTT_to_RR2_root_reg \<G>)" using q
	+ using fsubsetD[OF ta_der_mono to_ta_der_pair_automaton(3)[OF q], of "GTT_to_RR2_root \<G>"]
	+ by (auto simp: \<L>_def GTT_to_RR2_root_def gta_lang_def image_def gtt_states_def
	+ gta_der_def GTT_to_RR2_root_reg_def)
	+ } ultimately show ?thesis by (auto simp: RR2_spec_def agtt_lang_def \<L>_def gta_der_def)
	+qed
	+
	+lemma swap_GTT_to_RR2_root:
	+ "gpair s t \<in> \<L> (GTT_to_RR2_root_reg (prod.swap \<G>)) \<longleftrightarrow>
	+ gpair t s \<in> \<L> (GTT_to_RR2_root_reg \<G>)"
	+ by (auto simp: GTT_to_RR2_root[unfolded RR2_spec_def] agtt_lang_def)
	+
	+lemma funas_mctxt_map_vars_mctxt [simp]:
	+ "funas_mctxt (map_vars_mctxt f C) = funas_mctxt C"
	+ by (induct C) auto
	+
	+definition GTT_to_RR2_reg :: "('f \<times> nat) fset \<Rightarrow> ('q, 'f) gtt \<Rightarrow> (_, 'f option \<times> 'f option) reg" where
	+ "GTT_to_RR2_reg F G = parallel_closure_reg (lift_sig_RR2 \|`\| F) (GTT_to_RR2_root_reg G)"
	+
	+lemma agtt_lang_syms:
	+ "gtt_syms \<G> \|\<subseteq>\| \<F> \<Longrightarrow> agtt_lang \<G> \<subseteq> {t. funas_gterm t \<subseteq> fset \<F>} \<times> {t. funas_gterm t \<subseteq> fset \<F>}"
	+ by (auto simp: agtt_lang_def gta_der_def funas_term_of_gterm_conv)
	+ (metis ffunas_gterm.rep_eq fin_mono notin_fset ta_der_gterm_sig)+
	+
	+
	+lemma gtt_lang_from_agtt_lang:
	+ "gtt_lang \<G> = lift_root_step UNIV PAny EParallel (agtt_lang \<G>)"
	+ unfolding lift_root_step.simps agtt_lang_def
	+ by (auto simp: lift_root_step.simps agtt_lang_def gmctxt_cl_gmctxtex_onp_conv)
	+
	+lemma GTT_to_RR2:
	+ assumes "gtt_syms \<G> \|\<subseteq>\| \<F>"
	+ shows "RR2_spec (GTT_to_RR2_reg \<F> \<G>) (ggtt_lang \<F> \<G>)"
	+proof -
	+ have *: "snd ` (X \<times> X) = X" for X by auto
	+ show ?thesis unfolding gtt_lang_from_agtt_lang GTT_to_RR2_reg_def RR2_spec_def
	+ parallel_closure_automaton[OF GTT_to_RR2_root, of \<F> \<G>, unfolded RR2_spec_def]
	+ proof (intro arg_cong[where f = "\<lambda>X. {gpair t u \|t u. (t,u) \<in> X}"] equalityI subrelI, goal_cases)
	+ case (1 s t) then show ?case
	+ using subsetD[OF equalityD2[OF gtt_lang_from_agtt_lang], of "(s, t)" \<G>]
	+ by (intro rev_image_eqI[of "(term_of_gterm s, term_of_gterm t)"])
	+ (auto simp: funas_term_of_gterm_conv subsetD[OF lift_root_step_mono]
	+ dest: subsetD[OF lift_root_step_sig[unfolded \<T>\<^sub>G_equivalent_def, OF agtt_lang_syms[OF assms]]])
	+ next
	+ case (2 s t)
	+ from image_mono[OF agtt_lang_syms[OF assms], of snd, unfolded *]
	+ have *: "snd ` agtt_lang \<G> \<subseteq> gterms UNIV" by auto
	+ show ?case using 2
	+ by (auto intro!: lift_root_step_sig_transfer[unfolded \<T>\<^sub>G_equivalent_def, OF _ *, of _ _ _ "fset \<F>"]
	+ simp: funas_gterm_gterm_of_term funas_term_of_gterm_conv)
	+ qed
	+qed
	+
	+
	+end
	diff --git a/thys/FO_Theory_Rewriting/Closure/Lift_Root_Step.thy b/thys/FO_Theory_Rewriting/Closure/Lift_Root_Step.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Closure/Lift_Root_Step.thy
	@@ -0,0 +1,702 @@
	+section \<open>Lifting root steps to single/parallel root/non-root steps\<close>
	+theory Lift_Root_Step
	+ imports
	+ Rewriting
	+ FOR_Certificate
	+ Context_Extensions
	+ Multihole_Context
	+begin
	+
	+text \<open>Closure under all contexts\<close>
	+abbreviation "gctxtcl \<R> \<equiv> gctxtex_onp (\<lambda> C. True) \<R>"
	+abbreviation "gmctxtcl \<R> \<equiv> gctxtex_onp (\<lambda> C. True) \<R>"
	+
	+text \<open>Extension under all non empty contexts\<close>
	+abbreviation "gctxtex_nempty \<R> \<equiv> gctxtex_onp (\<lambda> C. C \<noteq> \<box>\<^sub>G) \<R>"
	+abbreviation "gmctxtex_nempty \<R> \<equiv> gmctxtex_onp (\<lambda> C. C \<noteq> GMHole) \<R>"
	+
	+text \<open>Closure under all contexts respecting the signature\<close>
	+abbreviation "gctxtcl_funas \<F> \<R> \<equiv> gctxtex_onp (\<lambda> C. funas_gctxt C \<subseteq> \<F>) \<R>"
	+abbreviation "gmctxtcl_funas \<F> \<R> \<equiv> gmctxtex_onp (\<lambda> C. funas_gmctxt C \<subseteq> \<F>) \<R>"
	+
	+text \<open>Closure under all multihole contexts with at least one hole respecting the signature\<close>
	+abbreviation "gmctxtcl_funas_strict \<F> \<R> \<equiv> gmctxtex_onp (\<lambda> C. 0 < num_gholes C \<and> funas_gmctxt C \<subseteq> \<F>) \<R>"
	+
	+text \<open>Extension under all non empty contexts respecting the signature\<close>
	+abbreviation "gctxtex_funas_nroot \<F> \<R> \<equiv> gctxtex_onp (\<lambda> C. funas_gctxt C \<subseteq> \<F> \<and> C \<noteq> \<box>\<^sub>G) \<R>"
	+abbreviation "gmctxtex_funas_nroot \<F> \<R> \<equiv> gmctxtex_onp (\<lambda> C. funas_gmctxt C \<subseteq> \<F> \<and> C \<noteq> GMHole) \<R>"
	+
	+text \<open>Extension under all non empty contexts respecting the signature\<close>
	+abbreviation "gmctxtex_funas_nroot_strict \<F> \<R> \<equiv>
	+ gmctxtex_onp (\<lambda> C. 0 < num_gholes C \<and> funas_gmctxt C \<subseteq> \<F> \<and> C \<noteq> GMHole) \<R>"
	+
	+
	+subsection \<open>Rewrite steps equivalent definitions\<close>
	+
	+definition gsubst_cl :: "('f, 'v) trs \<Rightarrow> 'f gterm rel" where
	+ "gsubst_cl \<R> = {(gterm_of_term (l \<cdot> \<sigma>), gterm_of_term (r \<cdot> \<sigma>)) \|
	+ l r (\<sigma> :: 'v \<Rightarrow> ('f, 'v) Term.term). (l, r) \<in> \<R> \<and> ground (l \<cdot> \<sigma>) \<and> ground (r \<cdot> \<sigma>)}"
	+
	+definition gnrrstepD :: "'f sig \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" where
	+ "gnrrstepD \<F> \<R> = gctxtex_funas_nroot \<F> \<R>"
	+
	+definition grstepD :: "'f sig \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" where
	+ "grstepD \<F> \<R> = gctxtcl_funas \<F> \<R>"
	+
	+definition gpar_rstepD :: "'f sig \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" where
	+ "gpar_rstepD \<F> \<R> = gmctxtcl_funas \<F> \<R>"
	+
	+inductive_set gpar_rstepD' :: "'f sig \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" for \<F> :: "'f sig" and \<R> :: "'f gterm rel"
	+ where groot_step [intro]: "(s, t) \<in> \<R> \<Longrightarrow> (s, t) \<in> gpar_rstepD' \<F> \<R>"
	+ \| gpar_step_fun [intro]: "\<lbrakk>\<And> i. i < length ts \<Longrightarrow> (ss ! i, ts ! i) \<in> gpar_rstepD' \<F> \<R>\<rbrakk> \<Longrightarrow> length ss = length ts
	+ \<Longrightarrow> (f, length ts) \<in> \<F> \<Longrightarrow> (GFun f ss, GFun f ts) \<in> gpar_rstepD' \<F> \<R>"
	+
	+subsection \<open>Interface between rewrite step definitions and sets\<close>
	+
	+fun lift_root_step :: "('f \<times> nat) set \<Rightarrow> pos_step \<Rightarrow> ext_step \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" where
	+ "lift_root_step \<F> PAny ESingle \<R> = gctxtcl_funas \<F> \<R>"
	+\| "lift_root_step \<F> PAny EStrictParallel \<R> = gmctxtcl_funas_strict \<F> \<R>"
	+\| "lift_root_step \<F> PAny EParallel \<R> = gmctxtcl_funas \<F> \<R>"
	+\| "lift_root_step \<F> PNonRoot ESingle \<R> = gctxtex_funas_nroot \<F> \<R>"
	+\| "lift_root_step \<F> PNonRoot EStrictParallel \<R> = gmctxtex_funas_nroot_strict \<F> \<R>"
	+\| "lift_root_step \<F> PNonRoot EParallel \<R> = gmctxtex_funas_nroot \<F> \<R>"
	+\| "lift_root_step \<F> PRoot ESingle \<R> = \<R>"
	+\| "lift_root_step \<F> PRoot EStrictParallel \<R> = \<R>"
	+\| "lift_root_step \<F> PRoot EParallel \<R> = \<R> \<union> Restr Id (\<T>\<^sub>G \<F>)"
	+
	+subsection \<open>Compatibility of used predicate extensions and signature closure\<close>
	+
	+lemma compatible_p [simp]:
	+ "compatible_p (\<lambda> C. C \<noteq> \<box>\<^sub>G) (\<lambda> C. C \<noteq> GMHole)"
	+ "compatible_p (\<lambda> C. funas_gctxt C \<subseteq> \<F>) (\<lambda> C. funas_gmctxt C \<subseteq> \<F>)"
	+ "compatible_p (\<lambda> C. funas_gctxt C \<subseteq> \<F> \<and> C \<noteq> \<box>\<^sub>G) (\<lambda> C. funas_gmctxt C \<subseteq> \<F> \<and> C \<noteq> GMHole)"
	+ unfolding compatible_p_def
	+ by rule (case_tac C, auto)+
	+
	+lemma gmctxtcl_funas_sigcl:
	+ "all_ctxt_closed \<F> (gmctxtcl_funas \<F> \<R>)"
	+ by (intro gmctxtex_onp_sig_closed) auto
	+
	+lemma gctxtex_funas_nroot_sigcl:
	+ "all_ctxt_closed \<F> (gmctxtex_funas_nroot \<F> \<R>)"
	+ by (intro gmctxtex_onp_sig_closed) auto
	+
	+lemma gmctxtcl_funas_strict_funcl:
	+ "function_closed \<F> (gmctxtcl_funas_strict \<F> \<R>)"
	+ by (intro gmctxtex_onp_fun_closed) (auto dest: list.set_sel)
	+
	+lemma gmctxtex_funas_nroot_strict_funcl:
	+ "function_closed \<F> (gmctxtex_funas_nroot_strict \<F> \<R>)"
	+ by (intro gmctxtex_onp_fun_closed) (auto dest: list.set_sel)
	+
	+lemma gctxtcl_funas_dist:
	+ "gctxtcl_funas \<F> \<R> = gctxtex_onp (\<lambda> C. C = \<box>\<^sub>G) \<R> \<union> gctxtex_funas_nroot \<F> \<R>"
	+ by (intro gctxtex_onp_pred_dist) auto
	+
	+lemma gmctxtex_funas_nroot_dist:
	+ "gmctxtex_funas_nroot \<F> \<R> = gmctxtex_funas_nroot_strict \<F> \<R> \<union>
	+ gmctxtex_onp (\<lambda> C. num_gholes C = 0 \<and> funas_gmctxt C \<subseteq> \<F>) \<R>"
	+ by (intro gmctxtex_onp_pred_dist) auto
	+
	+lemma gmctxtcl_funas_dist:
	+ "gmctxtcl_funas \<F> \<R> = gmctxtex_onp (\<lambda> C. num_gholes C = 0 \<and> funas_gmctxt C \<subseteq> \<F>) \<R> \<union>
	+ gmctxtex_onp (\<lambda> C. 0 < num_gholes C \<and> funas_gmctxt C \<subseteq> \<F>) \<R>"
	+ by (intro gmctxtex_onp_pred_dist) auto
	+
	+lemma gmctxtcl_funas_strict_dist:
	+ "gmctxtcl_funas_strict \<F> \<R> = gmctxtex_funas_nroot_strict \<F> \<R> \<union> gmctxtex_onp (\<lambda> C. C = GMHole) \<R>"
	+ by (intro gmctxtex_onp_pred_dist) auto
	+
	+lemma gmctxtex_onpzero_num_gholes_id [simp]:
	+ "gmctxtex_onp (\<lambda> C. num_gholes C = 0 \<and> funas_gmctxt C \<subseteq> \<F>) \<R> = Restr Id (\<T>\<^sub>G \<F>)" (is "?Ls = ?Rs")
	+proof -
	+ {fix s t assume "(s, t) \<in> ?Ls" from gmctxtex_onpE[OF this] obtain C us vs where
	+ *: "s = fill_gholes C us" "t = fill_gholes C vs" and
	+ len: "num_gholes C = length us" "length us = length vs" and
	+ inv: "num_gholes C = 0 \<and> funas_gmctxt C \<subseteq> \<F>" by auto
	+ then have "(s, t) \<in> ?Rs" using len inv unfolding *
	+ by (cases us; cases vs) (auto simp: \<T>\<^sub>G_funas_gterm_conv)}
	+ moreover have "?Rs \<subseteq> ?Ls"
	+ by (intro Restr_id_subset_gmctxtex_onp) auto
	+ ultimately show ?thesis by auto
	+qed
	+
	+lemma gctxtex_onp_sign_trans_fst:
	+ assumes "(s, t) \<in> gctxtex_onp P R" and "s \<in> \<T>\<^sub>G \<F>"
	+ shows "(s, t) \<in> gctxtex_onp (\<lambda> C. funas_gctxt C \<subseteq> \<F> \<and> P C) R"
	+ using assms
	+ by (auto simp: \<T>\<^sub>G_equivalent_def elim!: gctxtex_onpE)
	+
	+lemma gctxtex_onp_sign_trans_snd:
	+ assumes "(s, t) \<in> gctxtex_onp P R" and "t \<in> \<T>\<^sub>G \<F>"
	+ shows "(s, t) \<in> gctxtex_onp (\<lambda> C. funas_gctxt C \<subseteq> \<F> \<and> P C) R"
	+ using assms
	+ by (auto simp: \<T>\<^sub>G_equivalent_def elim!: gctxtex_onpE)
	+
	+lemma gmctxtex_onp_sign_trans_fst:
	+ assumes "(s, t) \<in> gmctxtex_onp P R" and "s \<in> \<T>\<^sub>G \<F>"
	+ shows "(s, t) \<in> gmctxtex_onp (\<lambda> C. P C \<and> funas_gmctxt C \<subseteq> \<F>) R"
	+ using assms
	+ by (auto simp: \<T>\<^sub>G_equivalent_def simp add: gmctxtex_onpI)
	+
	+lemma gmctxtex_onp_sign_trans_snd:
	+ assumes "(s, t) \<in> gmctxtex_onp P R" and "t \<in> \<T>\<^sub>G \<F>"
	+ shows "(s, t) \<in> gmctxtex_onp (\<lambda> C. P C \<and> funas_gmctxt C \<subseteq> \<F>) R"
	+ using assms
	+ by (auto simp: \<T>\<^sub>G_equivalent_def simp add: gmctxtex_onpI)
	+
	+subsection \<open>Basic lemmas\<close>
	+
	+lemma gsubst_cl:
	+ fixes \<R> :: "('f, 'v) trs" and \<sigma> :: "'v \<Rightarrow> ('f, 'v) term"
	+ assumes "(l, r) \<in> \<R>" and "ground (l \<cdot> \<sigma>)" "ground (r \<cdot> \<sigma>)"
	+ shows "(gterm_of_term (l \<cdot> \<sigma>), gterm_of_term (r \<cdot> \<sigma>)) \<in> gsubst_cl \<R>"
	+ using assms unfolding gsubst_cl_def by auto
	+
	+lemma grstepD [simp]:
	+ "(s, t) \<in> \<R> \<Longrightarrow> (s, t) \<in> grstepD \<F> \<R>"
	+ by (auto simp: grstepD_def gctxtex_onp_def intro!: exI[of _ "\<box>\<^sub>G"])
	+
	+lemma grstepD_ctxtI [intro]:
	+ "(l, r) \<in> \<R> \<Longrightarrow> funas_gctxt C \<subseteq> \<F> \<Longrightarrow> (C\<langle>l\<rangle>\<^sub>G, C\<langle>r\<rangle>\<^sub>G) \<in> grstepD \<F> \<R>"
	+ by (auto simp: grstepD_def gctxtex_onp_def intro!: exI[of _ "C"])
	+
	+lemma gctxtex_funas_nroot_gctxtcl_funas_subseteq:
	+ "gctxtex_funas_nroot \<F> (grstepD \<F> \<R>) \<subseteq> grstepD \<F> \<R>"
	+ unfolding grstepD_def
	+ by (intro gctxtex_pred_cmp_subseteq) auto
	+
	+lemma Restr_gnrrstepD_dist [simp]:
	+ "Restr (gnrrstepD \<F> \<R>) (\<T>\<^sub>G \<G>) = gnrrstepD (\<F> \<inter> \<G>) (Restr \<R> (\<T>\<^sub>G \<G>))"
	+ by (auto simp add: gnrrstepD_def)
	+
	+lemma Restr_grstepD_dist [simp]:
	+ "Restr (grstepD \<F> \<R>) (\<T>\<^sub>G \<G>) = grstepD (\<F> \<inter> \<G>) (Restr \<R> (\<T>\<^sub>G \<G>))"
	+ by (auto simp add: grstepD_def)
	+
	+lemma Restr_gpar_rstepD_dist [simp]:
	+ "Restr (gpar_rstepD \<F> \<R>) (\<T>\<^sub>G \<G>) = gpar_rstepD (\<F> \<inter> \<G>) (Restr \<R> (\<T>\<^sub>G \<G>))" (is "?Ls = ?Rs")
	+ by (auto simp: gpar_rstepD_def)
	+
	+subsection \<open>Equivalence lemmas\<close>
	+
	+lemma grrstep_subst_cl_conv:
	+ "grrstep \<R> = gsubst_cl \<R>"
	+ unfolding gsubst_cl_def grrstep_def rrstep_def rstep_r_p_s_def
	+ by (auto, metis ground_substI ground_term_of_gterm term_of_gterm_inv) blast
	+
	+lemma gnrrstepD_gnrrstep_conv:
	+ "gnrrstep \<R> = gnrrstepD UNIV (gsubst_cl \<R>)" (is "?Ls = ?Rs")
	+proof -
	+ {fix s t assume "(s, t) \<in> ?Ls" then obtain l r C \<sigma> where
	+ mem: "(l, r) \<in> \<R>" "C \<noteq> \<box>" "term_of_gterm s = C\<langle>l \<cdot> (\<sigma> :: 'b \<Rightarrow> ('a, 'b) term)\<rangle>" "term_of_gterm t = C\<langle>r \<cdot> \<sigma>\<rangle>"
	+ unfolding gnrrstep_def inv_image_def nrrstep_def' by auto
	+ then have "(s, t) \<in> ?Rs" using gsubst_cl[OF mem(1)]
	+ using gctxtex_onpI[of "\<lambda> C. funas_gctxt C \<subseteq> UNIV \<and> C \<noteq> \<box>\<^sub>G" "gctxt_of_ctxt C" "gterm_of_term (l \<cdot> \<sigma>)"
	+ "gterm_of_term (r \<cdot> \<sigma>)" "gsubst_cl \<R>"]
	+ by (auto simp: gnrrstepD_def)}
	+ moreover
	+ {fix s t assume "(s, t) \<in> ?Rs" then have "(s, t) \<in> ?Ls"
	+ unfolding gnrrstepD_def gctxtex_onp_def gnrrstep_def inv_image_def nrrstep_def' gsubst_cl_def
	+ by auto (metis ctxt_of_gctxt.simps(1) ctxt_of_gctxt_inv ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply ground_substI)}
	+ ultimately show ?thesis by auto
	+qed
	+
	+lemma grstepD_grstep_conv:
	+ "grstep \<R> = grstepD UNIV (gsubst_cl \<R>)" (is "?Ls = ?Rs")
	+proof -
	+ {fix s t assume "(s, t) \<in> ?Ls" then obtain C l r \<sigma> where
	+ mem: "(l, r) \<in> \<R>" "term_of_gterm s = C\<langle>l \<cdot> (\<sigma> :: 'b \<Rightarrow> ('a, 'b) term)\<rangle>" "term_of_gterm t = C\<langle>r \<cdot> \<sigma>\<rangle>"
	+ unfolding grstep_def inv_image_def by auto
	+ then have "(s, t) \<in> ?Rs" using grstepD_ctxtI[OF gsubst_cl[OF mem(1)], of \<sigma> "gctxt_of_ctxt C" UNIV]
	+ by (auto simp: grstepD_def gctxtex_onp_def)}
	+ moreover
	+ {fix s t assume "(s, t) \<in> ?Rs" then have "(s, t) \<in> ?Ls"
	+ by (auto simp: gctxtex_onp_def grstepD_def grstep_def gsubst_cl_def)
	+ (metis ctxt_of_gctxt_apply_gterm ground_ctxt_apply
	+ ground_ctxt_of_gctxt ground_substI gterm_of_term_inv rstep.intros)}
	+ ultimately show ?thesis by auto
	+qed
	+
	+lemma gpar_rstep_gpar_rstepD_conv:
	+ "gpar_rstep \<R> = gpar_rstepD' UNIV (gsubst_cl \<R>)" (is "?Ls = ?Rs")
	+proof -
	+ {fix s t assume "(s, t) \<in> ?Rs"
	+ then have "(s, t) \<in> gpar_rstep \<R>"
	+ by induct (auto simp: gpar_rstep_def gsubst_cl_def)}
	+ moreover
	+ {fix s t assume ass: "(s, t) \<in> ?Ls" then obtain u v where
	+ "(u, v) \<in> par_rstep \<R>" "u = term_of_gterm s" "v = term_of_gterm t"
	+ by (simp add: gpar_rstep_def inv_image_def)
	+ then have "(s, t) \<in> ?Rs"
	+ proof (induct arbitrary: s t)
	+ case (root_step u v \<sigma>)
	+ then have "(s, t) \<in> gsubst_cl \<R>" unfolding gsubst_cl_def
	+ by auto (metis ground_substI ground_term_of_gterm term_of_gterm_inv)
	+ then show ?case by auto
	+ next
	+ case (par_step_fun ts ss f)
	+ then show ?case by (cases s; cases t) auto
	+ next
	+ case (par_step_var x)
	+ then show ?case by (cases s) auto
	+ qed}
	+ ultimately show ?thesis by auto
	+qed
	+
	+lemma gmctxtcl_funas_idem:
	+ "gmctxtcl_funas \<F> (gmctxtcl_funas \<F> \<R>) \<subseteq> gmctxtcl_funas \<F> \<R>"
	+ by (intro gmctxtex_pred_cmp_subseteq)
	+ (auto elim!: less_eq_to_sup_mctxt_args, blast+)
	+
	+lemma gpar_rstepD_gpar_rstepD'_conv:
	+ "gpar_rstepD \<F> \<R> = gpar_rstepD' \<F> \<R>" (is "?Ls = ?Rs")
	+proof -
	+ {fix s t assume "(s, t) \<in> ?Rs" then have "(s, t) \<in> ?Ls"
	+ proof induct
	+ case (groot_step s t) then show ?case unfolding gpar_rstepD_def
	+ using gmctxtex_onpI[of _ GMHole "[s]" "[t]"]
	+ by auto
	+ next
	+ case (gpar_step_fun ts ss f)
	+ show ?case using gpar_step_fun(2-) unfolding gpar_rstepD_def
	+ using subsetD[OF gmctxtcl_funas_idem, of "(GFun f ss, GFun f ts)" \<F> \<R>]
	+ using gmctxtex_onpI[of _ "GMFun f (replicate (length ss) GMHole)" ss ts "gmctxtcl_funas \<F> \<R>"]
	+ by (auto simp del: fill_gholes.simps)
	+ qed}
	+ moreover
	+ {fix s t assume "(s, t) \<in> ?Ls" then obtain C ss ts where
	+ t: "s = fill_gholes C ss" "t = fill_gholes C ts" and
	+ inv: "num_gholes C = length ss" "num_gholes C = length ts" and
	+ pred: "funas_gmctxt C \<subseteq> \<F>" and rel: "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>"
	+ unfolding gpar_rstepD_def by auto
	+ have "(s, t) \<in> ?Rs" using inv pred rel unfolding t
	+ proof (induct rule: fill_gholes_induct2)
	+ case (GMHole x) then show ?case
	+ by (cases ts) auto
	+ next
	+ case (GMFun f Cs xs ys)
	+ from GMFun(1, 2, 5) have "i < length Cs \<Longrightarrow> \<forall> j < length (partition_gholes ys Cs ! i).
	+ (partition_gholes xs Cs ! i ! j, partition_gholes ys Cs ! i ! j) \<in> \<R>" for i
	+ by (auto simp: length_partition_by_nth partition_by_nth_nth(1, 2))
	+ from GMFun this show ?case unfolding partition_holes_fill_gholes_conv'
	+ by (intro gpar_step_fun) (auto, meson UN_I nth_mem subset_iff)
	+ qed}
	+ ultimately show ?thesis by auto
	+qed
	+
	+subsection \<open>Signature preserving lemmas\<close>
	+
	+lemma \<T>\<^sub>G_trans_closure_id [simp]:
	+ "(\<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>)\<^sup>+ = \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ by (auto simp: trancl_full_on)
	+
	+lemma signature_pres_funas_cl [simp]:
	+ "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F> \<Longrightarrow> gctxtcl_funas \<F> \<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F> \<Longrightarrow> gmctxtcl_funas \<F> \<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ apply (intro gctxtex_onp_in_signature) apply blast+
	+ apply (intro gmctxtex_onp_in_signature) apply blast+
	+ done
	+
	+lemma relf_on_gmctxtcl_funas:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "refl_on (\<T>\<^sub>G \<F>) (gmctxtcl_funas \<F> \<R>)"
	+proof -
	+ have "t \<in> \<T>\<^sub>G \<F> \<Longrightarrow> (t, t) \<in> gmctxtcl_funas \<F> \<R>" for t
	+ using gmctxtex_onpI[of _ "gmctxt_of_gterm t"]
	+ by (auto simp: \<T>\<^sub>G_funas_gterm_conv)
	+ then show ?thesis using assms
	+ by (auto simp: refl_on_def)
	+qed
	+
	+lemma gtrancl_rel_sound:
	+ "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F> \<Longrightarrow> gtrancl_rel \<F> \<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ unfolding gtrancl_rel_def
	+ by (intro Restr_tracl_comp_simps(3)) (auto simp: gmctxt_cl_gmctxtex_onp_conv)
	+
	+
	+subsection \<open>@{const gcomp_rel} and @{const gtrancl_rel} lemmas\<close>
	+
	+lemma gcomp_rel:
	+ "lift_root_step \<F> PAny EParallel (gcomp_rel \<F> \<R> \<S>) = lift_root_step \<F> PAny EParallel \<R> O lift_root_step \<F> PAny EParallel \<S>" (is "?Ls = ?Rs")
	+proof
	+ { fix s u assume "(s, u) \<in> gpar_rstepD' \<F> (\<R> O gpar_rstepD' \<F> \<S> \<union> gpar_rstepD' \<F> \<R> O \<S>)"
	+ then have "\<exists>t. (s, t) \<in> gpar_rstepD' \<F> \<R> \<and> (t, u) \<in> gpar_rstepD' \<F> \<S>"
	+ proof (induct)
	+ case (gpar_step_fun ts ss f)
	+ from Ex_list_of_length_P[of _ "\<lambda> u i. (ss ! i, u) \<in> gpar_rstepD' \<F> \<R> \<and> (u, ts ! i) \<in> gpar_rstepD' \<F> \<S>"]
	+ obtain us where l: "length us = length ts" and
	+ inv: "\<forall> i < length ts. (ss ! i, us ! i) \<in> gpar_rstepD' \<F> \<R> \<and> (us ! i, ts ! i) \<in> gpar_rstepD' \<F> \<S>"
	+ using gpar_step_fun(2, 3) by blast
	+ then show ?case using gpar_step_fun(3, 4)
	+ by (auto intro!: exI[of _ "GFun f us"])
	+ qed auto}
	+ then show "?Ls \<subseteq> ?Rs" unfolding gcomp_rel_def
	+ by (auto simp: gmctxt_cl_gmctxtex_onp_conv simp flip: gpar_rstepD_gpar_rstepD'_conv[unfolded gpar_rstepD_def])
	+next
	+ {fix s t u assume "(s, t) \<in> gpar_rstepD' \<F> \<R>" "(t, u) \<in> gpar_rstepD' \<F> \<S>"
	+ then have "(s, u) \<in> gpar_rstepD' \<F> (\<R> O gpar_rstepD' \<F> \<S> \<union> gpar_rstepD' \<F> \<R> O \<S>)"
	+ proof (induct arbitrary: u rule: gpar_rstepD'.induct)
	+ case (gpar_step_fun ts ss f) note IS = this
	+ show ?case
	+ proof (cases "(GFun f ts, u) \<in> \<S>")
	+ case True
	+ then have "(GFun f ss, u) \<in> gpar_rstepD' \<F> \<R> O \<S>" using IS(1, 3, 4)
	+ by auto
	+ then show ?thesis by auto
	+ next
	+ case False
	+ then obtain us where u[simp]: "u = GFun f us" and l: "length ts = length us"
	+ using IS(5) by (cases u) (auto elim!: gpar_rstepD'.cases)
	+ have "i < length us \<Longrightarrow>
	+ (ss ! i, us ! i) \<in> gpar_rstepD' \<F> (\<R> O gpar_rstepD' \<F> \<S> \<union> gpar_rstepD' \<F> \<R> O \<S>)" for i
	+ using IS(2, 5) False
	+ by (auto elim!: gpar_rstepD'.cases)
	+ then show ?thesis using l IS(3, 4) unfolding u
	+ by auto
	+ qed
	+ qed auto}
	+ then show "?Rs \<subseteq> ?Ls"
	+ by (auto simp: gmctxt_cl_gmctxtex_onp_conv gcomp_rel_def gpar_rstepD_gpar_rstepD'_conv[unfolded gpar_rstepD_def])
	+qed
	+
	+lemma gmctxtcl_funas_in_rtrancl_gctxtcl_funas:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gmctxtcl_funas \<F> \<R> \<subseteq> (gctxtcl_funas \<F> \<R>)\<^sup>*" using assms
	+ by (intro gmctxtex_onp_gctxtex_onp_rtrancl) (auto simp: gmctxt_p_inv_def)
	+
	+lemma R_in_gtrancl_rel:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "\<R> \<subseteq> gtrancl_rel \<F> \<R>"
	+proof
	+ fix s t assume ass: "(s, t) \<in> \<R>"
	+ then have "(s, s) \<in> gmctxtcl_funas \<F> \<R>" "(t, t) \<in> gmctxtcl_funas \<F> \<R>" using assms
	+ using all_ctxt_closed_imp_reflx_on_sig[OF gmctxtcl_funas_sigcl, of \<F> \<R>]
	+ by auto
	+ then show "(s, t) \<in> gtrancl_rel \<F> \<R>" using ass
	+ by (auto simp: gmctxt_cl_gmctxtex_onp_conv relcomp_unfold gtrancl_rel_def)
	+qed
	+
	+lemma trans_gtrancl_rel [simp]:
	+ "trans (gtrancl_rel \<F> \<R>)"
	+proof -
	+ have "(s, t) \<in> \<R> \<Longrightarrow> (s, t) \<in> gmctxtcl_funas \<F> \<R>" for s t
	+ by (metis bot.extremum funas_gmctxt.simps(2) gmctxtex_closure subsetD)
	+ then show ?thesis unfolding trans_def gtrancl_rel_def
	+ by (auto simp: gmctxt_cl_gmctxtex_onp_conv, meson relcomp3_I trancl_into_trancl2 trancl_trans)
	+qed
	+
	+lemma gtrancl_rel_cl:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gmctxtcl_funas \<F> (gtrancl_rel \<F> \<R>) \<subseteq> (gmctxtcl_funas \<F> \<R>)\<^sup>+"
	+proof -
	+ have *:"(s, t) \<in> \<R> \<Longrightarrow> (s, t) \<in> gmctxtcl_funas \<F> \<R>" for s t
	+ by (metis bot.extremum funas_gmctxt.simps(2) gmctxtex_closure subsetD)
	+ have "gmctxtcl_funas \<F> ((gmctxtcl_funas \<F> \<R>)\<^sup>+) \<subseteq> (gmctxtcl_funas \<F> \<R>)\<^sup>+"
	+ unfolding gtrancl_rel_def using relf_on_gmctxtcl_funas[OF assms]
	+ by (intro gmctxtex_onp_substep_trancl, intro gmctxtex_pred_cmp_subseteq2)
	+ (auto simp: less_sup_gmctxt_args_funas_gmctxt refl_on_def)
	+ moreover have "gtrancl_rel \<F> \<R> \<subseteq> (gmctxtcl_funas \<F> \<R>)\<^sup>+"
	+ unfolding gtrancl_rel_def using *
	+ by (auto simp: gmctxt_cl_gmctxtex_onp_conv, meson trancl.trancl_into_trancl trancl_trans)
	+ ultimately show ?thesis using gmctxtex_onp_rel_mono by blast
	+qed
	+
	+lemma gtrancl_rel_aux:
	+ "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F> \<Longrightarrow> gmctxtcl_funas \<F> (gtrancl_rel \<F> \<R>) O gtrancl_rel \<F> \<R> \<subseteq> gtrancl_rel \<F> \<R>"
	+ "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F> \<Longrightarrow> gtrancl_rel \<F> \<R> O gmctxtcl_funas \<F> (gtrancl_rel \<F> \<R>) \<subseteq> gtrancl_rel \<F> \<R>"
	+ using subsetD[OF gtrancl_rel_cl[of \<R> \<F>]] unfolding gtrancl_rel_def
	+ by (auto simp: gmctxt_cl_gmctxtex_onp_conv) (meson relcomp3_I trancl_trans)+
	+
	+
	+declare subsetI [rule del]
	+lemma gtrancl_rel:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>" "compatible_p Q P"
	+ and "\<And> C. P C \<Longrightarrow> funas_gmctxt C \<subseteq> \<F>"
	+ and "\<And> C D. P C \<Longrightarrow> P D \<Longrightarrow> (C, D) \<in> comp_gmctxt \<Longrightarrow> P (C \<sqinter> D)"
	+ shows "(gctxtex_onp Q \<R>)\<^sup>+ \<subseteq> gmctxtex_onp P (gtrancl_rel \<F> \<R>)"
	+proof -
	+ have fst: "gctxtex_onp Q \<R> \<subseteq> gctxtex_onp Q (gtrancl_rel \<F> \<R>)"
	+ using R_in_gtrancl_rel[OF assms(1)]
	+ by (simp add: gctxtex_onp_rel_mono)
	+ have snd: "gctxtex_onp Q (gtrancl_rel \<F> \<R>) \<subseteq> gmctxtex_onp P (gtrancl_rel \<F> \<R>)"
	+ using assms(2)
	+ by auto
	+ have "(gmctxtex_onp P (gtrancl_rel \<F> \<R>))\<^sup>+ = gmctxtex_onp P (gtrancl_rel \<F> \<R>)"
	+ by (intro gmctxtex_onp_substep_tranclE[of _ "\<lambda> C. funas_gmctxt C \<subseteq> \<F>"])
	+ (auto simp: gtrancl_rel_aux[OF assms(1)] assms(3, 4) intro: funas_gmctxt_poss_gmctxt_subgm_at_funas)
	+ then show ?thesis using subset_trans[OF fst snd]
	+ using trancl_mono_set by fastforce
	+qed
	+
	+lemma gtrancl_rel_subseteq_trancl_gctxtcl_funas:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gtrancl_rel \<F> \<R> \<subseteq> (gctxtcl_funas \<F> \<R>)\<^sup>+"
	+proof -
	+ have [dest!]: "(s, t) \<in> \<R> \<Longrightarrow> (s, t) \<in> (gctxtcl_funas \<F> \<R>)\<^sup>+" for s t
	+ using grstepD grstepD_def by blast
	+ have [dest!]: "(s, t) \<in> (gmctxtcl_funas \<F> \<R>)\<^sup>+ \<Longrightarrow> (s, t) \<in> (gctxtcl_funas \<F> \<R>)\<^sup>+ \<union> Restr Id (\<T>\<^sub>G \<F>)"
	+ for s t
	+ using gmctxtcl_funas_in_rtrancl_gctxtcl_funas[OF assms]
	+ using signature_pres_funas_cl[OF assms]
	+ apply (auto simp: gtrancl_rel_def rtrancl_eq_or_trancl intro!: subsetI)
	+ apply (metis rtranclD rtrancl_trancl_absorb trancl_mono)
	+ apply (metis mem_Sigma_iff trancl_full_on trancl_mono)+
	+ done
	+ then show ?thesis using gtrancl_rel_sound[OF assms]
	+ by (auto simp: gtrancl_rel_def rtrancl_eq_or_trancl gmctxt_cl_gmctxtex_onp_conv intro!: subsetI)
	+qed
	+
	+lemma gmctxtex_onp_gtrancl_rel:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>" and "\<And> C D. Q C \<Longrightarrow> funas_gctxt D \<subseteq> \<F> \<Longrightarrow> Q (C \<circ>\<^sub>G\<^sub>c D)"
	+ and "\<And>C. P C \<Longrightarrow> 0 < num_gholes C \<and> funas_gmctxt C \<subseteq> \<F>"
	+ and "\<And>C. P C \<Longrightarrow> gmctxt_p_inv C \<F> Q"
	+ shows "gmctxtex_onp P (gtrancl_rel \<F> \<R>) \<subseteq> (gctxtex_onp Q \<R>)\<^sup>+"
	+proof -
	+ {fix s t assume ass: "(s, t) \<in> gctxtex_onp Q ((gctxtcl_funas \<F> \<R>)\<^sup>+)"
	+ from gctxtex_onpE[OF ass] obtain C u v where
	+ *: "s = C\<langle>u\<rangle>\<^sub>G" "t = C\<langle>v\<rangle>\<^sub>G" and
	+ inv: "Q C" "(u, v) \<in> (gctxtcl_funas \<F> \<R>)\<^sup>+" by blast
	+ from inv(2) have "(s, t) \<in> (gctxtex_onp Q \<R>)\<^sup>+" unfolding *
	+ proof induct
	+ case (base y)
	+ then show ?case using assms(2)[OF inv(1)]
	+ by (auto elim!: gctxtex_onpE) (metis ctxt_ctxt_compose gctxtex_onpI trancl.r_into_trancl)
	+ next
	+ case (step y z)
	+ from step(2) have "(C\<langle>y\<rangle>\<^sub>G, C\<langle>z\<rangle>\<^sub>G) \<in> gctxtex_onp Q \<R>" using assms(2)[OF inv(1)]
	+ by (auto elim!: gctxtex_onpE) (metis ctxt_ctxt_compose gctxtex_onpI)
	+ then show ?case using step(3)
	+ by auto
	+ qed}
	+ then have con: "gctxtex_onp Q ((gctxtcl_funas \<F> \<R>)\<^sup>+) \<subseteq> (gctxtex_onp Q \<R>)\<^sup>+"
	+ using subrelI by blast
	+ have snd: "gmctxtex_onp P ((gctxtcl_funas \<F> \<R>)\<^sup>+) \<subseteq> (gctxtex_onp Q ((gctxtcl_funas \<F> \<R>)\<^sup>+))\<^sup>+"
	+ using assms(1)
	+ by (intro gmctxtex_onp_gctxtex_onp_trancl[OF assms(3) _ assms(4)]) auto
	+ have fst: "gmctxtex_onp P (gtrancl_rel \<F> \<R>) \<subseteq> gmctxtex_onp P ((gctxtcl_funas \<F> \<R>)\<^sup>+)"
	+ using gtrancl_rel_subseteq_trancl_gctxtcl_funas[OF assms(1)]
	+ by (simp add: gmctxtex_onp_rel_mono)
	+ show ?thesis using subset_trans[OF fst snd] con
	+ by (auto intro!: subsetI)
	+ (metis (no_types, lifting) in_mono rtrancl_trancl_trancl tranclD2 trancl_mono trancl_rtrancl_absorb)
	+qed
	+
	+lemma gmctxtcl_funas_strict_gtrancl_rel:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gmctxtcl_funas_strict \<F> (gtrancl_rel \<F> \<R>) = (gctxtcl_funas \<F> \<R>)\<^sup>+" (is "?Ls = ?Rs")
	+proof
	+ show "?Ls \<subseteq> ?Rs"
	+ by (intro gmctxtex_onp_gtrancl_rel[OF assms]) (auto simp: gmctxt_p_inv_def)
	+next
	+ show "?Rs \<subseteq> ?Ls"
	+ by (intro gtrancl_rel[OF assms])
	+ (auto simp: compatible_p_def num_gholes_at_least1
	+ intro: subset_trans[OF inf_funas_gmctxt_subset2])
	+qed
	+
	+lemma gmctxtex_funas_nroot_strict_gtrancl_rel:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gmctxtex_funas_nroot_strict \<F> (gtrancl_rel \<F> \<R>) = (gctxtex_funas_nroot \<F> \<R>)\<^sup>+"
	+ (is "?Ls = ?Rs")
	+proof
	+ show "?Ls \<subseteq> ?Rs"
	+ by (intro gmctxtex_onp_gtrancl_rel[OF assms])
	+ (auto simp: gmctxt_p_inv_def gmctxt_closing_def
	+ dest!: less_eq_gmctxt_Hole gctxt_of_gmctxt_hole_dest gctxt_compose_HoleE(1))
	+next
	+ show "?Rs \<subseteq> ?Ls"
	+ by (intro gtrancl_rel[OF assms])
	+ (auto simp: compatible_p_def num_gholes_at_least1
	+ elim!: comp_gmctxt.cases
	+ dest: gmctxt_of_gctxt_GMHole_Hole
	+ intro: subset_trans[OF inf_funas_gmctxt_subset2])
	+qed
	+
	+lemma lift_root_step_sig':
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<G> \<times> \<T>\<^sub>G \<H>" "\<F> \<subseteq> \<G>" "\<F> \<subseteq> \<H>"
	+ shows "lift_root_step \<F> W X \<R> \<subseteq> \<T>\<^sub>G \<G> \<times> \<T>\<^sub>G \<H>"
	+ using assms \<T>\<^sub>G_mono
	+ by (cases W; cases X) (auto simp add: Sigma_mono \<T>\<^sub>G_mono inf.coboundedI2)
	+
	+lemmas lift_root_step_sig = lift_root_step_sig'[OF _ subset_refl subset_refl]
	+
	+lemma lift_root_step_incr:
	+ "\<R> \<subseteq> \<S> \<Longrightarrow> lift_root_step \<F> W X \<R> \<subseteq> lift_root_step \<F> W X \<S>"
	+ by (cases W; cases X) (auto simp add: le_supI1 gctxtex_onp_rel_mono gmctxtex_onp_rel_mono)
	+
	+lemma Restr_id_mono:
	+ "\<F> \<subseteq> \<G> \<Longrightarrow> Restr Id (\<T>\<^sub>G \<F>) \<subseteq> Restr Id (\<T>\<^sub>G \<G>)"
	+ by (meson Sigma_mono \<T>\<^sub>G_mono inf_mono subset_refl)
	+
	+lemma lift_root_step_mono:
	+ "\<F> \<subseteq> \<G> \<Longrightarrow> lift_root_step \<F> W X \<R> \<subseteq> lift_root_step \<G> W X \<R>"
	+ by (cases W; cases X) (auto simp: Restr_id_mono intro: gmctxtex_onp_mono gctxtex_onp_mono,
	+ metis Restr_id_mono sup.coboundedI1 sup_commute)
	+
	+
	+lemma grstep_lift_root_step:
	+ "lift_root_step \<F> PAny ESingle (Restr (grrstep \<R>) (\<T>\<^sub>G \<F>)) = Restr (grstep \<R>) (\<T>\<^sub>G \<F>)"
	+ unfolding grstepD_grstep_conv grstepD_def grrstep_subst_cl_conv
	+ by auto
	+
	+lemma prod_swap_id_on_refl [simp]:
	+ "Restr Id (\<T>\<^sub>G \<F>) \<subseteq> prod.swap ` (\<R> \<union> Restr Id (\<T>\<^sub>G \<F>))"
	+ by (auto intro: subsetI)
	+
	+lemma swap_lift_root_step:
	+ "lift_root_step \<F> W X (prod.swap ` \<R>) = prod.swap ` lift_root_step \<F> W X \<R>"
	+ by (cases W; cases X) (auto simp add: image_mono swap_gmctxtex_onp swap_gctxtex_onp intro: subsetI)
	+
	+lemma converse_lift_root_step:
	+ "(lift_root_step \<F> W X R)\<inverse> = lift_root_step \<F> W X (R\<inverse>)"
	+ by (cases W; cases X) (auto simp add: converse_gctxtex_onp converse_gmctxtex_onp intro: subsetI)
	+
	+lemma lift_root_step_sig_transfer:
	+ assumes "p \<in> lift_root_step \<F> W X R" "snd ` R \<subseteq> \<T>\<^sub>G \<F>" "funas_gterm (fst p) \<subseteq> \<G>"
	+ shows "p \<in> lift_root_step \<G> W X R" using assms
	+proof -
	+ from assms have "p \<in> lift_root_step (\<F> \<inter> \<G>) W X R"
	+ by (cases p; cases W; cases X)
	+ (auto simp: gctxtex_onp_sign_trans_fst[of _ _ _ R \<G>] gctxtex_onp_sign_trans_snd[of _ _ _ R \<G>]
	+ gmctxtex_onp_sign_trans_fst gmctxtex_onp_sign_trans_snd simp flip: \<T>\<^sub>G_equivalent_def \<T>\<^sub>G_funas_gterm_conv
	+ intro: basic_trans_rules(30)[OF gctxtex_onp_sign_trans_fst[of _ _ _ R \<G>],
	+ where ?B = "gctxtex_onp P R" for P]
	+ basic_trans_rules(30)[OF gmctxtex_onp_sign_trans_fst[of _ _ _ R \<G>],
	+ where ?B = "gmctxtex_onp P R" for P])
	+ then show ?thesis
	+ by (meson inf.cobounded2 lift_root_step_mono subsetD)
	+qed
	+
	+
	+lemma lift_root_step_sig_transfer2:
	+ assumes "p \<in> lift_root_step \<F> W X R" "snd ` R \<subseteq> \<T>\<^sub>G \<G>" "funas_gterm (fst p) \<subseteq> \<G>"
	+ shows "p \<in> lift_root_step \<G> W X R"
	+proof -
	+ from assms have "p \<in> lift_root_step (\<F> \<inter> \<G>) W X R"
	+ by (cases p; cases W; cases X)
	+ (auto simp: gctxtex_onp_sign_trans_fst[of _ _ _ R \<G>] gctxtex_onp_sign_trans_snd[of _ _ _ R \<G>]
	+ gmctxtex_onp_sign_trans_fst gmctxtex_onp_sign_trans_snd simp flip: \<T>\<^sub>G_equivalent_def \<T>\<^sub>G_funas_gterm_conv
	+ intro: basic_trans_rules(30)[OF gctxtex_onp_sign_trans_fst[of _ _ _ R \<G>],
	+ where ?B = "gctxtex_onp P R" for P]
	+ basic_trans_rules(30)[OF gmctxtex_onp_sign_trans_fst[of _ _ _ R \<G>],
	+ where ?B = "gmctxtex_onp P R" for P])
	+ then show ?thesis
	+ by (meson inf.cobounded2 lift_root_step_mono subsetD)
	+qed
	+
	+lemma lift_root_steps_sig_transfer:
	+ assumes "(s, t) \<in> (lift_root_step \<F> W X R)\<^sup>+" "snd ` R \<subseteq> \<T>\<^sub>G \<G>" "funas_gterm s \<subseteq> \<G>"
	+ shows "(s, t) \<in> (lift_root_step \<G> W X R)\<^sup>+"
	+ using assms(1,3)
	+proof (induct rule: converse_trancl_induct)
	+ case (base s)
	+ show ?case using lift_root_step_sig_transfer2[OF base(1) assms(2)] base(2) by (simp add: r_into_trancl)
	+next
	+ case (step s s')
	+ show ?case using lift_root_step_sig_transfer2[OF step(1) assms(2)] step(3,4)
	+ lift_root_step_sig'[of R UNIV \<G> \<G> W X, THEN subsetD, of "(s, s')"] assms(2)
	+ by (auto simp: \<T>\<^sub>G_funas_gterm_conv \<T>\<^sub>G_equivalent_def)
	+ (smt SigmaI UNIV_I image_subset_iff snd_conv subrelI trancl_into_trancl2)
	+qed
	+
	+lemma lift_root_stepseq_sig_transfer:
	+ assumes "(s, t) \<in> (lift_root_step \<F> W X R)\<^sup>*" "snd ` R \<subseteq> \<T>\<^sub>G \<G>" "funas_gterm s \<subseteq> \<G>"
	+ shows "(s, t) \<in> (lift_root_step \<G> W X R)\<^sup>*"
	+ using assms by (auto simp flip: reflcl_trancl simp: lift_root_steps_sig_transfer)
	+
	+lemmas lift_root_step_sig_transfer' = lift_root_step_sig_transfer[of "prod.swap p" \<F> W X "prod.swap ` R" \<G> for p \<F> W X \<G> R,
	+ unfolded swap_lift_root_step, OF imageI, THEN imageI [of _ _ prod.swap],
	+ unfolded image_comp comp_def fst_swap snd_swap swap_swap image_ident]
	+
	+lemmas lift_root_steps_sig_transfer' = lift_root_steps_sig_transfer[of t s \<F> W X "prod.swap ` R" \<G> for t s \<F> W X \<G> R,
	+ THEN imageI [of _ _ prod.swap], unfolded swap_lift_root_step swap_trancl pair_in_swap_image
	+ image_comp comp_def snd_swap swap_swap swap_simp image_ident]
	+
	+lemmas lift_root_stepseq_sig_transfer' = lift_root_stepseq_sig_transfer[of t s \<F> W X "prod.swap ` R" \<G> for t s \<F> W X \<G> R,
	+ THEN imageI [of _ _ prod.swap], unfolded swap_lift_root_step swap_rtrancl pair_in_swap_image
	+ image_comp comp_def snd_swap swap_swap swap_simp image_ident]
	+
	+lemma lift_root_step_PRoot_ESingle [simp]:
	+ "lift_root_step \<F> PRoot ESingle \<R> = \<R>"
	+ by auto
	+
	+lemma lift_root_step_PRoot_EStrictParallel [simp]:
	+ "lift_root_step \<F> PRoot EStrictParallel \<R> = \<R>"
	+ by auto
	+
	+lemma lift_root_step_Parallel_conv:
	+ shows "lift_root_step \<F> W EParallel \<R> = lift_root_step \<F> W EStrictParallel \<R> \<union> Restr Id (\<T>\<^sub>G \<F>)"
	+ by (cases W) (auto simp: gmctxtcl_funas_dist gmctxtex_funas_nroot_dist)
	+
	+lemma relax_pos_lift_root_step:
	+ "lift_root_step \<F> W X R \<subseteq> lift_root_step \<F> PAny X R"
	+ by (cases W; cases X) (auto simp: gctxtex_closure gmctxtex_closure)
	+
	+lemma relax_pos_lift_root_steps:
	+ "(lift_root_step \<F> W X R)\<^sup>+ \<subseteq> (lift_root_step \<F> PAny X R)\<^sup>+"
	+ by (simp add: relax_pos_lift_root_step trancl_mono_set)
	+
	+lemma relax_ext_lift_root_step:
	+ "lift_root_step \<F> W X R \<subseteq> lift_root_step \<F> W EParallel R"
	+ by (cases W; cases X) (auto simp: compatible_p_gctxtex_gmctxtex_subseteq)
	+
	+lemma lift_root_step_StrictParallel_seq:
	+ assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "lift_root_step \<F> PAny EStrictParallel R \<subseteq> (lift_root_step \<F> PAny ESingle R)\<^sup>+"
	+ using assms
	+ by (auto simp: gmctxt_p_inv_def intro!: gmctxtex_onp_gctxtex_onp_trancl)
	+
	+lemma lift_root_step_Parallel_seq:
	+ assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "lift_root_step \<F> PAny EParallel R \<subseteq> (lift_root_step \<F> PAny ESingle R)\<^sup>+ \<union> Restr Id (\<T>\<^sub>G \<F>)"
	+ unfolding lift_root_step_Parallel_conv using lift_root_step_StrictParallel_seq[OF assms]
	+ using Un_mono by blast
	+
	+lemma lift_root_step_Single_to_Parallel:
	+ shows "lift_root_step \<F> PAny ESingle R \<subseteq> lift_root_step \<F> PAny EParallel R"
	+ by (simp add: compatible_p_gctxtex_gmctxtex_subseteq)
	+
	+lemma trancl_partial_reflcl:
	+ "(X \<union> Restr Id Y)\<^sup>+ = X\<^sup>+ \<union> Restr Id Y"
	+proof (intro equalityI subrelI, goal_cases LR RL)
	+ case (LR a b) then show ?case by (induct) (auto dest: trancl_into_trancl)
	+qed (auto intro: trancl_mono)
	+
	+lemma lift_root_step_Parallels_single:
	+ assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "(lift_root_step \<F> PAny EParallel R)\<^sup>+ = (lift_root_step \<F> PAny ESingle R)\<^sup>+ \<union> Restr Id (\<T>\<^sub>G \<F>)"
	+ using trancl_mono_set[OF lift_root_step_Parallel_seq[OF assms]]
	+ using trancl_mono_set[OF lift_root_step_Single_to_Parallel, of \<F> R]
	+ by (auto simp: lift_root_step_Parallel_conv trancl_partial_reflcl)
	+
	+
	+lemma lift_root_Any_Single_eq:
	+ shows "lift_root_step \<F> PAny ESingle R = R \<union> lift_root_step \<F> PNonRoot ESingle R"
	+ by (auto simp: gctxtcl_funas_dist intro!: gctxtex_closure)
	+
	+lemma lift_root_Any_EStrict_eq [simp]:
	+ shows "lift_root_step \<F> PAny EStrictParallel R = R \<union> lift_root_step \<F> PNonRoot EStrictParallel R"
	+ by (auto simp: gmctxtcl_funas_strict_dist)
	+
	+lemma gar_rstep_lift_root_step:
	+ "lift_root_step \<F> PAny EParallel (Restr (grrstep \<R>) (\<T>\<^sub>G \<F>)) = Restr (gpar_rstep \<R>) (\<T>\<^sub>G \<F>)"
	+ unfolding grrstep_subst_cl_conv gpar_rstep_gpar_rstepD_conv
	+ unfolding gpar_rstepD_gpar_rstepD'_conv[symmetric]
	+ by (auto simp: gpar_rstepD_def)
	+
	+lemma grrstep_lift_root_gnrrstep:
	+ "lift_root_step \<F> PNonRoot ESingle (Restr (grrstep \<R>) (\<T>\<^sub>G \<F>)) = Restr (gnrrstep \<R>) (\<T>\<^sub>G \<F>)"
	+ unfolding gnrrstepD_gnrrstep_conv grrstep_subst_cl_conv
	+ by (simp add: gnrrstepD_def)
	+
	+(* Restoring Isabelle standard attributes to lemmas *)
	+declare subsetI [intro!]
	+declare lift_root_step.simps[simp del]
	+
	+lemma gpar_rstepD_grstepD_rtrancl_subseteq:
	+ assumes "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gpar_rstepD \<F> \<R> \<subseteq> (grstepD \<F> \<R>)\<^sup>*"
	+ using assms unfolding gpar_rstepD_def grstepD_def
	+ by (intro gmctxtex_onp_gctxtex_onp_rtrancl) (auto simp: \<T>\<^sub>G_equivalent_def gmctxt_p_inv_def)
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Closure/TA_Clousure_Const.thy b/thys/FO_Theory_Rewriting/Closure/TA_Clousure_Const.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Closure/TA_Clousure_Const.thy
	@@ -0,0 +1,1019 @@
	+section \<open>(Multihole)Context closure of recognized tree languages\<close>
	+
	+theory TA_Clousure_Const
	+ imports Tree_Automata_Derivation_Split
	+begin
	+
	+
	+subsection \<open>Tree Automata closure constructions\<close>
	+declare ta_union_def [simp]
	+subsubsection \<open>Reflexive closure over a given signature\<close>
	+
	+definition "reflcl_rules \<F> q \<equiv> (\<lambda> (f, n). TA_rule f (replicate n q) q) \|`\| \<F>"
	+definition "refl_ta \<F> q = TA (reflcl_rules \<F> q) {\|\|}"
	+
	+definition gen_reflcl_automaton :: "('f \<times> nat) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q \<Rightarrow> ('q, 'f) ta" where
	+ "gen_reflcl_automaton \<F> \<A> q = ta_union \<A> (refl_ta \<F> q)"
	+
	+definition "reflcl_automaton \<F> \<A> = (let \<B> = fmap_states_ta Some \<A> in
	+ gen_reflcl_automaton \<F> \<B> None)"
	+
	+definition "reflcl_reg \<F> \<A> = Reg (finsert None (Some \|`\| fin \<A>)) (reflcl_automaton \<F> (ta \<A>))"
	+
	+subsubsection \<open>Multihole context closure over a given signature\<close>
	+
	+definition "refl_over_states_ta Q \<F> \<A> q = TA (reflcl_rules \<F> q) ((\<lambda> p. (p, q)) \|`\| (Q \|\<inter>\| \<Q> \<A>))"
	+
	+definition gen_parallel_closure_automaton :: "'q fset \<Rightarrow> ('f \<times> nat) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q \<Rightarrow> ('q, 'f) ta" where
	+ "gen_parallel_closure_automaton Q \<F> \<A> q = ta_union \<A> (refl_over_states_ta Q \<F> \<A> q)"
	+
	+definition parallel_closure_reg where
	+ "parallel_closure_reg \<F> \<A> = (let \<B> = fmap_states_reg Some \<A> in
	+ Reg {\|None\|} (gen_parallel_closure_automaton (fin \<B>) \<F> (ta \<B>) None))"
	+
	+subsubsection \<open>Context closure of regular tree language\<close>
	+
	+definition "semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
	+ \|\<Union>\| ((\<lambda> (f, n). fset_of_list (map (\<lambda> i. TA_rule f ((replicate n q\<^sub>c)[i := q\<^sub>i]) q\<^sub>f) [0..< n])) \|`\| \<F>)"
	+
	+definition "reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f \<equiv>
	+ TA (reflcl_rules \<F> q\<^sub>c \|\<union>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f) ((\<lambda> p. (p, q\<^sub>f)) \|`\| Q)"
	+
	+definition "gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f = ta_union \<A> (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
	+
	+definition "gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f =
	+ Reg {\|q\<^sub>f\|} (gen_ctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>f)"
	+
	+definition "ctxt_closure_reg \<F> \<A> =
	+ (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
	+ gen_ctxt_closure_reg \<F> \<B> (Inr False) (Inr True))"
	+
	+
	+subsubsection \<open>Not empty context closure of regular tree language\<close>
	+
	+datatype cl_states = cl_state \| tr_state \| fin_state \| fin_clstate
	+
	+definition "reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
	+ TA (reflcl_rules \<F> q\<^sub>c \|\<union>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \|\<union>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f) ((\<lambda> p. (p, q\<^sub>i)) \|`\| Q)"
	+
	+definition "gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
	+ ta_union \<A> (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
	+
	+definition "gen_nhole_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
	+ Reg {\|q\<^sub>f\|} (gen_nhole_ctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"
	+
	+definition "nhole_ctxt_closure_reg \<F> \<A> =
	+ (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
	+ (gen_nhole_ctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"
	+
	+subsubsection \<open>Non empty multihole context closure of regular tree language\<close>
	+
	+abbreviation "add_eps \<A> e \<equiv> TA (rules \<A>) (eps \<A> \|\<union>\| e)"
	+definition "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
	+ add_eps (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) {\|(q\<^sub>i, q\<^sub>c)\|}"
	+
	+definition "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
	+ ta_union \<A> (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
	+
	+definition "gen_nhole_mctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
	+ Reg {\|q\<^sub>f\|} (gen_nhole_mctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"
	+
	+definition "nhole_mctxt_closure_reg \<F> \<A> =
	+ (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
	+ (gen_nhole_mctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"
	+
	+subsubsection \<open>Not empty multihole context closure of regular tree language\<close>
	+
	+definition "gen_mctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
	+ Reg {\|q\<^sub>f, q\<^sub>i\|} (gen_nhole_mctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"
	+
	+definition "mctxt_closure_reg \<F> \<A> =
	+ (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
	+ (gen_mctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"
	+
	+
	+subsubsection \<open>Multihole context closure of regular tree language\<close>
	+
	+definition "nhole_mctxt_reflcl_reg \<F> \<A> =
	+ reg_union (nhole_mctxt_closure_reg \<F> \<A>) (Reg {\|fin_clstate\|} (refl_ta \<F> (fin_clstate)))"
	+
	+subsubsection \<open>Lemmas about @{const ta_der'}\<close>
	+
	+lemma ta_det'_ground_id:
	+ "t \|\<in>\| ta_der' \<A> s \<Longrightarrow> ground t \<Longrightarrow> t = s"
	+ by (induct s arbitrary: t) (auto simp add: ta_der'.simps nth_equalityI)
	+
	+lemma ta_det'_vars_term_id:
	+ "t \|\<in>\| ta_der' \<A> s \<Longrightarrow> vars_term t \<inter> fset (\<Q> \<A>) = {} \<Longrightarrow> t = s"
	+proof (induct s arbitrary: t)
	+ case (Fun f ss)
	+ from Fun(2-) obtain ts where [simp]: "t = Fun f ts" and len: "length ts = length ss"
	+ by (cases t) (auto simp flip: fmember.rep_eq dest: rule_statesD eps_dest_all)
	+ from Fun(1)[OF nth_mem, of i "ts ! i" for i] show ?case using Fun(2-) len
	+ by (auto simp add: ta_der'.simps Union_disjoint simp flip: fmember.rep_eq
	+ dest: rule_statesD eps_dest_all intro!: nth_equalityI)
	+qed (auto simp add: ta_der'.simps simp flip: fmember.rep_eq dest: rule_statesD eps_dest_all)
	+
	+lemma fresh_states_ta_der'_pres:
	+ assumes st: "q \<in> vars_term s" "q \|\<notin>\| \<Q> \<A>"
	+ and reach: "t \|\<in>\| ta_der' \<A> s"
	+ shows "q \<in> vars_term t" using reach st(1)
	+proof (induct s arbitrary: t)
	+ case (Var x)
	+ then show ?case using assms(2)
	+ by (cases t) (auto simp: ta_der'.simps dest: eps_trancl_statesD)
	+next
	+ case (Fun f ss)
	+ from Fun(3) obtain i where w: "i < length ss" "q \<in> vars_term (ss ! i)" by (auto simp: in_set_conv_nth)
	+ have "i < length (args t) \<and> q \<in> vars_term (args t ! i)" using Fun(2) w assms(2) Fun(1)[OF nth_mem[OF w(1)] _ w(2)]
	+ using rule_statesD(3) ta_der_to_ta_der'
	+ by (auto simp: ta_der'.simps dest: rule_statesD(3)) fastforce+
	+ then show ?case by (cases t) auto
	+qed
	+
	+lemma ta_der'_states:
	+ "t \|\<in>\| ta_der' \<A> s \<Longrightarrow> vars_term t \<subseteq> vars_term s \<union> fset (\<Q> \<A>)"
	+proof (induct s arbitrary: t)
	+ case (Var x) then show ?case
	+ by (auto simp: ta_der'.simps simp flip: fmember.rep_eq dest: eps_dest_all)
	+next
	+ case (Fun f ts) then show ?case
	+ by (auto simp: ta_der'.simps rule_statesD simp flip: fmember.rep_eq dest: eps_dest_all)
	+ (metis (no_types, opaque_lifting) Un_iff in_set_conv_nth notin_fset subsetD)
	+qed
	+
	+lemma ta_der'_gterm_states:
	+ "t \|\<in>\| ta_der' \<A> (term_of_gterm s) \<Longrightarrow> vars_term t \<subseteq> fset (\<Q> \<A>)"
	+ using ta_der'_states[of t \<A> "term_of_gterm s"]
	+ by auto
	+
	+lemma ta_der'_Var_funas:
	+ "Var q \|\<in>\| ta_der' \<A> s \<Longrightarrow> funas_term s \<subseteq> fset (ta_sig \<A>)"
	+ by (auto simp: less_eq_fset.rep_eq ffunas_term.rep_eq dest!: ta_der_term_sig ta_der'_to_ta_der)
	+
	+
	+lemma ta_sig_fsubsetI:
	+ assumes "\<And> r. r \|\<in>\| rules \<A> \<Longrightarrow> (r_root r, length (r_lhs_states r)) \|\<in>\| \<F>"
	+ shows "ta_sig \<A> \|\<subseteq>\| \<F>" using assms
	+ by (auto simp: ta_sig_def)
	+
	+subsubsection \<open>Signature induced by @{const refl_ta} and @{const refl_over_states_ta}\<close>
	+
	+lemma refl_ta_sig [simp]:
	+ "ta_sig (refl_ta \<F> q) = \<F>"
	+ "ta_sig (refl_over_states_ta Q \<F> \<A> q ) = \<F>"
	+ by (auto simp: ta_sig_def refl_ta_def reflcl_rules_def refl_over_states_ta_def fimage_iff fBex_def)
	+
	+subsubsection \<open>Correctness of @{const refl_ta}, @{const gen_reflcl_automaton}, and @{const reflcl_automaton}\<close>
	+
	+lemma refl_ta_eps [simp]: "eps (refl_ta \<F> q) = {\|\|}"
	+ by (auto simp: refl_ta_def)
	+
	+lemma refl_ta_sound:
	+ "s \<in> \<T>\<^sub>G (fset \<F>) \<Longrightarrow> q \|\<in>\| ta_der (refl_ta \<F> q) (term_of_gterm s)"
	+ by (induct rule: \<T>\<^sub>G.induct) (auto simp: refl_ta_def reflcl_rules_def
	+ fimage_iff fBex_def simp flip: fmember.rep_eq)
	+
	+lemma reflcl_rules_args:
	+ "length ps = n \<Longrightarrow> f ps \<rightarrow> p \|\<in>\| reflcl_rules \<F> q \<Longrightarrow> ps = replicate n q"
	+ by (auto simp: reflcl_rules_def)
	+
	+lemma \<Q>_refl_ta:
	+ "\<Q> (refl_ta \<F> q) \|\<subseteq>\| {\|q\|}"
	+ by (auto simp: \<Q>_def refl_ta_def rule_states_def reflcl_rules_def fset_of_list_elem)
	+
	+lemma refl_ta_complete1:
	+ "Var p \|\<in>\| ta_der' (refl_ta \<F> q) s \<Longrightarrow> p \<noteq> q \<Longrightarrow> s = Var p"
	+ by (cases s) (auto simp: ta_der'.simps refl_ta_def reflcl_rules_def)
	+
	+lemma refl_ta_complete2:
	+ "Var q \|\<in>\| ta_der' (refl_ta \<F> q) s \<Longrightarrow> funas_term s \<subseteq> fset \<F> \<and> vars_term s \<subseteq> {q}"
	+ unfolding ta_der_to_ta_der'[symmetric]
	+ using ta_der_term_sig[of q "refl_ta \<F> q" s] ta_der_states'[of q "refl_ta \<F> q" s]
	+ using fsubsetD[OF \<Q>_refl_ta[of \<F> q]]
	+ by (auto simp: fmember.rep_eq ffunas_term.rep_eq)
	+ (metis Term.term.simps(17) fresh_states_ta_der'_pres notin_fset singletonD ta_der_to_ta_der')
	+
	+lemma gen_reflcl_lang:
	+ assumes "q \|\<notin>\| \<Q> \<A>"
	+ shows "gta_lang (finsert q Q) (gen_reflcl_automaton \<F> \<A> q) = gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?A = "gen_reflcl_automaton \<F> \<A> q"
	+ interpret sq: derivation_split ?A "\<A>" "refl_ta \<F> q"
	+ using assms unfolding derivation_split_def
	+ by (auto simp: gen_reflcl_automaton_def refl_ta_def reflcl_rules_def \<Q>_def)
	+ show ?thesis
	+ proof
	+ {fix s assume "s \<in> ?Ls" then obtain p u where
	+ seq: "u \|\<in>\| ta_der' \<A> (term_of_gterm s)" "Var p \|\<in>\| ta_der' (refl_ta \<F> q) u" and
	+ fin: "p \|\<in>\| finsert q Q"
	+ by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
	+ have "vars_term u \<subseteq> {q} \<Longrightarrow> u = term_of_gterm s" using assms
	+ by (intro ta_det'_vars_term_id[OF seq(1)]) (auto simp flip: fmember.rep_eq)
	+ then have "s \<in> ?Rs" using assms fin seq funas_term_of_gterm_conv
	+ using refl_ta_complete1[OF seq(2)]
	+ by (cases "p = q") (auto simp: ta_der_to_ta_der' \<T>\<^sub>G_funas_gterm_conv dest!: refl_ta_complete2)}
	+ then show "?Ls \<subseteq> gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)" by blast
	+ next
	+ show "gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>) \<subseteq> ?Ls"
	+ using sq.ta_der_monos unfolding gta_lang_def gta_der_def
	+ by (auto dest: refl_ta_sound)
	+ qed
	+qed
	+
	+lemma reflcl_lang:
	+ "gta_lang (finsert None (Some \|`\| Q)) (reflcl_automaton \<F> \<A>) = gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)"
	+proof -
	+ have st: "None \|\<notin>\| \<Q> (fmap_states_ta Some \<A>)" by auto
	+ have "gta_lang Q \<A> = gta_lang (Some \|`\| Q) (fmap_states_ta Some \<A>)"
	+ by (simp add: finj_Some fmap_states_ta_lang2)
	+ then show ?thesis
	+ unfolding reflcl_automaton_def Let_def gen_reflcl_lang[OF st, of "Some \|`\| Q" \<F>]
	+ by simp
	+qed
	+
	+lemma \<L>_reflcl_reg:
	+ "\<L> (reflcl_reg \<F> \<A>) = \<L> \<A> \<union> \<T>\<^sub>G (fset \<F>)"
	+ by (simp add: \<L>_def reflcl_lang reflcl_reg_def )
	+
	+subsubsection \<open>Correctness of @{const gen_parallel_closure_automaton} and @{const parallel_closure_reg}\<close>
	+
	+lemma set_list_subset_nth_conv:
	+ "set xs \<subseteq> A \<Longrightarrow> i < length xs \<Longrightarrow> xs ! i \<in> A"
	+ by (metis in_set_conv_nth subset_code(1))
	+
	+lemma ground_gmctxt_of_mctxt_fill_holes':
	+ "num_holes C = length ss \<Longrightarrow> ground_mctxt C \<Longrightarrow> \<forall>s\<in>set ss. ground s \<Longrightarrow>
	+ fill_gholes (gmctxt_of_mctxt C) (map gterm_of_term ss) = gterm_of_term (fill_holes C ss)"
	+ using ground_gmctxt_of_mctxt_fill_holes
	+ by (metis term_of_gterm_inv)
	+
	+
	+lemma refl_over_states_ta_eps_trancl [simp]:
	+ "(eps (refl_over_states_ta Q \<F> \<A> q))\|\<^sup>+\| = eps (refl_over_states_ta Q \<F> \<A> q)"
	+ using ftranclD ftranclE unfolding refl_over_states_ta_def
	+ by fastforce
	+
	+lemma refl_over_states_ta_epsD:
	+ "(p, q) \|\<in>\| (eps (refl_over_states_ta Q \<F> \<A> q)) \<Longrightarrow> p \|\<in>\| Q"
	+ by (auto simp: refl_over_states_ta_def)
	+
	+lemma refl_over_states_ta_vars_term:
	+ "q \|\<in>\| ta_der (refl_over_states_ta Q \<F> \<A> q) u \<Longrightarrow> vars_term u \<subseteq> insert q (fset Q)"
	+proof (induct u)
	+ case (Fun f ts)
	+ from Fun(2) reflcl_rules_args[of _ "length ts" f _ \<F> q]
	+ have "i < length ts \<Longrightarrow> q \|\<in>\| ta_der (refl_over_states_ta Q \<F> \<A> q) (ts ! i)" for i
	+ by (fastforce simp: refl_over_states_ta_def)
	+ then have "i < length ts \<Longrightarrow> x \<in> vars_term (ts ! i) \<Longrightarrow> x = q \<or> x \|\<in>\| Q" for i x
	+ using Fun(1)[OF nth_mem, of i]
	+ by (meson insert_iff notin_fset subsetD)
	+ then show ?case by (fastforce simp: in_set_conv_nth fmember.rep_eq)
	+qed (auto simp flip: fmember.rep_eq dest: refl_over_states_ta_epsD)
	+
	+lemmas refl_over_states_ta_vars_term' =
	+ refl_over_states_ta_vars_term[unfolded ta_der_to_ta_der' ta_der'_target_args_vars_term_conv,
	+ THEN set_list_subset_nth_conv, unfolded fmember.rep_eq[symmetric] finsert.rep_eq[symmetric]]
	+
	+lemma refl_over_states_ta_sound:
	+ "funas_term u \<subseteq> fset \<F> \<Longrightarrow> vars_term u \<subseteq> insert q (fset (Q \|\<inter>\| \<Q> \<A>)) \<Longrightarrow> q \|\<in>\| ta_der (refl_over_states_ta Q \<F> \<A> q) u"
	+proof (induct u)
	+ case (Fun f ts)
	+ have reach: "i < length ts \<Longrightarrow> q \|\<in>\| ta_der (refl_over_states_ta Q \<F> \<A> q) (ts ! i)" for i
	+ using Fun(2-) by (intro Fun(1)[OF nth_mem]) (auto simp: SUP_le_iff)
	+ from Fun(2) have "TA_rule f (replicate (length ts) q) q \|\<in>\| rules (refl_over_states_ta Q \<F> \<A> q)"
	+ by (auto simp: refl_over_states_ta_def reflcl_rules_def fimage_iff fBex_def simp flip: fmember.rep_eq)
	+ then show ?case using reach
	+ by force
	+qed (auto simp: refl_over_states_ta_def simp flip: fmember.rep_eq)
	+
	+lemma gen_parallelcl_lang:
	+ fixes \<A> :: "('q, 'f) ta"
	+ assumes "q \|\<notin>\| \<Q> \<A>"
	+ shows "gta_lang {\|q\|} (gen_parallel_closure_automaton Q \<F> \<A> q) =
	+ {fill_gholes C ss \| C ss. num_gholes C = length ss \<and> funas_gmctxt C \<subseteq> (fset \<F>) \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?A = "gen_parallel_closure_automaton Q \<F> \<A> q" let ?B = "refl_over_states_ta Q \<F> \<A> q"
	+ interpret sq: derivation_split "?A" "\<A>" "?B"
	+ using assms unfolding derivation_split_def
	+ by (auto simp: gen_parallel_closure_automaton_def refl_over_states_ta_def \<Q>_def reflcl_rules_def)
	+ {fix s assume "s \<in> ?Ls" then obtain u where
	+ seq: "u \|\<in>\| ta_der' \<A> (term_of_gterm s)" "Var q \|\<in>\| ta_der'?B u" and
	+ fin: "q \|\<in>\| finsert q Q"
	+ by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
	+ let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
	+ have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)] fin
	+ using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms
	+ using refl_over_states_ta_vars_term'[OF seq(2)]
	+ using ta_der'_ground_mctxt_structure[OF seq(1)]
	+ by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
	+ intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
	+ exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
	+ gta_langI[of "ta_der'_target_args u ! i" Q \<A>
	+ "gterm_of_term (?w i)" for i])}
	+ then have ls: "?Ls \<subseteq> ?Rs" by blast
	+ {fix t assume "t \<in> ?Rs"
	+ then obtain C ss where len: "num_gholes C = length ss" and
	+ gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
	+ reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
	+ const: "t = fill_gholes C ss" by auto
	+ from reachA obtain qs where "length ss = length qs" "\<forall> i < length qs. qs ! i \|\<in>\| Q \|\<inter>\| \<Q> \<A>"
	+ "\<forall> i < length qs. qs ! i \|\<in>\| ta_der \<A> ((map term_of_gterm ss) ! i)"
	+ using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q \|\<in>\| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q \|\<in>\| Q"]
	+ by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
	+ then have "q \|\<in>\| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
	+ using reachA len gr_fun
	+ by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q])
	+ (auto simp: funas_mctxt_of_gmctxt_conv simp flip: fmember.rep_eq
	+ dest!: in_set_idx intro!: refl_over_states_ta_sound)
	+ then have "t \<in> ?Ls" unfolding const
	+ by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
	+ then show ?thesis using ls by blast
	+qed
	+
	+lemma parallelcl_gmctxt_lang:
	+ fixes \<A> :: "('q, 'f) reg"
	+ shows "\<L> (parallel_closure_reg \<F> \<A>) =
	+ {fill_gholes C ss \|
	+ C ss. num_gholes C = length ss \<and> funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
	+proof -
	+ have *: "gta_lang (fin (fmap_states_reg Some \<A>)) (fmap_states_ta Some (ta \<A>)) = gta_lang (fin \<A>) (ta \<A>)"
	+ by (simp add: finj_Some fmap_states_reg_def fmap_states_ta_lang2)
	+ have " None \|\<notin>\| \<Q> (fmap_states_ta Some (ta \<A>))" by auto
	+ from gen_parallelcl_lang[OF this, of "fin (fmap_states_reg Some \<A>)" \<F>] show ?thesis
	+ unfolding \<L>_def parallel_closure_reg_def Let_def * fmap_states_reg_def
	+ by (simp add: finj_Some fmap_states_ta_lang2)
	+qed
	+
	+lemma parallelcl_mctxt_lang:
	+ shows "\<L> (parallel_closure_reg \<F> \<A>) =
	+ {(gterm_of_term :: ('f, 'q option) term \<Rightarrow> 'f gterm) (fill_holes C (map term_of_gterm ss)) \|
	+ C ss. num_holes C = length ss \<and> ground_mctxt C \<and> funas_mctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
	+ by (auto simp: parallelcl_gmctxt_lang) (metis funas_gmctxt_of_mctxt num_gholes_gmctxt_of_mctxt
	+ ground_gmctxt_of_gterm_of_term funas_mctxt_of_gmctxt_conv
	+ ground_mctxt_of_gmctxt mctxt_of_gmctxt_fill_holes num_holes_mctxt_of_gmctxt)+
	+
	+subsubsection \<open>Correctness of @{const gen_ctxt_closure_reg} and @{const ctxt_closure_reg}\<close>
	+
	+lemma semantic_path_rules_rhs:
	+ "r \|\<in>\| semantic_path_rules Q q\<^sub>c q\<^sub>i q\<^sub>f \<Longrightarrow> r_rhs r = q\<^sub>f"
	+ by (auto simp: semantic_path_rules_def)
	+
	+lemma reflcl_over_single_ta_transl [simp]:
	+ "(eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f))\|\<^sup>+\| = eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
	+ using ftranclD ftranclE unfolding reflcl_over_single_ta_def
	+ by fastforce
	+
	+lemma reflcl_over_single_ta_epsD:
	+ "(p, q\<^sub>f) \|\<in>\| eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow> p \|\<in>\| Q"
	+ "(p, q) \|\<in>\| eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow> q = q\<^sub>f"
	+ by (auto simp: reflcl_over_single_ta_def)
	+
	+lemma reflcl_over_single_ta_rules_split:
	+ "r \|\<in>\| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow>
	+ r \|\<in>\| reflcl_rules \<F> q\<^sub>c \<or> r \|\<in>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f"
	+ by (auto simp: reflcl_over_single_ta_def)
	+
	+lemma reflcl_over_single_ta_rules_semantic_path_rulesI:
	+ "r \|\<in>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f \<Longrightarrow> r \|\<in>\| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
	+ by (auto simp: reflcl_over_single_ta_def)
	+
	+lemma semantic_path_rules_fmember [intro]:
	+ "TA_rule f qs q \|\<in>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<longleftrightarrow> (\<exists> n i. (f, n) \|\<in>\| \<F> \<and> i < n \<and> q = q\<^sub>f \<and>
	+ (qs = (replicate n q\<^sub>c)[i := q\<^sub>i]))" (is "?Ls \<longleftrightarrow> ?Rs")
	+ by (force simp: semantic_path_rules_def fBex_def fimage_iff fset_of_list_elem)
	+
	+lemma semantic_path_rules_fmemberD:
	+ "r \|\<in>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<Longrightarrow> (\<exists> n i. (r_root r, n) \|\<in>\| \<F> \<and> i < n \<and> r_rhs r = q\<^sub>f \<and>
	+ (r_lhs_states r = (replicate n q\<^sub>c)[i := q\<^sub>i]))"
	+ by (cases r) (simp add: semantic_path_rules_fmember)
	+
	+
	+lemma reflcl_over_single_ta_vars_term_q\<^sub>c:
	+ "q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) u \<Longrightarrow>
	+ vars_term_list u = replicate (length (vars_term_list u)) q\<^sub>c"
	+proof (induct u)
	+ case (Fun f ts)
	+ have "i < length ts \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ts ! i)" for i using Fun(2, 3)
	+ by (auto dest!: reflcl_over_single_ta_rules_split reflcl_over_single_ta_epsD
	+ reflcl_rules_args semantic_path_rules_rhs)
	+ then have "i < length (concat (map vars_term_list ts)) \<Longrightarrow> concat (map vars_term_list ts) ! i = q\<^sub>c" for i
	+ using Fun(1)[OF nth_mem Fun(2)]
	+ by (metis (no_types, lifting) length_map nth_concat_split nth_map nth_replicate)
	+ then show ?case using Fun(1)[OF nth_mem Fun(2)]
	+ by (auto intro: nth_equalityI)
	+qed (auto simp flip: fmember.rep_eq dest: reflcl_over_single_ta_epsD)
	+
	+lemma reflcl_over_single_ta_vars_term:
	+ "q\<^sub>c \|\<notin>\| Q \<Longrightarrow> q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>f \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) u \<Longrightarrow>
	+ length (vars_term_list u) = n \<Longrightarrow> (\<exists> i q. i < n \<and> q \|\<in>\| finsert q\<^sub>f Q \<and> vars_term_list u = (replicate n q\<^sub>c)[i := q])"
	+proof (induct u arbitrary: n)
	+ case (Var x) then show ?case
	+ by (intro exI[of _ 0] exI[of _ x]) (auto dest: reflcl_over_single_ta_epsD(1))
	+next
	+ case (Fun f ts)
	+ from Fun(2, 3, 4) obtain qs where rule: "TA_rule f qs q\<^sub>f \|\<in>\| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f"
	+ "length qs = length ts" "\<forall> i < length ts. qs ! i \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ts ! i)"
	+ using semantic_path_rules_rhs reflcl_over_single_ta_epsD
	+ by (fastforce simp: reflcl_rules_def dest!: reflcl_over_single_ta_rules_split)
	+ from rule(1, 2) obtain i where states: "i < length ts" "qs = (replicate (length ts) q\<^sub>c)[i := q\<^sub>f]"
	+ by (auto simp: semantic_path_rules_fmember)
	+ then have qc: "j < length ts \<Longrightarrow> j \<noteq> i \<Longrightarrow> vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) q\<^sub>c" for j
	+ using reflcl_over_single_ta_vars_term_q\<^sub>c[OF Fun(3)] rule
	+ by force
	+ from Fun(1)[OF nth_mem, of i] Fun(2, 3) rule states obtain k q where
	+ qf: "k < length (vars_term_list (ts ! i))" "q \|\<in>\| finsert q\<^sub>f Q"
	+ "vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) q\<^sub>c)[k := q]"
	+ by (auto simp: nth_list_update split: if_splits)
	+ let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
	+ show ?case using qc qf rule(2) Fun(5) states(1)
	+ apply (intro exI[of _ ?l] exI[of _ q])
	+ apply (auto simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
	+ apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
	+ done
	+qed
	+
	+lemma refl_ta_reflcl_over_single_ta_mono:
	+ "q \|\<in>\| ta_der (refl_ta \<F> q) t \<Longrightarrow> q \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q q\<^sub>f) t"
	+ by (intro ta_der_el_mono[where ?\<B> = "reflcl_over_single_ta Q \<F> q q\<^sub>f"])
	+ (auto simp: refl_ta_def reflcl_over_single_ta_def)
	+
	+lemma reflcl_over_single_ta_sound:
	+ assumes "funas_gctxt C \<subseteq> fset \<F>" "q \|\<in>\| Q"
	+ shows "q\<^sub>f \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using assms(1)
	+proof (induct C)
	+ case GHole then show ?case using assms(2)
	+ by (auto simp add: reflcl_over_single_ta_def)
	+next
	+ case (GMore f ss C ts)
	+ let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
	+ from GMore have "(f, ?n) \|\<in>\| \<F>" by (auto simp flip: fmember.rep_eq)
	+ then have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>f]) \<rightarrow> q\<^sub>f \|\<in>\| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
	+ using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]" q\<^sub>f \<F> q\<^sub>c q\<^sub>f q\<^sub>f]
	+ using less_add_Suc1
	+ by (intro reflcl_over_single_ta_rules_semantic_path_rulesI) blast
	+ moreover from GMore(2) have "i < length ss \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (term_of_gterm (ss ! i))" for i
	+ by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
	+ moreover from GMore(2) have "i < length ts \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (term_of_gterm (ts ! i))" for i
	+ by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
	+ moreover from GMore have "q\<^sub>f \|\<in>\| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" by auto
	+ ultimately show ?case
	+ by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]"] exI[of _ q\<^sub>f])
	+qed
	+
	+lemma reflcl_over_single_ta_sig: "ta_sig (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \|\<subseteq>\| \<F>"
	+ by (intro ta_sig_fsubsetI)
	+ (auto simp: reflcl_rules_def dest!: semantic_path_rules_fmemberD reflcl_over_single_ta_rules_split)
	+
	+lemma gen_gctxtcl_lang:
	+ assumes "q\<^sub>c \|\<notin>\| \<Q> \<A>" and "q\<^sub>f \|\<notin>\| \<Q> \<A>" and "q\<^sub>c \|\<notin>\| Q" and "q\<^sub>c \<noteq> q\<^sub>f"
	+ shows "gta_lang {\|q\<^sub>f\|} (gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f) =
	+ {C\<langle>s\<rangle>\<^sub>G \| C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> gta_lang Q \<A>}"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?A = "gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f" let ?B = "reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f"
	+ interpret sq: derivation_split ?A \<A> ?B
	+ using assms unfolding derivation_split_def
	+ by (auto simp: gen_ctxt_closure_automaton_def reflcl_over_single_ta_def \<Q>_def reflcl_rules_def
	+ dest!: semantic_path_rules_rhs)
	+ {fix s assume "s \<in> ?Ls" then obtain u where
	+ seq: "u \|\<in>\| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f \|\<in>\| ta_der'?B u" using sq.ta_der'_split
	+ by (force simp: ta_der_to_ta_der' elim!: gta_langE)
	+ have "q\<^sub>c \<notin> vars_term u" "q\<^sub>f \<notin> vars_term u"
	+ using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1, 2)
	+ by (auto simp flip: set_vars_term_list fmember.rep_eq)
	+ then obtain q where vars: "vars_term_list u = [q]" and fin: "q \|\<in>\| Q" unfolding set_vars_term_list[symmetric]
	+ using reflcl_over_single_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(3, 4) seq(2), of "length (vars_term_list u)"]
	+ by (metis (no_types, lifting) finsertE in_set_conv_nth length_0_conv length_Suc_conv
	+ length_replicate lessI less_Suc_eq_0_disj nth_Cons_0 nth_list_update nth_replicate zero_less_Suc)
	+ have "s \<in> ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars]
	+ using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_single_ta_sig[unfolded less_eq_fset.rep_eq]]
	+ by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
	+ (metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv subset_eq)
	+ }
	+ then have ls: "?Ls \<subseteq> ?Rs" by blast
	+ {fix t assume "t \<in> ?Rs"
	+ then obtain C s where gr_fun: "funas_gctxt C \<subseteq> fset \<F>" and reachA: "s \<in> gta_lang Q \<A>" and
	+ const: "t = C\<langle>s\<rangle>\<^sub>G" by auto
	+ from reachA obtain q where der_A: "q \|\<in>\| Q \|\<inter>\| \<Q> \<A>" "q \|\<in>\| ta_der \<A> (term_of_gterm s)"
	+ by auto
	+ have "q\<^sub>f \|\<in>\| ta_der ?B (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using gr_fun der_A(1)
	+ using reflcl_over_single_ta_sound[OF gr_fun]
	+ by force
	+ then have "t \<in> ?Ls" unfolding const
	+ by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
	+ then show ?thesis using ls by blast
	+qed
	+
	+lemma gen_gctxt_closure_sound:
	+ fixes \<A> :: "('q, 'f) reg"
	+ assumes "q\<^sub>c \|\<notin>\| \<Q>\<^sub>r \<A>" and "q\<^sub>f \|\<notin>\| \<Q>\<^sub>r \<A>" and "q\<^sub>c \|\<notin>\| fin \<A>" and "q\<^sub>c \<noteq> q\<^sub>f"
	+ shows "\<L> (gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f) = {C\<langle>s\<rangle>\<^sub>G \| C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
	+ using gen_gctxtcl_lang[OF assms] unfolding \<L>_def
	+ by (simp add: gen_ctxt_closure_reg_def)
	+
	+lemma gen_ctxt_closure_sound:
	+ fixes \<A> :: "('q, 'f) reg"
	+ assumes "q\<^sub>c \|\<notin>\| \<Q>\<^sub>r \<A>" and "q\<^sub>f \|\<notin>\| \<Q>\<^sub>r \<A>" and "q\<^sub>c \|\<notin>\| fin \<A>" and "q\<^sub>c \<noteq> q\<^sub>f"
	+ shows "\<L> (gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f) =
	+ {(gterm_of_term :: ('f, 'q) term \<Rightarrow> 'f gterm) C\<langle>term_of_gterm s\<rangle> \| C s. ground_ctxt C \<and> funas_ctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
	+ unfolding gen_gctxt_closure_sound[OF assms]
	+ by (metis (no_types, opaque_lifting) ctxt_of_gctxt_apply funas_ctxt_of_gctxt_conv gctxt_of_ctxt_inv ground_ctxt_of_gctxt)
	+
	+lemma gctxt_closure_lang:
	+ shows "\<L> (ctxt_closure_reg \<F> \<A>) =
	+ { C\<langle>s\<rangle>\<^sub>G \| C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
	+proof -
	+ let ?B = "fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)"
	+ have ts: "Inr False \|\<notin>\| \<Q>\<^sub>r ?B" "Inr True \|\<notin>\| \<Q>\<^sub>r ?B" "Inr False \|\<notin>\| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
	+ by (auto simp: fmap_states_reg_def fmap_states_ta_def' \<Q>_def rule_states_def)
	+ from gen_gctxt_closure_sound[OF ts] show ?thesis
	+ by (simp add: ctxt_closure_reg_def)
	+qed
	+
	+lemma ctxt_closure_lang:
	+ shows "\<L> (ctxt_closure_reg \<F> \<A>) =
	+ {(gterm_of_term :: ('f, 'q + bool) term \<Rightarrow> 'f gterm) C\<langle>term_of_gterm s\<rangle> \|
	+ C s. ground_ctxt C \<and> funas_ctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
	+ unfolding gctxt_closure_lang
	+ by (metis (mono_tags, opaque_lifting) ctxt_of_gctxt_inv funas_gctxt_of_ctxt
	+ ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply_gterm term_of_gterm_inv)
	+
	+
	+subsubsection \<open>Correctness of @{const gen_nhole_ctxt_closure_automaton} and @{const nhole_ctxt_closure_reg}\<close>
	+
	+lemma reflcl_over_nhole_ctxt_ta_vars_term_q\<^sub>c:
	+ "q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>c \<noteq> q\<^sub>i \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u \<Longrightarrow>
	+ vars_term_list u = replicate (length (vars_term_list u)) q\<^sub>c"
	+proof (induct u)
	+ case (Fun f ts)
	+ have "i < length ts \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)" for i using Fun(2, 3, 4)
	+ by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2 reflcl_rules_args semantic_path_rules_rhs)
	+ then have "i < length (concat (map vars_term_list ts)) \<Longrightarrow> concat (map vars_term_list ts) ! i = q\<^sub>c" for i
	+ using Fun(1)[OF nth_mem Fun(2, 3)]
	+ by (metis (no_types, lifting) length_map map_nth_eq_conv nth_concat_split' nth_replicate)
	+ then show ?case using Fun(1)[OF nth_mem Fun(2)]
	+ by (auto intro: nth_equalityI)
	+qed (auto simp flip: fmember.rep_eq simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)
	+
	+lemma reflcl_over_nhole_ctxt_ta_vars_term_Var:
	+ assumes disj: "q\<^sub>c \|\<notin>\| Q" "q\<^sub>f \|\<notin>\| Q" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f" "q\<^sub>c \<noteq> q\<^sub>i"
	+ and reach: "q\<^sub>i \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u"
	+ shows "(\<exists> q. q \|\<in>\| finsert q\<^sub>i Q \<and> u = Var q)" using assms
	+ by (cases u) (fastforce simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD semantic_path_rules_rhs)+
	+
	+lemma reflcl_over_nhole_ctxt_ta_vars_term:
	+ assumes disj: "q\<^sub>c \|\<notin>\| Q" "q\<^sub>f \|\<notin>\| Q" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f" "q\<^sub>c \<noteq> q\<^sub>i"
	+ and reach: "q\<^sub>f \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u"
	+ shows "(\<exists> i q. i < length (vars_term_list u) \<and> q \|\<in>\| {\|q\<^sub>i, q\<^sub>f\|} \|\<union>\| Q \<and> vars_term_list u = (replicate (length (vars_term_list u)) q\<^sub>c)[i := q])"
	+ using assms
	+proof (induct u)
	+ case (Var q) then show ?case
	+ by (intro exI[of _ 0] exI[of _ q]) (auto simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)
	+next
	+ case (Fun f ts)
	+ from Fun(2 - 7) obtain q qs where rule: "TA_rule f qs q\<^sub>f \|\<in>\| semantic_path_rules \<F> q\<^sub>c q q\<^sub>f" "q = q\<^sub>i \<or> q = q\<^sub>f"
	+ "length qs = length ts" "\<forall> i < length ts. qs ! i \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)"
	+ by (auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD2)
	+ from rule(1- 3) obtain i where states: "i < length ts" "qs = (replicate (length ts) q\<^sub>c)[i := q]"
	+ by (auto simp: semantic_path_rules_fmember)
	+ then have qc: "j < length ts \<Longrightarrow> j \<noteq> i \<Longrightarrow> vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) q\<^sub>c" for j
	+ using reflcl_over_nhole_ctxt_ta_vars_term_q\<^sub>c[OF Fun(4, 6)] rule
	+ by force
	+ from rule states have "q \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)"
	+ by auto
	+ from this Fun(1)[OF nth_mem, of i, OF _ Fun(2 - 6)] rule(2) states(1) obtain k q' where
	+ qf: "k < length (vars_term_list (ts ! i))" "q' \|\<in>\| {\|q\<^sub>i, q\<^sub>f\|} \|\<union>\| Q "
	+ "vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) q\<^sub>c)[k := q']"
	+ using reflcl_over_nhole_ctxt_ta_vars_term_Var[OF Fun(2 - 6), of \<F> "ts ! i"]
	+ by (auto simp: nth_list_update split: if_splits) blast
	+ let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
	+ show ?case using qc qf rule(3) states(1)
	+ apply (intro exI[of _ ?l] exI[of _ q'])
	+ apply (auto 0 0 simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
	+ apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
	+ done
	+qed
	+
	+lemma reflcl_over_nhole_ctxt_ta_mono:
	+ "q \|\<in>\| ta_der (refl_ta \<F> q) t \<Longrightarrow> q \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q q\<^sub>i q\<^sub>f) t"
	+ by (intro ta_der_el_mono[where ?\<B> = "reflcl_over_nhole_ctxt_ta Q \<F> q q\<^sub>i q\<^sub>f"])
	+ (auto simp: refl_ta_def reflcl_over_nhole_ctxt_ta_def)
	+
	+
	+lemma reflcl_over_nhole_ctxt_ta_sound:
	+ assumes "funas_gctxt C \<subseteq> fset \<F>" "C \<noteq> GHole" "q \|\<in>\| Q"
	+ shows "q\<^sub>f \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using assms(1, 2)
	+proof (induct C)
	+ case GHole then show ?case using assms(2)
	+ by (auto simp add: reflcl_over_single_ta_def)
	+next
	+ case (GMore f ss C ts) note IH = this
	+ let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
	+ from GMore have funas: "(f, ?n) \|\<in>\| \<F>" by (auto simp flip: fmember.rep_eq)
	+ from GMore(2) have args_ss: "i < length ss \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (term_of_gterm (ss ! i))" for i
	+ by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
	+ from GMore(2) have args_ts: "i < length ts \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (term_of_gterm (ts ! i))" for i
	+ by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
	+ note args = this
	+ show ?case
	+ proof (cases C)
	+ case [simp]: GHole
	+ from funas have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>i]) \<rightarrow> q\<^sub>f \|\<in>\| rules (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
	+ using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>i]" q\<^sub>f \<F> q\<^sub>c q\<^sub>i q\<^sub>f]
	+ unfolding reflcl_over_nhole_ctxt_ta_def
	+ by (metis funionCI less_add_Suc1 ta.sel(1))
	+ moreover have "q\<^sub>i \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
	+ using assms(3) by (auto simp: reflcl_over_nhole_ctxt_ta_def)
	+ ultimately show ?thesis using args_ss args_ts
	+ by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>i]"] exI[of _ q\<^sub>f])
	+ next
	+ case (GMore x21 x22 x23 x24)
	+ then have "q\<^sub>f \|\<in>\| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
	+ using IH(1, 2) by auto
	+ moreover from funas have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>f]) \<rightarrow> q\<^sub>f \|\<in>\| rules (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
	+ using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]" q\<^sub>f \<F> q\<^sub>c q\<^sub>f q\<^sub>f]
	+ unfolding reflcl_over_nhole_ctxt_ta_def
	+ by (metis funionI2 less_add_Suc1 ta.sel(1))
	+ ultimately show ?thesis using args_ss args_ts
	+ by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]"] exI[of _ q\<^sub>f])
	+ qed
	+qed
	+
	+lemma reflcl_over_nhole_ctxt_ta_sig: "ta_sig (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) \|\<subseteq>\| \<F>"
	+ by (intro ta_sig_fsubsetI)
	+ (auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest!: semantic_path_rules_fmemberD)
	+
	+lemma gen_nhole_gctxt_closure_lang:
	+ assumes "q\<^sub>c \|\<notin>\| \<Q> \<A>" "q\<^sub>i \|\<notin>\| \<Q> \<A>" "q\<^sub>f \|\<notin>\| \<Q> \<A>"
	+ and "q\<^sub>c \|\<notin>\| Q" "q\<^sub>f \|\<notin>\| Q"
	+ and "q\<^sub>c \<noteq> q\<^sub>i" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f"
	+ shows "gta_lang {\|q\<^sub>f\|} (gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
	+ {C\<langle>s\<rangle>\<^sub>G \| C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> gta_lang Q \<A>}"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?A = "gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
	+ interpret sq: derivation_split ?A \<A> ?B
	+ using assms unfolding derivation_split_def
	+ by (auto simp: gen_nhole_ctxt_closure_automaton_def reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def
	+ dest!: semantic_path_rules_rhs)
	+ {fix s assume "s \<in> ?Ls" then obtain u where
	+ seq: "u \|\<in>\| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f \|\<in>\| ta_der'?B u" using sq.ta_der'_split
	+ by (force simp: ta_der_to_ta_der' elim!: gta_langE)
	+ have "q\<^sub>c \<notin> vars_term u" "q\<^sub>i \<notin> vars_term u" "q\<^sub>f \<notin> vars_term u"
	+ using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1 - 3)
	+ by (auto simp flip: set_vars_term_list fmember.rep_eq)
	+ then obtain q where vars: "vars_term_list u = [q]" and fin: "q \|\<in>\| Q"
	+ unfolding set_vars_term_list[symmetric]
	+ using reflcl_over_nhole_ctxt_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(4, 5, 7 - 8, 6) seq(2)]
	+ by (metis (no_types, opaque_lifting) finsert_iff funion_commute funion_finsert_right
	+ length_greater_0_conv lessI list.size(3) list_update_code(2) not0_implies_Suc
	+ nth_list_update_neq nth_mem nth_replicate replicate_Suc replicate_empty sup_bot.right_neutral)
	+ from seq(2) have "ta_der'_gctxt u \<noteq> GHole" using ta_der'_ground_ctxt_structure(1)[OF seq(1) vars]
	+ using fin assms(4, 5, 8) by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2)
	+ then have "s \<in> ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars] seq(2)
	+ using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_nhole_ctxt_ta_sig[unfolded less_eq_fset.rep_eq]]
	+ by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
	+ (metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv in_mono)}
	+ then have ls: "?Ls \<subseteq> ?Rs" by blast
	+ {fix t assume "t \<in> ?Rs"
	+ then obtain C s where gr_fun: "funas_gctxt C \<subseteq> fset \<F>" "C \<noteq> GHole" and reachA: "s \<in> gta_lang Q \<A>" and
	+ const: "t = C\<langle>s\<rangle>\<^sub>G" by auto
	+ from reachA obtain q where der_A: "q \|\<in>\| Q \|\<inter>\| \<Q> \<A>" "q \|\<in>\| ta_der \<A> (term_of_gterm s)"
	+ by auto
	+ have "q\<^sub>f \|\<in>\| ta_der ?B (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using gr_fun der_A(1)
	+ using reflcl_over_nhole_ctxt_ta_sound[OF gr_fun]
	+ by force
	+ then have "t \<in> ?Ls" unfolding const
	+ by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
	+ then show ?thesis using ls by blast
	+qed
	+
	+lemma gen_nhole_gctxt_closure_sound:
	+ assumes "q\<^sub>c \|\<notin>\| \<Q>\<^sub>r \<A>" "q\<^sub>i \|\<notin>\| \<Q>\<^sub>r \<A>" "q\<^sub>f \|\<notin>\| \<Q>\<^sub>r \<A>"
	+ and "q\<^sub>c \|\<notin>\| (fin \<A>)" "q\<^sub>f \|\<notin>\| (fin \<A>)"
	+ and "q\<^sub>c \<noteq> q\<^sub>i" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f"
	+ shows "\<L> (gen_nhole_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
	+ { C\<langle>s\<rangle>\<^sub>G \| C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
	+ using gen_nhole_gctxt_closure_lang[OF assms] unfolding \<L>_def
	+ by (auto simp: gen_nhole_ctxt_closure_reg_def)
	+
	+
	+lemma nhole_ctxtcl_lang:
	+ "\<L> (nhole_ctxt_closure_reg \<F> \<A>) =
	+ { C\<langle>s\<rangle>\<^sub>G \| C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
	+proof -
	+ let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
	+ have ts: "Inr cl_state \|\<notin>\| \<Q>\<^sub>r ?B" "Inr tr_state \|\<notin>\| \<Q>\<^sub>r ?B" "Inr fin_state \|\<notin>\| \<Q>\<^sub>r ?B"
	+ by (auto simp: fmap_states_reg_def)
	+ then have "Inr cl_state \|\<notin>\| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
	+ "Inr fin_state \|\<notin>\| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
	+ using finj_Inl_Inr(1) fmap_states_reg_Restr_Q\<^sub>f_fin by blast+
	+ from gen_nhole_gctxt_closure_sound[OF ts this] show ?thesis
	+ by (simp add: nhole_ctxt_closure_reg_def Let_def)
	+qed
	+
	+
	+subsubsection \<open>Correctness of @{const gen_nhole_mctxt_closure_automaton}\<close>
	+
	+lemmas reflcl_over_nhole_mctxt_ta_simp = reflcl_over_nhole_mctxt_ta_def reflcl_over_nhole_ctxt_ta_def
	+
	+lemma reflcl_rules_rhsD:
	+ "f ps \<rightarrow> q \|\<in>\| reflcl_rules \<F> q\<^sub>c \<Longrightarrow> q = q\<^sub>c"
	+ by (auto simp: reflcl_rules_def)
	+
	+lemma reflcl_over_nhole_mctxt_ta_vars_term:
	+ assumes "q \|\<in>\| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t"
	+ and "q\<^sub>c \|\<notin>\| Q" "q \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>i \<noteq> q\<^sub>c"
	+ shows "vars_term t \<noteq> {}" using assms
	+proof (induction t arbitrary: q)
	+ case (Fun f ts)
	+ let ?A = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
	+ from Fun(2) obtain p ps where rule: "TA_rule f ps p \|\<in>\| rules ?A"
	+ "length ps = length ts" "\<forall> i < length ts. ps ! i \|\<in>\| ta_der ?A (ts ! i)"
	+ "p = q \<or> (p, q) \|\<in>\| (eps ?A)\|\<^sup>+\|"
	+ by force
	+ from rule(1, 4) Fun(3-) have "p \<noteq> q\<^sub>c"
	+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD)
	+ then have "\<exists> i < length ts. ps ! i \<noteq> q\<^sub>c" using rule(1, 2) Fun(4-)
	+ using semantic_path_rules_fmemberD
	+ by (force simp: reflcl_over_nhole_mctxt_ta_simp dest: reflcl_rules_rhsD)
	+ then show ?case using Fun(1)[OF nth_mem _ Fun(3) _ Fun(5, 6)] rule(2, 3)
	+ by fastforce
	+qed auto
	+
	+lemma reflcl_over_nhole_mctxt_ta_Fun:
	+ assumes "q\<^sub>f \|\<in>\| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" "t \<noteq> Var q\<^sub>f"
	+ and "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i"
	+ shows "is_Fun t" using assms
	+ by (cases t) (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD2)
	+
	+lemma rule_states_reflcl_rulesD:
	+ "p \|\<in>\| rule_states (reflcl_rules \<F> q) \<Longrightarrow> p = q"
	+ by (auto simp: reflcl_rules_def rule_states_def fset_of_list_elem)
	+
	+lemma rule_states_semantic_path_rulesD:
	+ "p \|\<in>\| rule_states (semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f) \<Longrightarrow> p = q\<^sub>c \<or> p = q\<^sub>i \<or> p = q\<^sub>f"
	+ by (auto simp: rule_states_def dest!: semantic_path_rules_fmemberD)
	+ (metis in_fset_conv_nth length_list_update length_replicate nth_list_update nth_replicate)
	+
	+lemma \<Q>_reflcl_over_nhole_mctxt_ta:
	+ "\<Q> (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) \|\<subseteq>\| Q \|\<union>\| {\|q\<^sub>c, q\<^sub>i, q\<^sub>f\|}"
	+ by (auto 0 0 simp: eps_states_def reflcl_over_nhole_mctxt_ta_simp \<Q>_def
	+ dest!: rule_states_reflcl_rulesD rule_states_semantic_path_rulesD)
	+
	+lemma reflcl_over_nhole_mctxt_ta_vars_term_subset_eq:
	+ assumes "q \|\<in>\| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" "q = q\<^sub>f \<or> q = q\<^sub>i"
	+ shows "vars_term t \<subseteq> {q\<^sub>c, q\<^sub>i, q\<^sub>f} \<union> fset Q"
	+ using fresh_states_ta_der'_pres[OF _ _ assms(1)[unfolded ta_der_to_ta_der']] assms(2)
	+ using fsubsetD[OF \<Q>_reflcl_over_nhole_mctxt_ta[of Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f]]
	+ by auto (meson notin_fset)+
	+
	+lemma sig_reflcl_over_nhole_mctxt_ta [simp]:
	+ "ta_sig (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) = \<F>"
	+ by (force simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def
	+ dest!: semantic_path_rules_fmemberD intro!: ta_sig_fsubsetI)
	+
	+lemma reflcl_over_nhole_mctxt_ta_aux_sound:
	+ assumes "funas_term t \<subseteq> fset \<F>" "vars_term t \<subseteq> fset Q"
	+ shows "q\<^sub>c \|\<in>\| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" using assms
	+proof (induct t)
	+ case (Var x)
	+ then show ?case
	+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp fimage_iff simp flip: fmember.rep_eq)
	+ (meson finsertI1 finsertI2 fr_into_trancl ftrancl_into_trancl rev_fimage_eqI)
	+next
	+ case (Fun f ts)
	+ from Fun(2) have "TA_rule f (replicate (length ts) q\<^sub>c) q\<^sub>c \|\<in>\| rules (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
	+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def fimage_iff fBall_def
	+ simp flip: fmember.rep_eq split: prod.splits)
	+ then show ?case using Fun(1)[OF nth_mem] Fun(2-)
	+ by (auto simp: SUP_le_iff) (metis length_replicate nth_replicate)
	+qed
	+
	+lemma reflcl_over_nhole_mctxt_ta_sound:
	+ assumes "funas_term t \<subseteq> fset \<F>" "vars_term t \<subseteq> fset Q" "vars_term t \<noteq> {}"
	+ shows "(is_Var t \<longrightarrow> q\<^sub>i \|\<in>\| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t) \<and>
	+ (is_Fun t \<longrightarrow> q\<^sub>f \|\<in>\| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t)" using assms
	+proof (induct t)
	+ case (Fun f ts)
	+ let ?A = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
	+ from Fun(4) obtain i where vars: "i < length ts" "vars_term (ts ! i) \<noteq> {}"
	+ by (metis SUP_le_iff in_set_conv_nth subset_empty term.set(4))
	+ consider (v) "is_Var (ts ! i)" \| (f) "is_Fun (ts ! i)" by blast
	+ then show ?case
	+ proof cases
	+ case v
	+ from v Fun(1)[OF nth_mem[OF vars(1)]] have "q\<^sub>i \|\<in>\| ta_der ?A (ts ! i)"
	+ using vars Fun(2-) by (auto simp: SUP_le_iff)
	+ moreover have "f (replicate (length ts) q\<^sub>c)[i := q\<^sub>i] \<rightarrow> q\<^sub>f \|\<in>\| rules ?A"
	+ using Fun(2) vars(1)
	+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember.rep_eq)
	+ moreover have "j < length ts \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der ?A (ts ! j)" for j using Fun(2-)
	+ by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
	+ ultimately show ?thesis using vars
	+ by auto (metis length_list_update length_replicate nth_list_update nth_replicate)
	+ next
	+ case f
	+ from f Fun(1)[OF nth_mem[OF vars(1)]] have "q\<^sub>f \|\<in>\| ta_der ?A (ts ! i)"
	+ using vars Fun(2-) by (auto simp: SUP_le_iff)
	+ moreover have "f (replicate (length ts) q\<^sub>c)[i := q\<^sub>f] \<rightarrow> q\<^sub>f \|\<in>\| rules ?A"
	+ using Fun(2) vars(1)
	+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember.rep_eq)
	+ moreover have "j < length ts \<Longrightarrow> q\<^sub>c \|\<in>\| ta_der ?A (ts ! j)" for j using Fun(2-)
	+ by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
	+ ultimately show ?thesis using vars
	+ by auto (metis length_list_update length_replicate nth_list_update nth_replicate)
	+ qed
	+qed (auto simp: reflcl_over_nhole_mctxt_ta_simp simp flip: fmember.rep_eq dest!: ftranclD2)
	+
	+
	+lemma gen_nhole_gmctxt_closure_lang:
	+ assumes "q\<^sub>c \|\<notin>\| \<Q> \<A>" and "q\<^sub>i \|\<notin>\| \<Q> \<A>" "q\<^sub>f \|\<notin>\| \<Q> \<A>"
	+ and "q\<^sub>c \|\<notin>\| Q" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i" "q\<^sub>i \<noteq> q\<^sub>c"
	+ shows "gta_lang {\|q\<^sub>f\|} (gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
	+ { fill_gholes C ss \|
	+ C ss. 0 < num_gholes C \<and> num_gholes C = length ss \<and> C \<noteq> GMHole \<and>
	+ funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?A = "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
	+ interpret sq: derivation_split "?A" "\<A>" "?B"
	+ using assms unfolding derivation_split_def
	+ by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
	+ reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def dest!: semantic_path_rules_rhs)
	+ {fix s assume "s \<in> ?Ls" then obtain u where
	+ seq: "u \|\<in>\| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f \|\<in>\| ta_der'?B u"
	+ by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
	+ note der = seq(2)[unfolded ta_der_to_ta_der'[symmetric]]
	+ have "vars_term u \<subseteq> fset Q" "vars_term u \<noteq> {}"
	+ using ta_der'_gterm_states[OF seq(1)] assms(1 - 3)
	+ using reflcl_over_nhole_mctxt_ta_vars_term[OF der assms(4) assms(5) assms(5) assms(7)]
	+ using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF der]
	+ by (metis Un_insert_left insert_is_Un notin_fset subset_iff subset_insert)+
	+ then have vars: "\<not> ground u" "i < length (ta_der'_target_args u) \<Longrightarrow> ta_der'_target_args u ! i \|\<in>\| Q" for i
	+ by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
	+ fmember.rep_eq set_list_subset_nth_conv simp flip: set_vars_term_list)
	+ have hole: "ta_der'_target_mctxt u \<noteq> MHole" using vars assms(3-)
	+ using reflcl_over_nhole_mctxt_ta_Fun[OF der]
	+ using ta_der'_mctxt_structure(1, 3)[OF seq(1)]
	+ by auto (metis fill_holes_MHole gterm_ta_der_states length_map lessI map_nth_eq_conv seq(1) ta_der_to_ta_der' term.disc(1))
	+ let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
	+ have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
	+ using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms vars
	+ using ta_der'_ground_mctxt_structure[OF seq(1)] hole
	+ by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
	+ intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
	+ exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
	+ gta_langI[of "ta_der'_target_args u ! i" Q \<A>
	+ "gterm_of_term (?w i)" for i])}
	+ then have ls: "?Ls \<subseteq> ?Rs" by blast
	+ {fix t assume "t \<in> ?Rs"
	+ then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" "C \<noteq> GMHole" and
	+ gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
	+ reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
	+ const: "t = fill_gholes C ss" by auto
	+ from reachA obtain qs where states: "length ss = length qs" "\<forall> i < length qs. qs ! i \|\<in>\| Q \|\<inter>\| \<Q> \<A>"
	+ "\<forall> i < length qs. qs ! i \|\<in>\| ta_der \<A> ((map term_of_gterm ss) ! i)"
	+ using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q \|\<in>\| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q \|\<in>\| Q"]
	+ by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
	+ have [simp]: "is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) \<longleftrightarrow> True"
	+ "is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) \<longleftrightarrow> False"
	+ using len(3) by (cases C, auto)+
	+ have "q\<^sub>f \|\<in>\| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
	+ using reachA len gr_fun states
	+ using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
	+ by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>f])
	+ (auto simp: funas_mctxt_of_gmctxt_conv fmember.rep_eq set_list_subset_eq_nth_conv
	+ simp flip: fmember.rep_eq dest!: in_set_idx)
	+ then have "t \<in> ?Ls" unfolding const
	+ by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
	+ then show ?thesis using ls by blast
	+qed
	+
	+lemma nhole_gmctxt_closure_lang:
	+ "\<L> (nhole_mctxt_closure_reg \<F> \<A>) =
	+ { fill_gholes C ss \| C ss. num_gholes C = length ss \<and> 0 < num_gholes C \<and> C \<noteq> GMHole \<and>
	+ funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
	+ have ts: "Inr cl_state \|\<notin>\| \<Q>\<^sub>r ?B" "Inr tr_state \|\<notin>\| \<Q>\<^sub>r ?B" "Inr fin_state \|\<notin>\| \<Q>\<^sub>r ?B"
	+ "Inr cl_state \|\<notin>\| fin ?B"
	+ by (auto simp: fmap_states_reg_def)
	+ have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))) (ta (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)))
	+ = gta_lang (fin \<A>) (ta \<A>)"
	+ by (metis \<L>_def \<L>_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states)
	+ from gen_nhole_gmctxt_closure_lang[OF ts] show ?thesis
	+ by (auto simp add: nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def Let_def \<L>_def)
	+qed
	+
	+subsubsection \<open>Correctness of @{const gen_mctxt_closure_reg} and @{const mctxt_closure_reg}\<close>
	+
	+lemma gen_gmctxt_closure_lang:
	+ assumes "q\<^sub>c \|\<notin>\| \<Q> \<A>" and "q\<^sub>i \|\<notin>\| \<Q> \<A>" "q\<^sub>f \|\<notin>\| \<Q> \<A>"
	+ and disj: "q\<^sub>c \|\<notin>\| Q" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i" "q\<^sub>i \<noteq> q\<^sub>c"
	+ shows "gta_lang {\|q\<^sub>f, q\<^sub>i\|} (gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
	+ { fill_gholes C ss \|
	+ C ss. 0 < num_gholes C \<and> num_gholes C = length ss \<and>
	+ funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?A = "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
	+ interpret sq: derivation_split "?A" "\<A>" "?B"
	+ using assms unfolding derivation_split_def
	+ by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
	+ reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def dest!: semantic_path_rules_rhs)
	+ {fix s assume "s \<in> ?Ls" then obtain u q where
	+ seq: "u \|\<in>\| ta_der' \<A> (term_of_gterm s)" "Var q \|\<in>\| ta_der'?B u" "q = q\<^sub>f \<or> q = q\<^sub>i"
	+ by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
	+ have "vars_term u \<subseteq> fset Q" "vars_term u \<noteq> {}"
	+ using ta_der'_gterm_states[OF seq(1)] assms seq(3)
	+ using reflcl_over_nhole_mctxt_ta_vars_term[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] disj(1) _ disj(2, 4)]
	+ using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] seq(3)]
	+ by (metis Un_insert_left notin_fset subsetD subset_insert sup_bot_left)+
	+ then have vars: "\<not> ground u" "i < length (ta_der'_target_args u) \<Longrightarrow> ta_der'_target_args u ! i \|\<in>\| Q" for i
	+ by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
	+ fmember.rep_eq set_list_subset_nth_conv simp flip: set_vars_term_list)
	+ let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
	+ have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
	+ using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms vars
	+ using ta_der'_ground_mctxt_structure[OF seq(1)]
	+ by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
	+ intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
	+ exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
	+ gta_langI[of "ta_der'_target_args u ! i" Q \<A>
	+ "gterm_of_term (?w i)" for i])}
	+ then have "?Ls \<subseteq> ?Rs" by blast
	+ moreover
	+ {fix t assume "t \<in> ?Rs"
	+ then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" and
	+ gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
	+ reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
	+ const: "t = fill_gholes C ss" by auto
	+ from const have const': "term_of_gterm t = fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss)"
	+ by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes len(2))
	+ from reachA obtain qs where states: "length ss = length qs" "\<forall> i < length qs. qs ! i \|\<in>\| Q \|\<inter>\| \<Q> \<A>"
	+ "\<forall> i < length qs. qs ! i \|\<in>\| ta_der \<A> ((map term_of_gterm ss) ! i)"
	+ using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q \|\<in>\| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q \|\<in>\| Q"]
	+ by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
	+ have "C = GMHole \<Longrightarrow> is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True" using len states(1)
	+ by (metis fill_holes_MHole length_map mctxt_of_gmctxt.simps(1) nth_map num_gholes.simps(1) term.disc(1))
	+ then have hole: "C = GMHole \<Longrightarrow> q\<^sub>i \|\<in>\| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
	+ using reachA len gr_fun states len
	+ using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
	+ by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>i])
	+ (auto simp: funas_mctxt_of_gmctxt_conv fmember.rep_eq set_list_subset_eq_nth_conv
	+ simp flip: fmember.rep_eq dest!: in_set_idx)
	+ have "C \<noteq> GMHole \<Longrightarrow> is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True"
	+ by (cases C) auto
	+ then have "C \<noteq> GMHole \<Longrightarrow> q\<^sub>f \|\<in>\| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
	+ using reachA len gr_fun states
	+ using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
	+ by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>f])
	+ (auto simp: funas_mctxt_of_gmctxt_conv fmember.rep_eq set_list_subset_eq_nth_conv
	+ simp flip: fmember.rep_eq dest!: in_set_idx)
	+ then have "t \<in> ?Ls" using hole const' unfolding gta_lang_def gta_der_def
	+ by (metis (mono_tags, lifting) fempty_iff finsert_iff finterI mem_Collect_eq)}
	+ ultimately show ?thesis
	+ by (meson subsetI subset_antisym)
	+qed
	+
	+
	+lemma gmctxt_closure_lang:
	+ "\<L> (mctxt_closure_reg \<F> \<A>) =
	+ { fill_gholes C ss \| C ss. num_gholes C = length ss \<and> 0 < num_gholes C \<and>
	+ funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
	+ (is "?Ls = ?Rs")
	+proof -
	+ let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
	+ have ts: "Inr cl_state \|\<notin>\| \<Q>\<^sub>r ?B" "Inr tr_state \|\<notin>\| \<Q>\<^sub>r ?B" "Inr fin_state \|\<notin>\| \<Q>\<^sub>r ?B"
	+ "Inr cl_state \|\<notin>\| fin ?B"
	+ by (auto simp: fmap_states_reg_def)
	+ have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))) (ta (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)))
	+ = gta_lang (fin \<A>) (ta \<A>)"
	+ by (metis \<L>_def \<L>_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states)
	+ from gen_gmctxt_closure_lang[OF ts] show ?thesis
	+ by (auto simp add: mctxt_closure_reg_def gen_mctxt_closure_reg_def Let_def \<L>_def)
	+qed
	+
	+
	+subsubsection \<open>Correctness of @{const nhole_mctxt_reflcl_reg}\<close>
	+
	+lemma nhole_mctxt_reflcl_lang:
	+ "\<L> (nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<F> \<A>) \<union> \<T>\<^sub>G (fset \<F>)"
	+proof -
	+ let ?refl = "Reg {\|fin_clstate\|} (refl_ta \<F> (fin_clstate))"
	+ {fix t assume "t \<in> \<L> ?refl" then have "t \<in> \<T>\<^sub>G (fset \<F>)"
	+ using reg_funas by fastforce}
	+ moreover
	+ {fix t assume "t \<in> \<T>\<^sub>G (fset \<F>)" then have "t \<in> \<L> ?refl"
	+ by (simp add: \<L>_def gta_langI refl_ta_sound)}
	+ ultimately have *: "\<L> ?refl = \<T>\<^sub>G (fset \<F>)"
	+ by blast
	+ show ?thesis unfolding nhole_mctxt_reflcl_reg_def \<L>_union * by simp
	+qed
	+declare ta_union_def [simp del]
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/FOL_Extra.thy b/thys/FO_Theory_Rewriting/FOL_Extra.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/FOL_Extra.thy
	@@ -0,0 +1,405 @@
	+theory FOL_Extra
	+ imports
	+ Type_Instances_Impl
	+ "FOL-Fitting.FOL_Fitting"
	+ "HOL-Library.FSet"
	+begin
	+
	+section \<open>Additional support for FOL-Fitting\<close>
	+subsection \<open>Iff\<close>
	+
	+definition Iff where
	+ "Iff p q = And (Impl p q) (Impl q p)"
	+
	+lemma eval_Iff:
	+ "eval e f g (Iff p q) \<longleftrightarrow> (eval e f g p \<longleftrightarrow> eval e f g q)"
	+ by (auto simp: Iff_def)
	+
	+
	+subsection \<open>Replacement of subformulas\<close>
	+
	+datatype ('a, 'b) ctxt
	+ = Hole
	+ \| And1 "('a, 'b) ctxt" "('a, 'b) form"
	+ \| And2 "('a, 'b) form" "('a, 'b) ctxt"
	+ \| Or1 "('a, 'b) ctxt" "('a, 'b) form"
	+ \| Or2 "('a, 'b) form" "('a, 'b) ctxt"
	+ \| Impl1 "('a, 'b) ctxt" "('a, 'b) form"
	+ \| Impl2 "('a, 'b) form" "('a, 'b) ctxt"
	+ \| Neg1 "('a, 'b) ctxt"
	+ \| Forall1 "('a, 'b) ctxt"
	+ \| Exists1 "('a, 'b) ctxt"
	+
	+primrec apply_ctxt :: "('a, 'b) ctxt \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form" where
	+ "apply_ctxt Hole p = p"
	+\| "apply_ctxt (And1 c v) p = And (apply_ctxt c p) v"
	+\| "apply_ctxt (And2 u c) p = And u (apply_ctxt c p)"
	+\| "apply_ctxt (Or1 c v) p = Or (apply_ctxt c p) v"
	+\| "apply_ctxt (Or2 u c) p = Or u (apply_ctxt c p)"
	+\| "apply_ctxt (Impl1 c v) p = Impl (apply_ctxt c p) v"
	+\| "apply_ctxt (Impl2 u c) p = Impl u (apply_ctxt c p)"
	+\| "apply_ctxt (Neg1 c) p = Neg (apply_ctxt c p)"
	+\| "apply_ctxt (Forall1 c) p = Forall (apply_ctxt c p)"
	+\| "apply_ctxt (Exists1 c) p = Exists (apply_ctxt c p)"
	+
	+lemma replace_subformula:
	+ assumes "\<And>e. eval e f g (Iff p q)"
	+ shows "eval e f g (Iff (apply_ctxt c p) (apply_ctxt c q))"
	+ by (induct c arbitrary: e) (auto simp: assms[unfolded eval_Iff] Iff_def)
	+
	+
	+subsection \<open>Propositional identities\<close>
	+
	+lemma prop_ids:
	+ "eval e f g (Iff (And p q) (And q p))"
	+ "eval e f g (Iff (Or p q) (Or q p))"
	+ "eval e f g (Iff (Or p (Or q r)) (Or (Or p q) r))"
	+ "eval e f g (Iff (And p (And q r)) (And (And p q) r))"
	+ "eval e f g (Iff (Neg (Or p q)) (And (Neg p) (Neg q)))"
	+ "eval e f g (Iff (Neg (And p q)) (Or (Neg p) (Neg q)))"
	+ (* ... *)
	+ by (auto simp: Iff_def)
	+
	+
	+subsection \<open>de Bruijn index manipulation for formulas; cf. @{term liftt}\<close>
	+
	+primrec liftti :: "nat \<Rightarrow> 'a term \<Rightarrow> 'a term" where
	+ "liftti i (Var j) = (if i > j then Var j else Var (Suc j))"
	+\| "liftti i (App f ts) = App f (map (liftti i) ts)"
	+
	+lemma liftts_def':
	+ "liftts ts = map liftt ts"
	+ by (induct ts) auto
	+
	+text \<open>@{term liftt} is a special case of @{term liftti}\<close>
	+lemma lifttti_0:
	+ "liftti 0 t = liftt t"
	+ by (induct t) (auto simp: liftts_def')
	+
	+primrec lifti :: "nat \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form" where
	+ "lifti i FF = FF"
	+\| "lifti i TT = TT"
	+\| "lifti i (Pred b ts) = Pred b (map (liftti i) ts)"
	+\| "lifti i (And p q) = And (lifti i p) (lifti i q)"
	+\| "lifti i (Or p q) = Or (lifti i p) (lifti i q)"
	+\| "lifti i (Impl p q) = Impl (lifti i p) (lifti i q)"
	+\| "lifti i (Neg p) = Neg (lifti i p)"
	+\| "lifti i (Forall p) = Forall (lifti (Suc i) p)"
	+\| "lifti i (Exists p) = Exists (lifti (Suc i) p)"
	+
	+abbreviation lift where
	+ "lift \<equiv> lifti 0"
	+
	+text \<open>interaction of @{term lifti} and @{term eval}\<close>
	+
	+lemma evalts_def':
	+ "evalts e f ts = map (evalt e f) ts"
	+ by (induct ts) auto
	+
	+lemma evalt_liftti:
	+ "evalt (e\<langle>i:z\<rangle>) f (liftti i t) = evalt e f t"
	+ by (induct t) (auto simp: evalts_def' cong: map_cong)
	+
	+lemma eval_lifti [simp]:
	+ "eval (e\<langle>i:z\<rangle>) f g (lifti i p) = eval e f g p"
	+ by (induct p arbitrary: e i) (auto simp: evalt_liftti evalts_def' comp_def)
	+
	+
	+subsection \<open>Quantifier Identities\<close>
	+
	+lemma quant_ids:
	+ "eval e f g (Iff (Neg (Exists p)) (Forall (Neg p)))"
	+ "eval e f g (Iff (Neg (Forall p)) (Exists (Neg p)))"
	+ "eval e f g (Iff (And p (Forall q)) (Forall (And (lift p) q)))"
	+ "eval e f g (Iff (And p (Exists q)) (Exists (And (lift p) q)))"
	+ "eval e f g (Iff (Or p (Forall q)) (Forall (Or (lift p) q)))"
	+ "eval e f g (Iff (Or p (Exists q)) (Exists (Or (lift p) q)))"
	+ (* ... *)
	+ by (auto simp: Iff_def)
	+
	+(* We'd need a bit of more machinery to deal with "\<forall>x y. P(x,y) \<longleftrightarrow> \<forall>y x. P(x, y)":
	+ * swapping of de Bruijn indices (perhaps arbitrary permutation?) *)
	+
	+
	+subsection \<open>Function symbols and predicates, with arities.\<close>
	+
	+primrec predas_form :: "('a, 'b) form \<Rightarrow> ('b \<times> nat) set" where
	+ "predas_form FF = {}"
	+\| "predas_form TT = {}"
	+\| "predas_form (Pred b ts) = {(b, length ts)}"
	+\| "predas_form (And p q) = predas_form p \<union> predas_form q"
	+\| "predas_form (Or p q) = predas_form p \<union> predas_form q"
	+\| "predas_form (Impl p q) = predas_form p \<union> predas_form q"
	+\| "predas_form (Neg p) = predas_form p"
	+\| "predas_form (Forall p) = predas_form p"
	+\| "predas_form (Exists p) = predas_form p"
	+
	+primrec funas_term :: "'a term \<Rightarrow> ('a \<times> nat) set" where
	+ "funas_term (Var x) = {}"
	+\| "funas_term (App f ts) = {(f, length ts)} \<union> \<Union>(set (map funas_term ts))"
	+
	+primrec terms_form :: "('a, 'b) form \<Rightarrow> 'a term set" where
	+ "terms_form FF = {}"
	+\| "terms_form TT = {}"
	+\| "terms_form (Pred b ts) = set ts"
	+\| "terms_form (And p q) = terms_form p \<union> terms_form q"
	+\| "terms_form (Or p q) = terms_form p \<union> terms_form q"
	+\| "terms_form (Impl p q) = terms_form p \<union> terms_form q"
	+\| "terms_form (Neg p) = terms_form p"
	+\| "terms_form (Forall p) = terms_form p"
	+\| "terms_form (Exists p) = terms_form p"
	+
	+definition funas_form :: "('a, 'b) form \<Rightarrow> ('a \<times> nat) set" where
	+ "funas_form f \<equiv> \<Union>(funas_term ` terms_form f)"
	+
	+
	+subsection \<open>Negation Normal Form\<close>
	+
	+inductive is_nnf :: "('a, 'b) form \<Rightarrow> bool" where
	+ "is_nnf TT"
	+\| "is_nnf FF"
	+\| "is_nnf (Pred p ts)"
	+\| "is_nnf (Neg (Pred p ts))"
	+\| "is_nnf p \<Longrightarrow> is_nnf q \<Longrightarrow> is_nnf (And p q)"
	+\| "is_nnf p \<Longrightarrow> is_nnf q \<Longrightarrow> is_nnf (Or p q)"
	+\| "is_nnf p \<Longrightarrow> is_nnf (Forall p)"
	+\| "is_nnf p \<Longrightarrow> is_nnf (Exists p)"
	+
	+primrec nnf' :: "bool \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form" where
	+ "nnf' b TT = (if b then TT else FF)"
	+\| "nnf' b FF = (if b then FF else TT)"
	+\| "nnf' b (Pred p ts) = (if b then id else Neg) (Pred p ts)"
	+\| "nnf' b (And p q) = (if b then And else Or) (nnf' b p) (nnf' b q)"
	+\| "nnf' b (Or p q) = (if b then Or else And) (nnf' b p) (nnf' b q)"
	+\| "nnf' b (Impl p q) = (if b then Or else And) (nnf' (\<not> b) p) (nnf' b q)"
	+\| "nnf' b (Neg p) = nnf' (\<not> b) p"
	+\| "nnf' b (Forall p) = (if b then Forall else Exists) (nnf' b p)"
	+\| "nnf' b (Exists p) = (if b then Exists else Forall) (nnf' b p)"
	+
	+lemma eval_nnf':
	+ "eval e f g (nnf' b p) \<longleftrightarrow> (eval e f g p \<longleftrightarrow> b)"
	+ by (induct p arbitrary: e b) auto
	+
	+lemma is_nnf_nnf':
	+ "is_nnf (nnf' b p)"
	+ by (induct p arbitrary: b) (auto intro: is_nnf.intros)
	+
	+abbreviation nnf where
	+ "nnf \<equiv> nnf' True"
	+
	+lemmas nnf_simpls [simp] = eval_nnf'[where b = True, unfolded eq_True] is_nnf_nnf'[where b = True]
	+
	+
	+subsection \<open>Reasoning modulo ACI01\<close>
	+
	+datatype ('a, 'b) form_aci
	+ = TT_aci
	+ \| FF_aci
	+ \| Pred_aci bool 'b "'a term list"
	+ \| And_aci "('a, 'b) form_aci fset"
	+ \| Or_aci "('a, 'b) form_aci fset"
	+ \| Forall_aci "('a, 'b) form_aci"
	+ \| Exists_aci "('a, 'b) form_aci"
	+
	+text \<open>evaluation, see @{const eval}\<close>
	+
	+primrec eval_aci :: \<open>(nat \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'c list \<Rightarrow> 'c) \<Rightarrow>
	+ ('b \<Rightarrow> 'c list \<Rightarrow> bool) \<Rightarrow> ('a, 'b) form_aci \<Rightarrow> bool\<close> where
	+ "eval_aci e f g FF_aci \<longleftrightarrow> False"
	+\| "eval_aci e f g TT_aci \<longleftrightarrow> True"
	+\| "eval_aci e f g (Pred_aci b a ts) \<longleftrightarrow> (g a (evalts e f ts) \<longleftrightarrow> b)"
	+\| "eval_aci e f g (And_aci ps) \<longleftrightarrow> fBall (fimage (eval_aci e f g) ps) id"
	+\| "eval_aci e f g (Or_aci ps) \<longleftrightarrow> fBex (fimage (eval_aci e f g) ps) id"
	+\| "eval_aci e f g (Forall_aci p) \<longleftrightarrow> (\<forall>z. eval_aci (e\<langle>0:z\<rangle>) f g p)"
	+\| "eval_aci e f g (Exists_aci p) \<longleftrightarrow> (\<exists>z. eval_aci (e\<langle>0:z\<rangle>) f g p)"
	+
	+text \<open>smart constructor: conjunction\<close>
	+
	+fun and_aci where
	+ "and_aci FF_aci _ = FF_aci"
	+\| "and_aci _ FF_aci = FF_aci"
	+\| "and_aci TT_aci q = q"
	+\| "and_aci p TT_aci = p"
	+\| "and_aci (And_aci ps) (And_aci qs) = And_aci (ps \|\<union>\| qs)"
	+\| "and_aci (And_aci ps) q = And_aci (ps \|\<union>\| {\|q\|})"
	+\| "and_aci p (And_aci qs) = And_aci ({\|p\|} \|\<union>\| qs)"
	+\| "and_aci p q = (if p = q then p else And_aci {\|p,q\|})"
	+
	+lemma eval_and_aci [simp]:
	+ "eval_aci e f g (and_aci p q) \<longleftrightarrow> eval_aci e f g p \<and> eval_aci e f g q"
	+ by (cases "(p, q)" rule: and_aci.cases) (simp_all add: fBall_funion, meson+)
	+
	+declare and_aci.simps [simp del]
	+
	+text \<open>smart constructor: disjunction\<close>
	+
	+fun or_aci where
	+ "or_aci TT_aci _ = TT_aci"
	+\| "or_aci _ TT_aci = TT_aci"
	+\| "or_aci FF_aci q = q"
	+\| "or_aci p FF_aci = p"
	+\| "or_aci (Or_aci ps) (Or_aci qs) = Or_aci (ps \|\<union>\| qs)"
	+\| "or_aci (Or_aci ps) q = Or_aci (ps \|\<union>\| {\|q\|})"
	+\| "or_aci p (Or_aci qs) = Or_aci ({\|p\|} \|\<union>\| qs)"
	+\| "or_aci p q = (if p = q then p else Or_aci {\|p,q\|})"
	+
	+lemma eval_or_aci [simp]:
	+ "eval_aci e f g (or_aci p q) \<longleftrightarrow> eval_aci e f g p \<or> eval_aci e f g q"
	+ by (cases "(p, q)" rule: or_aci.cases) (simp_all add: fBex_funion, meson+)
	+
	+declare or_aci.simps [simp del]
	+
	+text \<open>convert negation normal form to ACIU01 normal form\<close>
	+
	+fun nnf_to_aci :: "('a, 'b) form \<Rightarrow> ('a, 'b) form_aci" where
	+ "nnf_to_aci FF = FF_aci"
	+\| "nnf_to_aci TT = TT_aci"
	+\| "nnf_to_aci (Pred b ts) = Pred_aci True b ts"
	+\| "nnf_to_aci (Neg (Pred b ts)) = Pred_aci False b ts"
	+\| "nnf_to_aci (And p q) = and_aci (nnf_to_aci p) (nnf_to_aci q)"
	+\| "nnf_to_aci (Or p q) = or_aci (nnf_to_aci p) (nnf_to_aci q)"
	+\| "nnf_to_aci (Forall p) = Forall_aci (nnf_to_aci p)"
	+\| "nnf_to_aci (Exists p) = Exists_aci (nnf_to_aci p)"
	+\| "nnf_to_aci _ = undefined" (* the remaining cases are impossible for NNFs *)
	+
	+lemma eval_nnf_to_aci:
	+ "is_nnf p \<Longrightarrow> eval_aci e f g (nnf_to_aci p) \<longleftrightarrow> eval e f g p"
	+ by (induct p arbitrary: e rule: is_nnf.induct) simp_all
	+
	+
	+subsection \<open>A (mostly) Propositional Equivalence Check\<close>
	+
	+text \<open>We reason modulo $\forall = \neg\exists\neg$, de Morgan, double negation, and
	+ ACUI01 of $\vee$ and $\wedge$, by converting to negation normal form, and then collapsing
	+ conjunctions and disjunctions taking units, absorption, commutativity, associativity, and
	+ idempotence into account. We only need soundness for a certifier.\<close>
	+
	+lemma check_equivalence_by_nnf_aci:
	+ "nnf_to_aci (nnf p) = nnf_to_aci (nnf q) \<Longrightarrow> eval e f g p \<longleftrightarrow> eval e f g q"
	+ by (metis eval_nnf_to_aci is_nnf_nnf' eval_nnf')
	+
	+
	+subsection \<open>Reasoning modulo ACI01\<close>
	+
	+datatype ('a, 'b) form_list_aci
	+ = TT_aci
	+ \| FF_aci
	+ \| Pred_aci bool 'b "'a term list"
	+ \| And_aci "('a, 'b) form_list_aci list"
	+ \| Or_aci "('a, 'b) form_list_aci list"
	+ \| Forall_aci "('a, 'b) form_list_aci"
	+ \| Exists_aci "('a, 'b) form_list_aci"
	+
	+text \<open>evaluation, see @{const eval}\<close>
	+
	+fun eval_list_aci :: \<open>(nat \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'c list \<Rightarrow> 'c) \<Rightarrow>
	+ ('b \<Rightarrow> 'c list \<Rightarrow> bool) \<Rightarrow> ('a, 'b) form_list_aci \<Rightarrow> bool\<close> where
	+ "eval_list_aci e f g FF_aci \<longleftrightarrow> False"
	+\| "eval_list_aci e f g TT_aci \<longleftrightarrow> True"
	+\| "eval_list_aci e f g (Pred_aci b a ts) \<longleftrightarrow> (g a (evalts e f ts) \<longleftrightarrow> b)"
	+\| "eval_list_aci e f g (And_aci ps) \<longleftrightarrow> list_all (\<lambda> fm. eval_list_aci e f g fm) ps"
	+\| "eval_list_aci e f g (Or_aci ps) \<longleftrightarrow> list_ex (\<lambda> fm. eval_list_aci e f g fm) ps"
	+\| "eval_list_aci e f g (Forall_aci p) \<longleftrightarrow> (\<forall>z. eval_list_aci (e\<langle>0:z\<rangle>) f g p)"
	+\| "eval_list_aci e f g (Exists_aci p) \<longleftrightarrow> (\<exists>z. eval_list_aci (e\<langle>0:z\<rangle>) f g p)"
	+
	+text \<open>smart constructor: conjunction\<close>
	+
	+fun and_list_aci where
	+ "and_list_aci FF_aci _ = FF_aci"
	+\| "and_list_aci _ FF_aci = FF_aci"
	+\| "and_list_aci TT_aci q = q"
	+\| "and_list_aci p TT_aci = p"
	+\| "and_list_aci (And_aci ps) (And_aci qs) = And_aci (remdups (ps @ qs))"
	+\| "and_list_aci (And_aci ps) q = And_aci (List.insert q ps)"
	+\| "and_list_aci p (And_aci qs) = And_aci (List.insert p qs)"
	+\| "and_list_aci p q = (if p = q then p else And_aci [p,q])"
	+
	+lemma eval_and_list_aci [simp]:
	+ "eval_list_aci e f g (and_list_aci p q) \<longleftrightarrow> eval_list_aci e f g p \<and> eval_list_aci e f g q"
	+ apply (cases "(p, q)" rule: and_list_aci.cases)
	+ apply (simp_all add: list.pred_set list_ex_iff)
	+ apply blast+
	+ done
	+
	+declare and_list_aci.simps [simp del]
	+
	+text \<open>smart constructor: disjunction\<close>
	+
	+fun or_list_aci where
	+ "or_list_aci TT_aci _ = TT_aci"
	+\| "or_list_aci _ TT_aci = TT_aci"
	+\| "or_list_aci FF_aci q = q"
	+\| "or_list_aci p FF_aci = p"
	+\| "or_list_aci (Or_aci ps) (Or_aci qs) = Or_aci (remdups (ps @ qs))"
	+\| "or_list_aci (Or_aci ps) q = Or_aci (List.insert q ps)"
	+\| "or_list_aci p (Or_aci qs) = Or_aci (List.insert p qs)"
	+\| "or_list_aci p q = (if p = q then p else Or_aci [p,q])"
	+
	+lemma eval_or_list_aci [simp]:
	+ "eval_list_aci e f g (or_list_aci p q) \<longleftrightarrow> eval_list_aci e f g p \<or> eval_list_aci e f g q"
	+ by (cases "(p, q)" rule: or_list_aci.cases) (simp_all add: list.pred_set list_ex_iff, blast+)
	+
	+declare or_list_aci.simps [simp del]
	+
	+text \<open>convert negation normal form to ACIU01 normal form\<close>
	+
	+fun nnf_to_list_aci :: "('a, 'b) form \<Rightarrow> ('a, 'b) form_list_aci" where
	+ "nnf_to_list_aci FF = FF_aci"
	+\| "nnf_to_list_aci TT = TT_aci"
	+\| "nnf_to_list_aci (Pred b ts) = Pred_aci True b ts"
	+\| "nnf_to_list_aci (Neg (Pred b ts)) = Pred_aci False b ts"
	+\| "nnf_to_list_aci (And p q) = and_list_aci (nnf_to_list_aci p) (nnf_to_list_aci q)"
	+\| "nnf_to_list_aci (Or p q) = or_list_aci (nnf_to_list_aci p) (nnf_to_list_aci q)"
	+\| "nnf_to_list_aci (Forall p) = Forall_aci (nnf_to_list_aci p)"
	+\| "nnf_to_list_aci (Exists p) = Exists_aci (nnf_to_list_aci p)"
	+\| "nnf_to_list_aci _ = undefined" (* the remaining cases are impossible for NNFs *)
	+
	+lemma eval_nnf_to_list_aci:
	+ "is_nnf p \<Longrightarrow> eval_list_aci e f g (nnf_to_list_aci p) \<longleftrightarrow> eval e f g p"
	+ by (induct p arbitrary: e rule: is_nnf.induct) simp_all
	+
	+subsection \<open>A (mostly) Propositional Equivalence Check\<close>
	+
	+text \<open>We reason modulo $\forall = \neg\exists\neg$, de Morgan, double negation, and
	+ ACUI01 of $\vee$ and $\wedge$, by converting to negation normal form, and then collapsing
	+ conjunctions and disjunctions taking units, absorption, commutativity, associativity, and
	+ idempotence into account. We only need soundness for a certifier.\<close>
	+
	+derive linorder "term"
	+derive compare "term"
	+derive linorder form_list_aci
	+derive compare form_list_aci
	+
	+fun ord_form_list_aci where
	+ "ord_form_list_aci TT_aci = TT_aci"
	+\| "ord_form_list_aci FF_aci = FF_aci"
	+\| "ord_form_list_aci (Pred_aci bool b ts) = Pred_aci bool b ts"
	+\| "ord_form_list_aci (And_aci fm) = (And_aci (sort (map ord_form_list_aci fm)))"
	+\| "ord_form_list_aci (Or_aci fm) = (Or_aci (sort (map ord_form_list_aci fm)))"
	+\| "ord_form_list_aci (Forall_aci fm) = (Forall_aci (ord_form_list_aci fm))"
	+\| "ord_form_list_aci (Exists_aci fm) = Exists_aci (ord_form_list_aci fm)"
	+
	+lemma and_list_aci_simps:
	+ "and_list_aci TT_aci q = q"
	+ "and_list_aci q FF_aci = FF_aci"
	+ by (cases q, auto simp add: and_list_aci.simps)+
	+
	+lemma ord_form_list_idemp:
	+ "ord_form_list_aci (ord_form_list_aci q) = ord_form_list_aci q"
	+ apply (induct q) apply (auto simp: list.set_map)
	+ apply (smt imageE list.set_map map_idI set_sort sorted_sort_id sorted_sort_key)+
	+ done
	+
	+lemma eval_lsit_aci_ord_form_list_aci:
	+ "eval_list_aci e f g (ord_form_list_aci p) \<longleftrightarrow> eval_list_aci e f g p"
	+ by (induct p arbitrary: e) (auto simp: list.pred_set list_ex_iff)
	+
	+lemma check_equivalence_by_nnf_sortedlist_aci:
	+ "ord_form_list_aci (nnf_to_list_aci (nnf p)) = ord_form_list_aci (nnf_to_list_aci (nnf q)) \<Longrightarrow> eval e f g p \<longleftrightarrow> eval e f g q"
	+ by (metis eval_nnf_to_list_aci eval_lsit_aci_ord_form_list_aci is_nnf_nnf' eval_nnf')
	+
	+hide_type (open) "term"
	+hide_const (open) Var
	+hide_type (open) ctxt
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/FOR_Certificate.thy b/thys/FO_Theory_Rewriting/FOR_Certificate.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/FOR_Certificate.thy
	@@ -0,0 +1,183 @@
	+theory FOR_Certificate
	+ imports Rewriting
	+begin
	+
	+section \<open>Certificate syntax and type declarations\<close>
	+
	+type_alias fvar = nat \<comment> \<open>variable id\<close>
	+datatype ftrs = Fwd nat \| Bwd nat \<comment> \<open>TRS id and direction\<close>
	+
	+definition map_ftrs where
	+ "map_ftrs f = case_ftrs (Fwd \<circ> f) (Bwd \<circ> f)"
	+
	+subsection \<open>GTT relations\<close>
	+
	+(* note: the 'trs will always be trs, but this way we get map functions for free *)
	+
	+datatype 'trs gtt_rel \<comment> \<open>GTT relations\<close>
	+ = ARoot "'trs list" \<comment> \<open>root steps\<close>
	+ \| GInv "'trs gtt_rel" \<comment> \<open>inverse of anchored or ordinary GTT relation\<close>
	+ \| AUnion "'trs gtt_rel" "'trs gtt_rel" \<comment> \<open>union of anchored GTT relation\<close>
	+ \| ATrancl "'trs gtt_rel" \<comment> \<open>transitive closure of anchored GTT relation\<close>
	+ \| GTrancl "'trs gtt_rel" \<comment> \<open>transitive closure of ordinary GTT relation\<close>
	+ \| AComp "'trs gtt_rel" "'trs gtt_rel" \<comment> \<open>composition of anchored GTT relations\<close>
	+ \| GComp "'trs gtt_rel" "'trs gtt_rel" \<comment> \<open>composition of ordinary GTT relations\<close>
	+
	+(* derived constructs *)
	+definition GSteps where "GSteps trss = GTrancl (ARoot trss)"
	+
	+
	+subsection \<open>RR1 and RR2 relations\<close>
	+
	+datatype pos_step \<comment> \<open>position specification for lifting anchored GTT relation\<close>
	+ = PRoot \<comment> \<open>allow only root steps\<close>
	+ \| PNonRoot \<comment> \<open>allow only non-root steps\<close>
	+ \| PAny \<comment> \<open>allow any position\<close>
	+
	+datatype ext_step \<comment> \<open>kind of rewrite steps for lifting anchored GTT relation\<close>
	+ = ESingle \<comment> \<open>single steps\<close>
	+ \| EParallel \<comment> \<open>parallel steps, allowing the empty step\<close>
	+ \| EStrictParallel \<comment> \<open>parallel steps, no allowing the empty step\<close>
	+
	+datatype 'trs rr1_rel \<comment> \<open>RR1 relations, aka regular tree languages\<close>
	+ = R1Terms \<comment> \<open>all terms as RR1 relation (regular tree languages)\<close>
	+ \| R1NF "'trs list" \<comment> \<open>direct normal form construction wrt. single steps\<close>
	+ \| R1Inf "'trs rr2_rel" \<comment> \<open>infiniteness predicate\<close>
	+ \| R1Proj nat "'trs rr2_rel" \<comment> \<open>projection of RR2 relation\<close>
	+ \| R1Union "'trs rr1_rel" "'trs rr1_rel" \<comment> \<open>union of RR1 relations\<close>
	+ \| R1Inter "'trs rr1_rel" "'trs rr1_rel" \<comment> \<open>intersection of RR1 relations\<close>
	+ \| R1Diff "'trs rr1_rel" "'trs rr1_rel" \<comment> \<open>difference of RR1 relations\<close>
	+and 'trs rr2_rel \<comment> \<open>RR2 relations\<close>
	+ = R2GTT_Rel "'trs gtt_rel" pos_step ext_step \<comment> \<open>lifted GTT relations\<close>
	+ \| R2Diag "'trs rr1_rel" \<comment> \<open>diagonal relation\<close>
	+ \| R2Prod "'trs rr1_rel" "'trs rr1_rel" \<comment> \<open>Cartesian product\<close>
	+ \| R2Inv "'trs rr2_rel" \<comment> \<open>inverse of RR2 relation\<close>
	+ \| R2Union "'trs rr2_rel" "'trs rr2_rel" \<comment> \<open>union of RR2 relations\<close>
	+ \| R2Inter "'trs rr2_rel" "'trs rr2_rel" \<comment> \<open>intersection of RR2 relations\<close>
	+ \| R2Diff "'trs rr2_rel" "'trs rr2_rel" \<comment> \<open>difference of RR2 relations\<close>
	+ \| R2Comp "'trs rr2_rel" "'trs rr2_rel" \<comment> \<open>composition of RR2 relations\<close>
	+
	+(* derived constructs *)
	+definition R1Fin where \<comment> \<open>finiteness predicate\<close>
	+ "R1Fin r = R1Diff R1Terms (R1Inf r)"
	+definition R2Eq where \<comment> \<open>equality\<close>
	+ "R2Eq = R2Diag R1Terms"
	+definition R2Reflc where \<comment> \<open>reflexive closure\<close>
	+ "R2Reflc r = R2Union r R2Eq"
	+definition R2Step where \<comment> \<open>single step $\to$\<close>
	+ "R2Step trss = R2GTT_Rel (ARoot trss) PAny ESingle"
	+definition R2StepEq where \<comment> \<open>at most one step $\to^=$\<close>
	+ "R2StepEq trss = R2Reflc (R2Step trss)"
	+definition R2Steps where \<comment> \<open>at least one step $\to^+$\<close>
	+ "R2Steps trss = R2GTT_Rel (GSteps trss) PAny EStrictParallel"
	+definition R2StepsEq where \<comment> \<open>many steps $\to^*$\<close>
	+ "R2StepsEq trss = R2GTT_Rel (GSteps trss) PAny EParallel"
	+definition R2StepsNF where \<comment> \<open>rewrite to normal form $\to^!$\<close>
	+ "R2StepsNF trss = R2Inter (R2StepsEq trss) (R2Prod R1Terms (R1NF trss))"
	+definition R2ParStep where \<comment> \<open>parallel step\<close>
	+ "R2ParStep trss = R2GTT_Rel (ARoot trss) PAny EParallel"
	+definition R2RootStep where \<comment> \<open>root step $\to_\epsilon$\<close>
	+ "R2RootStep trss = R2GTT_Rel (ARoot trss) PRoot ESingle"
	+definition R2RootStepEq where \<comment> \<open>at most one root step $\to_\epsilon^=$\<close>
	+ "R2RootStepEq trss = R2Reflc (R2RootStep trss)"
	+ (* alternatively R2GTT_Rel (ARoot trss) PRoot SParallel *)
	+definition R2RootSteps where \<comment> \<open>at least one root step $\to_\epsilon^+$\<close>
	+ "R2RootSteps trss = R2GTT_Rel (ATrancl (ARoot trss)) PRoot ESingle"
	+definition R2RootStepsEq where \<comment> \<open>many root steps $\to_\epsilon^*$\<close>
	+ "R2RootStepsEq trss = R2Reflc (R2RootSteps trss)"
	+definition R2NonRootStep where \<comment> \<open>non-root step $\to_{>\epsilon}$\<close>
	+ "R2NonRootStep trss = R2GTT_Rel (ARoot trss) PNonRoot ESingle"
	+definition R2NonRootStepEq where \<comment> \<open>at most one non-root step $\to_{>\epsilon}^=$\<close>
	+ "R2NonRootStepEq trss = R2Reflc (R2NonRootStep trss)"
	+definition R2NonRootSteps where \<comment> \<open>at least one non-root step $\to_{>\epsilon}^+$\<close>
	+ "R2NonRootSteps trss = R2GTT_Rel (GSteps trss) PNonRoot EStrictParallel"
	+definition R2NonRootStepsEq where \<comment> \<open>many non-root steps $\to_{>\epsilon}^*$\<close>
	+ "R2NonRootStepsEq trss = R2GTT_Rel (GSteps trss) PNonRoot EParallel"
	+definition R2Meet where \<comment> \<open>meet $\uparrow$\<close>
	+ "R2Meet trss = R2GTT_Rel (GComp (GInv (GSteps trss)) (GSteps trss)) PAny EParallel"
	+definition R2Join where \<comment> \<open>join $\downarrow$\<close>
	+ "R2Join trss = R2GTT_Rel (GComp (GSteps trss) (GInv (GSteps trss))) PAny EParallel"
	+
	+
	+subsection \<open>Formulas\<close>
	+
	+datatype 'trs formula \<comment> \<open>formulas\<close>
	+ = FRR1 "'trs rr1_rel" fvar \<comment> \<open>application of RR1 relation\<close>
	+ \| FRR2 "'trs rr2_rel" fvar fvar \<comment> \<open>application of RR2 relation\<close>
	+ \| FAnd "('trs formula) list" \<comment> \<open>conjunction\<close>
	+ \| FOr "('trs formula) list" \<comment> \<open>disjunction\<close>
	+ \| FNot "'trs formula" \<comment> \<open>negation\<close>
	+ \| FExists "'trs formula" \<comment> \<open>existential quantification\<close>
	+ \| FForall "'trs formula" \<comment> \<open>universal quantification\<close>
	+
	+(* derived constructs *)
	+definition FTrue where \<comment> \<open>true\<close>
	+ "FTrue \<equiv> FAnd []"
	+definition FFalse where \<comment> \<open>false\<close>
	+ "FFalse \<equiv> FOr []"
	+(* FRestrict can be defined, but we may want to do out of bounds checking later *)
	+definition FRestrict where \<comment> \<open>reorder/rename/restrict TRSs for subformula\<close>
	+ "FRestrict f trss \<equiv> map_formula (map_ftrs (\<lambda>n. if n \<ge> length trss then 0 else trss ! n)) f"
	+
	+
	+subsection \<open>Signatures and Problems\<close>
	+
	+datatype ('f, 'v, 't) many_sorted_sig
	+ = Many_Sorted_Sig (ms_functions: "('f \<times> 't list \<times> 't) list") (ms_variables: "('v \<times> 't) list")
	+
	+datatype ('f, 'v, 't) problem
	+ = Problem (p_signature: "('f, 'v, 't) many_sorted_sig")
	+ (p_trss: "('f, 'v) trs list")
	+ (p_formula: "ftrs formula")
	+
	+
	+subsection \<open>Proofs\<close>
	+
	+datatype equivalence \<comment> \<open>formula equivalences\<close>
	+ = EDistribAndOr \<comment> \<open>distributivity: conjunction over disjunction\<close>
	+ \| EDistribOrAnd \<comment> \<open>distributivity: disjunction over conjunction\<close>
	+
	+datatype 'trs inference \<comment> \<open>inference rules for formula creation\<close>
	+ = IRR1 "'trs rr1_rel" fvar \<comment> \<open>formula from RR1 relation\<close>
	+ \| IRR2 "'trs rr2_rel" fvar fvar \<comment> \<open>formula from RR2 relation\<close>
	+ \| IAnd "nat list" \<comment> \<open>conjunction\<close>
	+ \| IOr "nat list" \<comment> \<open>disjunction\<close>
	+ \| INot nat \<comment> \<open>negation\<close>
	+ \| IExists nat \<comment> \<open>existential quantification\<close>
	+ \| IRename nat "fvar list" \<comment> \<open>permute variables\<close>
	+ \| INNFPlus nat \<comment> \<open>equivalence modulo negation normal form plus ACIU0 for $\land$ and $\lor$\<close>
	+ \| IRepl equivalence "nat list" nat \<comment> \<open>replacement according to given equivalence\<close>
	+
	+datatype claim = Empty \| Nonempty
	+
	+datatype info = Size nat nat nat
	+
	+datatype 'trs certificate
	+ = Certificate "(nat \<times> 'trs inference \<times> 'trs formula \<times> info list) list" claim nat
	+
	+
	+subsection \<open>Example\<close>
	+
	+definition no_normal_forms_cert :: "ftrs certificate" where
	+ "no_normal_forms_cert = Certificate
	+ [ (0, (IRR2 (R2Step [Fwd 0]) 1 0),
	+ (FRR2 (R2Step [Fwd 0]) 1 0), [])
	+ , (1, (IExists 0),
	+ (FExists (FRR2 (R2Step [Fwd 0]) 1 0)), [])
	+ , (2, (INot 1),
	+ (FNot (FExists (FRR2 (R2Step [Fwd 0]) 1 0))), [])
	+ , (3, (IExists 2),
	+ (FExists (FNot (FExists (FRR2 (R2Step [Fwd 0]) 1 0)))), [])
	+ , (4, (INot 3),
	+ (FNot (FExists (FNot (FExists (FRR2 (R2Step [Fwd 0]) 1 0))))), [])
	+ , (5, (INNFPlus 4),
	+ (FForall (FExists (FRR2 (R2Step [Fwd 0]) 1 0))), [])
	+ ] Nonempty 5"
	+
	+definition no_normal_forms_problem :: "(string, string, unit) problem" where
	+ "no_normal_forms_problem = Problem
	+ (Many_Sorted_Sig [(''f'',[()],()), (''a'',[],())] [(''x'',())])
	+ [{(Fun ''f'' [Var ''x''],Fun ''a'' [])}]
	+ (FForall (FExists (FRR2 (R2Step [Fwd 0]) 1 0)))"
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/FOR_Check.thy b/thys/FO_Theory_Rewriting/FOR_Check.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/FOR_Check.thy
	@@ -0,0 +1,1193 @@
	+theory FOR_Check
	+ imports
	+ FOR_Semantics
	+ FOL_Extra
	+ GTT_RRn
	+ First_Order_Terms.Option_Monad
	+ LV_to_GTT
	+ NF
	+ Regular_Tree_Relations.GTT_Transitive_Closure
	+ Regular_Tree_Relations.AGTT
	+ Regular_Tree_Relations.RR2_Infinite_Q_infinity
	+ Regular_Tree_Relations.RRn_Automata
	+begin
	+
	+section \<open>Check inference steps\<close>
	+
	+type_synonym ('f, 'v) fin_trs = "('f, 'v) rule fset"
	+
	+lemma tl_drop_conv:
	+ "tl xs = drop 1 xs"
	+ by (induct xs) auto
	+
	+definition rrn_drop_fst where
	+ "rrn_drop_fst \<A> = relabel_reg (trim_reg (collapse_automaton_reg (fmap_funs_reg (drop_none_rule 1) (trim_reg \<A>))))"
	+
	+lemma rrn_drop_fst_lang:
	+ assumes "RRn_spec n A T" "1 < n"
	+ shows "RRn_spec (n - 1) (rrn_drop_fst A) (drop 1 ` T)"
	+ using drop_automaton_reg[OF _ assms(2), of "trim_reg A" T] assms(1)
	+ unfolding rrn_drop_fst_def
	+ by (auto simp: trim_ta_reach)
	+
	+
	+definition liftO1 :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a option \<Rightarrow> 'b option" where
	+ "liftO1 = map_option"
	+
	+definition liftO2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> 'c option" where
	+ "liftO2 f a b = case_option None (\<lambda>a'. liftO1 (f a') b) a"
	+
	+lemma liftO1_Some [simp]:
	+ "liftO1 f x = Some y \<longleftrightarrow> (\<exists>x'. x = Some x') \<and> y = f (the x)"
	+ by (cases x) (auto simp: liftO1_def)
	+
	+lemma liftO2_Some [simp]:
	+ "liftO2 f x y = Some z \<longleftrightarrow> (\<exists>x' y'. x = Some x' \<and> y = Some y') \<and> z = f (the x) (the y)"
	+ by (cases x; cases y) (auto simp: liftO2_def)
	+
	+subsection \<open>Computing TRSs\<close>
	+
	+lemma is_to_trs_props:
	+ assumes "\<forall> R \<in> set Rs. finite R \<and> lv_trs R \<and> funas_trs R \<subseteq> \<F>" "\<forall>i \<in> set is. case_ftrs id id i < length Rs"
	+ shows "funas_trs (is_to_trs Rs is) \<subseteq> \<F>" "lv_trs (is_to_trs Rs is)" "finite (is_to_trs Rs is)"
	+proof (goal_cases \<F> lv fin)
	+ case \<F> show ?case using assms nth_mem
	+ apply (auto simp: is_to_trs_def funas_trs_def case_prod_beta split: ftrs.splits)
	+ apply fastforce
	+ apply (metis (no_types, lifting) assms(1) in_mono rhs_wf)
	+ apply (metis (no_types, lifting) assms(1) in_mono rhs_wf)
	+ by (smt (z3) UN_subset_iff fst_conv in_mono le_sup_iff)
	+qed (insert assms, (fastforce simp: is_to_trs_def funas_trs_def lv_trs_def split: ftrs.splits)+)
	+
	+
	+definition is_to_fin_trs :: "('f, 'v) fin_trs list \<Rightarrow> ftrs list \<Rightarrow> ('f, 'v) fin_trs" where
	+ "is_to_fin_trs Rs is = \|\<Union>\| (fset_of_list (map (case_ftrs ((!) Rs) ((\|`\|) prod.swap \<circ> (!) Rs)) is))"
	+
	+
	+lemma is_to_fin_trs_conv:
	+ assumes "\<forall>i \<in> set is. case_ftrs id id i < length Rs"
	+ shows "is_to_trs (map fset Rs) is = fset (is_to_fin_trs Rs is)"
	+ using assms unfolding is_to_trs_def is_to_fin_trs_def
	+ by (auto simp: ffUnion.rep_eq fset_of_list.rep_eq split: ftrs.splits)
	+
	+definition is_to_trs' :: "('f, 'v) fin_trs list \<Rightarrow> ftrs list \<Rightarrow> ('f, 'v) fin_trs option" where
	+ "is_to_trs' Rs is = do {
	+ guard (\<forall>i \<in> set is. case_ftrs id id i < length Rs);
	+ Some (is_to_fin_trs Rs is)
	+ }"
	+
	+lemma is_to_trs_conv:
	+ "is_to_trs' Rs is = Some S \<Longrightarrow> is_to_trs (map fset Rs) is = fset S"
	+ using is_to_fin_trs_conv unfolding is_to_trs'_def
	+ by (auto simp add: guard_simps split: bind_splits)
	+
	+lemma is_to_trs'_props:
	+ assumes "\<forall> R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>" and "is_to_trs' Rs is = Some S"
	+ shows "ffunas_trs S \|\<subseteq>\| \<F>" "lv_trs (fset S)"
	+proof -
	+ from assms(2) have well: "\<forall>i \<in> set is. case_ftrs id id i < length Rs" "is_to_fin_trs Rs is = S"
	+ unfolding is_to_trs'_def
	+ by (auto simp add: guard_simps split: bind_splits)
	+ have "\<forall> R \<in> set Rs. finite (fset R) \<and> lv_trs (fset R) \<and> funas_trs (fset R) \<subseteq> (fset \<F>)"
	+ using assms(1) by (auto simp: ffunas_trs.rep_eq less_eq_fset.rep_eq)
	+ from is_to_trs_props[of "map fset Rs" "fset \<F>" "is"] this well(1)
	+ have "lv_trs (is_to_trs (map fset Rs) is)" "funas_trs (is_to_trs (map fset Rs) is) \<subseteq> fset \<F>"
	+ by auto
	+ then show "lv_trs (fset S)" "ffunas_trs S \|\<subseteq>\| \<F>"
	+ using is_to_fin_trs_conv[OF well(1)] unfolding well(2)
	+ by (auto simp: ffunas_trs.rep_eq less_eq_fset.rep_eq)
	+qed
	+
	+subsection \<open>Computing GTTs\<close>
	+
	+fun gtt_of_gtt_rel :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs gtt_rel \<Rightarrow> (nat, 'f) gtt option" where
	+ "gtt_of_gtt_rel \<F> Rs (ARoot is) = liftO1 (\<lambda>R. relabel_gtt (agtt_grrstep R \<F>)) (is_to_trs' Rs is)"
	+\| "gtt_of_gtt_rel \<F> Rs (GInv g) = liftO1 prod.swap (gtt_of_gtt_rel \<F> Rs g)"
	+\| "gtt_of_gtt_rel \<F> Rs (AUnion g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_union' g1 g2)) (gtt_of_gtt_rel \<F> Rs g1) (gtt_of_gtt_rel \<F> Rs g2)"
	+\| "gtt_of_gtt_rel \<F> Rs (ATrancl g) = liftO1 (relabel_gtt \<circ> AGTT_trancl) (gtt_of_gtt_rel \<F> Rs g)"
	+\| "gtt_of_gtt_rel \<F> Rs (GTrancl g) = liftO1 GTT_trancl (gtt_of_gtt_rel \<F> Rs g)"
	+\| "gtt_of_gtt_rel \<F> Rs (AComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_comp' g1 g2)) (gtt_of_gtt_rel \<F> Rs g1) (gtt_of_gtt_rel \<F> Rs g2)"
	+\| "gtt_of_gtt_rel \<F> Rs (GComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (GTT_comp' g1 g2)) (gtt_of_gtt_rel \<F> Rs g1) (gtt_of_gtt_rel \<F> Rs g2)"
	+
	+
	+lemma gtt_of_gtt_rel_correct:
	+ assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>"
	+ shows "gtt_of_gtt_rel \<F> Rs g = Some g' \<Longrightarrow> agtt_lang g' = eval_gtt_rel (fset \<F>) (map fset Rs) g"
	+proof (induct g arbitrary: g')
	+ note [simp] = bind_eq_Some_conv guard_simps
	+ have proj_sq: "fst ` (X \<times> X) = X" "snd ` (X \<times> X) = X" for X by auto
	+{
	+ case (ARoot "is")
	+ then obtain w where w:"is_to_trs' Rs is = Some w" by auto
	+ then show ?case using ARoot is_to_trs'_props[OF assms w] is_to_trs_conv[OF w]
	+ using agtt_grrstep
	+ by auto
	+next
	+ case (GInv g) then show ?case by (simp add: agtt_lang_swap gtt_states_def)
	+next
	+ case (AUnion g1 g2)
	+ from AUnion(3)[simplified, THEN conjunct1] AUnion(3)[simplified, THEN conjunct2, THEN conjunct1]
	+ obtain w1 w2 where
	+ [simp]: "gtt_of_gtt_rel \<F> Rs g1 = Some w1" "gtt_of_gtt_rel \<F> Rs g2 = Some w2"
	+ by blast
	+ then show ?case using AUnion(3)
	+ by (simp add: AGTT_union'_sound AUnion)
	+next
	+ case (ATrancl g)
	+ from ATrancl[simplified] obtain w1 where
	+ [simp]: "gtt_of_gtt_rel \<F> Rs g = Some w1" "g' = relabel_gtt (AGTT_trancl w1)" by auto
	+ then have fin_lang: "eval_gtt_rel (fset \<F>) (map fset Rs) g = agtt_lang w1"
	+ using ATrancl by auto
	+ from fin_lang show ?case using AGTT_trancl_sound[of w1]
	+ by auto
	+next
	+ case (GTrancl g) note * = GTrancl(2)[simplified, THEN conjunct2]
	+ show ?case unfolding gtt_of_gtt_rel.simps GTT_trancl_alang * gtrancl_rel_def eval_gtt_rel.simps gmctxt_cl_gmctxtex_onp_conv
	+ proof ((intro conjI equalityI subrelI; (elim relcompE)?), goal_cases LR RL)
	+ case (LR _ _ s _ z s' t' t)
	+ show ?case using lift_root_steps_sig_transfer'[OF LR(2)[folded lift_root_step.simps], of "fset \<F>"]
	+ lift_root_steps_sig_transfer[OF LR(5)[folded lift_root_step.simps], of "fset \<F>"]
	+ image_mono[OF eval_gtt_rel_sig[of "fset \<F>" "map fset Rs" g], of fst, unfolded proj_sq]
	+ image_mono[OF eval_gtt_rel_sig[of "fset \<F>" "map fset Rs" g], of snd, unfolded proj_sq]
	+ subsetD[OF eval_gtt_rel_sig[of "fset \<F>" "map fset Rs" g]] LR(1, 3, 4) GTrancl
	+ by (intro relcompI[OF _ relcompI, of _ s' _ t' _])
	+ (auto simp: \<T>\<^sub>G_funas_gterm_conv lift_root_step.simps)
	+ next
	+ case (RL _ _ s _ z s' t' t)
	+ then show ?case using GTrancl
	+ lift_root_step_mono[of "fset \<F>" UNIV PAny ESingle "eval_gtt_rel (fset \<F>) (map fset Rs) g", THEN rtrancl_mono]
	+ unfolding lift_root_step.simps[symmetric]
	+ by (intro relcompI[OF _ relcompI, of _ s' _ t' _])
	+ (auto simp: \<T>\<^sub>G_funas_gterm_conv lift_root_step_mono trancl_mono)
	+ qed
	+next
	+ case (AComp g1 g2)
	+ from AComp[simplified] obtain w1 w2 where
	+ [simp]: "gtt_of_gtt_rel \<F> Rs g1 = Some w1" "gtt_of_gtt_rel \<F> Rs g2 = Some w2"
	+ "g' = relabel_gtt (AGTT_comp' w1 w2)" by auto
	+ then have fin_lang: "eval_gtt_rel (fset \<F>) (map fset Rs) g1 = agtt_lang w1"
	+ "eval_gtt_rel (fset \<F>) (map fset Rs) g2 = agtt_lang w2"
	+ using AComp by auto
	+ from fin_lang AGTT_comp'_sound[of w1 w2]
	+ show ?case by simp
	+next
	+ case (GComp g1 g2)
	+ let ?r = "\<lambda> g. eval_gtt_rel (fset \<F>) (map fset Rs) g"
	+ have *: "gmctxtex_onp (\<lambda>C. True) (?r g1) = lift_root_step UNIV PAny EParallel (?r g1)"
	+ "gmctxtex_onp (\<lambda>C. True) (?r g2) = lift_root_step UNIV PAny EParallel (?r g2)"
	+ by (auto simp: lift_root_step.simps)
	+ show ?case using GComp(3)
	+ apply (intro conjI equalityI subrelI; simp add: gmctxt_cl_gmctxtex_onp_conv GComp(1,2) gtt_comp'_alang gcomp_rel_def * flip: lift_root_step.simps; elim conjE disjE exE relcompE)
	+ subgoal for s t _ _ _ _ _ u
	+ using image_mono[OF eval_gtt_rel_sig, of snd "fset \<F>" "map fset Rs", unfolded proj_sq]
	+ apply (subst relcompI[of _ u "eval_gtt_rel _ _ g1", OF _ lift_root_step_sig_transfer[of _ UNIV PAny EParallel "_ g2" "fset \<F>"]])
	+ apply (force simp add: subsetI \<T>\<^sub>G_equivalent_def)+
	+ done
	+ subgoal for s t _ _ _ _ _ u
	+ using image_mono[OF eval_gtt_rel_sig, of fst "fset \<F>" "map fset Rs", unfolded proj_sq]
	+ apply (subst relcompI[of _ u _ _ "eval_gtt_rel _ _ g2", OF lift_root_step_sig_transfer'[of _ UNIV PAny EParallel "_ g1" "fset \<F>"]])
	+ apply (force simp add: subsetI \<T>\<^sub>G_equivalent_def)+
	+ done
	+ by (auto intro: subsetD[OF lift_root_step_mono[of "fset \<F>" UNIV]])
	+}
	+qed
	+
	+
	+subsection \<open>Computing RR1 and RR2 relations\<close>
	+
	+definition "simplify_reg \<A> = (relabel_reg (trim_reg \<A>))"
	+
	+lemma \<L>_simplify_reg [simp]: "\<L> (simplify_reg \<A>) = \<L> \<A>"
	+ by (simp add: simplify_reg_def \<L>_trim)
	+
	+lemma RR1_spec_simplify_reg[simp]:
	+ "RR1_spec (simplify_reg \<A>) R = RR1_spec \<A> R"
	+ by (auto simp: RR1_spec_def)
	+lemma RR2_spec_simplify_reg[simp]:
	+ "RR2_spec (simplify_reg \<A>) R = RR2_spec \<A> R"
	+ by (auto simp: RR2_spec_def)
	+lemma RRn_spec_simplify_reg[simp]:
	+ "RRn_spec n (simplify_reg \<A>) R = RRn_spec n \<A> R"
	+ by (auto simp: RRn_spec_def)
	+
	+lemma RR1_spec_eps_free_reg[simp]:
	+ "RR1_spec (eps_free_reg \<A>) R = RR1_spec \<A> R"
	+ by (auto simp: RR1_spec_def \<L>_eps_free)
	+lemma RR2_spec_eps_free_reg[simp]:
	+ "RR2_spec (eps_free_reg \<A>) R = RR2_spec \<A> R"
	+ by (auto simp: RR2_spec_def \<L>_eps_free)
	+lemma RRn_spec_eps_free_reg[simp]:
	+ "RRn_spec n (eps_free_reg \<A>) R = RRn_spec n \<A> R"
	+ by (auto simp: RRn_spec_def \<L>_eps_free)
	+
	+fun rr1_of_rr1_rel :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> (nat, 'f) reg option"
	+and rr2_of_rr2_rel :: "('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> (nat, 'f option \<times> 'f option) reg option" where
	+ "rr1_of_rr1_rel \<F> Rs R1Terms = Some (relabel_reg (term_reg \<F>))"
	+\| "rr1_of_rr1_rel \<F> Rs (R1NF is) = liftO1 (\<lambda>R. (simplify_reg (nf_reg (fst \|`\| R) \<F>))) (is_to_trs' Rs is)"
	+\| "rr1_of_rr1_rel \<F> Rs (R1Inf r) = liftO1 (\<lambda>R.
	+ let \<A> = trim_reg R in
	+ simplify_reg (proj_1_reg (Inf_reg_impl \<A>))
	+ ) (rr2_of_rr2_rel \<F> Rs r)"
	+\| "rr1_of_rr1_rel \<F> Rs (R1Proj i r) = (case i of 0 \<Rightarrow>
	+ liftO1 (trim_reg \<circ> proj_1_reg) (rr2_of_rr2_rel \<F> Rs r)
	+ \| _ \<Rightarrow> liftO1 (trim_reg \<circ> proj_2_reg) (rr2_of_rr2_rel \<F> Rs r))"
	+\| "rr1_of_rr1_rel \<F> Rs (R1Union s1 s2) =
	+ liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
	+\| "rr1_of_rr1_rel \<F> Rs (R1Inter s1 s2) =
	+ liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
	+\| "rr1_of_rr1_rel \<F> Rs (R1Diff s1 s2) = liftO2 (\<lambda> x y. relabel_reg (trim_reg (difference_reg x y))) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
	+
	+\| "rr2_of_rr2_rel \<F> Rs (R2GTT_Rel g w x) =
	+ (case w of PRoot \<Rightarrow>
	+ (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
	+ \| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> reflcl_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
	+ \| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g))
	+ \| PNonRoot \<Rightarrow>
	+ (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> nhole_ctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
	+ \| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> nhole_mctxt_reflcl_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
	+ \| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> nhole_mctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g))
	+ \| PAny \<Rightarrow>
	+ (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> ctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
	+ \| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> parallel_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
	+ \| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> mctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)))"
	+\| "rr2_of_rr2_rel \<F> Rs (R2Diag s) =
	+ liftO1 (\<lambda> x. fmap_funs_reg (\<lambda>f. (Some f, Some f)) x) (rr1_of_rr1_rel \<F> Rs s)"
	+\| "rr2_of_rr2_rel \<F> Rs (R2Prod s1 s2) =
	+ liftO2 (\<lambda> x y. simplify_reg (pair_automaton_reg x y)) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
	+\| "rr2_of_rr2_rel \<F> Rs (R2Inv r) = liftO1 (fmap_funs_reg prod.swap) (rr2_of_rr2_rel \<F> Rs r)"
	+\| "rr2_of_rr2_rel \<F> Rs (R2Union r1 r2) =
	+ liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
	+\| "rr2_of_rr2_rel \<F> Rs (R2Inter r1 r2) =
	+ liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
	+\| "rr2_of_rr2_rel \<F> Rs (R2Diff r1 r2) = liftO2 (\<lambda> x y. simplify_reg (difference_reg x y)) (rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
	+\| "rr2_of_rr2_rel \<F> Rs (R2Comp r1 r2) = liftO2 (\<lambda> x y. simplify_reg (rr2_compositon \<F> x y))
	+ (rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
	+
	+
	+abbreviation lhss where
	+ "lhss R \<equiv> fst \|`\| R"
	+
	+lemma rr12_of_rr12_rel_correct:
	+ fixes Rs :: "(('f :: linorder, 'v) Term.term \<times> ('f, 'v) Term.term) fset list"
	+ assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>"
	+ shows "\<forall>ta1. rr1_of_rr1_rel \<F> Rs r1 = Some ta1 \<longrightarrow> RR1_spec ta1 (eval_rr1_rel (fset \<F>) (map fset Rs) r1)"
	+ "\<forall>ta2. rr2_of_rr2_rel \<F> Rs r2 = Some ta2 \<longrightarrow> RR2_spec ta2 (eval_rr2_rel (fset \<F>) (map fset Rs) r2)"
	+proof (induct r1 and r2)
	+ note [simp] = bind_eq_Some_conv guard_simps
	+ let ?F = "fset \<F>" let ?Rs = "map fset Rs"
	+{
	+ case R1Terms
	+ then show ?case using term_automaton[of \<F>]
	+ by (simp add: \<T>\<^sub>G_equivalent_def)
	+next
	+ case (R1NF r)
	+ consider (a) "\<exists> R. is_to_trs' Rs r = Some R" \| (b) "is_to_trs' Rs r = None" by auto
	+ then show ?case
	+ proof (cases)
	+ case a
	+ from a obtain R where [simp]: "is_to_trs' Rs r = Some R" "is_to_fin_trs Rs r = R"
	+ by (auto simp: is_to_trs'_def)
	+ from is_to_trs'_props[OF assms this(1)] have inv: "ffunas_trs R \|\<subseteq>\| \<F>" "lv_trs (fset R)" .
	+ from inv have fl: "\<forall> l \|\<in>\| lhss R. linear_term l"
	+ by (auto simp: lv_trs_def fmember.rep_eq split!: prod.splits)
	+ {fix s t assume ass: "(s, t) \<in> grstep (fset R)"
	+ then obtain C l r \<sigma> where step: "(l, r) \|\<in>\| R" "term_of_gterm s = (C :: ('f, 'v) ctxt) \<langle>l \<cdot> \<sigma>\<rangle>" "term_of_gterm t = C\<langle>r \<cdot> \<sigma>\<rangle>"
	+ unfolding grstep_def by (auto simp: fmember.rep_eq dest!: rstep_imp_C_s_r)
	+ from step ta_nf_lang_sound[of l "lhss R" C \<sigma> \<F>]
	+ have "s \<notin> \<L> (nf_reg (lhss R) \<F>)" unfolding \<L>_def
	+ by (metis fimage_eqI fst_conv nf_reg_def reg.sel(1, 2) term_of_gterm_in_ta_lang_conv)}
	+ note mem = this
	+ have funas: "funas_trs (fset R) \<subseteq> ?F" using inv(1)
	+ by (simp add: ffunas_trs.rep_eq less_eq_fset.rep_eq subsetD)
	+ {fix s assume "s \<in> \<L> (nf_reg (lhss R) \<F>)"
	+ then have "s \<in> NF (Restr (grstep (fset R)) (\<T>\<^sub>G (fset \<F>))) \<inter> \<T>\<^sub>G (fset \<F>)"
	+ by (meson IntI NF_I \<T>\<^sub>G_funas_gterm_conv gta_lang_nf_ta_funas inf.cobounded1 mem subset_iff)}
	+ moreover
	+ {fix s assume ass: "s \<in> NF (Restr (grstep (fset R)) (\<T>\<^sub>G (fset \<F>))) \<inter> \<T>\<^sub>G (fset \<F>)"
	+ then have *: "(term_of_gterm s, term_of_gterm t) \<notin> rstep (fset R)" for t using funas
	+ by (auto simp: funas_trs_def grstep_def NF_iff_no_step \<T>\<^sub>G_funas_gterm_conv fmember.rep_eq)
	+ (meson R1NF_reps funas rstep.cases)
	+ then have "s \<in> \<L> (nf_reg (lhss R) \<F>)" using fl ass
	+ using ta_nf_\<L>_complete[OF fl, of _ \<F>] gta_lang_nf_ta_funas[of _ "lhss R" \<F>]
	+ by (smt (verit, ccfv_SIG) IntE R1NF_reps \<T>\<^sub>G_sound fimageE funas notin_fset surjective_pairing)}
	+ ultimately have "\<L> (nf_reg (lhss R) \<F>) = NF (Restr (grstep (fset R)) (\<T>\<^sub>G (fset \<F>))) \<inter> \<T>\<^sub>G (fset \<F>)"
	+ by blast
	+ then show ?thesis using fl(1)
	+ by (simp add: RR1_spec_def is_to_trs_conv)
	+ qed auto
	+next
	+ case (R1Inf r)
	+ consider (a) "\<exists> A. rr2_of_rr2_rel \<F> Rs r = Some A" \| (b) " rr2_of_rr2_rel \<F> Rs r = None" by auto
	+ then show ?case
	+ proof cases
	+ case a
	+ have [simp]: "{u. (t, u) \<in> eval_rr2_rel ?F ?Rs r \<and> funas_gterm u \<subseteq> ?F} =
	+ {u. (t, u) \<in> eval_rr2_rel ?F ?Rs r}" for t
	+ using eval_rr12_rel_sig(2)[of ?F ?Rs r] by (auto simp: \<T>\<^sub>G_equivalent_def)
	+ have [simp]: "infinite {u. (t, u) \<in> eval_rr2_rel ?F ?Rs r} \<Longrightarrow> funas_gterm t \<subseteq> ?F" for t
	+ using eval_rr12_rel_sig(2)[of ?F ?Rs r] not_finite_existsD by (fastforce simp: \<T>\<^sub>G_equivalent_def)
	+ from a obtain A where [simp]: "rr2_of_rr2_rel \<F> Rs r = Some A" by blast
	+ from R1Inf this have spec: "RR2_spec A (eval_rr2_rel ?F ?Rs r)" by auto
	+ then have spec_trim: "RR2_spec (trim_reg A) (eval_rr2_rel ?F ?Rs r)" by auto
	+ let ?B = "(Inf_reg (trim_reg A) (Q_infty (ta (trim_reg A)) \<F>))"
	+ have B: "RR2_spec ?B {(s, t) \| s t. gpair s t \<in> \<L> ?B}"
	+ using subset_trans[OF Inf_automata_subseteq[of "trim_reg A" \<F>], of "\<L> A"] spec
	+ by (auto simp: RR2_spec_def \<L>_trim)
	+ have *: "\<L> (Inf_reg_impl (trim_reg A)) = \<L> ?B" using spec
	+ using eval_rr12_rel_sig(2)[of ?F ?Rs r]
	+ by (intro Inf_reg_impl_sound) (auto simp: \<L>_trim RR2_spec_def \<T>\<^sub>G_equivalent_def)
	+ then have **: "RR2_spec (Inf_reg_impl (trim_reg A)) {(s, t) \| s t. gpair s t \<in> \<L> ?B}" using B
	+ by (auto simp: RR2_spec_def)
	+ show ?thesis
	+ using spec eval_rr12_rel_sig(2)[of ?F ?Rs r]
	+ using \<L>_Inf_reg[OF spec_trim, of \<F>]
	+ by (auto simp: \<T>\<^sub>G_equivalent_def * RR1_spec_def \<L>_trim \<L>_proj(1)[OF **]
	+ Inf_branching_terms_def fImage_singleton)
	+ (metis (no_types, lifting) SigmaD1 in_mono mem_Collect_eq not_finite_existsD)
	+ qed auto
	+next
	+ case (R1Proj i r)
	+ then show ?case
	+ proof (cases i)
	+ case [simp]:0 show ?thesis using R1Proj
	+ using proj_automaton_gta_lang(1)[of "the (rr2_of_rr2_rel \<F> Rs r)" "eval_rr2_rel ?F ?Rs r"]
	+ by simp
	+ next
	+ case (Suc nat) then show ?thesis using R1Proj
	+ using proj_automaton_gta_lang(2)[of "the (rr2_of_rr2_rel \<F> Rs r)" "eval_rr2_rel ?F ?Rs r"]
	+ by simp
	+ qed
	+next
	+ case (R1Union s1 s2)
	+ then show ?case
	+ by (auto simp: RR1_spec_def \<L>_union)
	+next
	+ case (R1Inter s1 s2)
	+ from R1Inter show ?case
	+ by (auto simp: \<L>_intersect RR1_spec_def)
	+next
	+ case (R1Diff s1 s2)
	+ then show ?case
	+ by (auto intro: RR1_difference)
	+next
	+ case (R2GTT_Rel g w x)
	+ note ass = R2GTT_Rel
	+ consider (a) "\<exists> A. gtt_of_gtt_rel \<F> Rs g = Some A" \| (b) "gtt_of_gtt_rel \<F> Rs g = None" by blast
	+ then show ?case
	+ proof cases
	+ case a then obtain A where [simp]: "gtt_of_gtt_rel \<F> Rs g = Some A" by blast
	+ from gtt_of_gtt_rel_correct[OF assms this]
	+ have spec [simp]: "eval_gtt_rel ?F ?Rs g = agtt_lang A" by auto
	+ let ?B = "GTT_to_RR2_root_reg A" note [simp] = GTT_to_RR2_root[of A]
	+ show ?thesis
	+ proof (cases w)
	+ case [simp]: PRoot show ?thesis
	+ proof (cases x)
	+ case EParallel
	+ then show ?thesis using reflcl_automaton[of ?B "agtt_lang A" \<F>]
	+ by auto
	+ qed (auto simp: GTT_to_RR2_root)
	+ next
	+ case PNonRoot
	+ then show ?thesis
	+ using nhole_ctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
	+ using nhole_mctxt_reflcl_automaton[of ?B "agtt_lang A" \<F>]
	+ using nhole_mctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
	+ by (cases x) auto
	+ next
	+ case PAny
	+ then show ?thesis
	+ using ctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
	+ using parallel_closure_automaton[of ?B "agtt_lang A" \<F>]
	+ using mctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
	+ by (cases x) auto
	+ qed
	+ qed (cases w; cases x, auto)
	+next
	+ case (R2Diag s)
	+ then show ?case
	+ by (auto simp: RR2_spec_def RR1_spec_def fmap_funs_\<L> Id_on_iff
	+ fmap_funs_gta_lang map_funs_term_some_gpair)
	+next
	+ case (R2Prod s1 s2)
	+ then show ?case using pair_automaton[of "the (rr1_of_rr1_rel \<F> Rs s1)" _ "the (rr1_of_rr1_rel \<F> Rs s2)"]
	+ by auto
	+next
	+ case (R2Inv r)
	+ show ?case using R2Inv by (auto simp: swap_RR2_spec)
	+next
	+ case (R2Union r1 r2)
	+ then show ?case using union_automaton
	+ by (auto simp: RR2_spec_def \<L>_union)
	+next
	+ case (R2Inter r1 r2)
	+ then show ?case
	+ by (auto simp: \<L>_intersect RR2_spec_def)
	+next
	+ case (R2Diff r1 r2)
	+ then show ?case by (auto intro: RR2_difference)
	+next
	+ case (R2Comp r1 r2)
	+ then show ?case using eval_rr12_rel_sig
	+ by (auto intro!: rr2_compositon) blast+
	+}
	+qed
	+
	+
	+subsection \<open>Misc\<close>
	+
	+lemma eval_formula_arity_cong:
	+ assumes "\<And>i. i < formula_arity f \<Longrightarrow> \<alpha>' i = \<alpha> i"
	+ shows "eval_formula \<F> Rs \<alpha>' f = eval_formula \<F> Rs \<alpha> f"
	+proof -
	+ have [simp]: "j < length fs \<Longrightarrow> i < formula_arity (fs ! j) \<Longrightarrow> i < max_list (map formula_arity fs)" for i j fs
	+ by (simp add: less_le_trans max_list)
	+ show ?thesis using assms
	+ proof (induct f arbitrary: \<alpha> \<alpha>')
	+ case (FAnd fs)
	+ show ?case using FAnd(1)[OF nth_mem, of _ \<alpha>' \<alpha>] FAnd(2) by (auto simp: all_set_conv_all_nth)
	+ next
	+ case (FOr fs)
	+ show ?case using FOr(1)[OF nth_mem, of _ \<alpha>' \<alpha>] FOr(2) by (auto simp: ex_set_conv_ex_nth)
	+ next
	+ case (FNot f)
	+ show ?case using FNot(1)[of \<alpha>' \<alpha>] FNot(2) by simp
	+ next
	+ case (FExists f)
	+ show ?case using FExists(1)[of "\<alpha>'\<langle>0 : z\<rangle>" "\<alpha>\<langle>0 : z\<rangle>" for z] FExists(2) by (auto simp: shift_def)
	+ next
	+ case (FForall f)
	+ show ?case using FForall(1)[of "\<alpha>'\<langle>0 : z\<rangle>" "\<alpha>\<langle>0 : z\<rangle>" for z] FForall(2) by (auto simp: shift_def)
	+ qed simp_all
	+qed
	+
	+
	+subsection \<open>Connect semantics to FOL-Fitting\<close>
	+
	+primrec form_of_formula :: "'trs formula \<Rightarrow> (unit, 'trs rr1_rel + 'trs rr2_rel) form" where
	+ "form_of_formula (FRR1 r1 x) = Pred (Inl r1) [Var x]"
	+\| "form_of_formula (FRR2 r2 x y) = Pred (Inr r2) [Var x, Var y]"
	+\| "form_of_formula (FAnd fs) = foldr And (map form_of_formula fs) TT"
	+\| "form_of_formula (FOr fs) = foldr Or (map form_of_formula fs) FF"
	+\| "form_of_formula (FNot f) = Neg (form_of_formula f)"
	+\| "form_of_formula (FExists f) = Exists (And (Pred (Inl R1Terms) [Var 0]) (form_of_formula f))"
	+\| "form_of_formula (FForall f) = Forall (Impl (Pred (Inl R1Terms) [Var 0]) (form_of_formula f))"
	+
	+
	+fun for_eval_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs rr1_rel + ftrs rr2_rel \<Rightarrow> 'f gterm list \<Rightarrow> bool" where
	+ "for_eval_rel \<F> Rs (Inl r1) [t] \<longleftrightarrow> t \<in> eval_rr1_rel \<F> Rs r1"
	+\| "for_eval_rel \<F> Rs (Inr r2) [t, u] \<longleftrightarrow> (t, u) \<in> eval_rr2_rel \<F> Rs r2"
	+
	+lemma eval_formula_conv:
	+ "eval_formula \<F> Rs \<alpha> f = eval \<alpha> undefined (for_eval_rel \<F> Rs) (form_of_formula f)"
	+proof (induct f arbitrary: \<alpha>)
	+ case (FAnd fs) then show ?case
	+ unfolding eval_formula.simps by (induct fs) auto
	+next
	+ case (FOr fs) then show ?case
	+ unfolding eval_formula.simps by (induct fs) auto
	+qed auto
	+
	+
	+subsection \<open>RRn relations and formulas\<close>
	+
	+lemma shift_rangeI [intro!]:
	+ "range \<alpha> \<subseteq> T \<Longrightarrow> x \<in> T \<Longrightarrow> range (shift \<alpha> i x) \<subseteq> T"
	+ by (auto simp: shift_def)
	+
	+definition formula_relevant where
	+ "formula_relevant \<F> Rs vs fm \<longleftrightarrow>
	+ (\<forall>\<alpha> \<alpha>'. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<longrightarrow> range \<alpha>' \<subseteq> \<T>\<^sub>G \<F> \<longrightarrow> map \<alpha> vs = map \<alpha>' vs \<longrightarrow> eval_formula \<F> Rs \<alpha> fm \<longrightarrow> eval_formula \<F> Rs \<alpha>' fm)"
	+
	+lemma formula_relevant_mono:
	+ "set vs \<subseteq> set ws \<Longrightarrow> formula_relevant \<F> Rs vs fm \<Longrightarrow> formula_relevant \<F> Rs ws fm"
	+ unfolding formula_relevant_def
	+ by (meson map_eq_conv subset_code(1))
	+
	+lemma formula_relevantD:
	+ "formula_relevant \<F> Rs vs fm \<Longrightarrow>
	+ range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> range \<alpha>' \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> map \<alpha> vs = map \<alpha>' vs \<Longrightarrow>
	+ eval_formula \<F> Rs \<alpha> fm \<Longrightarrow> eval_formula \<F> Rs \<alpha>' fm"
	+ unfolding formula_relevant_def
	+ by blast
	+
	+lemma trivial_formula_relevant:
	+ assumes "\<And>\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> \<not> eval_formula \<F> Rs \<alpha> fm"
	+ shows "formula_relevant \<F> Rs vs fm"
	+ using assms unfolding formula_relevant_def
	+ by auto
	+
	+lemma formula_relevant_0_FExists:
	+ assumes "formula_relevant \<F> Rs [0] fm"
	+ shows "formula_relevant \<F> Rs [] (FExists fm)"
	+ unfolding formula_relevant_def
	+proof (intro allI, intro impI)
	+ fix \<alpha> \<alpha>' assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "range (\<alpha>' :: fvar \<Rightarrow> 'a gterm) \<subseteq> \<T>\<^sub>G \<F>"
	+ "eval_formula \<F> Rs \<alpha> (FExists fm)"
	+ from ass(3) obtain z where "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) fm"
	+ by auto
	+ then show "eval_formula \<F> Rs \<alpha>' (FExists fm)"
	+ using ass(1, 2) formula_relevantD[OF assms, of "\<alpha>\<langle>0:z\<rangle>" "\<alpha>'\<langle>0:z\<rangle>"]
	+ by (auto simp: shift_rangeI intro!: exI[of _ z])
	+qed
	+
	+definition formula_spec where
	+ "formula_spec \<F> Rs vs A fm \<longleftrightarrow> sorted vs \<and> distinct vs \<and>
	+ formula_relevant \<F> Rs vs fm \<and>
	+ RRn_spec (length vs) A {map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm}"
	+
	+lemma formula_spec_RRn_spec:
	+ "formula_spec \<F> Rs vs A fm \<Longrightarrow> RRn_spec (length vs) A {map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm}"
	+ by (simp add: formula_spec_def)
	+
	+lemma formula_spec_nt_empty_form_sat:
	+ "\<not> reg_empty A \<Longrightarrow> formula_spec \<F> Rs vs A fm \<Longrightarrow> \<exists> \<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm"
	+ unfolding formula_spec_def
	+ by (auto simp: RRn_spec_def \<L>_def)
	+
	+lemma formula_spec_empty:
	+ "reg_empty A \<Longrightarrow> formula_spec \<F> Rs vs A fm \<Longrightarrow> range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> eval_formula \<F> Rs \<alpha> fm \<longleftrightarrow> False"
	+ unfolding formula_spec_def
	+ by (auto simp: RRn_spec_def \<L>_def)
	+
	+text \<open>In each inference step, we obtain a triple consisting of a formula @{term "fm"}, a list of
	+ relevant variables @{term "vs"} (typically a sublist of @{term "[0..<formula_arity fm]"}), and
	+ an RRn automaton @{term "A"}, such that the property @{term "formula_spec \<F> Rs vs A fm"} holds.\<close>
	+
	+lemma false_formula_spec:
	+ "sorted vs \<Longrightarrow> distinct vs \<Longrightarrow> formula_spec \<F> Rs vs empty_reg FFalse"
	+ by (auto simp: formula_spec_def false_RRn_spec FFalse_def formula_relevant_def)
	+
	+lemma true_formula_spec:
	+ assumes "vs \<noteq> [] \<or> \<T>\<^sub>G (fset \<F>) \<noteq> {}" "sorted vs" "distinct vs"
	+ shows "formula_spec (fset \<F>) Rs vs (true_RRn \<F> (length vs)) FTrue"
	+proof -
	+ have "{ts. length ts = length vs \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>)} = {map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>)}"
	+ proof (intro equalityI subsetI CollectI, goal_cases LR RL)
	+ case (LR ts)
	+ moreover obtain t0 where "funas_gterm t0 \<subseteq> fset \<F>" using LR assms(1) unfolding \<T>\<^sub>G_equivalent_def
	+ by (cases vs) fastforce+
	+ ultimately show ?case using `distinct vs`
	+ apply (intro exI[of _ "\<lambda>t. if t \<in> set vs then ts ! inv_into {0..<length vs} ((!) vs) t else t0"])
	+ apply (auto intro!: nth_equalityI dest!: inj_on_nth[of vs "{0..<length vs}"] simp: in_set_conv_nth \<T>\<^sub>G_equivalent_def)
	+ by (metis inv_to_set mem_Collect_eq subsetD)
	+ qed fastforce
	+ then show ?thesis using assms true_RRn_spec[of "length vs" \<F>]
	+ by (auto simp: formula_spec_def FTrue_def formula_relevant_def \<T>\<^sub>G_equivalent_def)
	+qed
	+
	+lemma relabel_formula_spec:
	+ "formula_spec \<F> Rs vs A fm \<Longrightarrow> formula_spec \<F> Rs vs (relabel_reg A) fm"
	+ by (simp add: formula_spec_def)
	+
	+lemma trim_formula_spec:
	+ "formula_spec \<F> Rs vs A fm \<Longrightarrow> formula_spec \<F> Rs vs (trim_reg A) fm"
	+ by (simp add: formula_spec_def)
	+
	+definition fit_permute :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
	+ "fit_permute vs vs' vs'' = map (\<lambda>v. if v \<in> set vs then the (mem_idx v vs) else length vs + the (mem_idx v vs'')) vs'"
	+
	+definition fit_rrn :: "('f \<times> nat) fset \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> (nat, 'f option list) reg \<Rightarrow> (_, 'f option list) reg" where
	+ "fit_rrn \<F> vs vs' A = (let vs'' = subtract_list_sorted vs' vs in
	+ fmap_funs_reg (\<lambda>fs. map ((!) fs) (fit_permute vs vs' vs''))
	+ (fmap_funs_reg (pad_with_Nones (length vs) (length vs'')) (pair_automaton_reg A (true_RRn \<F> (length vs'')))))"
	+
	+lemma the_mem_idx_simp [simp]:
	+ "distinct xs \<Longrightarrow> i < length xs \<Longrightarrow> the (mem_idx (xs ! i) xs) = i"
	+ using mem_idx_sound[THEN iffD1, OF nth_mem, of i xs] mem_idx_sound_output[of "xs ! i" xs] distinct_conv_nth
	+ by fastforce
	+
	+lemma fit_rrn:
	+ assumes spec: "formula_spec (fset \<F>) Rs vs A fm" and vs: "sorted vs'" "distinct vs'" "set vs \<subseteq> set vs'"
	+ shows "formula_spec (fset \<F>) Rs vs' (fit_rrn \<F> vs vs' A) fm"
	+ using spec unfolding formula_spec_def formula_relevant_def
	+ apply (elim conjE)
	+proof (intro conjI vs(1,2) allI, goal_cases rel spec)
	+ case (rel \<alpha> \<alpha>') show ?case using vs(3)
	+ by (fastforce intro!: rel(3)[rule_format, of \<alpha> \<alpha>'])
	+next
	+ case spec
	+ define vs'' where "vs'' = subtract_list_sorted vs' vs"
	+ have evalI: "range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<Longrightarrow> range \<alpha>' \<subseteq> \<T>\<^sub>G (fset \<F>) \<Longrightarrow> map \<alpha> vs = map \<alpha>' vs
	+ \<Longrightarrow> eval_formula (fset \<F>) Rs \<alpha> fm \<Longrightarrow> eval_formula (fset \<F>) Rs \<alpha>' fm" for \<alpha> \<alpha>'
	+ using spec(3) by blast
	+ have [simp]: "set vs' = set vs \<union> set vs''" "set vs'' \<inter> set vs = {}" "set vs \<inter> set vs'' = {}" and d: "distinct vs''"
	+ using vs spec(1,2) by (auto simp: vs''_def)
	+ then have [dest]: "v \<in> set vs'' \<Longrightarrow> v \<in> set vs \<Longrightarrow> False" for v by blast
	+ note * = permute_automaton[OF append_automaton[OF spec(4) true_RRn_spec, of "length vs''"]]
	+ have [simp]: "distinct vs \<Longrightarrow> i \<in> set vs \<Longrightarrow> vs ! the (mem_idx i vs) = (i :: nat)" for vs i
	+ by (simp add: mem_idx_sound mem_idx_sound_output)
	+ have [dest]: "distinct vs \<Longrightarrow> i \<in> set vs \<Longrightarrow> \<not> the (mem_idx i vs) < length vs \<Longrightarrow> False" for i
	+ by (meson mem_idx_sound2 mem_idx_sound_output option.exhaust_sel)
	+ show ?case unfolding fit_rrn_def Let_def vs''_def[symmetric] \<T>\<^sub>G_equivalent_def
	+ apply (rule subst[where P = "\<lambda>l. RRn_spec l _ _", OF _ subst[where P = "\<lambda>ta. RRn_spec _ _ ta", OF _ *]])
	+ subgoal by (simp add: fit_permute_def)
	+ subgoal
	+ apply (intro equalityI subsetI CollectI imageI; elim imageE CollectE exE conjE; unfold \<T>\<^sub>G_equivalent_def)
	+ subgoal for x fs ts us \<alpha>
	+ using spec(1, 2) d
	+ apply (intro exI[of _ "\<lambda>v. if v \<in> set vs'' then us ! the (mem_idx v vs'') else \<alpha> v"])
	+ apply (auto simp: fit_permute_def nth_append \<T>\<^sub>G_equivalent_def
	+ intro!: nth_equalityI evalI[of \<alpha> "\<lambda>v. if v \<in> set vs'' then us ! the (mem_idx v vs'') else \<alpha> v"])
	+ apply (metis distinct_Ex1 in_mono mem_Collect_eq nth_mem the_mem_idx_simp)
	+ apply (metis distinct_Ex1 in_mono mem_Collect_eq nth_mem the_mem_idx_simp)
	+ apply blast
	+ by (meson \<open>\<And>va. \<lbrakk>va \<in> set vs''; va \<in> set vs\<rbrakk> \<Longrightarrow> False\<close> nth_mem)
	+ subgoal premises p for xs \<alpha>
	+ apply (intro rev_image_eqI[of "map \<alpha> (vs @ vs'')"])
	+ subgoal using p by (force intro!: exI[of _ "map \<alpha> vs", OF exI[of _ "map \<alpha> vs''"]])
	+ subgoal using p(1)
	+ by (force intro!: nth_equalityI simp: fit_permute_def comp_def nth_append dest: iffD1[OF mem_idx_sound] mem_idx_sound_output)
	+ done
	+ done
	+ subgoal using vs spec(1,2) unfolding fit_permute_def
	+ apply (intro equalityI subsetI)
	+ subgoal by (auto 0 3 dest: iffD1[OF mem_idx_sound] mem_idx_sound_output)
	+ subgoal for x
	+ apply (simp add: Compl_eq[symmetric] Diff_eq[symmetric] Un_Diff Diff_triv Int_absorb1)
	+ apply (simp add: nth_image[symmetric, of "length xs" xs for xs, simplified] image_iff comp_def)
	+ using image_cong[OF refl arg_cong[OF the_mem_idx_simp]] \<open>distinct vs''\<close>
	+ by (smt (z3) add_diff_inverse_nat add_less_cancel_left atLeast0LessThan lessThan_iff the_mem_idx_simp)
	+ done
	+ done
	+qed
	+
	+definition fit_rrns :: "('f \<times> nat) fset \<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) list \<Rightarrow>
	+ nat list \<times> ((nat, 'f option list) reg) list" where
	+ "fit_rrns \<F> rrns = (let vs' = fold union_list_sorted (map (fst \<circ> snd) rrns) [] in
	+ (vs', map (\<lambda>(fm, vs, ta). relabel_reg (trim_reg (fit_rrn \<F> vs vs' ta))) rrns))"
	+
	+lemma sorted_union_list_sortedI [simp]:
	+ "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> sorted (union_list_sorted xs ys)"
	+ by (induct xs ys rule: union_list_sorted.induct) auto
	+
	+lemma distinct_union_list_sortedI [simp]:
	+ "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> distinct xs \<Longrightarrow> distinct ys \<Longrightarrow> distinct (union_list_sorted xs ys)"
	+ by (induct xs ys rule: union_list_sorted.induct) auto
	+
	+lemma fit_rrns:
	+ assumes infs: "\<And>fvA. fvA \<in> set rrns \<Longrightarrow> formula_spec (fset \<F>) Rs (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
	+ assumes "(vs', tas') = fit_rrns \<F> rrns"
	+ shows "length tas' = length rrns" "\<And>i. i < length rrns \<Longrightarrow> formula_spec (fset \<F>) Rs vs' (tas' ! i) (fst (rrns ! i))"
	+ "distinct vs'" "sorted vs'"
	+proof (goal_cases)
	+ have vs': "vs' = fold union_list_sorted (map (fst \<circ> snd) rrns) []" using assms(2) by (simp add: fit_rrns_def Let_def)
	+ have *: "sorted vs'" "distinct vs'" "\<And>fvA. fvA \<in> set rrns \<Longrightarrow> set (fst (snd fvA)) \<subseteq> set vs'"
	+ using infs[unfolded formula_spec_def, THEN conjunct2, THEN conjunct1]
	+ infs[unfolded formula_spec_def, THEN conjunct1]
	+ unfolding vs' by (induct rrns rule: rev_induct) auto
	+{
	+ case 1 then show ?case using assms(2) by (simp add: fit_rrns_def Let_def)
	+next
	+ case (2 i)
	+ have tas': "tas' ! i = relabel_reg (trim_reg (fit_rrn \<F> (fst (snd (rrns ! i))) vs' (snd (snd (rrns ! i)))))"
	+ using 2 assms(2) by (simp add: fit_rrns_def Let_def split: prod.splits)
	+ from (1,2) (3)[OF nth_mem] show ?case using 2 unfolding tas'
	+ by (auto intro!: relabel_formula_spec trim_formula_spec fit_rrn 2 assms(1,2))
	+next
	+ case 3 show ?case by (rule *)
	+next
	+ case 4 show ?case by (rule *)
	+}
	+qed
	+
	+
	+subsection \<open>Building blocks\<close>
	+
	+definition for_rrn where
	+ "for_rrn tas = fold (\<lambda>A B. relabel_reg (reg_union A B)) tas (Reg {\|\|} (TA {\|\|} {\|\|}))"
	+
	+lemma for_rrn:
	+ assumes "length tas = length fs" "\<And>i. i < length fs \<Longrightarrow> formula_spec \<F> Rs vs (tas ! i) (fs ! i)"
	+ and vs: "sorted vs" "distinct vs"
	+ shows "formula_spec \<F> Rs vs (for_rrn tas) (FOr fs)"
	+ using assms(1,2) unfolding for_rrn_def
	+proof (induct fs arbitrary: tas rule: rev_induct)
	+ case Nil then show ?case using vs false_formula_spec[of vs \<F> Rs] by (auto simp: FFalse_def)
	+next
	+ case (snoc fm fs)
	+ have *: "Bex (set [x]) P = P x" for P x by auto
	+ have [intro!]: "formula_spec \<F> Rs vs (reg_union A B) (FOr (fs @ [fm]))" if
	+ "formula_spec \<F> Rs vs A fm" "formula_spec \<F> Rs vs B (FOr fs)" for A B using that
	+ unfolding formula_spec_def
	+ apply (intro conjI, blast, blast)
	+ subgoal unfolding formula_relevant_def eval_formula.simps set_append bex_Un * by blast
	+ apply (elim conjE)
	+ subgoal premises p by (rule subst[of _ _ "RRn_spec _ _", OF _ union_automaton[OF p(6,8)]]) auto
	+ done
	+ show ?case using snoc(1)[of "take (length fs) tas"] snoc(2) snoc(3)[simplified, OF less_SucI] snoc(3)[of "length fs"] vs
	+ by (cases tas rule: rev_exhaust) (auto simp: min_def nth_append intro!: relabel_formula_spec)
	+qed
	+
	+fun fand_rrn where
	+ "fand_rrn \<F> n [] = true_RRn \<F> n"
	+\| "fand_rrn \<F> n (A # tas) = fold (\<lambda>A B. simplify_reg (reg_intersect A B)) tas A"
	+
	+lemma fand_rrn:
	+ assumes "\<T>\<^sub>G (fset \<F>) \<noteq> {}" "length tas = length fs" "\<And>i. i < length fs \<Longrightarrow> formula_spec (fset \<F>) Rs vs (tas ! i) (fs ! i)"
	+ and vs: "sorted vs" "distinct vs"
	+ shows "formula_spec (fset \<F>) Rs vs (fand_rrn \<F> (length vs) tas) (FAnd fs)"
	+proof (cases fs)
	+ case Nil
	+ have "tas = []" using assms(2) by (auto simp: Nil)
	+ then show ?thesis using true_formula_spec[OF _ vs, of \<F> Rs] assms(1) Nil
	+ by (simp add: FTrue_def)
	+next
	+ case (Cons fm fs)
	+ obtain ta tas' where tas: "tas = ta # tas'" using assms(2) Cons by (cases tas) auto
	+ show ?thesis using assms(2) assms(3)[of "Suc _"] unfolding tas Cons
	+ unfolding list.size add_Suc_right add_0_right nat.inject Suc_less_eq nth_Cons_Suc fand_rrn.simps
	+ proof (induct fs arbitrary: tas' rule: rev_induct)
	+ case Nil
	+ have "formula_relevant (fset \<F>) Rs vs (FAnd [fm])" using assms(3)[of 0]
	+ apply (simp add: tas Cons formula_spec_def)
	+ unfolding formula_relevant_def eval_formula.simps in_set_simps by blast
	+ then show ?case using assms(3)[of 0, unfolded tas Cons, simplified] Nil by (simp add: formula_spec_def)
	+ next
	+ case (snoc fm' fs)
	+ have *: "Ball (insert x X) P \<longleftrightarrow> P x \<and> Ball X P" for P x X by auto
	+ have [intro!]: "formula_spec (fset \<F>) Rs vs (reg_intersect A B) (FAnd (fm # fs @ [fm']))" if
	+ "formula_spec (fset \<F>) Rs vs A fm'" "formula_spec (fset \<F>) Rs vs B (FAnd (fm # fs))" for A B using that
	+ unfolding formula_spec_def
	+ apply (intro conjI, blast, blast)
	+ subgoal unfolding formula_relevant_def eval_formula.simps set_append set_simps ball_simps ball_Un in_set_simps *
	+ by blast
	+ apply (elim conjE)
	+ subgoal premises p
	+ by (rule subst[of _ _ "RRn_spec _ _", OF _ intersect_automaton[OF p(6,8)]])
	+ (auto dest: p(5)[unfolded formula_relevant_def, rule_format])
	+ done
	+ show ?case using snoc(1)[of "take (length fs) tas'"] snoc(2) snoc(3)[simplified, OF less_SucI] snoc(3)[of "length fs"] vs
	+ by (cases tas' rule: rev_exhaust) (auto simp: min_def nth_append simplify_reg_def intro!: relabel_formula_spec trim_formula_spec)
	+ qed
	+qed
	+
	+subsubsection \<open>IExists inference rule\<close>
	+
	+lemma lift_fun_gpairD:
	+ "map_gterm lift_fun s = gpair t u \<Longrightarrow> t = s"
	+ "map_gterm lift_fun s = gpair t u \<Longrightarrow> u = s"
	+ by (metis gfst_gpair gsnd_gpair map_funs_term_some_gpair)+
	+
	+definition upd_bruijn :: "nat list \<Rightarrow> nat list" where
	+ "upd_bruijn vs = tl (map (\<lambda> x. x - 1) vs)"
	+
	+lemma upd_bruijn_length[simp]:
	+ "length (upd_bruijn vs) = length vs - 1"
	+ by (induct vs) (auto simp: upd_bruijn_def)
	+
	+lemma pres_sorted_dec:
	+ "sorted xs \<Longrightarrow> sorted (map (\<lambda>x. x - Suc 0) xs)"
	+ by (induct xs) auto
	+
	+lemma upd_bruijn_pres_sorted:
	+ "sorted xs \<Longrightarrow> sorted (upd_bruijn xs)"
	+ unfolding upd_bruijn_def
	+ by (intro sorted_tl) (auto simp: pres_sorted_dec)
	+
	+lemma pres_distinct_not_0_list_dec:
	+ "distinct xs \<Longrightarrow> 0 \<notin> set xs \<Longrightarrow> distinct (map (\<lambda>x. x - Suc 0) xs)"
	+ by (induct xs) (auto, metis Suc_pred neq0_conv)
	+
	+lemma upd_bruijn_pres_distinct:
	+ assumes "sorted xs" "distinct xs"
	+ shows "distinct (upd_bruijn xs)"
	+proof -
	+ have "sorted (ys :: nat list) \<Longrightarrow> distinct ys \<Longrightarrow> 0 \<notin> set (tl ys)" for ys
	+ by (induct ys) auto
	+ from this[OF assms] show ?thesis using assms(2)
	+ using pres_distinct_not_0_list_dec[OF distinct_tl, OF assms(2)]
	+ unfolding upd_bruijn_def
	+ by (simp add: map_tl)
	+qed
	+
	+lemma upd_bruijn_relevant_inv:
	+ assumes "sorted vs" "distinct vs" "0 \<in> set vs"
	+ and "\<And> x. x \<in> set (upd_bruijn vs) \<Longrightarrow> \<alpha> x = \<alpha>' x"
	+ shows "\<And> x. x \<in> set vs \<Longrightarrow> (shift \<alpha> 0 z) x = (shift \<alpha>' 0 z) x"
	+ using assms unfolding upd_bruijn_def
	+ by (induct vs) (auto simp add: FOL_Fitting.shift_def)
	+
	+lemma ExistsI_upd_brujin_0:
	+ assumes "sorted vs" "distinct vs" "0 \<in> set vs" "formula_relevant \<F> Rs vs fm"
	+ shows "formula_relevant \<F> Rs (upd_bruijn vs) (FExists fm)"
	+ unfolding formula_relevant_def
	+proof (intro allI, intro impI)
	+ fix \<alpha> \<alpha>' assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "range (\<alpha>' :: fvar \<Rightarrow> 'a gterm) \<subseteq> \<T>\<^sub>G \<F>"
	+ "map \<alpha> (upd_bruijn vs) = map \<alpha>' (upd_bruijn vs)" "eval_formula \<F> Rs \<alpha> (FExists fm)"
	+ from ass(4) obtain z where "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) fm"
	+ by auto
	+ then show "eval_formula \<F> Rs \<alpha>' (FExists fm)"
	+ using ass(1 - 3) formula_relevantD[OF assms(4), of "\<alpha>\<langle>0:z\<rangle>" "\<alpha>'\<langle>0:z\<rangle>"]
	+ using upd_bruijn_relevant_inv[OF assms(1 - 3), of "\<alpha>" "\<alpha>'"]
	+ by (auto simp: shift_rangeI intro!: exI[of _ z])
	+qed
	+
	+declare subsetI[rule del]
	+lemma ExistsI_upd_brujin_no_0:
	+ assumes "0 \<notin> set vs" and "formula_relevant \<F> Rs vs fm"
	+ shows "formula_relevant \<F> Rs (map (\<lambda>x. x - Suc 0) vs) (FExists fm)"
	+ unfolding formula_relevant_def
	+proof ((intro allI)+ , (intro impI)+, unfold eval_formula.simps)
	+ fix \<alpha> \<alpha>' assume st: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "range \<alpha>' \<subseteq> \<T>\<^sub>G \<F>"
	+ "map \<alpha> (map (\<lambda>x. x - Suc 0) vs) = map \<alpha>' (map (\<lambda>x. x - Suc 0) vs)"
	+ "\<exists> z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (shift \<alpha> 0 z) fm"
	+ then obtain z where w: "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (shift \<alpha> 0 z) fm" by auto
	+ from this(1) have "eval_formula \<F> Rs (shift \<alpha>' 0 z) fm"
	+ using st(1 - 3) assms(1) FOL_Fitting.shift_def
	+ apply (intro formula_relevantD[OF assms(2) _ _ _ w(2), of "shift \<alpha>' 0 z"])
	+ by auto (simp add: FOL_Fitting.shift_def)
	+ then show "\<exists> z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (shift \<alpha>' 0 z) fm" using w(1)
	+ by blast
	+qed
	+
	+definition shift_right where
	+ "shift_right \<alpha> \<equiv> \<lambda> i. \<alpha> (i + 1)"
	+
	+lemma shift_right_nt_0:
	+ "i \<noteq> 0 \<Longrightarrow> \<alpha> i = shift_right \<alpha> (i - Suc 0)"
	+ unfolding shift_right_def
	+ by auto
	+
	+lemma shift_shift_right_id [simp]:
	+ "shift (shift_right \<alpha>) 0 (\<alpha> 0) = \<alpha>"
	+ by (auto simp: shift_def shift_right_def)
	+
	+lemma shift_right_rangeI [intro]:
	+ "range \<alpha> \<subseteq> T \<Longrightarrow> range (shift_right \<alpha>) \<subseteq> T"
	+ by (auto simp: shift_right_def intro: subsetI)
	+
	+lemma eval_formula_shift_right_eval:
	+ "eval_formula \<F> Rs \<alpha> fm \<Longrightarrow> eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm"
	+ "eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm \<Longrightarrow> eval_formula \<F> Rs \<alpha> fm"
	+ by (auto)
	+declare subsetI[intro!]
	+
	+lemma nt_rel_0_trivial_shift:
	+ assumes "0 \<notin> set vs"
	+ shows "{map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm} =
	+ {map (\<lambda>x. \<alpha> (x - Suc 0)) vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> (\<exists>z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm)}"
	+ (is "?Ls = ?Rs")
	+proof
	+ {fix \<alpha> assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs \<alpha> fm"
	+ then have "map \<alpha> vs = map (\<lambda>x. (shift_right \<alpha>) (x - Suc 0)) vs"
	+ "range (shift_right \<alpha>) \<subseteq> \<T>\<^sub>G \<F>" "\<alpha> 0 \<in>\<T>\<^sub>G \<F>" "eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm"
	+ using shift_right_rangeI[OF ass(1)] assms
	+ by (auto intro: eval_formula_shift_right_eval(1), metis shift_right_nt_0)}
	+ then show "?Ls \<subseteq> ?Rs"
	+ by blast
	+next
	+ show "?Rs \<subseteq> ?Ls"
	+ by auto (metis FOL_Fitting.shift_def One_nat_def assms not_less0 shift_rangeI)
	+qed
	+
	+lemma relevant_vars_upd_bruijn_tl:
	+ assumes "sorted vs" "distinct vs"
	+ shows "map (shift_right \<alpha>) (upd_bruijn vs) = tl (map \<alpha> vs)" using assms
	+proof (induct vs)
	+ case (Cons a vs) then show ?case
	+ using le_antisym
	+ by (auto simp: upd_bruijn_def shift_right_def)
	+ (metis One_nat_def Suc_eq_plus1 le_0_eq shift_right_def shift_right_nt_0)
	+qed (auto simp: upd_bruijn_def)
	+
	+lemma drop_upd_bruijn_set:
	+ assumes "sorted vs" "distinct vs"
	+ shows "drop 1 ` {map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm} =
	+ {map \<alpha> (upd_bruijn vs) \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> (\<exists>z\<in>\<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm)}"
	+ (is "?Ls = ?Rs")
	+proof
	+ {fix \<alpha> assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs \<alpha> fm"
	+ then have "drop 1 (map \<alpha> vs) = map (shift_right \<alpha>) (upd_bruijn vs)"
	+ "range (shift_right \<alpha>) \<subseteq> \<T>\<^sub>G \<F>" "\<alpha> 0 \<in>\<T>\<^sub>G \<F>" "eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm"
	+ using shift_right_rangeI[OF ass(1)]
	+ by (auto simp: tl_drop_conv relevant_vars_upd_bruijn_tl[OF assms(1, 2)])}
	+ then show "?Ls \<subseteq> ?Rs"
	+ by blast
	+next
	+ have [dest]: "0 \<in> set (tl vs) \<Longrightarrow> False" using assms(1, 2)
	+ by (cases vs) auto
	+ {fix \<alpha> z assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm"
	+ then have "map \<alpha> (upd_bruijn vs) = tl (map (\<alpha>\<langle>0:z\<rangle>) vs)"
	+ "range (\<alpha>\<langle>0:z\<rangle>) \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm"
	+ using shift_rangeI[OF ass(1)]
	+ by (auto simp: upd_bruijn_def shift_def simp flip: map_tl)}
	+ then show "?Rs \<subseteq> ?Ls"
	+ by (auto simp: tl_drop_conv image_def) blast
	+qed
	+
	+
	+lemma closed_sat_form_env_dom:
	+ assumes "formula_relevant \<F> Rs [] (FExists fm)" "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs \<alpha> fm"
	+ shows "{[\<alpha> 0] \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> (\<exists> z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm)} = {[t] \| t. t \<in> \<T>\<^sub>G \<F>}"
	+ using formula_relevantD[OF assms(1)] assms(2-)
	+ apply auto
	+ apply blast
	+ by (smt rangeI shift_eq shift_rangeI shift_right_rangeI shift_shift_right_id subsetD)
	+
	+(* MOVE *)
	+lemma find_append:
	+ "find P (xs @ ys) = (if find P xs \<noteq> None then find P xs else find P ys)"
	+ by (induct xs arbitrary: ys) (auto split!: if_splits)
	+
	+subsection \<open>Checking inferences\<close>
	+
	+derive linorder ext_step pos_step gtt_rel rr1_rel rr2_rel ftrs
	+derive compare ext_step pos_step gtt_rel rr1_rel rr2_rel ftrs
	+
	+fun check_inference :: "(('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> (nat, 'f) reg option)
	+ \<Rightarrow> (('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> (nat, 'f option \<times> 'f option) reg option)
	+ \<Rightarrow> ('f \<times> nat) fset \<Rightarrow> ('f :: compare, 'v) fin_trs list
	+ \<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) list
	+ \<Rightarrow> (nat \<times> ftrs inference \<times> ftrs formula \<times> info list)
	+ \<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) option" where
	+ "check_inference rr1c rr2c \<F> Rs infs (l, step, fm, is) = do {
	+ guard (l = length infs);
	+ case step of
	+ IRR1 s x \<Rightarrow> do {
	+ guard (fm = FRR1 s x);
	+ liftO1 (\<lambda>ta. (FRR1 s x, [x], fmap_funs_reg (\<lambda>f. [Some f]) ta)) (rr1c \<F> Rs s)
	+ }
	+ \| IRR2 r x y \<Rightarrow> do {
	+ guard (fm = FRR2 r x y);
	+ case compare x y of
	+ Lt \<Rightarrow> liftO1 (\<lambda>ta. (FRR2 r x y, [x, y], fmap_funs_reg (\<lambda>(f, g). [f, g]) ta)) (rr2c \<F> Rs r)
	+ \| Eq \<Rightarrow> liftO1 (\<lambda>ta. (FRR2 r x y, [x], fmap_funs_reg (\<lambda>f. [Some f]) ta))
	+ (liftO1 (simplify_reg \<circ> proj_1_reg)
	+ (liftO2 (\<lambda> t1 t2. simplify_reg (reg_intersect t1 t2)) (rr2c \<F> Rs r) (rr2c \<F> Rs (R2Diag R1Terms))))
	+ \| Gt \<Rightarrow> liftO1 (\<lambda>ta. (FRR2 r x y, [y, x], fmap_funs_reg (\<lambda>(f, g). [g, f]) ta)) (rr2c \<F> Rs r)
	+ }
	+ \| IAnd ls \<Rightarrow> do {
	+ guard (\<forall>l' \<in> set ls. l' < l);
	+ guard (fm = FAnd (map (\<lambda>l'. fst (infs ! l')) ls));
	+ let (vs', tas') = fit_rrns \<F> (map ((!) infs) ls) in
	+ Some (fm, vs', fand_rrn \<F> (length vs') tas')
	+ }
	+ \| IOr ls \<Rightarrow> do {
	+ guard (\<forall>l' \<in> set ls. l' < l);
	+ guard (fm = FOr (map (\<lambda>l'. fst (infs ! l')) ls));
	+ let (vs', tas') = fit_rrns \<F> (map ((!) infs) ls) in
	+ Some (fm, vs', for_rrn tas')
	+ }
	+ \| INot l' \<Rightarrow> do {
	+ guard (l' < l);
	+ guard (fm = FNot (fst (infs ! l')));
	+ let (vs', tas') = snd (infs ! l');
	+ Some (fm, vs', simplify_reg (difference_reg (true_RRn \<F> (length vs')) tas'))
	+ }
	+ \| IExists l' \<Rightarrow> do {
	+ guard (l' < l);
	+ guard (fm = FExists (fst (infs ! l')));
	+ let (vs', tas') = snd (infs ! l');
	+ if length vs' = 0 then Some (fm, [], tas') else
	+ if reg_empty tas' then Some (fm, [], empty_reg)
	+ else if 0 \<notin> set vs' then Some (fm, map (\<lambda> x. x - 1) vs', tas')
	+ else if 1 = length vs' then Some (fm, [], true_RRn \<F> 0)
	+ else Some (fm, upd_bruijn vs', rrn_drop_fst tas')
	+ }
	+ \| IRename l' vs \<Rightarrow> guard (l' < l) \<then> None
	+ \| INNFPlus l' \<Rightarrow> do {
	+ guard (l' < l);
	+ let fm' = fst (infs ! l');
	+ guard (ord_form_list_aci (nnf_to_list_aci (nnf (form_of_formula fm'))) = ord_form_list_aci (nnf_to_list_aci (nnf (form_of_formula fm))));
	+ Some (fm, snd (infs ! l'))
	+ }
	+ \| IRepl eq pos l' \<Rightarrow> guard (l' < l) \<then> None
	+ }"
	+
	+lemma RRn_spec_true_RRn:
	+ "RRn_spec (Suc 0) (true_RRn \<F> (Suc 0)) {[t] \|t. t \<in> \<T>\<^sub>G (fset \<F>)}"
	+ apply (auto simp: RRn_spec_def \<T>\<^sub>G_equivalent_def fmap_funs_\<L>
	+ image_def term_automaton[of \<F>, unfolded RR1_spec_def])
	+ apply (metis gencode_singleton)+
	+ done
	+
	+lemma check_inference_correct:
	+ assumes sig: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" and Rs: "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>"
	+ assumes infs: "\<And>fvA. fvA \<in> set infs \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
	+ assumes inf: "check_inference rr1c rr2c \<F> Rs infs (l, step, fm, is) = Some (fm', vs, A')"
	+ assumes rr1: "\<And>r1. \<forall>ta1. rr1c \<F> Rs r1 = Some ta1 \<longrightarrow> RR1_spec ta1 (eval_rr1_rel (fset \<F>) (map fset Rs) r1)"
	+ assumes rr2: "\<And>r2. \<forall>ta2. rr2c \<F> Rs r2 = Some ta2 \<longrightarrow> RR2_spec ta2 (eval_rr2_rel (fset \<F>) (map fset Rs) r2)"
	+ shows "l = length infs \<and> fm = fm' \<and> formula_spec (fset \<F>) (map fset Rs) vs A' fm'"
	+ using inf
	+proof (induct step)
	+ note [simp] = bind_eq_Some_conv guard_simps
	+ let ?F = "fset \<F>" let ?Rs = "map fset Rs"
	+{
	+ case (IRR1 s x)
	+ then show ?case
	+ using rr1[rule_format, of s]
	+ subsetD[OF eval_rr12_rel_sig(1), of _ ?F ?Rs s]
	+ by (force simp: formula_spec_def formula_relevant_def RR1_spec_def \<T>\<^sub>G_equivalent_def
	+ intro!: RR1_to_RRn_spec[of _ "(\<lambda>\<alpha>. \<alpha> x) ` Collect P" for P, unfolded image_comp, unfolded image_Collect comp_def One_nat_def])
	+next
	+ case (IRR2 r x y)
	+ then show ?case using rr2[rule_format, of r]
	+ subsetD[OF eval_rr12_rel_sig(2), of _ ?F ?Rs r]
	+ two_comparisons_into_compare(1)[of x y "x = y" "x < y" "x > y"]
	+ proof (induct "compare x y")
	+ note [intro!] = RR1_to_RRn_spec[of _ "(\<lambda>\<alpha>. \<alpha> y) ` Collect P" for P, unfolded image_comp,
	+ unfolded image_Collect comp_def One_nat_def prod.simps]
	+ case Eq
	+ then obtain A where w[simp]: "rr2c \<F> Rs r = Some A" by auto
	+ from Eq obtain B where [simp]:"rr2c \<F> Rs (R2Diag R1Terms) = Some B" by auto
	+ let ?B = "reg_intersect A B"
	+ from Eq(3)[OF w] have "RR2_spec ?B (eval_rr2_rel ?F ?Rs r \<inter> Restr Id (\<T>\<^sub>G ?F))"
	+ using rr2[rule_format, of "R2Diag R1Terms" B]
	+ by (auto simp add: \<L>_intersect RR2_spec_def dest: lift_fun_gpairD)
	+ then have "RR2_spec (relabel_reg (trim_reg ?B)) (eval_rr2_rel ?F ?Rs r \<inter> Restr Id (\<T>\<^sub>G ?F))" by simp
	+ from proj_1(1)[OF this]
	+ have "RR1_spec (proj_1_reg (relabel_reg (trim_reg ?B))) {\<alpha> y \|\<alpha>. range \<alpha> \<subseteq> gterms ?F \<and> (\<alpha> y, \<alpha> y) \<in> eval_rr2_rel ?F ?Rs r}"
	+ apply (auto simp: RR1_spec_def \<T>\<^sub>G_equivalent_def image_iff)
	+ by (metis Eq.prems(3) IdI IntI \<T>\<^sub>G_equivalent_def fst_conv)
	+ then show ?thesis using Eq
	+ by (auto simp: formula_spec_def formula_relevant_def liftO1_def \<T>\<^sub>G_equivalent_def simplify_reg_def RR2_spec_def
	+ split: if_splits intro!: exI[of _ "\<lambda>z. if z = x then _ else _"])
	+ next
	+ note [intro!] = RR2_to_RRn_spec[of _ "(\<lambda>\<alpha>. (\<alpha> x, \<alpha> y)) ` Collect P" for P, unfolded image_comp,
	+ unfolded image_Collect comp_def numeral_2_eq_2 prod.simps]
	+ case Lt then show ?thesis by (fastforce simp: formula_spec_def formula_relevant_def RR2_spec_def \<T>\<^sub>G_equivalent_def
	+ split: if_splits intro!: exI[of _ "\<lambda>z. if z = x then _ else _"])
	+ next
	+ note [intro!] = RR2_to_RRn_spec[of _ "prod.swap ` (\<lambda>\<alpha>. (\<alpha> x, \<alpha> y)) ` Collect P" for P, OF swap_RR2_spec,
	+ unfolded image_comp, unfolded image_Collect comp_def numeral_2_eq_2 prod.simps fmap_funs_reg_comp case_swap]
	+ case Gt then show ?thesis
	+ by (fastforce simp: formula_spec_def formula_relevant_def RR2_spec_def \<T>\<^sub>G_equivalent_def
	+ split: if_splits intro!: exI[of _ "\<lambda>z. if z = x then _ else _"])
	+ qed
	+next
	+ case (IAnd ls)
	+ have [simp]: "(fm, vs, ta) \<in> (!) infs ` set ls \<Longrightarrow> formula_spec ?F ?Rs vs ta fm" for fm vs ta
	+ using infs IAnd by auto
	+ show ?case using IAnd fit_rrns[OF assms(3), of "map ((!) infs) ls", OF _ prod.collapse]
	+ by (force split: prod.splits intro!: fand_rrn[OF assms(1)])
	+next
	+ case (IOr ls)
	+ have [simp]: "(fm, vs, ta) \<in> (!) infs ` set ls \<Longrightarrow> formula_spec ?F ?Rs vs ta fm" for fm vs ta
	+ using infs IOr by auto
	+ show ?case using IOr fit_rrns[OF assms(3), of "map ((!) infs) ls", OF _ prod.collapse]
	+ by (force split: prod.splits intro!: for_rrn)
	+next
	+ case (INot l')
	+ obtain fm vs' ta where [simp]: "infs ! l' = (fm, vs', ta)" by (cases "infs ! l'") auto
	+ then have spec: "formula_spec ?F ?Rs vs ta fm" using infs[OF nth_mem, of l'] INot
	+ by auto
	+ have rel: "formula_relevant (fset \<F>) (map fset Rs) vs (FNot fm)" using spec
	+ unfolding formula_spec_def formula_relevant_def
	+ by (metis (no_types, lifting) eval_formula.simps(5))
	+ have vs: "sorted vs" "distinct vs" using spec by (auto simp: formula_spec_def)
	+ {fix xs assume ass: "\<forall>\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<longrightarrow> xs = map \<alpha> vs \<longrightarrow> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm"
	+ "length xs = length vs" "set xs \<subseteq> \<T>\<^sub>G (fset \<F>)"
	+ from sig obtain s where mem: "s \<in> \<T>\<^sub>G (fset \<F>)" by blast
	+ let ?g = "\<lambda> i. find (\<lambda> p. fst p = i) (zip vs [0 ..< length vs])"
	+ let ?f = "\<lambda> i. if ?g i = None then s else xs ! snd (the (?g i))"
	+ from vs(1) have *: "sorted (zip vs [0 ..< length vs])"
	+ by (induct vs rule: rev_induct) (auto simp: sorted_append elim!: in_set_zipE intro!: sorted_append_bigger)
	+ have "i < length vs \<Longrightarrow> ?g (vs ! i) = Some (vs ! i, i)" for i using vs(2)
	+ by (induct vs rule: rev_induct) (auto simp: nth_append find_append find_Some_iff nth_eq_iff_index_eq split!: if_splits)
	+ then have "map ?f vs = xs" using vs(2) ass(2)
	+ by (intro nth_equalityI) (auto simp: find_None_iff set_zip)
	+ moreover have "range ?f \<subseteq> \<T>\<^sub>G (fset \<F>)" using ass(2, 3) mem
	+ using find_SomeD(2) set_zip_rightD by auto fastforce
	+ ultimately have "\<exists>\<alpha>. xs = map \<alpha> vs \<and> range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm" using ass(1)
	+ by (intro exI[of _ ?f]) auto}
	+ then have *: "{ts. length ts = length vs \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>)} -
	+ {map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm} =
	+ {map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm}"
	+ apply auto
	+ apply force
	+ using formula_relevantD[OF rel] unfolding eval_formula.simps
	+ by (meson map_ext)
	+ have "RRn_spec (length vs) (difference_reg (true_RRn \<F> (length vs)) ta)
	+ {map \<alpha> vs \|\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm}"
	+ using RRn_difference[OF true_RRn_spec[of "length vs" \<F>] formula_spec_RRn_spec[OF spec]]
	+ unfolding * by simp
	+ then show ?case using INot spec rel
	+ by (auto split: prod.splits simp: formula_spec_def)
	+next
	+ case (IExists l')
	+ obtain fm vs ta where [simp]: "infs ! l' = (fm, vs, ta)" by (cases "infs ! l'") auto
	+ then have spec: "formula_spec ?F ?Rs vs ta fm" using infs[OF nth_mem, of l'] IExists
	+ by auto
	+ show ?case
	+ proof (cases "length vs = 0")
	+ case True
	+ then show ?thesis using IExists spec
	+ apply (auto simp: formula_spec_def)
	+ subgoal apply (auto simp: formula_relevant_def)
	+ apply (meson shift_rangeI)
	+ done
	+ subgoal apply (auto simp: RRn_spec_def image_iff)
	+ apply (meson eval_formula_shift_right_eval(1) rangeI shift_right_rangeI subsetD)
	+ apply (meson shift_rangeI)
	+ done
	+ done
	+ next
	+ case False note len = this
	+ then have *[simp]: "vs \<noteq> []" by (cases vs) auto
	+ show ?thesis
	+ proof (cases "reg_empty ta")
	+ case True
	+ then show ?thesis using IExists spec formula_spec_empty[OF _ spec]
	+ by (auto simp: \<T>\<^sub>G_equivalent_def comp_def formula_spec_def
	+ shift_rangeI RRn_spec_def image_iff \<L>_epmty
	+ intro!: trivial_formula_relevant)
	+ next
	+ case False
	+ then have nt_empty [simp]: "\<L> ta \<noteq> {}" by auto
	+ show ?thesis
	+ proof (cases "0 \<notin> set vs")
	+ case True
	+ then have ta: "ta = A'" using spec IExists
	+ by (auto simp: formula_spec_def)
	+ from True have relv: "formula_relevant ?F ?Rs (map (\<lambda>x. x - Suc 0) vs) (FExists fm)"
	+ using spec IExists
	+ by (intro ExistsI_upd_brujin_no_0) (auto simp: formula_spec_def)
	+ then show ?thesis using True spec IExists nt_rel_0_trivial_shift[OF True, of ?F ?Rs ]
	+ by (auto simp: formula_spec_def \<T>\<^sub>G_equivalent_def comp_def
	+ elim!: formula_relevantD
	+ intro!: pres_distinct_not_0_list_dec pres_sorted_dec)
	+ next
	+ case False
	+ then have rel_0: "0 \<in> set vs" by simp
	+ show ?thesis
	+ proof (cases "1 = length vs")
	+ case True
	+ then have [simp]: "vs = [0]" using rel_0 by (induct vs) auto
	+ {fix t assume "0 \|\<in>\| ta_der (TA {\|[] [] \<rightarrow> 0\|} {\|\|}) (term_of_gterm t)"
	+ then have "t = GFun [] []" by (cases t) auto}
	+ then have [simp]: "\<L> (Reg {\|0\|} (TA {\|TA_rule [] [] 0\|} {\|\|})) = {GFun [] []}"
	+ by (auto simp: \<L>_def gta_der_def gta_lang_def)
	+ have [simp]: "GFun [] [] = gencode []"
	+ by (auto simp: gencode_def gunions_def)
	+ show ?thesis using IExists spec nt_empty
	+ by (auto simp: formula_spec_def RRn_spec_true_RRn RRn_spec_def formula_relevant_0_FExists image_iff)
	+ (meson eval_formula_shift_right_eval(1) in_mono rangeI shift_right_rangeI)
	+ next
	+ case False
	+ from False show ?thesis using spec IExists rel_0 nt_empty
	+ using rrn_drop_fst_lang[OF formula_spec_RRn_spec[OF spec]]
	+ by (auto simp: formula_spec_def Suc_lessI simp flip: drop_upd_bruijn_set
	+ split: prod.splits
	+ intro: upd_bruijn_pres_sorted upd_bruijn_pres_distinct ExistsI_upd_brujin_0)
	+ qed
	+ qed
	+ qed
	+ qed
	+next
	+ case (IRename l' vs)
	+ then show ?case by simp
	+next
	+ case (INNFPlus l')
	+ show ?case using infs[OF nth_mem, of l'] INNFPlus
	+ apply (auto simp: formula_spec_def formula_relevant_def eval_formula_conv)
	+ apply (simp_all only: check_equivalence_by_nnf_sortedlist_aci[of "form_of_formula (fst (infs ! l'))" "form_of_formula fm"])
	+ done
	+next
	+ case (IRepl eq pos l')
	+ then show ?case by simp
	+}
	+qed
	+
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/FOR_Check_Impl.thy b/thys/FO_Theory_Rewriting/FOR_Check_Impl.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/FOR_Check_Impl.thy
	@@ -0,0 +1,773 @@
	+theory FOR_Check_Impl
	+ imports FOR_Check
	+ Regular_Tree_Relations.Regular_Relation_Impl
	+ NF_Impl
	+begin
	+
	+section \<open>Inference checking implementation\<close>
	+
	+(* we define epsilon free agtt/gtt constructions *)
	+definition "ftrancl_eps_free_closures \<A> = eps_free_automata (eps \<A>) \<A>"
	+abbreviation "ftrancl_eps_free_reg \<A> \<equiv> Reg (fin \<A>) (ftrancl_eps_free_closures (ta \<A>))"
	+
	+lemma ftrancl_eps_free_ta_derI:
	+ "(eps \<A>)\|\<^sup>+\| = eps \<A> \<Longrightarrow> ta_der (ftrancl_eps_free_closures \<A>) (term_of_gterm t) = ta_der \<A> (term_of_gterm t)"
	+ using eps_free[of \<A>] ta_res_eps_free[of \<A>]
	+ by (auto simp add: ftrancl_eps_free_closures_def)
	+
	+lemma \<L>_ftrancl_eps_free_closuresI:
	+ "(eps (ta \<A>))\|\<^sup>+\| = eps (ta \<A>) \<Longrightarrow> \<L> (ftrancl_eps_free_reg \<A>) = \<L> \<A>"
	+ using ftrancl_eps_free_ta_derI[of "ta \<A>"]
	+ unfolding \<L>_def by (auto simp: gta_lang_def gta_der_def)
	+
	+definition "root_step R \<F> \<equiv> (let (TA1, TA2) = agtt_grrstep R \<F> in
	+ (ftrancl_eps_free_closures TA1, TA2))"
	+
	+definition AGTT_trancl_eps_free :: "('q, 'f) gtt \<Rightarrow> ('q + 'q, 'f) gtt" where
	+ "AGTT_trancl_eps_free \<G> = (let (\<A>, \<B>) = AGTT_trancl \<G> in
	+ (ftrancl_eps_free_closures \<A>, \<B>))"
	+
	+definition GTT_trancl_eps_free where
	+ "GTT_trancl_eps_free \<G> = (let (\<A>, \<B>) = GTT_trancl \<G> in
	+ (ftrancl_eps_free_closures \<A>,
	+ ftrancl_eps_free_closures \<B>))"
	+
	+definition AGTT_comp_eps_free where
	+ "AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2 = (let (\<A>, \<B>) = AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 in
	+ (ftrancl_eps_free_closures \<A>, \<B>))"
	+
	+definition GTT_comp_eps_free where
	+ "GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2 =(let (\<A>, \<B>) = GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 in
	+ (ftrancl_eps_free_closures \<A>, ftrancl_eps_free_closures \<B>))"
	+
	+(* epsilon free proves *)
	+lemma eps_free_relable [simp]:
	+ "is_gtt_eps_free (relabel_gtt \<G>) = is_gtt_eps_free \<G>"
	+ by (auto simp: is_gtt_eps_free_def relabel_gtt_def fmap_states_gtt_def fmap_states_ta_def)
	+
	+lemma eps_free_prod_swap:
	+ "is_gtt_eps_free (\<A>, \<B>) \<Longrightarrow> is_gtt_eps_free (\<B>, \<A>)"
	+ by (auto simp: is_gtt_eps_free_def)
	+
	+lemma eps_free_root_step:
	+ "is_gtt_eps_free (root_step R \<F>)"
	+ by (auto simp add: case_prod_beta is_gtt_eps_free_def root_step_def pair_at_to_agtt'_def ftrancl_eps_free_closures_def)
	+
	+lemma eps_free_AGTT_trancl_eps_free:
	+ "is_gtt_eps_free \<G> \<Longrightarrow> is_gtt_eps_free (AGTT_trancl_eps_free \<G>)"
	+ by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_trancl_def Let_def
	+ AGTT_trancl_eps_free_def ftrancl_eps_free_closures_def)
	+
	+lemma eps_free_GTT_trancl_eps_free:
	+ "is_gtt_eps_free \<G> \<Longrightarrow> is_gtt_eps_free (GTT_trancl_eps_free \<G>)"
	+ by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_trancl_eps_free_def ftrancl_eps_free_closures_def)
	+
	+lemma eps_free_AGTT_comp_eps_free:
	+ "is_gtt_eps_free \<G>\<^sub>2 \<Longrightarrow> is_gtt_eps_free (AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2)"
	+ by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_comp_eps_free_def
	+ ftrancl_eps_free_closures_def AGTT_comp_def fmap_states_gtt_def fmap_states_ta_def)
	+
	+lemma eps_free_GTT_comp_eps_free:
	+ "is_gtt_eps_free (GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2)"
	+ by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_comp_eps_free_def ftrancl_eps_free_closures_def)
	+
	+lemmas eps_free_const =
	+ eps_free_prod_swap
	+ eps_free_root_step
	+ eps_free_AGTT_trancl_eps_free
	+ eps_free_GTT_trancl_eps_free
	+ eps_free_AGTT_comp_eps_free
	+ eps_free_GTT_comp_eps_free
	+
	+(* lang preserve proofs *)
	+lemma agtt_lang_derI:
	+ assumes "\<And> t. ta_der (fst \<A>) (term_of_gterm t) = ta_der (fst \<B>) (term_of_gterm t)"
	+ and "\<And> t. ta_der (snd \<A>) (term_of_gterm t) = ta_der (snd \<B>) (term_of_gterm t)"
	+ shows "agtt_lang \<A> = agtt_lang \<B>" using assms
	+ by (auto simp: agtt_lang_def gta_der_def)
	+
	+lemma agtt_lang_root_step_conv:
	+ "agtt_lang (root_step R \<F>) = agtt_lang (agtt_grrstep R \<F>)"
	+ using ftrancl_eps_free_ta_derI[OF agtt_grrstep_eps_trancl(1), of R \<F>]
	+ by (auto simp: case_prod_beta root_step_def intro!: agtt_lang_derI)
	+
	+lemma agtt_lang_AGTT_trancl_eps_free_conv:
	+ assumes "is_gtt_eps_free \<G>"
	+ shows "agtt_lang (AGTT_trancl_eps_free \<G>) = agtt_lang (AGTT_trancl \<G>)"
	+proof -
	+ let ?eps = "eps (fst (AGTT_trancl \<G>))"
	+ have "?eps \|O\| ?eps = {\|\|}" using assms
	+ by (auto simp: AGTT_trancl_def is_gtt_eps_free_def Let_def fmap_states_ta_def)
	+ from ftrancl_eps_free_ta_derI[OF frelcomp_empty_ftrancl_simp[OF this]]
	+ show ?thesis
	+ by (auto simp: case_prod_beta AGTT_trancl_eps_free_def intro!: agtt_lang_derI)
	+qed
	+
	+lemma agtt_lang_GTT_trancl_eps_free_conv:
	+ assumes "is_gtt_eps_free \<G>"
	+ shows "agtt_lang (GTT_trancl_eps_free \<G>) = agtt_lang (GTT_trancl \<G>)"
	+proof -
	+ have "(eps (fst (GTT_trancl \<G>)))\|\<^sup>+\| = eps (fst (GTT_trancl \<G>))"
	+ "(eps (snd (GTT_trancl \<G>)))\|\<^sup>+\| = eps (snd (GTT_trancl \<G>))" using assms
	+ by (auto simp: GTT_trancl_def Let_def is_gtt_eps_free_def \<Delta>_trancl_inv)
	+ from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
	+ show ?thesis
	+ by (auto simp: case_prod_beta GTT_trancl_eps_free_def intro!: agtt_lang_derI)
	+qed
	+
	+lemma agtt_lang_AGTT_comp_eps_free_conv:
	+ assumes "is_gtt_eps_free \<G>\<^sub>1" "is_gtt_eps_free \<G>\<^sub>2"
	+ shows "agtt_lang (AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)"
	+proof -
	+ have "(eps (fst (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))\|\<^sup>+\| = eps (fst (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))" using assms
	+ by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def
	+ case_prod_beta AGTT_comp_def gtt_interface_def \<Q>_def intro!: frelcomp_empty_ftrancl_simp)
	+ from ftrancl_eps_free_ta_derI[OF this] show ?thesis
	+ by (auto simp: case_prod_beta AGTT_comp_eps_free_def intro!: agtt_lang_derI)
	+qed
	+
	+lemma agtt_lang_GTT_comp_eps_free_conv:
	+ assumes "is_gtt_eps_free \<G>\<^sub>1" "is_gtt_eps_free \<G>\<^sub>2"
	+ shows "agtt_lang (GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)"
	+proof -
	+ have "(eps (fst (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))\|\<^sup>+\| = eps (fst (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))"
	+ "(eps (snd (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))\|\<^sup>+\| = eps (snd (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))" using assms
	+ by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def \<Delta>\<^sub>\<epsilon>_fmember
	+ case_prod_beta GTT_comp_def gtt_interface_def \<Q>_def dest!: ground_ta_der_statesD
	+ intro!: frelcomp_empty_ftrancl_simp)
	+ from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
	+ show ?thesis
	+ by (auto simp: case_prod_beta GTT_comp_eps_free_def intro!: agtt_lang_derI)
	+qed
	+
	+fun gtt_of_gtt_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs gtt_rel \<Rightarrow> (nat, 'f) gtt option" where
	+ "gtt_of_gtt_rel_impl \<F> Rs (ARoot is) = liftO1 (\<lambda>R. relabel_gtt (root_step R \<F>)) (is_to_trs' Rs is)"
	+\| "gtt_of_gtt_rel_impl \<F> Rs (GInv g) = liftO1 prod.swap (gtt_of_gtt_rel_impl \<F> Rs g)"
	+\| "gtt_of_gtt_rel_impl \<F> Rs (AUnion g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_union' g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
	+\| "gtt_of_gtt_rel_impl \<F> Rs (ATrancl g) = liftO1 (relabel_gtt \<circ> AGTT_trancl_eps_free) (gtt_of_gtt_rel_impl \<F> Rs g)"
	+\| "gtt_of_gtt_rel_impl \<F> Rs (GTrancl g) = liftO1 GTT_trancl_eps_free (gtt_of_gtt_rel_impl \<F> Rs g)"
	+\| "gtt_of_gtt_rel_impl \<F> Rs (AComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
	+\| "gtt_of_gtt_rel_impl \<F> Rs (GComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (GTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
	+
	+lemma gtt_of_gtt_rel_impl_is_gtt_eps_free:
	+ "gtt_of_gtt_rel_impl \<F> Rs g = Some g' \<Longrightarrow> is_gtt_eps_free g'"
	+proof (induct g arbitrary: g')
	+ case (AUnion g1 g2)
	+ then show ?case
	+ by (auto simp: is_gtt_eps_free_def AGTT_union_def fmap_states_gtt_def fmap_states_ta_def ta_union_def relabel_gtt_def)
	+qed (auto simp: eps_free_const)
	+
	+lemma gtt_of_gtt_rel_impl_gtt_of_gtt_rel:
	+ "gtt_of_gtt_rel_impl \<F> Rs g \<noteq> None \<longleftrightarrow> gtt_of_gtt_rel \<F> Rs g \<noteq> None" (is "?Ls \<longleftrightarrow> ?Rs")
	+proof -
	+ have "?Ls \<Longrightarrow> ?Rs" by (induct g) auto
	+ moreover have "?Rs \<Longrightarrow> ?Ls" by (induct g) auto
	+ ultimately show ?thesis by blast
	+qed
	+
	+lemma gtt_of_gtt_rel_impl_sound:
	+ "gtt_of_gtt_rel_impl \<F> Rs g = Some g' \<Longrightarrow> gtt_of_gtt_rel \<F> Rs g = Some g'' \<Longrightarrow> agtt_lang g' = agtt_lang g''"
	+proof (induct g arbitrary: g' g'')
	+ case (ARoot x)
	+ then show ?case by (simp add: agtt_lang_root_step_conv)
	+next
	+ case (GInv g)
	+ then have "agtt_lang (prod.swap g') = agtt_lang (prod.swap g'')" by auto
	+ then show ?case
	+ by (metis converse_agtt_lang converse_converse)
	+next
	+ case (AUnion g1 g2)
	+ then show ?case
	+ by simp (metis AGTT_union'_sound option.sel)
	+next
	+ case (ATrancl g)
	+ then show ?case
	+ using agtt_lang_AGTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g]
	+ by simp (metis AGTT_trancl_sound option.sel)
	+next
	+ case (GTrancl g)
	+ then show ?case
	+ using agtt_lang_GTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g]
	+ by simp (metis GTT_trancl_alang option.sel)
	+next
	+ case (AComp g1 g2)
	+ then show ?case
	+ using agtt_lang_AGTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g
	+ "the (gtt_of_gtt_rel_impl \<F> Rs g1)" "the (gtt_of_gtt_rel_impl \<F> Rs g2)"]
	+ by simp (metis AGTT_comp'_sound agtt_lang_AGTT_comp_eps_free_conv gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel)
	+next
	+ case (GComp g1 g2)
	+ then show ?case
	+ using agtt_lang_GTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g
	+ "the (gtt_of_gtt_rel_impl \<F> Rs g1)" "the (gtt_of_gtt_rel_impl \<F> Rs g2)"]
	+ by simp (metis agtt_lang_GTT_comp_eps_free_conv gtt_comp'_alang gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel)
	+qed
	+
	+(* eps free closure constructions *)
	+lemma \<L>_eps_free_nhole_ctxt_closure_reg:
	+ assumes "is_ta_eps_free (ta \<A>)"
	+ shows "\<L> (ftrancl_eps_free_reg (nhole_ctxt_closure_reg \<F> \<A>)) = \<L> (nhole_ctxt_closure_reg \<F> \<A>)"
	+proof -
	+ have "eps (ta (nhole_ctxt_closure_reg \<F> \<A>)) \|O\| eps (ta (nhole_ctxt_closure_reg \<F> \<A>)) = {\|\|}" using assms
	+ by (auto simp: nhole_ctxt_closure_reg_def gen_nhole_ctxt_closure_reg_def
	+ gen_nhole_ctxt_closure_automaton_def ta_union_def reflcl_over_nhole_ctxt_ta_def
	+ fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
	+ from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
	+ by (intro \<L>_ftrancl_eps_free_closuresI) simp
	+qed
	+
	+lemma \<L>_eps_free_ctxt_closure_reg:
	+ assumes "is_ta_eps_free (ta \<A>)"
	+ shows "\<L> (ftrancl_eps_free_reg (ctxt_closure_reg \<F> \<A>)) = \<L> (ctxt_closure_reg \<F> \<A>)"
	+proof -
	+ have "eps (ta (ctxt_closure_reg \<F> \<A>)) \|O\| eps (ta (ctxt_closure_reg \<F> \<A>)) = {\|\|}" using assms
	+ by (auto simp: ctxt_closure_reg_def gen_ctxt_closure_reg_def Let_def
	+ gen_ctxt_closure_automaton_def ta_union_def reflcl_over_single_ta_def
	+ fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
	+ from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
	+ by (intro \<L>_ftrancl_eps_free_closuresI) simp
	+qed
	+
	+lemma \<L>_eps_free_parallel_closure_reg:
	+ assumes "is_ta_eps_free (ta \<A>)"
	+ shows "\<L> (ftrancl_eps_free_reg (parallel_closure_reg \<F> \<A>)) = \<L> (parallel_closure_reg \<F> \<A>)"
	+proof -
	+ have "eps (ta (parallel_closure_reg \<F> \<A>)) \|O\| eps (ta (parallel_closure_reg \<F> \<A>)) = {\|\|}" using assms
	+ by (auto simp: parallel_closure_reg_def gen_parallel_closure_automaton_def Let_def ta_union_def
	+ refl_over_states_ta_def fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
	+ from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
	+ by (intro \<L>_ftrancl_eps_free_closuresI) simp
	+qed
	+
	+abbreviation "eps_free_reg' S R \<equiv> Reg (fin R) (eps_free_automata S (ta R))"
	+
	+definition "eps_free_mctxt_closure_reg \<F> \<A> =
	+ (let \<B> = mctxt_closure_reg \<F> \<A> in
	+ eps_free_reg' ((\<lambda> p. (fst p, Inr cl_state)) \|`\| (eps (ta \<B>)) \|\<union>\| eps (ta \<B>)) \<B>)"
	+
	+definition "eps_free_nhole_mctxt_reflcl_reg \<F> \<A> =
	+ (let \<B> = nhole_mctxt_reflcl_reg \<F> \<A> in
	+ eps_free_reg' ((\<lambda> p. (fst p, Inl (Inr cl_state))) \|`\| (eps (ta \<B>)) \|\<union>\| eps (ta \<B>)) \<B>)"
	+
	+definition "eps_free_nhole_mctxt_closure_reg \<F> \<A> =
	+ (let \<B> = nhole_mctxt_closure_reg \<F> \<A> in
	+ eps_free_reg' ((\<lambda> p. (fst p, (Inr cl_state))) \|`\| (eps (ta \<B>)) \|\<union>\| eps (ta \<B>)) \<B>)"
	+
	+lemma \<L>_eps_free_reg'I:
	+ "(eps (ta \<A>))\|\<^sup>+\| = S \<Longrightarrow> \<L> (eps_free_reg' S \<A>) = \<L> \<A>"
	+ by (auto simp: \<L>_def gta_lang_def gta_der_def ta_res_eps_free simp flip: eps_free)
	+
	+lemma \<L>_eps_free_mctxt_closure_reg:
	+ assumes "is_ta_eps_free (ta \<A>)"
	+ shows "\<L> (eps_free_mctxt_closure_reg \<F> \<A>) = \<L> (mctxt_closure_reg \<F> \<A>)" using assms
	+ unfolding eps_free_mctxt_closure_reg_def Let_def
	+ apply (intro \<L>_eps_free_reg'I)
	+ apply (auto simp: comp_def mctxt_closure_reg_def is_ta_eps_free_def Let_def
	+ gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
	+ reflcl_over_nhole_ctxt_ta_def gen_mctxt_closure_reg_def reg_Restr_Q\<^sub>f_def
	+ fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
	+ by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)
	+
	+lemma \<L>_eps_free_nhole_mctxt_reflcl_reg:
	+ assumes "is_ta_eps_free (ta \<A>)"
	+ shows "\<L> (eps_free_nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_reflcl_reg \<F> \<A>)" using assms
	+ unfolding eps_free_nhole_mctxt_reflcl_reg_def Let_def
	+ apply (intro \<L>_eps_free_reg'I)
	+ apply (auto simp: comp_def nhole_mctxt_reflcl_reg_def is_ta_eps_free_def Let_def
	+ nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def reg_union_def ta_union_def
	+ gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
	+ reflcl_over_nhole_ctxt_ta_def reg_Restr_Q\<^sub>f_def fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
	+ by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)
	+
	+lemma \<L>_eps_free_nhole_mctxt_closure_reg:
	+ assumes "is_ta_eps_free (ta \<A>)"
	+ shows "\<L> (eps_free_nhole_mctxt_closure_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<F> \<A>)" using assms
	+ unfolding eps_free_nhole_mctxt_closure_reg_def Let_def
	+ apply (intro \<L>_eps_free_reg'I)
	+ apply (auto simp: comp_def nhole_mctxt_closure_reg_def is_ta_eps_free_def Let_def
	+ gen_nhole_mctxt_closure_reg_def reg_Restr_Q\<^sub>f_def fmap_states_reg_def fmap_states_ta_def
	+ gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
	+ reflcl_over_nhole_ctxt_ta_def dest: ftranclD ftranclD2)
	+ by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)
	+
	+fun rr1_of_rr1_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> (nat, 'f) reg option"
	+and rr2_of_rr2_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> (nat, 'f option \<times> 'f option) reg option" where
	+ "rr1_of_rr1_rel_impl \<F> Rs R1Terms = Some (relabel_reg (term_reg \<F>))"
	+\| "rr1_of_rr1_rel_impl \<F> Rs (R1NF is) = liftO1 (\<lambda>R. (simplify_reg (nf_reg (fst \|`\| R) \<F>))) (is_to_trs' Rs is)"
	+\| "rr1_of_rr1_rel_impl \<F> Rs (R1Inf r) = liftO1 (\<lambda>R.
	+ let \<A> = trim_reg R in
	+ simplify_reg (proj_1_reg (Inf_reg_impl \<A>))
	+ ) (rr2_of_rr2_rel_impl \<F> Rs r)"
	+\| "rr1_of_rr1_rel_impl \<F> Rs (R1Proj i r) = (case i of 0 \<Rightarrow>
	+ liftO1 (trim_reg \<circ> proj_1_reg) (rr2_of_rr2_rel_impl \<F> Rs r)
	+ \| _ \<Rightarrow> liftO1 (trim_reg \<circ> proj_2_reg) (rr2_of_rr2_rel_impl \<F> Rs r))"
	+\| "rr1_of_rr1_rel_impl \<F> Rs (R1Union s1 s2) =
	+ liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
	+\| "rr1_of_rr1_rel_impl \<F> Rs (R1Inter s1 s2) =
	+ liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
	+\| "rr1_of_rr1_rel_impl \<F> Rs (R1Diff s1 s2) = liftO2 (\<lambda> x y. relabel_reg (trim_reg (difference_reg x y))) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
	+
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2GTT_Rel g w x) =
	+ (case w of PRoot \<Rightarrow>
	+ (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
	+ \| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> reflcl_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
	+ \| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g))
	+ \| PNonRoot \<Rightarrow>
	+ (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> nhole_ctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
	+ \| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_nhole_mctxt_reflcl_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
	+ \| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_nhole_mctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g))
	+ \| PAny \<Rightarrow>
	+ (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> ctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
	+ \| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> parallel_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
	+ \| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_mctxt_closure_reg (lift_sig_RR2 \|`\| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)))"
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2Diag s) =
	+ liftO1 (\<lambda> x. fmap_funs_reg (\<lambda>f. (Some f, Some f)) x) (rr1_of_rr1_rel_impl \<F> Rs s)"
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2Prod s1 s2) =
	+ liftO2 (\<lambda> x y. simplify_reg (pair_automaton_reg x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2Inv r) = liftO1 (fmap_funs_reg prod.swap) (rr2_of_rr2_rel_impl \<F> Rs r)"
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2Union r1 r2) =
	+ liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2Inter r1 r2) =
	+ liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2Diff r1 r2) = liftO2 (\<lambda> x y. simplify_reg (difference_reg x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
	+\| "rr2_of_rr2_rel_impl \<F> Rs (R2Comp r1 r2) = liftO2 (\<lambda> x y. simplify_reg (rr2_compositon \<F> x y))
	+ (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
	+
	+lemmas ta_simp_unfold = simplify_reg_def relabel_reg_def trim_reg_def relabel_ta_def term_reg_def
	+lemma is_ta_eps_free_trim_reg [intro!]:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (trim_reg R))"
	+ by (simp add: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)
	+
	+lemma is_ta_eps_free_relabel_reg [intro!]:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (relabel_reg R))"
	+ by (simp add: is_ta_eps_free_def relabel_reg_def relabel_ta_def fmap_states_ta_def)
	+
	+lemma is_ta_eps_free_simplify_reg [intro!]:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (simplify_reg R))"
	+ by (simp add: is_ta_eps_free_def ta_simp_unfold fmap_states_ta_def trim_ta_def ta_restrict_def)
	+
	+lemma is_ta_emptyI [simp]:
	+ "is_ta_eps_free (TA R {\|\|}) \<longleftrightarrow> True"
	+ by (simp add: is_ta_eps_free_def)
	+
	+lemma is_ta_empty_trim_reg:
	+ "is_ta_eps_free (ta A) \<Longrightarrow> eps (ta (trim_reg A)) = {\|\|}"
	+ by (auto simp: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)
	+
	+lemma is_proj_ta_eps_empty:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (proj_1_reg R))"
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (proj_2_reg R))"
	+ by (auto simp: is_ta_eps_free_def proj_1_reg_def proj_2_reg_def collapse_automaton_reg_def collapse_automaton_def
	+ fmap_funs_reg_def fmap_funs_ta_def trim_reg_def trim_ta_def ta_restrict_def)
	+
	+lemma is_pod_ta_eps_empty:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta L) \<Longrightarrow> is_ta_eps_free (ta (reg_intersect R L))"
	+ by (auto simp: reg_intersect_def prod_ta_def prod_epsRp_def prod_epsLp_def is_ta_eps_free_def)
	+
	+lemma is_fmap_funs_reg_eps_empty:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (fmap_funs_reg f R))"
	+ by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
	+
	+lemma is_collapse_automaton_reg_eps_empty:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (collapse_automaton_reg R))"
	+ by (auto simp: collapse_automaton_reg_def collapse_automaton_def is_ta_eps_free_def)
	+
	+lemma is_pair_automaton_reg_eps_empty:
	+ "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta L) \<Longrightarrow> is_ta_eps_free (ta (pair_automaton_reg R L))"
	+ by (auto simp: pair_automaton_reg_def pair_automaton_def is_ta_eps_free_def)
	+
	+lemma is_reflcl_automaton_eps_free:
	+ "is_ta_eps_free A \<Longrightarrow> is_ta_eps_free (reflcl_automaton (lift_sig_RR2 \|`\| \<F>) A)"
	+ by (auto simp: is_ta_eps_free_def reflcl_automaton_def ta_union_def gen_reflcl_automaton_def Let_def fmap_states_ta_def)
	+
	+lemma is_GTT_to_RR2_root_eps_empty:
	+ "is_gtt_eps_free \<G> \<Longrightarrow> is_ta_eps_free (GTT_to_RR2_root \<G>)"
	+ by (auto simp: is_gtt_eps_free_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def)
	+
	+lemma is_term_automata_eps_empty:
	+ "is_ta_eps_free (ta (term_reg \<F>)) \<longleftrightarrow> True"
	+ by (auto simp: is_ta_eps_free_def term_reg_def term_automaton_def)
	+
	+lemma is_ta_eps_free_eps_free_automata [simp]:
	+ " is_ta_eps_free (eps_free_automata S R) \<longleftrightarrow> True"
	+ by (auto simp: eps_free_automata_def is_ta_eps_free_def)
	+
	+lemma rr2_of_rr2_rel_impl_eps_free:
	+ shows "\<forall> A. rr1_of_rr1_rel_impl \<F> Rs r1 = Some A \<longrightarrow> is_ta_eps_free (ta A)"
	+ "\<forall> A. rr2_of_rr2_rel_impl \<F> Rs r2 = Some A \<longrightarrow> is_ta_eps_free (ta A)"
	+proof (induct r1 and r2)
	+case R1Terms
	+ then show ?case
	+ by (auto simp: is_ta_eps_free_def term_automaton_def fmap_states_ta_def ta_simp_unfold)
	+next
	+ case (R1NF x)
	+ then show ?case
	+ by (auto simp: nf_reg_def nf_ta_def)
	+next
	+ case (R1Inf x)
	+ then show ?case
	+ by (auto simp: Inf_reg_impl_def Let_def Inf_reg_def Inf_automata_def is_ta_empty_trim_reg intro!: is_proj_ta_eps_empty)
	+next
	+ case (R1Proj n x2)
	+ then show ?case
	+ by (cases n) (auto intro!: is_proj_ta_eps_empty)
	+next
	+ case (R1Union x1 x2)
	+ then show ?case
	+ by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
	+next
	+ case (R1Inter x1 x2)
	+ then show ?case
	+ by (auto intro: is_pod_ta_eps_empty)
	+next
	+ case (R1Diff x1 x2)
	+ then show ?case
	+ by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
	+next
	+ case (R2GTT_Rel x1 x2 x3)
	+ then show ?case
	+ by (cases x2; cases x3) (auto simp: GTT_to_RR2_root_reg_def ftrancl_eps_free_closures_def
	+ eps_free_nhole_mctxt_closure_reg_def eps_free_nhole_mctxt_reflcl_reg_def Let_def
	+ eps_free_mctxt_closure_reg_def reflcl_reg_def
	+ dest: gtt_of_gtt_rel_impl_is_gtt_eps_free
	+ intro!: is_GTT_to_RR2_root_eps_empty is_reflcl_automaton_eps_free)
	+next
	+ case (R2Diag x)
	+ then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
	+next
	+ case (R2Prod x1 x2)
	+ then show ?case by (auto intro: is_pair_automaton_reg_eps_empty)
	+next
	+ case (R2Inv x)
	+ then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
	+next
	+ case (R2Union x1 x2)
	+ then show ?case by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
	+next
	+ case (R2Inter x1 x2)
	+ then show ?case by (auto intro: is_pod_ta_eps_empty)
	+next
	+ case (R2Diff x1 x2)
	+ then show ?case by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
	+next
	+ case (R2Comp x1 x2)
	+ then show ?case by (auto simp: is_term_automata_eps_empty rr2_compositon_def Let_def
	+ intro!: is_pod_ta_eps_empty is_fmap_funs_reg_eps_empty is_collapse_automaton_reg_eps_empty is_pair_automaton_reg_eps_empty)
	+qed
	+
	+lemma rr_of_rr_rel_impl_complete:
	+ "rr1_of_rr1_rel_impl \<F> Rs r1 \<noteq> None \<longleftrightarrow> rr1_of_rr1_rel \<F> Rs r1 \<noteq> None"
	+ "rr2_of_rr2_rel_impl \<F> Rs r2 \<noteq> None \<longleftrightarrow> rr2_of_rr2_rel \<F> Rs r2 \<noteq> None"
	+proof (induct r1 and r2)
	+ case (R1Proj n x2)
	+ then show ?case by (cases n) auto
	+next
	+ case (R2GTT_Rel x1 n p)
	+ then show ?case using gtt_of_gtt_rel_impl_gtt_of_gtt_rel[of \<F> Rs]
	+ by (cases p; cases n) auto
	+qed auto
	+
	+lemma \<Q>_fmap_funs_reg [simp]:
	+ "\<Q>\<^sub>r (fmap_funs_reg f \<A>) = \<Q>\<^sub>r \<A>"
	+ by (auto simp: fmap_funs_reg_def)
	+
	+lemma ta_reachable_fmap_funs_reg [simp]:
	+ "ta_reachable (ta (fmap_funs_reg f \<A>)) = ta_reachable (ta \<A>)"
	+ by (auto simp: fmap_funs_reg_def)
	+
	+lemma collapse_reg_cong:
	+ "\<Q>\<^sub>r \<A> \|\<subseteq>\| ta_reachable (ta \<A>) \<Longrightarrow> \<Q>\<^sub>r \<B> \|\<subseteq>\| ta_reachable (ta \<B>) \<Longrightarrow> \<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (collapse_automaton_reg \<A>) = \<L> (collapse_automaton_reg \<B>)"
	+ by (auto simp: collapse_automaton_reg_def \<L>_def collapse_automaton')
	+
	+lemma \<L>_fmap_funs_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (fmap_funs_reg h \<A>) = \<L> (fmap_funs_reg h \<B>)"
	+ by (auto simp: fmap_funs_\<L>)
	+
	+lemma \<L>_pair_automaton_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> \<C> = \<L> \<D> \<Longrightarrow> \<L> (pair_automaton_reg \<A> \<C>) = \<L> (pair_automaton_reg \<B> \<D>)"
	+ by (auto simp: pair_automaton')
	+
	+lemma \<L>_nhole_ctxt_closure_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_ctxt_closure_reg \<F> \<A>) = \<L> (nhole_ctxt_closure_reg \<G> \<B>)"
	+ by (auto simp: nhole_ctxtcl_lang)
	+
	+lemma \<L>_nhole_mctxt_closure_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_mctxt_closure_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<G> \<B>)"
	+ by (auto simp: nhole_gmctxt_closure_lang)
	+
	+lemma \<L>_ctxt_closure_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (ctxt_closure_reg \<F> \<A>) = \<L> (ctxt_closure_reg \<G> \<B>)"
	+ by (auto simp: gctxt_closure_lang)
	+
	+lemma \<L>_parallel_closure_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (parallel_closure_reg \<F> \<A>) = \<L> (parallel_closure_reg \<G> \<B>)"
	+ by (auto simp: parallelcl_gmctxt_lang)
	+
	+lemma \<L>_mctxt_closure_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (mctxt_closure_reg \<F> \<A>) = \<L> (mctxt_closure_reg \<G> \<B>)"
	+ by (auto simp: gmctxt_closure_lang)
	+
	+lemma \<L>_nhole_mctxt_reflcl_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_reflcl_reg \<G> \<B>)"
	+ unfolding nhole_mctxt_reflcl_lang
	+ by (intro arg_cong2[where ?f = "(\<union>)"] \<L>_nhole_mctxt_closure_reg_cong) auto
	+
	+declare equalityI[rule del]
	+declare fsubsetI[rule del]
	+lemma \<L>_proj_1_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (proj_1_reg \<A>) = \<L> (proj_1_reg \<B>)"
	+ by (auto simp: proj_1_reg_def \<L>_trim intro!: collapse_reg_cong \<L>_fmap_funs_reg_cong)
	+
	+lemma \<L>_proj_2_reg_cong:
	+ "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (proj_2_reg \<A>) = \<L> (proj_2_reg \<B>)"
	+ by (auto simp: proj_2_reg_def \<L>_trim intro!: collapse_reg_cong \<L>_fmap_funs_reg_cong)
	+
	+lemma rr2_of_rr2_rel_impl_sound:
	+ assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>"
	+ shows "\<And> A B. rr1_of_rr1_rel_impl \<F> Rs r1 = Some A \<Longrightarrow> rr1_of_rr1_rel \<F> Rs r1 = Some B \<Longrightarrow> \<L> A = \<L> B"
	+ "\<And> A B. rr2_of_rr2_rel_impl \<F> Rs r2 = Some A \<Longrightarrow> rr2_of_rr2_rel \<F> Rs r2 = Some B \<Longrightarrow> \<L> A = \<L> B"
	+proof (induct r1 and r2)
	+ case (R1Inf r)
	+ then obtain C D where inf: "rr2_of_rr2_rel_impl \<F> Rs r = Some C" "rr2_of_rr2_rel \<F> Rs r = Some D"
	+ "\<L> C = \<L> D" by auto
	+ have spec: "RR2_spec C (eval_rr2_rel (fset \<F>) (map fset Rs) r)" "RR2_spec D (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
	+ using rr12_of_rr12_rel_correct(2)[OF assms, rule_format, OF inf(2)] inf(3)
	+ by (auto simp: RR2_spec_def)
	+ then have trim_spec: "RR2_spec (trim_reg C) (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
	+ "RR2_spec (trim_reg D) (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
	+ by (auto simp: RR2_spec_def \<L>_trim)
	+ let ?C = "Inf_reg (trim_reg C) (Q_infty (ta (trim_reg C)) \<F>)" let ?D = "Inf_reg (trim_reg D) (Q_infty (ta (trim_reg D)) \<F>)"
	+ from spec have *: "\<L> (Inf_reg_impl (trim_reg C)) = \<L> ?C"
	+ using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
	+ by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def)
	+ from spec have **: "\<L> (Inf_reg_impl (trim_reg D)) = \<L> ?D"
	+ using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
	+ by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def)
	+ then have C: "RR2_spec ?C {(s, t) \| s t. gpair s t \<in> \<L> ?C}" and
	+ D: "RR2_spec ?D {(s, t) \| s t. gpair s t \<in> \<L> ?D}"
	+ using subset_trans[OF Inf_automata_subseteq[of "trim_reg C" \<F>], of "\<L> C"] spec
	+ using subset_trans[OF Inf_automata_subseteq[of "trim_reg D" \<F>], of "\<L> D"]
	+ using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
	+ by (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def intro!: equalityI fsubsetI)
	+ from * ** have r: "\<L> (proj_1_reg (Inf_reg_impl (trim_reg C))) = \<L> (proj_1_reg ?C)"
	+ "\<L> (proj_1_reg (Inf_reg_impl (trim_reg D))) = \<L> (proj_1_reg ?D)"
	+ by (auto intro: \<L>_proj_1_reg_cong)
	+ from \<L>_Inf_reg[OF trim_spec(1), of \<F>] \<L>_Inf_reg[OF trim_spec(2), of \<F>]
	+ show ?case using R1Inf eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
	+ by (auto simp: liftO1_def r inf \<T>\<^sub>G_equivalent_def \<L>_proj(1)[OF C] \<L>_proj(1)[OF D])
	+next
	+ case (R1Proj n x2)
	+ then show ?case by (cases n)
	+ (auto simp: liftO1_def \<L>_trim proj_1_reg_def proj_2_reg_def intro!: fsubsetI \<L>_fmap_funs_reg_cong collapse_reg_cong, (meson fin_mono trim_reg_reach)+)
	+next
	+ case (R2GTT_Rel g p n) note IH = this
	+ note ass = R2GTT_Rel
	+ consider (a) "\<exists> A. gtt_of_gtt_rel_impl \<F> Rs g = Some A" \| (b) "gtt_of_gtt_rel_impl \<F> Rs g = None" by blast
	+ then show ?case
	+ proof cases
	+ case a then obtain C D where gtt [simp]: "gtt_of_gtt_rel_impl \<F> Rs g = Some C"
	+ "gtt_of_gtt_rel \<F> Rs g = Some D" using gtt_of_gtt_rel_impl_gtt_of_gtt_rel by blast
	+ from gtt_of_gtt_rel_impl_sound[OF this]
	+ have spec [simp]: "agtt_lang C = agtt_lang D" by auto
	+ have eps [simp]: "is_ta_eps_free (ta (GTT_to_RR2_root_reg C))"
	+ using gtt_of_gtt_rel_impl_is_gtt_eps_free[OF gtt(1)]
	+ by (auto simp: GTT_to_RR2_root_reg_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def is_gtt_eps_free_def)
	+ have lang: "\<L> (GTT_to_RR2_root_reg C) = \<L> (GTT_to_RR2_root_reg D)"
	+ by (metis (no_types, lifting) GTT_to_RR2_root RR2_spec_def spec)
	+ show ?thesis
	+ proof (cases p)
	+ case PRoot
	+ then show ?thesis using IH spec lang
	+ by (cases n) (auto simp: \<L>_eps_free \<L>_reflcl_reg)
	+ next
	+ case PNonRoot
	+ then show ?thesis using IH
	+ by (cases n) (auto simp: \<L>_eps_free \<L>_eps_free_nhole_ctxt_closure_reg[OF eps]
	+ \<L>_eps_free_nhole_mctxt_reflcl_reg[OF eps] \<L>_eps_free_nhole_mctxt_closure_reg[OF eps]
	+ lang intro: \<L>_nhole_ctxt_closure_reg_cong \<L>_nhole_mctxt_reflcl_reg_cong \<L>_nhole_mctxt_closure_reg_cong)
	+ next
	+ case PAny
	+ then show ?thesis using IH
	+ by (cases n) (auto simp: \<L>_eps_free \<L>_eps_free_ctxt_closure_reg[OF eps]
	+ \<L>_eps_free_parallel_closure_reg[OF eps] \<L>_eps_free_mctxt_closure_reg[OF eps] lang
	+ intro!: \<L>_ctxt_closure_reg_cong \<L>_parallel_closure_reg_cong \<L>_mctxt_closure_reg_cong)
	+ qed
	+ next
	+ case b then show ?thesis using IH
	+ by (cases p; cases n) auto
	+ qed
	+next
	+ case (R2Comp x1 x2)
	+ then show ?case
	+ by (auto simp: liftO1_def rr2_compositon_def \<L>_trim \<L>_intersect Let_def
	+ intro!: \<L>_pair_automaton_reg_cong \<L>_fmap_funs_reg_cong collapse_reg_cong arg_cong2[where ?f = "(\<inter>)"])
	+qed (auto simp: liftO1_def \<L>_intersect \<L>_union \<L>_trim \<L>_difference_reg intro!: \<L>_fmap_funs_reg_cong \<L>_pair_automaton_reg_cong)
	+declare equalityI[intro!]
	+declare fsubsetI[intro!]
	+
	+lemma rr12_of_rr12_rel_impl_correct:
	+ assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>"
	+ shows "\<forall>ta1. rr1_of_rr1_rel_impl \<F> Rs r1 = Some ta1 \<longrightarrow> RR1_spec ta1 (eval_rr1_rel (fset \<F>) (map fset Rs) r1)"
	+ "\<forall>ta2. rr2_of_rr2_rel_impl \<F> Rs r2 = Some ta2 \<longrightarrow> RR2_spec ta2 (eval_rr2_rel (fset \<F>) (map fset Rs) r2)"
	+ using rr12_of_rr12_rel_correct(1)[OF assms, of r1]
	+ using rr12_of_rr12_rel_correct(2)[OF assms, of r2]
	+ using rr2_of_rr2_rel_impl_sound(1)[OF assms, of r1]
	+ using rr2_of_rr2_rel_impl_sound(2)[OF assms, of r2]
	+ using rr_of_rr_rel_impl_complete(1)[of \<F> Rs r1]
	+ using rr_of_rr_rel_impl_complete(2)[of \<F> Rs r2]
	+ by (force simp: RR1_spec_def RR2_spec_def)+
	+
	+lemma check_inference_rrn_impl_correct:
	+ assumes sig: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" and Rs: "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>"
	+ assumes infs: "\<And>fvA. fvA \<in> set infs \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
	+ assumes inf: "check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs infs (l, step, fm, is) = Some (fm', vs, A')"
	+ shows "l = length infs \<and> fm = fm' \<and> formula_spec (fset \<F>) (map fset Rs) vs A' fm'"
	+ using check_inference_correct[where ?rr1c = rr1_of_rr1_rel_impl and ?rr2c = rr2_of_rr2_rel_impl, OF assms]
	+ using rr12_of_rr12_rel_impl_correct[OF Rs]
	+ by auto
	+
	+definition check_sig_nempty where
	+ "check_sig_nempty \<F> = (0 \|\<in>\| snd \|`\| \<F>)"
	+
	+definition check_trss where
	+ "check_trss \<R> \<F> = list_all (\<lambda> R. lv_trs (fset R) \<and> funas_trs (fset R) \<subseteq> fset \<F>) \<R>"
	+
	+lemma check_sig_nempty:
	+ "check_sig_nempty \<F> \<longleftrightarrow> \<T>\<^sub>G (fset \<F>) \<noteq> {}" (is "?Ls \<longleftrightarrow> ?Rs")
	+proof -
	+ {assume ?Ls then obtain a where "(a, 0) \|\<in>\| \<F>" by (auto simp: check_sig_nempty_def)
	+ then have "GFun a [] \<in> \<T>\<^sub>G (fset \<F>)"
	+ by (intro const) (simp add: fmember.rep_eq)
	+ then have ?Rs by blast}
	+ moreover
	+ {assume ?Rs then obtain s where "s \<in> \<T>\<^sub>G (fset \<F>)" by blast
	+ then obtain a where "(a, 0) \|\<in>\| \<F>" unfolding fmember.rep_eq
	+ by (induct s) (auto, force)
	+ then have ?Ls unfolding check_sig_nempty_def
	+ by (auto simp: fimage_iff fBex_def)}
	+ ultimately show ?thesis by blast
	+qed
	+
	+lemma check_trss:
	+ "check_trss \<R> \<F> \<longleftrightarrow> (\<forall> R \<in> set \<R>. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>)"
	+ unfolding check_trss_def list_all_iff
	+ by (auto simp: fmember.rep_eq ffunas_trs.rep_eq less_eq_fset.rep_eq)
	+
	+fun check_inference_list :: "('f \<times> nat) fset \<Rightarrow> ('f :: {compare,linorder}, 'v) fin_trs list
	+ \<Rightarrow> (nat \<times> ftrs inference \<times> ftrs formula \<times> info list) list
	+ \<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) list option" where
	+ "check_inference_list \<F> Rs infs = do {
	+ guard (check_sig_nempty \<F>);
	+ guard (check_trss Rs \<F>);
	+ foldl (\<lambda> tas inf. do {
	+ tas' \<leftarrow> tas;
	+ r \<leftarrow> check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs tas' inf;
	+ Some (tas' @ [r])
	+ })
	+ (Some []) infs
	+ }"
	+
	+lemma check_inference_list_correct:
	+ assumes "check_inference_list \<F> Rs infs = Some fvAs"
	+ shows "length infs = length fvAs \<and> (\<forall> i < length fvAs. fst (snd (snd (infs ! i))) = fst (fvAs ! i)) \<and>
	+ (\<forall> i < length fvAs. formula_spec (fset \<F>) (map fset Rs) (fst (snd (fvAs ! i))) (snd (snd (fvAs ! i))) (fst (fvAs ! i)))"
	+ using assms
	+proof (induct infs arbitrary: fvAs rule: rev_induct)
	+ note [simp] = bind_eq_Some_conv guard_simps
	+ {case Nil
	+ then show ?case by auto
	+ next
	+ case (snoc a infs)
	+ have inv: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" "\<forall>R\<in>set Rs. lv_trs (fset R) \<and> ffunas_trs R \|\<subseteq>\| \<F>"
	+ using snoc(2) by (auto simp: check_sig_nempty check_trss)
	+ from snoc(2) obtain fvAs' l steps fm fm' is' vs A' where
	+ ch: "check_inference_list \<F> Rs infs = Some fvAs'" "a = (l, steps, fm, is')"
	+ "check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs fvAs' (l, steps, fm, is') = Some (fm', vs, A')" "fvAs = fvAs' @ [(fm', vs, A')]"
	+ by (auto simp del: check_inference.simps) (metis prod_cases4)
	+ from snoc(1)[OF ch(1)] have "fvA \<in> set fvAs' \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)" for fvA
	+ by (auto dest: in_set_idx)
	+ from check_inference_rrn_impl_correct[OF inv this, of fvAs'] this
	+ show ?case using snoc(1)[OF ch(1)] ch
	+ by (auto simp del: check_inference.simps simp: nth_append)
	+ }
	+qed
	+
	+fun check_certificate where
	+ "check_certificate \<F> Rs A fm (Certificate infs claim n) = do {
	+ guard (n < length infs);
	+ guard (A \<longleftrightarrow> claim = Nonempty);
	+ guard (fm = fst (snd (snd (infs ! n))));
	+ fvA \<leftarrow> check_inference_list \<F> Rs (take (Suc n) infs);
	+ (let E = reg_empty (snd (snd (last fvA))) in
	+ case claim of Empty \<Rightarrow> Some E
	+ \| _ \<Rightarrow> Some (\<not> E))
	+ }"
	+
	+definition formula_unsatisfiable where
	+ "formula_unsatisfiable \<F> Rs fm \<longleftrightarrow> (formula_satisfiable \<F> Rs fm = False)"
	+
	+definition correct_certificate where
	+ "correct_certificate \<F> Rs claim infs n \<equiv>
	+ (claim = Empty \<longleftrightarrow> (formula_unsatisfiable (fset \<F>) (map fset Rs) (fst (snd (snd (infs ! n))))) \<and>
	+ claim = Nonempty \<longleftrightarrow> formula_satisfiable (fset \<F>) (map fset Rs) (fst (snd (snd (infs ! n)))))"
	+
	+lemma check_certificate_sound:
	+ assumes "check_certificate \<F> Rs A fm (Certificate infs claim n) = Some B"
	+ shows "fm = fst (snd (snd (infs ! n)))" "A \<longleftrightarrow> claim = Nonempty"
	+ using assms by (auto simp: bind_eq_Some_conv guard_simps)
	+
	+lemma check_certificate_correct:
	+ assumes "check_certificate \<F> Rs A fm (Certificate infs claim n) = Some B"
	+ shows "(B = True \<longrightarrow> correct_certificate \<F> Rs claim infs n) \<and>
	+ (B = False \<longrightarrow> correct_certificate \<F> Rs (case_claim Nonempty Empty claim) infs n)"
	+proof -
	+ note [simp] = bind_eq_Some_conv guard_simps
	+ from assms obtain fvAs where inf: "check_inference_list \<F> Rs (take (Suc n) infs) = Some fvAs"
	+ by auto
	+ from assms have len: "n < length infs" by auto
	+ from check_inference_list_correct[OF inf] have
	+ inv: "length fvAs = n + 1"
	+ "fst (snd (snd (infs ! n))) = fst (fvAs ! n)"
	+ "formula_spec (fset \<F>) (map fset Rs) (fst (snd (last fvAs))) (snd (snd (last fvAs))) (fst (last fvAs))"
	+ using len last_conv_nth[of fvAs] by force+
	+ have nth: "fst (last fvAs) = fst (fvAs ! n)" using inv(1)
	+ using len last_conv_nth[of fvAs] by force
	+ note spec = formula_spec_empty[OF _ inv(3)] formula_spec_nt_empty_form_sat[OF _ inv(3)]
	+ consider (a) "claim = Empty" \| (b) "claim = Nonempty" using claim.exhaust by blast
	+ then show ?thesis
	+ proof cases
	+ case a
	+ then have *: "B = reg_empty (snd (snd (last fvAs)))" using inv
	+ using assms len last_conv_nth[of fvAs]
	+ by (auto simp: inf simp del: check_inference_list.simps)
	+ show ?thesis using a inv spec unfolding *
	+ by (auto simp: formula_satisfiable_def nth correct_certificate_def formula_unsatisfiable_def simp del: reg_empty)
	+ next
	+ case b
	+ then have *: "B \<longleftrightarrow> \<not> (reg_empty (snd (snd (last fvAs))))" using inv
	+ using assms len last_conv_nth[of fvAs]
	+ by (auto simp: inf simp del: check_inference_list.simps)
	+ show ?thesis using b inv spec unfolding *
	+ by (auto simp: formula_satisfiable_def nth formula_unsatisfiable_def correct_certificate_def simp del: reg_empty)
	+ qed
	+qed
	+
	+
	+definition check_certificate_string ::
	+ "(integer list \<times> fvar) fset \<Rightarrow>
	+ ((integer list, integer list) Term.term \<times> (integer list, integer list) Term.term) fset list \<Rightarrow>
	+ bool \<Rightarrow> ftrs formula \<Rightarrow> ftrs certificate \<Rightarrow> bool option"
	+ where "check_certificate_string = check_certificate"
	+
	+
	+(***********************************)
	+export_code check_certificate_string Var Fun fset_of_list nat_of_integer Certificate
	+ R2GTT_Rel R2Eq R2Reflc R2Step R2StepEq R2Steps R2StepsEq R2StepsNF R2ParStep R2RootStep
	+ R2RootStepEq R2RootSteps R2RootStepsEq R2NonRootStep R2NonRootStepEq R2NonRootSteps
	+ R2NonRootStepsEq R2Meet R2Join
	+ ARoot GSteps PRoot ESingle Empty Size EDistribAndOr
	+ R1Terms R1Fin
	+ FRR1 FRestrict FTrue FFalse
	+ IRR1 Fwd in Haskell module_name FOR
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/FOR_Semantics.thy b/thys/FO_Theory_Rewriting/FOR_Semantics.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/FOR_Semantics.thy
	@@ -0,0 +1,243 @@
	+theory FOR_Semantics
	+ imports FOR_Certificate
	+ Lift_Root_Step
	+ "FOL-Fitting.FOL_Fitting"
	+begin
	+
	+section \<open>Semantics of Relations\<close>
	+
	+definition is_to_trs :: "('f, 'v) trs list \<Rightarrow> ftrs list \<Rightarrow> ('f, 'v) trs" where
	+ "is_to_trs Rs is = \<Union>(set (map (case_ftrs ((!) Rs) ((`) prod.swap \<circ> (!) Rs)) is))"
	+
	+primrec eval_gtt_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs gtt_rel \<Rightarrow> 'f gterm rel" where
	+ "eval_gtt_rel \<F> Rs (ARoot is) = Restr (grrstep (is_to_trs Rs is)) (\<T>\<^sub>G \<F>)"
	+\| "eval_gtt_rel \<F> Rs (GInv g) = prod.swap ` (eval_gtt_rel \<F> Rs g)"
	+\| "eval_gtt_rel \<F> Rs (AUnion g1 g2) = (eval_gtt_rel \<F> Rs g1) \<union> (eval_gtt_rel \<F> Rs g2)"
	+\| "eval_gtt_rel \<F> Rs (ATrancl g) = (eval_gtt_rel \<F> Rs g)\<^sup>+"
	+\| "eval_gtt_rel \<F> Rs (AComp g1 g2) = (eval_gtt_rel \<F> Rs g1) O (eval_gtt_rel \<F> Rs g2)"
	+\| "eval_gtt_rel \<F> Rs (GTrancl g) = gtrancl_rel \<F> (eval_gtt_rel \<F> Rs g)"
	+\| "eval_gtt_rel \<F> Rs (GComp g1 g2) = gcomp_rel \<F> (eval_gtt_rel \<F> Rs g1) (eval_gtt_rel \<F> Rs g2)"
	+
	+primrec eval_rr1_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> 'f gterm set"
	+ and eval_rr2_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> 'f gterm rel" where
	+ "eval_rr1_rel \<F> Rs R1Terms = (\<T>\<^sub>G \<F>)"
	+\| "eval_rr1_rel \<F> Rs (R1Union R S) = (eval_rr1_rel \<F> Rs R) \<union> (eval_rr1_rel \<F> Rs S)"
	+\| "eval_rr1_rel \<F> Rs (R1Inter R S) = (eval_rr1_rel \<F> Rs R) \<inter> (eval_rr1_rel \<F> Rs S)"
	+\| "eval_rr1_rel \<F> Rs (R1Diff R S) = (eval_rr1_rel \<F> Rs R) - (eval_rr1_rel \<F> Rs S)"
	+\| "eval_rr1_rel \<F> Rs (R1Proj n R) = (case n of 0 \<Rightarrow> fst ` (eval_rr2_rel \<F> Rs R)
	+ \| _ \<Rightarrow> snd ` (eval_rr2_rel \<F> Rs R))"
	+\| "eval_rr1_rel \<F> Rs (R1NF is) = NF (Restr (grstep (is_to_trs Rs is)) (\<T>\<^sub>G \<F>)) \<inter> (\<T>\<^sub>G \<F>)"
	+\| "eval_rr1_rel \<F> Rs (R1Inf R) = {s. infinite (eval_rr2_rel \<F> Rs R `` {s})}"
	+\| "eval_rr2_rel \<F> Rs (R2GTT_Rel A W X) = lift_root_step \<F> W X (eval_gtt_rel \<F> Rs A)"
	+\| "eval_rr2_rel \<F> Rs (R2Inv R) = prod.swap ` (eval_rr2_rel \<F> Rs R)"
	+\| "eval_rr2_rel \<F> Rs (R2Union R S) = (eval_rr2_rel \<F> Rs R) \<union> (eval_rr2_rel \<F> Rs S)"
	+\| "eval_rr2_rel \<F> Rs (R2Inter R S) = (eval_rr2_rel \<F> Rs R) \<inter> (eval_rr2_rel \<F> Rs S)"
	+\| "eval_rr2_rel \<F> Rs (R2Diff R S) = (eval_rr2_rel \<F> Rs R) - (eval_rr2_rel \<F> Rs S)"
	+\| "eval_rr2_rel \<F> Rs (R2Comp R S) = (eval_rr2_rel \<F> Rs R) O (eval_rr2_rel \<F> Rs S)"
	+\| "eval_rr2_rel \<F> Rs (R2Diag R) = Id_on (eval_rr1_rel \<F> Rs R)"
	+\| "eval_rr2_rel \<F> Rs (R2Prod R S) = (eval_rr1_rel \<F> Rs R) \<times> (eval_rr1_rel \<F> Rs S)"
	+
	+
	+subsection \<open>Semantics of Formulas\<close>
	+
	+fun eval_formula :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> (nat \<Rightarrow> 'f gterm) \<Rightarrow>
	+ ftrs formula \<Rightarrow> bool" where
	+ "eval_formula \<F> Rs \<alpha> (FRR1 r1 x) \<longleftrightarrow> \<alpha> x \<in> eval_rr1_rel \<F> Rs r1"
	+\| "eval_formula \<F> Rs \<alpha> (FRR2 r2 x y) \<longleftrightarrow> (\<alpha> x, \<alpha> y) \<in> eval_rr2_rel \<F> Rs r2"
	+\| "eval_formula \<F> Rs \<alpha> (FAnd fs) \<longleftrightarrow> (\<forall>f \<in> set fs. eval_formula \<F> Rs \<alpha> f)"
	+\| "eval_formula \<F> Rs \<alpha> (FOr fs) \<longleftrightarrow> (\<exists>f \<in> set fs. eval_formula \<F> Rs \<alpha> f)"
	+\| "eval_formula \<F> Rs \<alpha> (FNot f) \<longleftrightarrow> \<not> eval_formula \<F> Rs \<alpha> f"
	+\| "eval_formula \<F> Rs \<alpha> (FExists f) \<longleftrightarrow> (\<exists>z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) f)"
	+\| "eval_formula \<F> Rs \<alpha> (FForall f) \<longleftrightarrow> (\<forall>z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) f)"
	+
	+fun formula_arity :: "'trs formula \<Rightarrow> nat" where
	+ "formula_arity (FRR1 r1 x) = Suc x"
	+\| "formula_arity (FRR2 r2 x y) = max (Suc x) (Suc y)"
	+\| "formula_arity (FAnd fs) = max_list (map formula_arity fs)"
	+\| "formula_arity (FOr fs) = max_list (map formula_arity fs)"
	+\| "formula_arity (FNot f) = formula_arity f"
	+\| "formula_arity (FExists f) = formula_arity f - 1"
	+\| "formula_arity (FForall f) = formula_arity f - 1"
	+
	+
	+
	+lemma R1NF_reps:
	+ assumes "funas_trs R \<subseteq> \<F>" "\<forall> t. (term_of_gterm s, term_of_gterm t) \<in> rstep R \<longrightarrow> \<not>funas_gterm t \<subseteq> \<F>"
	+ and "funas_gterm s \<subseteq> \<F>" "(l, r) \<in> R" "term_of_gterm s = C\<langle>l \<cdot> (\<sigma> :: 'b \<Rightarrow> ('a, 'b) Term.term)\<rangle>"
	+ shows False
	+proof -
	+ obtain c where w: "funas_term (c :: ('a, 'b) Term.term) \<subseteq> \<F>" "ground c"
	+ using assms(3) funas_term_of_gterm_conv ground_term_of_gterm by blast
	+ define \<tau> where "\<tau> x = (if x \<in> vars_term l then \<sigma> x else c)" for x
	+ from assms(4-) have terms: "term_of_gterm s = C\<langle>l \<cdot> \<tau>\<rangle>" "(C\<langle>l \<cdot> \<tau>\<rangle>, C\<langle>r \<cdot> \<tau>\<rangle>) \<in> rstep R"
	+ using \<tau>_def by auto (metis term_subst_eq)
	+ from this(1) have [simp]: "funas_gterm s = funas_term C\<langle>l \<cdot> \<tau>\<rangle>" by (metis funas_term_of_gterm_conv)
	+ from w assms(1, 3, 4) have [simp]: "funas_term C\<langle>r \<cdot> \<tau>\<rangle> \<subseteq> \<F>" using \<tau>_def
	+ by (auto simp: funas_trs_def funas_term_subst)
	+ moreover have "ground C\<langle>r \<cdot> \<tau>\<rangle>" using terms(1) w \<tau>_def
	+ by (auto intro!: ground_substI) (metis term_of_gterm_ctxt_subst_apply_ground)
	+ ultimately show ?thesis using assms(2) terms(2)
	+ by (metis funas_term_of_gterm_conv ground_term_to_gtermD terms(1))
	+qed
	+
	+
	+text \<open>The central property we are interested in is satisfiability\<close>
	+
	+definition formula_satisfiable where
	+ "formula_satisfiable \<F> Rs f \<longleftrightarrow> (\<exists>\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> f)"
	+
	+subsection \<open>Validation\<close>
	+
	+subsection \<open>Defining properties of @{const gcomp_rel} and @{const gtrancl_rel}\<close>
	+
	+lemma gcomp_rel_sig:
	+ assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>" and "S \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gcomp_rel \<F> R S \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ using assms subsetD[OF signature_pres_funas_cl(2)[OF assms(1)]]
	+ by (auto simp: gcomp_rel_def lift_root_step.simps gmctxt_cl_gmctxtex_onp_conv) (metis refl_onD2 relf_on_gmctxtcl_funas)
	+
	+lemma gtrancl_rel_sig:
	+ assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "gtrancl_rel \<F> R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ using gtrancl_rel_sound[OF assms] by simp
	+
	+lemma gtrancl_rel:
	+ assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "lift_root_step \<F> PAny EStrictParallel (gtrancl_rel \<F> R) = (lift_root_step \<F> PAny ESingle R)\<^sup>+"
	+ unfolding lift_root_step.simps using gmctxtcl_funas_strict_gtrancl_rel[OF assms] .
	+
	+lemma gtrancl_rel':
	+ assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+ shows "lift_root_step \<F> PAny EParallel (gtrancl_rel \<F> R) = Restr ((lift_root_step \<F> PAny ESingle R)\<^sup>*) (\<T>\<^sub>G \<F>)"
	+ using assms gtrancl_rel[OF assms]
	+ by (auto simp: lift_root_step_Parallel_conv
	+ simp flip: reflcl_trancl dest: Restr_simps(5)[OF lift_root_step_sig, THEN subsetD])
	+
	+text \<open>GTT relation semantics respects the signature\<close>
	+
	+lemma eval_gtt_rel_sig:
	+ "eval_gtt_rel \<F> Rs g \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+proof -
	+ show ?thesis by (induct g) (auto 0 3 simp: gtrancl_rel_sig gcomp_rel_sig dest: tranclD tranclD2)
	+qed
	+
	+text \<open>RR1 and RR2 relation semantics respect the signature\<close>
	+
	+lemma eval_rr12_rel_sig:
	+ "eval_rr1_rel \<F> Rs r1 \<subseteq> \<T>\<^sub>G \<F>"
	+ "eval_rr2_rel \<F> Rs r2 \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
	+proof (induct r1 and r2)
	+ case (R1Inf r2) then show ?case by (auto dest!: infinite_imp_nonempty)
	+next
	+ case (R1Proj i r2) then show ?case by (fastforce split: nat.splits)
	+next
	+ case (R2GTT_Rel g W X) then show ?case by (simp add: lift_root_step_sig eval_gtt_rel_sig)
	+qed auto
	+
	+
	+subsection \<open>Correctness of derived constructions\<close>
	+
	+lemma R1Fin:
	+ "eval_rr1_rel \<F> Rs (R1Fin r) = {t \<in> \<T>\<^sub>G \<F>. finite {s. (t, s) \<in> eval_rr2_rel \<F> Rs r}}"
	+ by (auto simp: R1Fin_def Image_def)
	+
	+lemma R2Eq:
	+ "eval_rr2_rel \<F> Rs R2Eq = Id_on (\<T>\<^sub>G \<F>)"
	+ by (auto simp: \<T>\<^sub>G_funas_gterm_conv R2Eq_def)
	+
	+lemma R2Reflc:
	+ "eval_rr2_rel \<F> Rs (R2Reflc r) = eval_rr2_rel \<F> Rs r \<union> Id_on (\<T>\<^sub>G \<F>)"
	+ "eval_rr2_rel \<F> Rs (R2Reflc r) = Restr ((eval_rr2_rel \<F> Rs r)\<^sup>=) (\<T>\<^sub>G \<F>)"
	+ using eval_rr12_rel_sig(2)[of \<F> Rs "R2Reflc r"]
	+ by (auto simp: R2Reflc_def R2Eq)
	+
	+lemma R2Step:
	+ "eval_rr2_rel \<F> Rs (R2Step ts) = Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ by (auto simp: lift_root_step.simps R2Step_def grstep_lift_root_step grrstep_subst_cl_conv grstepD_grstep_conv grstepD_def)
	+
	+lemma R2StepEq:
	+ "eval_rr2_rel \<F> Rs (R2StepEq ts) = Restr ((grstep (is_to_trs Rs ts))\<^sup>=) (\<T>\<^sub>G \<F>)"
	+ by (auto simp: R2StepEq_def R2Step R2Reflc(2))
	+
	+lemma R2Steps:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2Steps ts) = R\<^sup>+"
	+ by (simp add: R2Steps_def GSteps_def R_def gtrancl_rel grstep_lift_root_step)
	+ (metis FOR_Semantics.gtrancl_rel Sigma_cong grstep_lift_root_step inf.cobounded2 lift_root_Any_EStrict_eq)
	+
	+lemma R2StepsEq:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2StepsEq ts) = Restr (R\<^sup>*) (\<T>\<^sub>G \<F>)"
	+ using R2Steps[of \<F> Rs ts]
	+ by (simp add: R2StepsEq_def R2Steps_def lift_root_step_Parallel_conv Int_Un_distrib2 R_def Restr_simps flip: reflcl_trancl)
	+
	+lemma R2StepsNF:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2StepsNF ts) = Restr (R\<^sup>* \<inter> UNIV \<times> NF R) (\<T>\<^sub>G \<F>)"
	+ using R2StepsEq[of \<F> Rs ts]
	+ by (auto simp: R2StepsNF_def R2StepsEq_def R_def)
	+
	+lemma R2ParStep:
	+ "eval_rr2_rel \<F> Rs (R2ParStep ts) = Restr (gpar_rstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ by (simp add: R2ParStep_def gar_rstep_lift_root_step)
	+
	+lemma R2RootStep:
	+ "eval_rr2_rel \<F> Rs (R2RootStep ts) = Restr (grrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ by (simp add: R2RootStep_def lift_root_step.simps)
	+
	+lemma R2RootStepEq:
	+ "eval_rr2_rel \<F> Rs (R2RootStepEq ts) = Restr ((grrstep (is_to_trs Rs ts))\<^sup>=) (\<T>\<^sub>G \<F>)"
	+ by (auto simp: R2RootStepEq_def R2RootStep R2Reflc(2))
	+
	+lemma R2RootSteps:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (grrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2RootSteps ts) = R\<^sup>+"
	+ by (simp add: R2RootSteps_def R_def lift_root_step.simps)
	+
	+lemma R2RootStepsEq:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (grrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2RootStepsEq ts) = Restr (R\<^sup>*) (\<T>\<^sub>G \<F>)"
	+ by (auto simp: R2RootStepsEq_def R2Reflc_def R2RootSteps R_def R2Eq_def Int_Un_distrib2 Restr_simps simp flip: reflcl_trancl)
	+
	+lemma R2NonRootStep:
	+ "eval_rr2_rel \<F> Rs (R2NonRootStep ts) = Restr (gnrrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ by (simp add: R2NonRootStep_def grrstep_lift_root_gnrrstep)
	+
	+lemma R2NonRootStepEq:
	+ "eval_rr2_rel \<F> Rs (R2NonRootStepEq ts) = Restr ((gnrrstep (is_to_trs Rs ts))\<^sup>=) (\<T>\<^sub>G \<F>)"
	+ by (auto simp: R2NonRootStepEq_def R2Reflc_def R2Eq_def R2NonRootStep Int_Un_distrib2)
	+
	+lemma R2NonRootSteps:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (gnrrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2NonRootSteps ts) = R\<^sup>+"
	+ apply (simp add: lift_root_step.simps gnrrstepD_gnrrstep_conv gnrrstepD_def
	+ grrstep_subst_cl_conv R2NonRootSteps_def R_def GSteps_def lift_root_step_Parallel_conv)
	+ apply (intro gmctxtex_funas_nroot_strict_gtrancl_rel)
	+ by simp
	+
	+lemma R2NonRootStepsEq:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (gnrrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2NonRootStepsEq ts) = Restr (R\<^sup>*) (\<T>\<^sub>G \<F>)"
	+ using R2NonRootSteps[of \<F> Rs ts]
	+ by (simp add: R2NonRootSteps_def R2NonRootStepsEq_def lift_root_step_Parallel_conv
	+ R_def Int_Un_distrib2 Restr_simps flip: reflcl_trancl)
	+
	+lemma converse_to_prod_swap:
	+ "R\<inverse> = prod.swap ` R"
	+ by auto
	+
	+lemma R2Meet:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2Meet ts) = Restr ((R\<inverse>)\<^sup>* O R\<^sup>*) (\<T>\<^sub>G \<F>)"
	+ apply (simp add: R2Meet_def R_def GSteps_def converse_to_prod_swap gcomp_rel[folded lift_root_step.simps] gtrancl_rel' swap_lift_root_step grstep_lift_root_step)
	+ apply (simp add: Restr_simps converse_Int converse_Un converse_Times Int_Un_distrib2 flip: reflcl_trancl trancl_converse converse_to_prod_swap)
	+ done
	+
	+lemma R2Join:
	+ fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
	+ shows "eval_rr2_rel \<F> Rs (R2Join ts) = Restr (R\<^sup>* O (R\<inverse>)\<^sup>*) (\<T>\<^sub>G \<F>)"
	+ apply (simp add: R2Join_def R_def GSteps_def converse_to_prod_swap gcomp_rel[folded lift_root_step.simps] gtrancl_rel' swap_lift_root_step grstep_lift_root_step)
	+ apply (simp add: Restr_simps converse_to_prod_swap[symmetric] converse_Int converse_Un converse_Times Int_Un_distrib2 flip: reflcl_trancl trancl_converse)
	+ done
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Primitives/LV_to_GTT.thy b/thys/FO_Theory_Rewriting/Primitives/LV_to_GTT.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Primitives/LV_to_GTT.thy
	@@ -0,0 +1,330 @@
	+section \<open>Primitive constructions\<close>
	+
	+theory LV_to_GTT
	+ imports Regular_Tree_Relations.Pair_Automaton
	+ Bot_Terms
	+ Rewriting
	+begin
	+
	+subsection \<open>Recognizing subterms of linear terms\<close>
	+(* Pattern recognizer automaton *)
	+abbreviation ffunas_terms where
	+ "ffunas_terms R \<equiv> \|\<Union>\| (ffunas_term \|`\| R)"
	+
	+definition "states R \<equiv> {t\<^sup>\<bottom> \| s t. s \<in> R \<and> s \<unrhd> t}"
	+
	+lemma states_conv:
	+ "states R = term_to_bot_term ` (\<Union> s \<in> R. subterms s)"
	+ unfolding states_def set_all_subteq_subterms
	+ by auto
	+
	+lemma finite_states:
	+ assumes "finite R" shows "finite (states R)"
	+proof -
	+ have conv: "states R = term_to_bot_term ` (\<Union> s \<in> R. {t \| t. s \<unrhd> t})"
	+ unfolding states_def by auto
	+ from assms have "finite (\<Union> s \<in> R. {t \| t. s \<unrhd> t})"
	+ by (intro finite_UN_I2 finite_imageI) (simp add: finite_subterms)+
	+ then show ?thesis using conv by auto
	+qed
	+
	+lemma root_bot_diff:
	+ "root_bot ` (R - {Bot}) = (root_bot ` R) - {None}"
	+ using root_bot.elims by auto
	+
	+lemma root_bot_states_root_subterms:
	+ "the ` (root_bot ` (states R - {Bot})) = the ` (root ` (\<Union> s \<in> R. subterms s) - {None})"
	+ unfolding states_conv root_bot_diff
	+ unfolding image_comp
	+ by simp
	+
	+context
	+includes fset.lifting
	+begin
	+
	+lift_definition fstates :: "('f, 'v) term fset \<Rightarrow> 'f bot_term fset" is states
	+ by (simp add: finite_states)
	+
	+lift_definition fsubterms :: "('f, 'v) term \<Rightarrow> ('f, 'v) term fset" is subterms
	+ by (simp add: finite_subterms_fun)
	+
	+lemmas fsubterms [code] = subterms.simps[Transfer.transferred]
	+
	+lift_definition ffunas_trs :: "(('f, 'v) term \<times> ('f, 'v) term) fset \<Rightarrow> ('f \<times> nat) fset" is funas_trs
	+ by (simp add: finite_funas_trs)
	+
	+lemma fstates_def':
	+ "t \|\<in>\| fstates R \<longleftrightarrow> (\<exists> s u. s \|\<in>\| R \<and> s \<unrhd> u \<and> u\<^sup>\<bottom> = t)"
	+ by transfer (auto simp: states_def)
	+
	+lemma fstates_fmemberE [elim!]:
	+ assumes "t \|\<in>\| fstates R"
	+ obtains s u where "s \|\<in>\| R \<and> s \<unrhd> u \<and> u\<^sup>\<bottom> = t"
	+ using assms unfolding fstates_def'
	+ by blast
	+
	+lemma fstates_fmemberI [intro]:
	+ "s \|\<in>\| R \<Longrightarrow> s \<unrhd> u \<Longrightarrow> u\<^sup>\<bottom> \|\<in>\| fstates R"
	+ unfolding fstates_def' by blast
	+
	+lemmas froot_bot_states_root_subterms = root_bot_states_root_subterms[Transfer.transferred]
	+lemmas root_fsubsterms_ffunas_term_fset = root_substerms_funas_term_set[Transfer.transferred]
	+
	+
	+lemma fstates[code]:
	+ "fstates R = term_to_bot_term \|`\| ( \|\<Union>\| (fsubterms \|`\| R))"
	+ by transfer (auto simp: states_conv)
	+
	+end
	+
	+definition ta_rule_sig where
	+ "ta_rule_sig = (\<lambda> r. (r_root r, length (r_lhs_states r)))"
	+
	+primrec term_to_ta_rule where
	+ "term_to_ta_rule (BFun f ts) = TA_rule f ts (BFun f ts)"
	+
	+lemma ta_rule_sig_term_to_ta_rule_root:
	+ "t \<noteq> Bot \<Longrightarrow> ta_rule_sig (term_to_ta_rule t) = the (root_bot t)"
	+ by (cases t) (auto simp: ta_rule_sig_def)
	+
	+lemma ta_rule_sig_term_to_ta_rule_root_set:
	+ assumes "Bot \|\<notin>\| R"
	+ shows "ta_rule_sig \|`\| (term_to_ta_rule \|`\| R) = the \|`\| (root_bot \|`\| R)"
	+proof -
	+ {fix x assume "x \|\<in>\| R" then have "ta_rule_sig (term_to_ta_rule x) = the (root_bot x)"
	+ using ta_rule_sig_term_to_ta_rule_root[of x] assms
	+ by auto}
	+ then show ?thesis
	+ by (force simp: fimage_iff)
	+qed
	+
	+definition pattern_automaton_rules where
	+ "pattern_automaton_rules \<F> R =
	+ (let states = (fstates R) - {\|Bot\|} in
	+ term_to_ta_rule \|`\| states \|\<union>\| (\<lambda> (f, n). TA_rule f (replicate n Bot) Bot) \|`\| \<F>)"
	+
	+lemma pattern_automaton_rules_BotD:
	+ assumes "TA_rule f ss Bot \|\<in>\| pattern_automaton_rules \<F> R"
	+ shows "TA_rule f ss Bot \|\<in>\| (\<lambda> (f, n). TA_rule f (replicate n Bot) Bot) \|`\| \<F>" using assms
	+ by (auto simp: pattern_automaton_rules_def)
	+ (metis ta_rule.inject term_to_bot_term.elims term_to_ta_rule.simps)
	+
	+lemma pattern_automaton_rules_FunD:
	+ assumes "TA_rule f ss (BFun g ts) \|\<in>\| pattern_automaton_rules \<F> R"
	+ shows "g = f \<and> ts = ss \<and>
	+ TA_rule f ss (BFun g ts) \|\<in>\| term_to_ta_rule \|`\| ((fstates R) - {\|Bot\|})" using assms
	+ apply (auto simp: pattern_automaton_rules_def)
	+ apply (metis bot_term.exhaust ta_rule.inject term_to_ta_rule.simps)
	+ by (metis (no_types, lifting) ta_rule.inject term_to_bot_term.elims term_to_ta_rule.simps)
	+
	+
	+definition pattern_automaton where
	+ "pattern_automaton \<F> R = TA (pattern_automaton_rules \<F> R) {\|\|}"
	+
	+lemma ta_sig_pattern_automaton [simp]:
	+ "ta_sig (pattern_automaton \<F> R) = \<F> \|\<union>\| ffunas_terms R"
	+proof -
	+ let ?r = "ta_rule_sig"
	+ have *:"Bot \|\<notin>\| (fstates R) - {\|Bot\|}" by simp
	+ have f: "\<F> = ?r \|`\| ((\<lambda> (f, n). TA_rule f (replicate n Bot) Bot) \|`\| \<F>)"
	+ by (auto simp: fimage_iff fBex_def ta_rule_sig_def split!: prod.splits)
	+ moreover have "ffunas_terms R = ?r \|`\| (term_to_ta_rule \|`\| ((fstates R) - {\|Bot\|}))"
	+ unfolding ta_rule_sig_term_to_ta_rule_root_set[OF *]
	+ unfolding froot_bot_states_root_subterms root_fsubsterms_ffunas_term_fset
	+ by simp
	+ ultimately show ?thesis unfolding pattern_automaton_def ta_sig_def
	+ unfolding ta_rule_sig_def pattern_automaton_rules_def
	+ by (auto simp add: Let_def comp_def fimage_funion)
	+qed
	+
	+lemma terms_reach_Bot:
	+ assumes "ffunas_gterm t \|\<subseteq>\| \<F>"
	+ shows "Bot \|\<in>\| ta_der (pattern_automaton \<F> R) (term_of_gterm t)" using assms
	+proof (induct t)
	+ case (GFun f ts)
	+ have [simp]: "s \<in> set ts \<Longrightarrow> ffunas_gterm s \|\<subseteq>\| \<F>" for s using GFun(2)
	+ using in_set_idx by fastforce
	+ from GFun show ?case
	+ by (auto simp: pattern_automaton_def pattern_automaton_rules_def rev_fimage_eqI
	+ intro!: exI[of _ "replicate (length ts) Bot"])
	+qed
	+
	+lemma pattern_automaton_reach_smaller_term:
	+ assumes "l \|\<in>\| R" "l \<unrhd> s" "s\<^sup>\<bottom> \<le>\<^sub>b (term_of_gterm t)\<^sup>\<bottom>" "ffunas_gterm t \|\<subseteq>\| \<F>"
	+ shows "s\<^sup>\<bottom> \|\<in>\| ta_der (pattern_automaton \<F> R) (term_of_gterm t)" using assms(2-)
	+proof (induct t arbitrary: s)
	+ case (GFun f ts) show ?case
	+ proof (cases s)
	+ case (Var x)
	+ then show ?thesis using terms_reach_Bot[OF GFun(4)]
	+ by (auto simp del: ta_der_Fun)
	+ next
	+ case [simp]: (Fun g ss)
	+ let ?ss = "map term_to_bot_term ss"
	+ have [simp]: "s \<in> set ts \<Longrightarrow> ffunas_gterm s \|\<subseteq>\| \<F>" for s using GFun(4)
	+ using in_set_idx by fastforce
	+ from GFun(3) have s: "g = f" "length ss = length ts" by auto
	+ from GFun(2) s(2) assms(1) have rule: "TA_rule f ?ss (BFun f ?ss) \|\<in>\| pattern_automaton_rules \<F> R"
	+ by (auto simp: s(1) pattern_automaton_rules_def fimage_iff fBex_def)
	+ {fix i assume bound: "i < length ts"
	+ then have sub: "l \<unrhd> ss ! i" using GFun(2) arg_subteq[OF nth_mem, of i ss f]
	+ unfolding Fun s(1) using s(2) by (metis subterm.order.trans)
	+ have "ss ! i\<^sup>\<bottom> \<le>\<^sub>b (term_of_gterm (ts ! i):: ('a, 'c) term)\<^sup>\<bottom>" using GFun(3) bound s(2)
	+ by (auto simp: s elim!: bless_eq.cases)
	+ from GFun(1)[OF nth_mem sub this] bound
	+ have "ss ! i\<^sup>\<bottom> \|\<in>\| ta_der (pattern_automaton \<F> R) (term_of_gterm (ts ! i))"
	+ by auto}
	+ then show ?thesis using GFun(2-) s(2) rule
	+ by (auto simp: s(1) pattern_automaton_def intro!: exI[of _ ?ss] exI[of _ "BFun f ?ss"])
	+ qed
	+qed
	+
	+lemma bot_term_of_gterm_conv:
	+ "term_of_gterm s\<^sup>\<bottom> = term_of_gterm s\<^sup>\<bottom>"
	+ by (induct s) auto
	+
	+lemma pattern_automaton_ground_instance_reach:
	+ assumes "l \|\<in>\| R" "l \<cdot> \<sigma> = (term_of_gterm t)" "ffunas_gterm t \|\<subseteq>\| \<F>"
	+ shows "l\<^sup>\<bottom> \|\<in>\| ta_der (pattern_automaton \<F> R) (term_of_gterm t)"
	+proof -
	+ let ?t = "(term_of_gterm t) :: ('a, 'a bot_term) term"
	+ from instance_to_bless_eq[OF assms(2)] have sm: "l\<^sup>\<bottom> \<le>\<^sub>b ?t\<^sup>\<bottom>"
	+ using bot_term_of_gterm_conv by metis
	+ show ?thesis using pattern_automaton_reach_smaller_term[OF assms(1) _ sm] assms(3-)
	+ by auto
	+qed
	+
	+lemma pattern_automaton_reach_smallet_term:
	+ assumes "l\<^sup>\<bottom> \|\<in>\| ta_der (pattern_automaton \<F> R) t" "ground t"
	+ shows "l\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>" using assms
	+proof (induct t arbitrary: l)
	+ case (Fun f ts) note IH = this show ?case
	+ proof (cases l)
	+ case (Fun g ss)
	+ let ?ss = "map term_to_bot_term ss"
	+ from IH(2) have rule: "g = f" "length ss = length ts"
	+ "TA_rule f ?ss (BFun f ?ss) \|\<in>\| rules (pattern_automaton \<F> R)"
	+ by (auto simp: Fun pattern_automaton_def dest: pattern_automaton_rules_FunD)
	+ {fix i assume "i < length ts"
	+ then have "ss ! i\<^sup>\<bottom> \<le>\<^sub>b ts ! i\<^sup>\<bottom>" using IH(2, 3) rule(2)
	+ by (intro IH(1)) (auto simp: Fun pattern_automaton_def dest: pattern_automaton_rules_FunD)}
	+ then show ?thesis using rule(2)
	+ by (auto simp: Fun rule(1))
	+ qed auto
	+qed auto
	+
	+subsection \<open>Recognizing root step relation of LV-TRSs\<close>
	+
	+definition lv_trs :: "('f, 'v) trs \<Rightarrow> bool" where
	+ "lv_trs R \<equiv> \<forall>(l, r) \<in> R. linear_term l \<and> linear_term r \<and> (vars_term l \<inter> vars_term r = {})"
	+
	+lemma subst_unification:
	+ assumes "vars_term s \<inter> vars_term t = {}"
	+ obtains \<mu> where "s \<cdot> \<sigma> = s \<cdot> \<mu>" "t \<cdot> \<tau> = t \<cdot> \<mu>"
	+ using assms
	+ by (auto intro!: that[of "\<lambda>x. if x \<in> vars_term s then \<sigma> x else \<tau> x"] simp: term_subst_eq_conv)
	+
	+lemma lv_trs_subst_unification:
	+ assumes "lv_trs R" "(l, r) \<in> R" "s = l \<cdot> \<sigma>" "t = r \<cdot> \<tau>"
	+ obtains \<mu> where "s = l \<cdot> \<mu> \<and> t = r \<cdot> \<mu>"
	+ using assms subst_unification[of l r \<sigma> \<tau>]
	+ unfolding lv_trs_def
	+ by (force split!: prod.splits)
	+
	+definition Rel\<^sub>f where
	+ "Rel\<^sub>f R = map_both term_to_bot_term \|`\| R"
	+
	+definition root_pair_automaton where
	+ "root_pair_automaton \<F> R = (pattern_automaton \<F> (fst \|`\| R),
	+ pattern_automaton \<F> (snd \|`\| R))"
	+
	+definition agtt_grrstep where
	+ "agtt_grrstep \<R> \<F> = pair_at_to_agtt' (root_pair_automaton \<F> \<R>) (Rel\<^sub>f \<R>)"
	+
	+lemma agtt_grrstep_eps_trancl [simp]:
	+ "(eps (fst (agtt_grrstep \<R> \<F>)))\|\<^sup>+\| = eps (fst (agtt_grrstep \<R> \<F>))"
	+ "(eps (snd (agtt_grrstep \<R> \<F>))) = {\|\|}"
	+ by (auto simp add: agtt_grrstep_def pair_at_to_agtt'_def
	+ pair_at_to_agtt_def Let_def root_pair_automaton_def pattern_automaton_def
	+ fmap_states_ta_def intro!: frelcomp_empty_ftrancl_simp)
	+
	+lemma root_pair_automaton_grrstep:
	+ fixes R :: "('f, 'v) rule fset"
	+ assumes "lv_trs (fset R)" "ffunas_trs R \|\<subseteq>\| \<F>"
	+ shows "pair_at_lang (root_pair_automaton \<F> R) (Rel\<^sub>f R) = Restr (grrstep (fset R)) (\<T>\<^sub>G (fset \<F>))" (is "?Ls = ?Rs")
	+proof
	+ let ?t_o_g = "term_of_gterm :: 'f gterm \<Rightarrow> ('f, 'v) Term.term"
	+ have [simp]: "\<F> \|\<union>\| \|\<Union>\| ((ffunas_term \<circ> fst) \|`\| R) = \<F>"
	+ "\<F> \|\<union>\| \|\<Union>\| ((ffunas_term \<circ> snd) \|`\| R) = \<F>" using assms(2)
	+ by (force simp: less_eq_fset.rep_eq ffunas_trs.rep_eq funas_trs_def ffunas_term.rep_eq fmember.rep_eq ffUnion.rep_eq)+
	+ {fix s t assume "(s, t) \<in> ?Ls"
	+ from pair_at_langE[OF this] obtain p q where st: "(q, p) \|\<in>\| Rel\<^sub>f R"
	+ "q \|\<in>\| gta_der (fst (root_pair_automaton \<F> R)) s" "p \|\<in>\| gta_der (snd (root_pair_automaton \<F> R)) t"
	+ by blast
	+ from st(1) obtain l r where tm: "q = l\<^sup>\<bottom>" "p = r\<^sup>\<bottom>" "(l, r) \|\<in>\| R" unfolding Rel\<^sub>f_def
	+ using assms(1) by (auto simp: fmember.abs_eq)
	+ have sm: "l\<^sup>\<bottom> \<le>\<^sub>b (?t_o_g s)\<^sup>\<bottom>" "r\<^sup>\<bottom> \<le>\<^sub>b (?t_o_g t)\<^sup>\<bottom>"
	+ using pattern_automaton_reach_smallet_term[of l \<F> "fst \|`\| R" "term_of_gterm s"]
	+ using pattern_automaton_reach_smallet_term[of r \<F> "snd \|`\| R" "term_of_gterm t"]
	+ using st(2, 3) tm(3) unfolding tm
	+ by (auto simp: gta_der_def root_pair_automaton_def) (smt bot_term_of_gterm_conv)+
	+ have "linear_term l" "linear_term r" using tm(3) assms(1)
	+ by (auto simp: lv_trs_def fmember.rep_eq)
	+ then obtain \<sigma> \<tau> where "l \<cdot> \<sigma> = ?t_o_g s" "r \<cdot> \<tau> = ?t_o_g t" using sm
	+ by (auto dest!: bless_eq_to_instance)
	+ then obtain \<mu> where subst: "l \<cdot> \<mu> = ?t_o_g s" "r \<cdot> \<mu> = ?t_o_g t"
	+ using lv_trs_subst_unification[OF assms(1) tm(3)[unfolded fmember.rep_eq], of "?t_o_g s" \<sigma> "?t_o_g t" \<tau>]
	+ by metis
	+ moreover have "s \<in> \<T>\<^sub>G (fset \<F>)" "t \<in> \<T>\<^sub>G (fset \<F>)" using st(2-) assms
	+ using ta_der_gterm_sig[of q "pattern_automaton \<F> (fst \|`\| R)" s]
	+ using ta_der_gterm_sig[of p "pattern_automaton \<F> (snd \|`\| R)" t]
	+ by (auto simp: gta_der_def root_pair_automaton_def \<T>\<^sub>G_equivalent_def less_eq_fset.rep_eq ffunas_gterm.rep_eq)
	+ ultimately have "(s, t) \<in> ?Rs" using tm(3)
	+ by (auto simp: grrstep_def rrstep_def' fmember.rep_eq) metis}
	+ then show "?Ls \<subseteq> ?Rs" by auto
	+next
	+ let ?t_o_g = "term_of_gterm :: 'f gterm \<Rightarrow> ('f, 'v) Term.term"
	+ {fix s t assume "(s, t) \<in> ?Rs"
	+ then obtain \<sigma> l r where st: "(l, r) \|\<in>\| R" "l \<cdot> \<sigma> = ?t_o_g s" "r \<cdot> \<sigma> = ?t_o_g t" "s \<in> \<T>\<^sub>G (fset \<F>)" "t \<in> \<T>\<^sub>G (fset \<F>)"
	+ by (auto simp: grrstep_def rrstep_def' fmember.rep_eq)
	+ have funas: "ffunas_gterm s \|\<subseteq>\| \<F>" "ffunas_gterm t \|\<subseteq>\| \<F>" using st(4, 5)
	+ by (auto simp: \<T>\<^sub>G_equivalent_def)
	+ (metis ffunas_gterm.rep_eq notin_fset subsetD)+
	+ from st(1) have "(l\<^sup>\<bottom>, r\<^sup>\<bottom>) \|\<in>\| Rel\<^sub>f R" unfolding Rel\<^sub>f_def using assms(1)
	+ by (auto simp: fimage_iff fBex_def)
	+ then have "(s, t) \<in> ?Ls" using st
	+ using pattern_automaton_ground_instance_reach[of l "fst \|`\| R" \<sigma>, OF _ _ funas(1)]
	+ using pattern_automaton_ground_instance_reach[of r "snd \|`\| R" \<sigma>, OF _ _ funas(2)]
	+ by (auto simp: \<T>\<^sub>G_equivalent_def fimage_iff fBex_def fmember.abs_eq root_pair_automaton_def gta_der_def pair_at_lang_def)}
	+ then show "?Rs \<subseteq> ?Ls" by auto
	+qed
	+
	+
	+lemma agtt_grrstep:
	+ fixes R :: "('f, 'v) rule fset"
	+ assumes "lv_trs (fset R)" "ffunas_trs R \|\<subseteq>\| \<F>"
	+ shows "agtt_lang (agtt_grrstep R \<F>) = Restr (grrstep (fset R)) (\<T>\<^sub>G (fset \<F>))"
	+ using root_pair_automaton_grrstep[OF assms] unfolding pair_at_agtt_cost agtt_grrstep_def
	+ by simp
	+
	+(* Results for set as input *)
	+lemma root_pair_automaton_grrstep_set:
	+ fixes R :: "('f, 'v) rule set"
	+ assumes "finite R" "finite \<F>" "lv_trs R" "funas_trs R \<subseteq> \<F>"
	+ shows "pair_at_lang (root_pair_automaton (Abs_fset \<F>) (Abs_fset R)) (Rel\<^sub>f (Abs_fset R)) = Restr (grrstep R) (\<T>\<^sub>G \<F>)"
	+proof -
	+ from assms(1, 2, 4) have "ffunas_trs (Abs_fset R) \|\<subseteq>\| Abs_fset \<F>"
	+ by (auto simp add: Abs_fset_inverse ffunas_trs.rep_eq fmember.rep_eq subset_eq)
	+ from root_pair_automaton_grrstep[OF _ this] assms
	+ show ?thesis
	+ by (auto simp: Abs_fset_inverse)
	+qed
	+
	+lemma agtt_grrstep_set:
	+ fixes R :: "('f, 'v) rule set"
	+ assumes "finite R" "finite \<F>" "lv_trs R" "funas_trs R \<subseteq> \<F>"
	+ shows "agtt_lang (agtt_grrstep (Abs_fset R) (Abs_fset \<F>)) = Restr (grrstep R) (\<T>\<^sub>G \<F>)"
	+ using root_pair_automaton_grrstep_set[OF assms] unfolding pair_at_agtt_cost agtt_grrstep_def
	+ by simp
	+
	+end
	diff --git a/thys/FO_Theory_Rewriting/Primitives/NF.thy b/thys/FO_Theory_Rewriting/Primitives/NF.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Primitives/NF.thy
	@@ -0,0 +1,295 @@
	+theory NF
	+ imports
	+ Saturation
	+ Bot_Terms
	+ Regular_Tree_Relations.Tree_Automata
	+begin
	+
	+subsection \<open>Recognizing normal forms of left linear TRSs\<close>
	+
	+interpretation lift_total: semilattice_closure_partial_operator "\<lambda> x y. (x, y) \<in> mergeP" "(\<up>)" "\<lambda> x y. x \<le>\<^sub>b y" Bot
	+ apply unfold_locales apply (auto simp: merge_refl merge_symmetric merge_terms_assoc merge_terms_idem merge_bot_args_bless_eq_merge)
	+ using merge_dist apply blast
	+ using megeP_ass apply blast
	+ using merge_terms_commutative apply blast
	+ apply (metis bless_eq_mergeP bless_eq_trans merge_bot_args_bless_eq_merge merge_dist merge_symmetric merge_terms_commutative)
	+ apply (metis merge_bot_args_bless_eq_merge merge_symmetric merge_terms_commutative)
	+ using bless_eq_closued_under_supremum bless_eq_trans bless_eq_anti_sym
	+ by blast+
	+
	+abbreviation "psubt_lhs_bot R \<equiv> {t\<^sup>\<bottom> \| s t. s \<in> R \<and> s \<rhd> t}"
	+abbreviation "closure S \<equiv> lift_total.cl.pred_closure S"
	+
	+definition states where
	+ "states R = insert Bot (closure (psubt_lhs_bot R))"
	+
	+lemma psubt_mono:
	+ "R \<subseteq> S \<Longrightarrow> psubt_lhs_bot R \<subseteq> psubt_lhs_bot S" by auto
	+
	+lemma states_mono:
	+ "R \<subseteq> S \<Longrightarrow> states R \<subseteq> states S"
	+ unfolding states_def using lift_total.cl.closure_mono[OF psubt_mono[of R S]]
	+ by auto
	+
	+lemma finite_lhs_subt [simp, intro]:
	+ assumes "finite R"
	+ shows "finite (psubt_lhs_bot R)"
	+proof -
	+ have conv: "psubt_lhs_bot R = term_to_bot_term ` {t \| s t . s \<in> R \<and> s \<rhd> t}" by auto
	+ from assms have "finite {t \| s t . s \<in> R \<and> s \<rhd> t}"
	+ by (simp add: finite_strict_subterms)
	+ then show ?thesis using conv by auto
	+qed
	+
	+lemma states_ref_closure:
	+ "states R \<subseteq> insert Bot (closure (psubt_lhs_bot R))"
	+ unfolding states_def by auto
	+
	+lemma finite_R_finite_states [simp, intro]:
	+ "finite R \<Longrightarrow> finite (states R)"
	+ using finite_lhs_subt states_ref_closure
	+ using lift_total.cl.finite_S_finite_closure finite_subset
	+ by fastforce
	+
	+abbreviation "lift_sup_small s S \<equiv> lift_total.supremum (lift_total.smaller_subset (Some s) (Some ` S))"
	+abbreviation "bound_max s S \<equiv> the (lift_sup_small s S)"
	+
	+lemma bound_max_state_set:
	+ assumes "finite R"
	+ shows "bound_max t (psubt_lhs_bot R) \<in> states R"
	+ using lift_total.supremum_neut_or_in_closure[OF finite_lhs_subt[OF assms], of t]
	+ unfolding states_def by auto
	+
	+context
	+includes fset.lifting
	+begin
	+lift_definition fstates :: "('a, 'b) term fset \<Rightarrow> 'a bot_term fset" is states
	+ by simp
	+
	+lemma bound_max_state_fset:
	+ "bound_max t (psubt_lhs_bot (fset R)) \|\<in>\| fstates R"
	+ using bound_max_state_set[of "fset R" t]
	+ using fstates.rep_eq notin_fset by fastforce
	+
	+end
	+
	+definition nf_rules where
	+ "nf_rules R \<F> = {\|TA_rule f qs q \| f qs q. (f, length qs) \|\<in>\| \<F> \<and> fset_of_list qs \|\<subseteq>\| fstates R \<and>
	+ \<not>(\<exists> l \|\<in>\| R. l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs) \<and> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))\|}"
	+
	+lemma nf_rules_fmember:
	+ "TA_rule f qs q \|\<in>\| nf_rules R \<F> \<longleftrightarrow> (f, length qs) \|\<in>\| \<F> \<and> fset_of_list qs \|\<subseteq>\| fstates R \<and>
	+ \<not>(\<exists> l \|\<in>\| R. l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs) \<and> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
	+proof -
	+ let ?subP = "\<lambda> n qs. fset_of_list qs \|\<subseteq>\| fstates R \<and> length qs = n"
	+ let ?sub = "\<lambda> n. Collect (?subP n)"
	+ have *: "finite (?sub n)" for n
	+ using finite_lists_length_eq[of "fset (fstates R)" n]
	+ by (simp add: less_eq_fset.rep_eq fset_of_list.rep_eq)
	+ {fix f n assume mem: "(f, n) \<in> fset \<F>"
	+ have **: "{f} \<times> (?sub n) = {(f, qs) \|qs. ?subP n qs}" by auto
	+ from mem have "finite {(f, qs) \|qs. ?subP n qs}" using *
	+ using finite_cartesian_product[OF _ [of n], of "{f}"] unfolding * by simp}
	+ then have *: "finite (\<Union> (f, n) \<in> fset \<F> . {(f, qs) \| qs. ?subP n qs})" by auto
	+ have **: "(\<Union> (f, n) \<in> fset \<F> . {(f, qs) \| qs. ?subP n qs}) = {(f, qs) \| f qs. (f, length qs) \|\<in>\| \<F> \<and> ?subP (length qs) qs}"
	+ by (auto simp: fmember.rep_eq)
	+ have *: "finite ({(f, qs) \| f qs. (f, length qs) \|\<in>\| \<F> \<and> ?subP (length qs) qs} \<times> fset (fstates R))"
	+ using * unfolding ** by (intro finite_cartesian_product) auto
	+ have **: "{TA_rule f qs q \| f qs q. (f, length qs) \|\<in>\| \<F> \<and> fset_of_list qs \|\<subseteq>\| fstates R \<and> q \|\<in>\| fstates R} =
	+ (\<lambda> ((f, qs), q). TA_rule f qs q) ` ({(f, qs) \| f qs. (f, length qs) \|\<in>\| \<F> \<and> ?subP (length qs) qs} \<times> fset (fstates R))"
	+ by (auto simp: image_def fmember.rep_eq split!: prod.splits)
	+ have f: "finite {TA_rule f qs q \| f qs q. (f, length qs) \|\<in>\| \<F> \<and> fset_of_list qs \|\<subseteq>\| fstates R \<and> q \|\<in>\| fstates R}"
	+ unfolding ** using * by auto
	+ show ?thesis
	+ by (auto simp: nf_rules_def bound_max_state_fset intro!: finite_subset[OF _ f])
	+qed
	+
	+definition nf_ta where
	+ "nf_ta R \<F> = TA (nf_rules R \<F>) {\|\|}"
	+
	+definition nf_reg where
	+ "nf_reg R \<F> = Reg (fstates R) (nf_ta R \<F>)"
	+
	+lemma bound_max_sound:
	+ assumes "finite R"
	+ shows "bound_max t (psubt_lhs_bot R) \<le>\<^sub>b t"
	+ using assms lift_total.lift_ord.supremum_smaller_subset[of "Some ` psubt_lhs_bot R" "Some t"]
	+ by auto (metis (no_types, lifting) lift_less_eq_total.elims(2) option.sel option.simps(3))
	+
	+lemma Bot_in_filter:
	+ "Bot \<in> Set.filter (\<lambda>s. s \<le>\<^sub>b t) (states R)"
	+ by (auto simp: Set.filter_def states_def)
	+
	+lemma bound_max_exists:
	+ "\<exists> p. p = bound_max t (psubt_lhs_bot R)"
	+ by blast
	+
	+lemma bound_max_unique:
	+ assumes "p = bound_max t (psubt_lhs_bot R)" and "q = bound_max t (psubt_lhs_bot R)"
	+ shows "p = q" using assms by force
	+
	+lemma nf_rule_to_bound_max:
	+ "f qs \<rightarrow> q \|\<in>\| nf_rules R \<F> \<Longrightarrow> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
	+ by (auto simp: nf_rules_fmember)
	+
	+lemma nf_rules_unique:
	+ assumes "f qs \<rightarrow> q \|\<in>\| nf_rules R \<F>" and "f qs \<rightarrow> q' \|\<in>\| nf_rules R \<F>"
	+ shows "q = q'" using assms unfolding nf_rules_def
	+ using nf_rule_to_bound_max[OF assms(1)] nf_rule_to_bound_max[OF assms(2)]
	+ using bound_max_unique by blast
	+
	+lemma nf_ta_det:
	+ shows "ta_det (nf_ta R \<F>)"
	+ by (auto simp add: ta_det_def nf_ta_def nf_rules_unique)
	+
	+lemma term_instance_of_reach_state:
	+ assumes "q \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars t)" and "ground t"
	+ shows "q \<le>\<^sub>b t\<^sup>\<bottom>" using assms(1, 2)
	+proof(induct t arbitrary: q)
	+ case (Fun f ts)
	+ from Fun(2) obtain qs where wit: "f qs \<rightarrow> q \|\<in>\| nf_rules R \<F>" "length qs = length ts"
	+ "\<forall> i < length ts. qs ! i \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
	+ by (auto simp add: nf_ta_def)
	+ then have "BFun f qs \<le>\<^sub>b Fun f ts\<^sup>\<bottom>" using Fun(1)[OF nth_mem, of i "qs !i" for i] using Fun(3)
	+ by auto
	+ then show ?case using bless_eq_trans wit(1) bound_max_sound[of "fset R"]
	+ by (auto simp: nf_rules_fmember)
	+qed auto
	+
	+
	+lemma [simp]: "i < length ss \<Longrightarrow> l \<rhd> Fun f ss \<Longrightarrow> l \<rhd> ss ! i"
	+ by (meson nth_mem subterm.dual_order.strict_trans supt.arg)
	+
	+lemma subt_less_eq_res_less_eq:
	+ assumes ground: "ground t" and "l \|\<in>\| R" and "l \<rhd> s" and "s\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>"
	+ and "q \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars t)"
	+ shows "s\<^sup>\<bottom> \<le>\<^sub>b q" using assms(2-)
	+proof (induction t arbitrary: q s)
	+ case (Var x)
	+ then show ?case using lift_total.anti_sym by fastforce
	+next
	+ case (Fun f ts) note IN = this
	+ from IN obtain qs where rule: "f qs \<rightarrow> q \|\<in>\| nf_rules R \<F>" and
	+ reach: "length qs = length ts" "\<forall> i < length ts. qs ! i \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
	+ by (auto simp add: nf_ta_def)
	+ have q: "lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)) = Some q"
	+ using nf_rule_to_bound_max[OF rule]
	+ using lift_total.supremum_smaller_exists_unique[OF finite_lhs_subt, of "fset R" "BFun f qs"]
	+ by simp (metis option.collapse option.distinct(1))
	+ have subst: "s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs" using IN(1)[OF nth_mem, of i "term.args s ! i" "qs ! i" for i] IN(2-) reach
	+ by (cases s) (auto elim!: bless_eq.cases)
	+ have "s\<^sup>\<bottom> \<in> psubt_lhs_bot (fset R)" using Fun(2 - 4)
	+ by auto (metis notin_fset)
	+ then have "lift_total.lifted_less_eq (Some (s\<^sup>\<bottom>)) (lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)))"
	+ using subst
	+ by (intro lift_total.lift_ord.supremum_sound)
	+ (auto simp: lift_total.lift_ord.smaller_subset_def)
	+ then show ?case using subst q finite_lhs_subt
	+ by auto
	+qed
	+
	+lemma ta_nf_sound1:
	+ assumes ground: "ground t" and lhs: "l \|\<in>\| R" and inst: "l\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>"
	+ shows "ta_der (nf_ta R \<F>) (adapt_vars t) = {\|\|}"
	+proof (rule ccontr)
	+ assume ass: "ta_der (nf_ta R \<F>) (adapt_vars t) \<noteq> {\|\|}"
	+ show False proof (cases t)
	+ case [simp]: (Fun f ts) from ass
	+ obtain q qs where fin: "q \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars (Fun f ts))" and
	+ rule: "(f qs \<rightarrow> q) \|\<in>\| rules (nf_ta R \<F>)" "length qs = length ts" and
	+ reach: "\<forall> i < length ts. qs ! i \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
	+ by (auto simp add: nf_ta_def) blast
	+ have "l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs" using reach assms(1) inst rule(2)
	+ using subt_less_eq_res_less_eq[OF _ lhs, of "ts ! i" "term.args l ! i" "qs ! i" \<F> for i]
	+ by (cases l) (auto elim!: bless_eq.cases intro!: bless_eq.step)
	+ then show ?thesis using lhs rule by (auto simp: nf_ta_def nf_rules_def)
	+ qed (metis ground ground.simps(1))
	+qed
	+
	+lemma ta_nf_tr_to_state:
	+ assumes "ground t" and "q \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars t)"
	+ shows "q \|\<in>\| fstates R" using assms bound_max_state_fset
	+ by (cases t) (auto simp: states_def nf_ta_def nf_rules_def)
	+
	+lemma ta_nf_sound2:
	+ assumes linear: "\<forall> l \|\<in>\| R. linear_term l"
	+ and "ground (t :: ('f, 'v) term)" and "funas_term t \<subseteq> fset \<F>"
	+ and NF: "\<And> l s. l \|\<in>\| R \<Longrightarrow> t \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>"
	+ shows "\<exists> q. q \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars t)" using assms(2 - 4)
	+proof (induct t)
	+ case (Fun f ts)
	+ have sub: "\<And> i. i < length ts \<Longrightarrow> (\<And>l s. l \|\<in>\| R \<Longrightarrow> ts ! i \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>) " using Fun(4) nth_mem by blast
	+ from Fun(1)[OF nth_mem] this Fun(2, 3) obtain qs where
	+ reach: "(\<forall> i < length ts. qs ! i \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i)))" and len: "length qs = length ts"
	+ using Ex_list_of_length_P[of "length ts" "\<lambda> x i. x \|\<in>\| (ta_der (nf_ta R \<F>) (adapt_vars (ts ! i)))"]
	+ by auto (meson UN_subset_iff nth_mem)
	+ have nt_inst: "\<not> (\<exists> s \|\<in>\| R. s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
	+ proof (rule ccontr, simp)
	+ assume ass: "\<exists> s \|\<in>\| R. s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs"
	+ from term_instance_of_reach_state[of "qs ! i" R \<F> "ts ! i" for i] reach Fun(2) len
	+ have "BFun f qs \<le>\<^sub>b Fun f ts\<^sup>\<bottom>" by auto
	+ then show False using ass Fun(4) bless_eq_trans by blast
	+ qed
	+ obtain q where "q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))" by blast
	+ then have "f qs \<rightarrow> q \|\<in>\| rules (nf_ta R \<F>)" using Fun(2 - 4)
	+ using ta_nf_tr_to_state[of "ts ! i" "qs ! i" R \<F> for i] len nt_inst reach
	+ by (auto simp: nf_ta_def nf_rules_fmember, simp add: fmember.rep_eq)
	+ (metis (no_types, lifting) in_fset_idx nth_mem)
	+ then show ?case using reach len by auto
	+qed auto
	+
	+lemma ta_nf_lang_sound:
	+ assumes "l \|\<in>\| R"
	+ shows "C\<langle>l \<cdot> \<sigma>\<rangle> \<notin> ta_lang (fstates R) (nf_ta R \<F>)"
	+proof (rule ccontr, simp del: ta_lang_to_gta_lang)
	+ assume *: "C\<langle>l \<cdot> \<sigma>\<rangle> \<in> ta_lang (fstates R) (nf_ta R \<F>)"
	+ then have cgr:"ground (C\<langle>l\<cdot>\<sigma>\<rangle>)" unfolding ta_lang_def by force
	+ then have gr: "ground (l \<cdot> \<sigma>)" by simp
	+ then have "l\<^sup>\<bottom> \<le>\<^sub>b (l \<cdot> \<sigma>)\<^sup>\<bottom>" using instance_to_bless_eq by blast
	+ from ta_nf_sound1[OF gr assms(1) this] have res: "ta_der (nf_ta R \<F>) (adapt_vars (l \<cdot> \<sigma>)) = {\|\|}" .
	+ from ta_langE * obtain q where "q \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars (C\<langle>l\<cdot>\<sigma>\<rangle>))"
	+ by (metis adapt_vars_adapt_vars)
	+ with ta_der_ctxt_decompose[OF this[unfolded adapt_vars_ctxt]] res
	+ show False by blast
	+qed
	+
	+lemma ta_nf_lang_complete:
	+ assumes linear: "\<forall> l \|\<in>\| R. linear_term l"
	+ and ground: "ground (t :: ('f, 'v) term)" and sig: "funas_term t \<subseteq> fset \<F>"
	+ and nf: "\<And>C \<sigma> l. l \|\<in>\| R \<Longrightarrow> C\<langle>l\<cdot>\<sigma>\<rangle> \<noteq> t"
	+ shows "t \<in> ta_lang (fstates R) (nf_ta R \<F>)"
	+proof -
	+ from nf have "\<And> l s. l \|\<in>\| R \<Longrightarrow> t \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>"
	+ using bless_eq_to_instance linear by blast
	+ from ta_nf_sound2[OF linear ground sig] this
	+ obtain q where "q \|\<in>\| ta_der (nf_ta R \<F>) (adapt_vars t)" by blast
	+ from this ta_nf_tr_to_state[OF ground this] ground show ?thesis
	+ by (intro ta_langI) (auto simp add: nf_ta_def)
	+qed
	+
	+lemma ta_nf_\<L>_complete:
	+ assumes linear: "\<forall> l \|\<in>\| R. linear_term l"
	+ and sig: "funas_gterm t \<subseteq> fset \<F>"
	+ and nf: "\<And>C \<sigma> l. l \|\<in>\| R \<Longrightarrow> C\<langle>l\<cdot>\<sigma>\<rangle> \<noteq> (term_of_gterm t)"
	+ shows "t \<in> \<L> (nf_reg R \<F>)"
	+ using ta_nf_lang_complete[of R "term_of_gterm t" \<F>] assms
	+ by (force simp: \<L>_def nf_reg_def funas_term_of_gterm_conv)
	+
	+lemma nf_ta_funas:
	+ assumes "ground t" "q \|\<in>\| ta_der (nf_ta R \<F>) t"
	+ shows "funas_term t \<subseteq> fset \<F>" using assms
	+proof (induct t arbitrary: q)
	+ case (Fun f ts)
	+ from Fun(2-) have "(f, length ts) \|\<in>\| \<F>"
	+ by (auto simp: nf_ta_def nf_rules_def)
	+ then show ?case using Fun
	+ by (auto simp: fmember.rep_eq) (metis Fun.hyps Fun.prems(2) in_set_idx subsetD ta_der_Fun)
	+qed auto
	+
	+lemma gta_lang_nf_ta_funas:
	+ assumes "t \<in> \<L> (nf_reg R \<F>)"
	+ shows "funas_gterm t \<subseteq> fset \<F>" using assms nf_ta_funas[of "term_of_gterm t" _ R \<F>]
	+ unfolding nf_reg_def \<L>_def
	+ by (auto simp: funas_term_of_gterm_conv)
	+
	+end
	diff --git a/thys/FO_Theory_Rewriting/Primitives/NF_Impl.thy b/thys/FO_Theory_Rewriting/Primitives/NF_Impl.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Primitives/NF_Impl.thy
	@@ -0,0 +1,198 @@
	+theory NF_Impl
	+ imports NF
	+ Type_Instances_Impl
	+begin
	+
	+subsubsection \<open>Implementation of normal form construction\<close>
	+(* Implementation *)
	+fun supteq_list :: "('f, 'v) Term.term \<Rightarrow> ('f, 'v) Term.term list"
	+where
	+ "supteq_list (Var x) = [Var x]" \|
	+ "supteq_list (Fun f ts) = Fun f ts # concat (map supteq_list ts)"
	+
	+fun supt_list :: "('f, 'v) Term.term \<Rightarrow> ('f, 'v) Term.term list"
	+where
	+ "supt_list (Var x) = []" \|
	+ "supt_list (Fun f ts) = concat (map supteq_list ts)"
	+
	+lemma supteq_list [simp]:
	+ "set (supteq_list t) = {s. t \<unrhd> s}"
	+proof (rule set_eqI, simp)
	+ fix s
	+ show "s \<in> set(supteq_list t) = (t \<unrhd> s)"
	+ proof (induct t, simp add: supteq_var_imp_eq)
	+ case (Fun f ss)
	+ show ?case
	+ proof (cases "Fun f ss = s", (auto)[1])
	+ case False
	+ show ?thesis
	+ proof
	+ assume "Fun f ss \<unrhd> s"
	+ with False have sup: "Fun f ss \<rhd> s" using supteq_supt_conv by auto
	+ obtain C where "C \<noteq> \<box>" and "Fun f ss = C\<langle>s\<rangle>" using sup by auto
	+ then obtain b D a where "Fun f ss = Fun f (b @ D\<langle>s\<rangle> # a)" by (cases C, auto)
	+ then have D: "D\<langle>s\<rangle> \<in> set ss" by auto
	+ with Fun[OF D] ctxt_imp_supteq[of D s] obtain t where "t \<in> set ss" and "s \<in> set (supteq_list t)" by auto
	+ then show "s \<in> set (supteq_list (Fun f ss))" by auto
	+ next
	+ assume "s \<in> set (supteq_list (Fun f ss))"
	+ with False obtain t where t: "t \<in> set ss" and "s \<in> set (supteq_list t)" by auto
	+ with Fun[OF t] have "t \<unrhd> s" by auto
	+ with t show "Fun f ss \<unrhd> s" by auto
	+ qed
	+ qed
	+ qed
	+qed
	+
	+lemma supt_list_sound [simp]:
	+ "set (supt_list t) = {s. t \<rhd> s}"
	+ by (cases t) auto
	+
	+fun mergeP_impl where
	+ "mergeP_impl Bot t = True"
	+\| "mergeP_impl t Bot = True"
	+\| "mergeP_impl (BFun f ss) (BFun g ts) =
	+ (if f = g \<and> length ss = length ts then list_all (\<lambda> (x, y). mergeP_impl x y) (zip ss ts) else False)"
	+
	+lemma [simp]: "mergeP_impl s Bot = True" by (cases s) auto
	+
	+lemma [simp]: "mergeP_impl s t \<longleftrightarrow> (s, t) \<in> mergeP" (is "?LS = ?RS")
	+proof
	+ show "?LS \<Longrightarrow> ?RS"
	+ by (induct rule: mergeP_impl.induct, auto split: if_splits intro!: step)
	+ (smt length_zip list_all_length mergeP.step min_less_iff_conj nth_mem nth_zip old.prod.case)
	+next
	+ show "?RS \<Longrightarrow> ?LS" by (induct rule: mergeP.induct, auto simp add: list_all_length)
	+qed
	+
	+fun bless_eq_impl where
	+ "bless_eq_impl Bot t = True"
	+\| "bless_eq_impl (BFun f ss) (BFun g ts) =
	+ (if f = g \<and> length ss = length ts then list_all (\<lambda> (x, y). bless_eq_impl x y) (zip ss ts) else False)"
	+\| "bless_eq_impl _ _ = False"
	+
	+
	+lemma [simp]: "bless_eq_impl s t \<longleftrightarrow> (s, t) \<in> bless_eq" (is "?RS = ?LS")
	+proof
	+ show "?LS \<Longrightarrow> ?RS" by (induct rule: bless_eq.induct, auto simp add: list_all_length)
	+next
	+ show "?RS \<Longrightarrow> ?LS"
	+ by (induct rule: bless_eq_impl.induct, auto split: if_splits intro!: bless_eq.step)
	+ (metis (full_types) length_zip list_all_length min_less_iff_conj nth_mem nth_zip old.prod.case)
	+qed
	+
	+definition "psubt_bot_impl R \<equiv> remdups (map term_to_bot_term (concat (map supt_list R)))"
	+lemma psubt_bot_impl[simp]: "set (psubt_bot_impl R) = psubt_lhs_bot (set R)"
	+ by (induct R, auto simp: psubt_bot_impl_def)
	+
	+definition "states_impl R = List.insert Bot (map the (removeAll None
	+ (closure_impl (lift_f_total mergeP_impl (\<up>)) (map Some (psubt_bot_impl R)))))"
	+
	+lemma states_impl [simp]: "set (states_impl R) = states (set R)"
	+proof -
	+ have [simp]: "lift_f_total mergeP_impl (\<up>) = lift_f_total (\<lambda> x y. mergeP_impl x y) (\<up>)" by blast
	+ show ?thesis unfolding states_impl_def states_def
	+ using lift_total.cl.closure_impl
	+ by (simp add: lift_total.cl.pred_closure_lift_closure)
	+qed
	+
	+abbreviation check_intance_lhs where
	+ "check_intance_lhs qs f R \<equiv> list_all (\<lambda> u. \<not> bless_eq_impl u (BFun f qs)) R"
	+
	+definition min_elem where
	+ "min_elem s ss = (let ts = filter (\<lambda> x. bless_eq_impl x s) ss in
	+ foldr (\<up>) ts Bot)"
	+
	+lemma bound_impl [simp, code]:
	+ "bound_max s (set ss) = min_elem s ss"
	+proof -
	+ have [simp]: "{y. lift_total.lifted_less_eq y (Some s) \<and> y \<in> Some ` set ss} = Some ` {x \<in> set ss. x \<le>\<^sub>b s}"
	+ by auto
	+ then show ?thesis
	+ using lift_total.supremum_impl[of "filter (\<lambda> x. bless_eq_impl x s) ss"]
	+ using lift_total.supremum_smaller_exists_unique[of "set ss" s]
	+ by (auto simp: min_elem_def Let_def lift_total.lift_ord.smaller_subset_def)
	+qed
	+
	+
	+definition nf_rule_impl where
	+ "nf_rule_impl S R SR h = (let (f, n) = h in
	+ let states = List.n_lists n S in
	+ let nlhs_inst = filter (\<lambda> qs. check_intance_lhs qs f R) states in
	+ map (\<lambda> qs. TA_rule f qs (min_elem (BFun f qs) SR)) nlhs_inst)"
	+
	+abbreviation nf_rules_impl where
	+ "nf_rules_impl R \<F> \<equiv> concat (map (nf_rule_impl (states_impl R) (map term_to_bot_term R) (psubt_bot_impl R)) \<F>)"
	+
	+(* Section proves that the implementation constructs the same rule set *)
	+
	+lemma nf_rules_in_impl:
	+ assumes "TA_rule f qs q \|\<in>\| nf_rules (fset_of_list R) (fset_of_list \<F>)"
	+ shows "TA_rule f qs q \|\<in>\| fset_of_list (nf_rules_impl R \<F>)"
	+proof -
	+ have funas: "(f, length qs) \<in> set \<F>" and st: "fset_of_list qs \|\<subseteq>\| fstates (fset_of_list R)"
	+ and nlhs: "\<not>(\<exists> s \<in> (set R). s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
	+ and min: "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
	+ using assms by (auto simp add: nf_rules_fmember simp flip: fset_of_list_elem fmember.rep_eq)
	+ then have st_impl: "qs \|\<in>\| fset_of_list (List.n_lists (length qs) (states_impl R))"
	+ by (auto simp add: fset_of_list_elem subset_code(1) set_n_lists
	+ fset_of_list.rep_eq less_eq_fset.rep_eq fstates.rep_eq)
	+ from nlhs have nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
	+ by (auto simp: list.pred_set)
	+ have min_impl: "q = min_elem (BFun f qs) (psubt_bot_impl R)"
	+ using bound_impl min
	+ by (auto simp flip: psubt_bot_impl)
	+ then show ?thesis using funas nlhs_impl funas st_impl unfolding nf_rule_impl_def
	+ by (auto simp: fset_of_list_elem)
	+qed
	+
	+
	+lemma nf_rules_impl_in_rules:
	+ assumes "TA_rule f qs q \|\<in>\| fset_of_list (nf_rules_impl R \<F>)"
	+ shows "TA_rule f qs q \|\<in>\| nf_rules (fset_of_list R) (fset_of_list \<F>)"
	+proof -
	+ have funas: "(f, length qs) \<in> set \<F>"
	+ and st_impl: "qs \|\<in>\| fset_of_list (List.n_lists (length qs) (states_impl R))"
	+ and nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
	+ and min: "q = min_elem (BFun f qs) (psubt_bot_impl R)" using assms
	+ by (auto simp add: set_n_lists nf_rule_impl_def fset_of_list_elem)
	+ from st_impl have st: "fset_of_list qs \|\<subseteq>\| fstates (fset_of_list R)"
	+ by (force simp: set_n_lists fset_of_list_elem fstates.rep_eq fmember.rep_eq fset_of_list.rep_eq)
	+ from nlhs_impl have nlhs: "\<not>(\<exists> l \<in> (set R). l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
	+ by auto (metis (no_types, lifting) Ball_set_list_all in_set_idx length_map nth_map nth_mem)
	+ have "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
	+ using bound_impl min
	+ by (auto simp flip: psubt_bot_impl)
	+ then show ?thesis using funas st nlhs
	+ by (auto simp add: nf_rules_fmember fset_of_list_elem fset_of_list.rep_eq)
	+qed
	+
	+lemma rule_set_eq:
	+ shows "nf_rules (fset_of_list R) (fset_of_list \<F>) = fset_of_list (nf_rules_impl R \<F>)" (is "?Ls = ?Rs")
	+proof -
	+ {fix r assume "r \|\<in>\| ?Ls" then have "r \|\<in>\| ?Rs"
	+ using nf_rules_in_impl[where ?R = R and ?\<F> = \<F>]
	+ by (cases r) auto}
	+ moreover
	+ {fix r assume "r \|\<in>\| ?Rs" then have "r \|\<in>\| ?Ls"
	+ using nf_rules_impl_in_rules[where ?R = R and ?\<F> = \<F>]
	+ by (cases r) auto}
	+ ultimately show ?thesis by blast
	+qed
	+
	+(* Code equation for normal form TA *)
	+
	+lemma fstates_code[code]:
	+ "fstates R = fset_of_list (states_impl (sorted_list_of_fset R))"
	+ by (auto simp: fmember.rep_eq fstates.rep_eq fset_of_list.rep_eq)
	+
	+lemma nf_ta_code [code]:
	+ "nf_ta R \<F> = TA (fset_of_list (nf_rules_impl (sorted_list_of_fset R) (sorted_list_of_fset \<F>))) {\|\|}"
	+ unfolding nf_ta_def using rule_set_eq[of "sorted_list_of_fset R" "sorted_list_of_fset \<F>"]
	+ by (intro TA_equalityI) auto
	+
	+(*
	+export_code nf_ta in Haskell
	+*)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/ROOT b/thys/FO_Theory_Rewriting/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/ROOT
	@@ -0,0 +1,42 @@
	+chapter AFP
	+
	+session FO_Theory_Rewriting (AFP) = "HOL-Library" +
	+ options
	+ [timeout = 600,document = pdf]
	+ sessions
	+ "Regular_Tree_Relations"
	+ "FOL-Fitting"
	+ directories
	+ "Util"
	+ "Primitives"
	+ "Rewriting"
	+ "Closure"
	+ theories
	+ "Util/Multihole_Context"
	+ "Util/Ground_MCtxt"
	+ "Util/Bot_Terms"
	+ "Util/Saturation"
	+ "Util/Utils"
	+ theories
	+ "Rewriting/Rewriting"
	+ theories
	+ "Primitives/LV_to_GTT"
	+ "Primitives/NF"
	+ "Primitives/NF_Impl"
	+ theories
	+ "Closure/TA_Clousure_Const"
	+ "Closure/Context_Extensions"
	+ "Closure/Lift_Root_Step"
	+ "Closure/GTT_RRn"
	+ "Closure/Context_RR2"
	+ theories
	+ "FOL_Extra"
	+ "FOR_Certificate"
	+ "FOR_Semantics"
	+ "FOR_Check"
	+ "Type_Instances_Impl"
	+ "FOR_Check_Impl"
	+ document_files
	+ "root.bib"
	+ "root.tex"
	+
	diff --git a/thys/FO_Theory_Rewriting/Rewriting/Rewriting.thy b/thys/FO_Theory_Rewriting/Rewriting/Rewriting.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Rewriting/Rewriting.thy
	@@ -0,0 +1,131 @@
	+section \<open>Rewriting\<close>
	+
	+theory Rewriting
	+ imports Regular_Tree_Relations.Term_Context
	+ Regular_Tree_Relations.Ground_Terms
	+ Utils
	+begin
	+
	+subsection \<open>Type definitions and rewrite relation definitions\<close>
	+type_synonym 'f sig = "('f \<times> nat) set"
	+type_synonym ('f, 'v) rule = "('f, 'v) term \<times> ('f, 'v) term"
	+type_synonym ('f, 'v) trs = "('f, 'v) rule set"
	+
	+
	+definition "sig_step \<F> \<R> = {(s, t). funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F> \<and> (s, t) \<in> \<R>}"
	+
	+inductive_set rstep :: "_ \<Rightarrow> ('f, 'v) term rel" for R :: "('f, 'v) trs"
	+ where
	+ rstep: "\<And>C \<sigma> l r. (l, r) \<in> R \<Longrightarrow> s = C\<langle>l \<cdot> \<sigma>\<rangle> \<Longrightarrow> t = C\<langle>r \<cdot> \<sigma>\<rangle> \<Longrightarrow> (s, t) \<in> rstep R"
	+
	+definition rstep_r_p_s :: "('f, 'v) trs \<Rightarrow> ('f, 'v) rule \<Rightarrow> pos \<Rightarrow> ('f, 'v) subst \<Rightarrow> ('f, 'v) trs" where
	+ "rstep_r_p_s R r p \<sigma> = {(s, t). p \<in> poss s \<and> p \<in> poss t \<and> r \<in> R \<and> ctxt_at_pos s p = ctxt_at_pos t p \<and>
	+ s[p \<leftarrow> (fst r \<cdot> \<sigma>)] = s \<and> t[p \<leftarrow> (snd r \<cdot> \<sigma>)] = t}"
	+
	+text \<open>Rewriting steps below the root position.\<close>
	+definition nrrstep :: "('f, 'v) trs \<Rightarrow> ('f, 'v) trs" where
	+ "nrrstep R = {(s,t). \<exists>r i ps \<sigma>. (s,t) \<in> rstep_r_p_s R r (i#ps) \<sigma>}"
	+
	+text \<open>Rewriting step at the root position.\<close>
	+definition rrstep :: "('f, 'v) trs \<Rightarrow> ('f, 'v) trs" where
	+ "rrstep R = {(s,t). \<exists>r \<sigma>. (s,t) \<in> rstep_r_p_s R r [] \<sigma>}"
	+
	+text \<open>the parallel rewrite relation\<close>
	+inductive_set par_rstep :: "('f,'v)trs \<Rightarrow> ('f,'v)trs" for R :: "('f,'v)trs"
	+ where root_step[intro]: "(s,t) \<in> R \<Longrightarrow> (s \<cdot> \<sigma>,t \<cdot> \<sigma>) \<in> par_rstep R"
	+ \| par_step_fun[intro]: "\<lbrakk>\<And> i. i < length ts \<Longrightarrow> (ss ! i,ts ! i) \<in> par_rstep R\<rbrakk> \<Longrightarrow> length ss = length ts
	+ \<Longrightarrow> (Fun f ss, Fun f ts) \<in> par_rstep R"
	+ \| par_step_var[intro]: "(Var x, Var x) \<in> par_rstep R"
	+
	+
	+subsection \<open>Ground variants connecting to FORT\<close>
	+
	+definition grrstep :: "('f, 'v) trs \<Rightarrow> 'f gterm rel" where
	+ "grrstep \<R> = inv_image (rrstep \<R>) term_of_gterm"
	+
	+definition gnrrstep :: "('f, 'v) trs \<Rightarrow> 'f gterm rel" where
	+ "gnrrstep \<R> = inv_image (nrrstep \<R>) term_of_gterm"
	+
	+definition grstep :: "('f, 'v) trs \<Rightarrow> 'f gterm rel" where
	+ "grstep \<R> = inv_image (rstep \<R>) term_of_gterm"
	+
	+definition gpar_rstep :: "('f, 'v) trs \<Rightarrow> 'f gterm rel" where
	+ "gpar_rstep \<R> = inv_image (par_rstep \<R>) term_of_gterm"
	+
	+
	+text \<open>
	+ An alternative induction scheme that treats the rule-case, the
	+ substition-case, and the context-case separately.
	+\<close>
	+lemma rstep_induct [consumes 1, case_names rule subst ctxt]:
	+ assumes "(s, t) \<in> rstep R"
	+ and rule: "\<And>l r. (l, r) \<in> R \<Longrightarrow> P l r"
	+ and subst: "\<And>s t \<sigma>. P s t \<Longrightarrow> P (s \<cdot> \<sigma>) (t \<cdot> \<sigma>)"
	+ and ctxt: "\<And>s t C. P s t \<Longrightarrow> P (C\<langle>s\<rangle>) (C\<langle>t\<rangle>)"
	+ shows "P s t"
	+ using assms by (induct) auto
	+
	+
	+lemmas rstepI = rstep.intros [intro]
	+
	+lemmas rstepE = rstep.cases [elim]
	+
	+lemma rstep_ctxt [intro]: "(s, t) \<in> rstep R \<Longrightarrow> (C\<langle>s\<rangle>, C\<langle>t\<rangle>) \<in> rstep R"
	+ by (force simp flip: ctxt_ctxt_compose)
	+
	+lemma rstep_rule [intro]: "(l, r) \<in> R \<Longrightarrow> (l, r) \<in> rstep R"
	+ using rstep.rstep [where C = \<box> and \<sigma> = Var and R = R] by simp
	+
	+lemma rstep_subst [intro]: "(s, t) \<in> rstep R \<Longrightarrow> (s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> rstep R"
	+ by (force simp flip: subst_subst_compose)
	+
	+lemma nrrstep_def':
	+ "nrrstep R = {(s, t). \<exists>l r C \<sigma>. (l, r) \<in> R \<and> C \<noteq> \<box> \<and> s = C\<langle>l\<cdot>\<sigma>\<rangle> \<and> t = C\<langle>r\<cdot>\<sigma>\<rangle>}" (is "?Ls = ?Rs")
	+proof
	+ show "?Ls \<subseteq> ?Rs"
	+ proof (rule subrelI)
	+ fix s t assume "(s, t) \<in> ?Ls"
	+ then obtain l r i ps \<sigma> where step: "(s, t) \<in> rstep_r_p_s R (l, r) (i # ps) \<sigma>"
	+ unfolding nrrstep_def by best
	+ let ?C = "ctxt_at_pos s (i # ps)"
	+ from step have"i # ps \<in> poss s" and "(l, r) \<in> R" and "s = ?C\<langle>l\<cdot>\<sigma>\<rangle>" and "t = ?C\<langle>r\<cdot>\<sigma>\<rangle>"
	+ unfolding rstep_r_p_s_def Let_def by (auto simp flip: replace_term_at_replace_at_conv)
	+ moreover from \<open>i # ps \<in> poss s\<close> have "?C \<noteq> \<box>" by (induct s) auto
	+ ultimately show "(s, t) \<in> ?Rs" by auto
	+ qed
	+next
	+ show "?Rs \<subseteq> ?Ls"
	+ proof (rule subrelI)
	+ fix s t assume "(s, t) \<in> ?Rs"
	+ then obtain l r C \<sigma> where in_R: "(l, r) \<in> R" and "C \<noteq> \<box>"
	+ and s: "s = C\<langle>l\<cdot>\<sigma>\<rangle>" and t: "t = C\<langle>r\<cdot>\<sigma>\<rangle>" by auto
	+ from \<open>C \<noteq> \<box>\<close> obtain i p where ip: "hole_pos C = i # p" by (induct C) auto
	+ have "i # p \<in> poss s" unfolding s ip[symmetric] by simp
	+ then have C: "C = ctxt_at_pos s (i # p) "
	+ unfolding s ip[symmetric] by simp
	+ from \<open>i # p \<in> poss s\<close> in_R s t have "(s, t) \<in> rstep_r_p_s R (l, r) (i # p) \<sigma>"
	+ unfolding rstep_r_p_s_def C[symmetric] ip[symmetric] by simp
	+ then show "(s, t) \<in> nrrstep R" unfolding nrrstep_def by best
	+ qed
	+qed
	+
	+lemma rrstep_def': "rrstep R = {(s, t). \<exists>l r \<sigma>. (l, r) \<in> R \<and> s = l\<cdot>\<sigma> \<and> t = r\<cdot>\<sigma>}"
	+ by (auto simp: rrstep_def rstep_r_p_s_def)
	+
	+
	+lemma rstep_imp_C_s_r:
	+ assumes "(s,t) \<in> rstep R"
	+ shows "\<exists>C \<sigma> l r. (l,r) \<in> R \<and> s = C\<langle>l\<cdot>\<sigma>\<rangle> \<and> t = C\<langle>r\<cdot>\<sigma>\<rangle>" using assms
	+ by (induct) auto
	+
	+lemma rhs_wf:
	+ assumes R: "(l, r) \<in> R" and "funas_trs R \<subseteq> F"
	+ shows "funas_term r \<subseteq> F"
	+ using assms by (force simp: funas_trs_def)
	+
	+abbreviation "linear_sys \<R> \<equiv> (\<forall> (l, r) \<in> \<R>. linear_term l \<and> linear_term r)"
	+abbreviation "const_subt c \<equiv> \<lambda> x. Fun c []"
	+
	+
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Type_Instances_Impl.thy b/thys/FO_Theory_Rewriting/Type_Instances_Impl.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Type_Instances_Impl.thy
	@@ -0,0 +1,118 @@
	+theory Type_Instances_Impl
	+ imports Bot_Terms
	+ TA_Clousure_Const
	+ Regular_Tree_Relations.Tree_Automata_Class_Instances_Impl
	+begin
	+
	+
	+section \<open>Type class instantiations for the implementation\<close>
	+
	+derive linorder sum
	+derive linorder bot_term
	+derive linorder cl_states
	+
	+derive compare bot_term
	+derive compare cl_states
	+
	+derive (eq) ceq bot_term mctxt cl_states
	+
	+derive (compare) ccompare bot_term cl_states
	+
	+derive (rbt) set_impl bot_term cl_states
	+
	+derive (no) cenum bot_term
	+
	+instantiation cl_states :: cenum
	+begin
	+abbreviation "cl_all_list \<equiv> [cl_state, tr_state, fin_state, fin_clstate]"
	+definition cEnum_cl_states :: "(cl_states list \<times> ((cl_states \<Rightarrow> bool) \<Rightarrow> bool) \<times> ((cl_states \<Rightarrow> bool) \<Rightarrow> bool)) option"
	+ where "cEnum_cl_states = Some (cl_all_list, (\<lambda> P. list_all P cl_all_list), (\<lambda> P. list_ex P cl_all_list))"
	+instance
	+ apply intro_classes apply (auto simp: cEnum_cl_states_def elim!: cl_states.induct)
	+ using cl_states.exhaust apply blast
	+ by (metis cl_states.exhaust)
	+end
	+
	+lemma infinite_bot_term_UNIV[simp, intro]: "infinite (UNIV :: 'f bot_term set)"
	+proof -
	+ fix f :: 'f
	+ let ?inj = "\<lambda>n. BFun f (replicate n Bot)"
	+ have "inj ?inj" unfolding inj_on_def by auto
	+ from infinite_super[OF _ range_inj_infinite[OF this]]
	+ show ?thesis by blast
	+qed
	+
	+lemma finite_cl_states: "(UNIV :: cl_states set) = {cl_state, tr_state, fin_state, fin_clstate}"
	+ using cl_states.exhaust
	+ by auto
	+
	+instantiation cl_states :: card_UNIV begin
	+definition "finite_UNIV = Phantom(cl_states) True"
	+definition "card_UNIV = Phantom(cl_states) 4"
	+instance
	+ by intro_classes (simp_all add: card_UNIV_cl_states_def finite_UNIV_cl_states_def finite_cl_states)
	+end
	+
	+instantiation bot_term :: (type) finite_UNIV
	+begin
	+definition "finite_UNIV = Phantom('a bot_term) False"
	+instance
	+ by (intro_classes, unfold finite_UNIV_bot_term_def, simp)
	+end
	+
	+
	+instantiation bot_term :: (compare) cproper_interval
	+begin
	+definition "cproper_interval = (\<lambda> ( _ :: 'a bot_term option) _ . False)"
	+instance by (intro_classes, auto)
	+end
	+
	+instantiation cl_states :: cproper_interval
	+begin
	+
	+(* cl_all_list *)
	+definition cproper_interval_cl_states :: "cl_states option \<Rightarrow> cl_states option \<Rightarrow> bool"
	+ where "cproper_interval_cl_states x y =
	+ (case ID CCOMPARE(cl_states) of Some f \<Rightarrow>
	+ (case x of None \<Rightarrow>
	+ (case y of None \<Rightarrow> True \| Some c \<Rightarrow> list_ex (\<lambda> x. (lt_of_comp f) x c) cl_all_list)
	+ \| Some c \<Rightarrow>
	+ (case y of None \<Rightarrow> list_ex (\<lambda> x. (lt_of_comp f) c x) cl_all_list
	+ \| Some d \<Rightarrow> (filter (\<lambda> x. (lt_of_comp f) x d \<and> (lt_of_comp f) c x) cl_all_list) \<noteq> [])))"
	+
	+instance
	+proof (intro_classes)
	+ assume ass: "(ID ccompare :: (cl_states \<Rightarrow> cl_states \<Rightarrow> order) option) \<noteq> None"
	+ from ass obtain f where comp: "(ID ccompare :: (cl_states \<Rightarrow> cl_states \<Rightarrow> order) option) = Some f" by auto
	+ let ?g = "cproper_interval :: cl_states option \<Rightarrow> cl_states option \<Rightarrow> bool"
	+ have [simp]: "x < y \<longleftrightarrow> lt_of_comp f x y" for x y
	+ by (metis ID_Some ccompare_cl_states_def comp compare_cl_states_def less_cl_states_def option.sel)
	+ {fix c d x assume "lt_of_comp f x d" "lt_of_comp f c x"
	+ then have "c < x" "x < d" by simp_all}
	+ moreover
	+ {fix c d assume "\<exists> z. (c ::cl_states) < z \<and> z < d"
	+ then obtain z where w: "c < z \<and> z < d" by blast
	+ then have "z \<in> set cl_all_list" by (cases z) auto
	+ moreover have "lt_of_comp f z d \<and> lt_of_comp f c z" using w comp
	+ by auto
	+ ultimately have "filter (\<lambda>x. lt_of_comp f x d \<and> lt_of_comp f c x) cl_all_list \<noteq> []" using w
	+ by auto}
	+ ultimately have "filter (\<lambda>x. lt_of_comp f x d \<and> lt_of_comp f c x) cl_all_list \<noteq> [] \<longleftrightarrow> (\<exists> z. c < z \<and> z < d)" for d c using comp
	+ unfolding filter_empty_conv by simp blast
	+ then have "?g (Some x) (Some y) = (\<exists> z. x < z \<and> z < y)" for x y
	+ by (simp add: comp cproper_interval_cl_states_def)
	+ moreover have "?g None None = True" by (simp add: comp cproper_interval_cl_states_def)
	+ moreover have "?g None (Some y) = (\<exists>z. z < y)" for y using comp
	+ by (auto simp add: cproper_interval_cl_states_def ccompare_cl_states_def) (metis cl_states.exhaust)+
	+ moreover have "?g (Some y) None = (\<exists>z. y < z)" for y using comp
	+ by (auto simp add: cproper_interval_cl_states_def) (metis cl_states.exhaust)+
	+ ultimately show "class.proper_interval cless ?g"
	+ unfolding class.proper_interval_def comp
	+ by simp
	+qed
	+end
	+
	+derive (rbt) mapping_impl cl_states
	+derive (rbt) mapping_impl bot_term
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Util/Bot_Terms.thy b/thys/FO_Theory_Rewriting/Util/Bot_Terms.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Util/Bot_Terms.thy
	@@ -0,0 +1,181 @@
	+theory Bot_Terms
	+ imports Utils
	+begin
	+
	+subsection \<open>Bottom terms\<close>
	+
	+datatype 'f bot_term = Bot \| BFun 'f (args: "'f bot_term list")
	+
	+fun term_to_bot_term :: "('f, 'v) term \<Rightarrow> 'f bot_term" ("_\<^sup>\<bottom>" [80] 80) where
	+ "(Var _)\<^sup>\<bottom> = Bot"
	+\| "(Fun f ts)\<^sup>\<bottom> = BFun f (map term_to_bot_term ts)"
	+
	+fun root_bot where
	+ "root_bot Bot = None" \|
	+ "root_bot (BFun f ts) = Some (f, length ts)"
	+
	+fun funas_bot_term where
	+ "funas_bot_term Bot = {}"
	+\| "funas_bot_term (BFun f ss) = {(f, length ss)} \<union> (\<Union> (funas_bot_term ` set ss))"
	+
	+lemma finite_funas_bot_term:
	+ "finite (funas_bot_term t)"
	+ by (induct t) auto
	+
	+lemma funas_bot_term_funas_term:
	+ "funas_bot_term (t\<^sup>\<bottom>) = funas_term t"
	+ by (induct t) auto
	+
	+lemma term_to_bot_term_root_bot [simp]:
	+ "root_bot (t\<^sup>\<bottom>) = root t"
	+ by (induct t) auto
	+
	+lemma term_to_bot_term_root_bot_comp [simp]:
	+ "root_bot \<circ> term_to_bot_term = root"
	+ using term_to_bot_term_root_bot by force
	+
	+inductive_set mergeP where
	+ base_l [simp]: "(Bot, t) \<in> mergeP"
	+\| base_r [simp]: "(t, Bot) \<in> mergeP"
	+\| step [intro]: "length ss = length ts \<Longrightarrow> (\<forall> i < length ts. (ss ! i, ts ! i) \<in> mergeP) \<Longrightarrow>
	+ (BFun f ss, BFun f ts) \<in> mergeP"
	+
	+lemma merge_refl:
	+ "(s, s) \<in> mergeP"
	+ by (induct s) auto
	+
	+lemma merge_symmetric:
	+ assumes "(s, t) \<in> mergeP"
	+ shows "(t, s) \<in> mergeP"
	+ using assms by induct auto
	+
	+fun merge_terms :: "'f bot_term \<Rightarrow> 'f bot_term \<Rightarrow> 'f bot_term" (infixr "\<up>" 67) where
	+ "Bot \<up> s = s"
	+\| "s \<up> Bot = s"
	+\| "(BFun f ss) \<up> (BFun g ts) = (if f = g \<and> length ss = length ts
	+ then BFun f (map (case_prod (\<up>)) (zip ss ts))
	+ else undefined)"
	+
	+lemma merge_terms_bot_rhs[simp]:
	+ "s \<up> Bot = s" by (cases s) auto
	+
	+lemma merge_terms_idem: "s \<up> s = s"
	+ by (induct s) (auto simp add: map_nth_eq_conv)
	+
	+lemma merge_terms_assoc [ac_simps]:
	+ assumes "(s, t) \<in> mergeP" and "(t, u) \<in> mergeP"
	+ shows "(s \<up> t) \<up> u = s \<up> t \<up> u"
	+ using assms by (induct s t arbitrary: u) (auto elim!: mergeP.cases intro!: nth_equalityI)
	+
	+lemma merge_terms_commutative [ac_simps]:
	+ shows "s \<up> t = t \<up> s"
	+ by (induct s t rule: merge_terms.induct)
	+ (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+
	+
	+lemma merge_dist:
	+ assumes "(s, t \<up> u) \<in> mergeP" and "(t, u) \<in> mergeP"
	+ shows "(s, t) \<in> mergeP" using assms
	+ by (induct t arbitrary: s u) (auto elim!: mergeP.cases, metis mergeP.step nth_mem)
	+
	+lemma megeP_ass:
	+ "(s, t \<up> u) \<in> mergeP \<Longrightarrow> (t, u) \<in> mergeP \<Longrightarrow> (s \<up> t, u) \<in> mergeP"
	+ by (induct t arbitrary: s u) (auto simp: mergeP.step elim!: mergeP.cases)
	+
	+inductive_set bless_eq where
	+ base_l [simp]: "(Bot, t) \<in> bless_eq"
	+\| step [intro]: "length ss = length ts \<Longrightarrow> (\<forall> i < length ts. (ss ! i, ts ! i) \<in> bless_eq) \<Longrightarrow>
	+ (BFun f ss, BFun f ts) \<in> bless_eq"
	+
	+text \<open>Infix syntax.\<close>
	+abbreviation "bless_eq_pred s t \<equiv> (s, t) \<in> bless_eq"
	+notation
	+ bless_eq ("{\<le>\<^sub>b}") and
	+ bless_eq_pred ("(_/ \<le>\<^sub>b _)" [56, 56] 55)
	+
	+lemma BFun_leq_Bot_False [simp]:
	+ "BFun f ts \<le>\<^sub>b Bot \<longleftrightarrow> False"
	+ using bless_eq.cases by auto
	+
	+lemma BFun_lesseqE [elim]:
	+ assumes "BFun f ts \<le>\<^sub>b t"
	+ obtains us where "length ts = length us" "t = BFun f us"
	+ using assms bless_eq.cases by blast
	+
	+lemma bless_eq_refl: "s \<le>\<^sub>b s"
	+ by (induct s) auto
	+
	+lemma bless_eq_trans [trans]:
	+ assumes "s \<le>\<^sub>b t" and "t \<le>\<^sub>b u"
	+ shows "s \<le>\<^sub>b u" using assms
	+proof (induct arbitrary: u)
	+ case (step ss ts f)
	+ from step(3) obtain us where [simp]: "u = BFun f us" "length ts = length us" by auto
	+ from step(3, 1, 2) have "i < length ss \<Longrightarrow> ss ! i \<le>\<^sub>b us ! i" for i
	+ by (cases rule: bless_eq.cases) auto
	+ then show ?case using step(1) by auto
	+qed auto
	+
	+lemma bless_eq_anti_sym:
	+ "s \<le>\<^sub>b t \<Longrightarrow> t \<le>\<^sub>b s \<Longrightarrow> s = t"
	+ by (induct rule: bless_eq.induct) (auto elim!: bless_eq.cases intro: nth_equalityI)
	+
	+lemma bless_eq_mergeP:
	+ "s \<le>\<^sub>b t \<Longrightarrow> (s, t) \<in> mergeP"
	+ by (induct s arbitrary: t) (auto elim!: bless_eq.cases)
	+
	+lemma merge_bot_args_bless_eq_merge:
	+ assumes "(s, t) \<in> mergeP"
	+ shows "s \<le>\<^sub>b s \<up> t" using assms
	+ by (induct s arbitrary: t) (auto simp: bless_eq_refl elim!: mergeP.cases intro!: step)
	+
	+lemma bless_eq_closued_under_merge:
	+ assumes "(s, t) \<in> mergeP" "(u, v) \<in> mergeP" "s \<le>\<^sub>b u" "t \<le>\<^sub>b v"
	+ shows "s \<up> t \<le>\<^sub>b u \<up> v" using assms(3, 4, 1, 2)
	+proof (induct arbitrary: t v)
	+ case (base_l t)
	+ then show ?case using bless_eq_trans merge_bot_args_bless_eq_merge
	+ by (metis merge_symmetric merge_terms.simps(1) merge_terms_commutative)
	+next
	+ case (step ss ts f)
	+ then show ?case apply (auto elim!: mergeP.cases intro!: bless_eq.step)
	+ using bless_eq_trans merge_bot_args_bless_eq_merge apply blast
	+ by (metis bless_eq.cases bot_term.distinct(1) bot_term.sel(2))
	+qed
	+
	+lemma bless_eq_closued_under_supremum:
	+ assumes "s \<le>\<^sub>b u" "t \<le>\<^sub>b u"
	+ shows "s \<up> t \<le>\<^sub>b u" using assms
	+ by (induct arbitrary: t) (auto elim!: bless_eq.cases intro!: bless_eq.step)
	+
	+lemma linear_term_comb_subst:
	+ assumes "linear_term (Fun f ss)"
	+ and "length ss = length ts"
	+ and "\<And> i. i < length ts \<Longrightarrow> ss ! i \<cdot> \<sigma> i = ts ! i"
	+ shows "\<exists> \<sigma>. Fun f ss \<cdot> \<sigma> = Fun f ts"
	+ using assms subst_merge[of ss "\<sigma>"]
	+ apply auto apply (rule_tac x = \<sigma>' in exI)
	+ apply (intro nth_equalityI) apply auto
	+ by (metis term_subst_eq)
	+
	+lemma bless_eq_to_instance:
	+ assumes "s\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>" and "linear_term s"
	+ shows "\<exists> \<sigma>. s \<cdot> \<sigma> = t" using assms
	+proof (induct s arbitrary: t)
	+ case (Fun f ts)
	+ from Fun(2) obtain us where [simp]: "t = Fun f us" "length ts = length us" by (cases t) auto
	+ have "i < length ts \<Longrightarrow> \<exists>\<sigma>. ts ! i \<cdot> \<sigma> = us ! i" for i
	+ using Fun(2, 3) Fun(1)[OF nth_mem, of i "us ! i" for i]
	+ by (auto elim: bless_eq.cases)
	+ then show ?case using Ex_list_of_length_P[of "length ts" "\<lambda> \<sigma> i. ts ! i \<cdot> \<sigma> = us ! i"]
	+ using linear_term_comb_subst[OF Fun(3)] by auto
	+qed auto
	+
	+lemma instance_to_bless_eq:
	+ assumes "s \<cdot> \<sigma> = t"
	+ shows "s\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>" using assms
	+proof (induct s arbitrary: t)
	+ case (Fun f ts) then show ?case
	+ by (cases t) auto
	+qed auto
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Util/Ground_MCtxt.thy b/thys/FO_Theory_Rewriting/Util/Ground_MCtxt.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Util/Ground_MCtxt.thy
	@@ -0,0 +1,1326 @@
	+theory Ground_MCtxt
	+ imports
	+ Multihole_Context
	+ Regular_Tree_Relations.Ground_Terms
	+ Regular_Tree_Relations.Ground_Ctxt
	+begin
	+
	+subsection \<open>Ground multihole context\<close>
	+
	+datatype (gfuns_mctxt: 'f) gmctxt = GMHole \| GMFun 'f "'f gmctxt list"
	+
	+subsubsection \<open>Basic function on ground mutlihole contexts\<close>
	+
	+primrec gmctxt_of_gterm :: "'f gterm \<Rightarrow> 'f gmctxt" where
	+ "gmctxt_of_gterm (GFun f ts) = GMFun f (map gmctxt_of_gterm ts)"
	+
	+fun num_gholes :: "'f gmctxt \<Rightarrow> nat" where
	+ "num_gholes GMHole = Suc 0"
	+\| "num_gholes (GMFun _ ctxts) = sum_list (map num_gholes ctxts)"
	+
	+primrec gterm_of_gmctxt :: "'f gmctxt \<Rightarrow> 'f gterm" where
	+ "gterm_of_gmctxt (GMFun f Cs) = GFun f (map gterm_of_gmctxt Cs)"
	+
	+primrec term_of_gmctxt :: "'f gmctxt \<Rightarrow> ('f, 'v) term" where
	+ "term_of_gmctxt (GMFun f Cs) = Fun f (map term_of_gmctxt Cs)"
	+
	+primrec gmctxt_of_gctxt :: "'f gctxt \<Rightarrow> 'f gmctxt" where
	+ "gmctxt_of_gctxt \<box>\<^sub>G = GMHole"
	+\| "gmctxt_of_gctxt (GMore f ss C ts) =
	+ GMFun f (map gmctxt_of_gterm ss @ gmctxt_of_gctxt C # map gmctxt_of_gterm ts)"
	+
	+fun gctxt_of_gmctxt :: "'f gmctxt \<Rightarrow> 'f gctxt" where
	+ "gctxt_of_gmctxt GMHole = \<box>\<^sub>G"
	+\| "gctxt_of_gmctxt (GMFun f Cs) = (let n = length (takeWhile (\<lambda> C. num_gholes C = 0) Cs) in
	+ (if n < length Cs then
	+ GMore f (map gterm_of_gmctxt (take n Cs)) (gctxt_of_gmctxt (Cs ! n)) (map gterm_of_gmctxt (drop (Suc n) Cs))
	+ else undefined))"
	+
	+primrec gmctxt_of_mctxt :: "('f, 'v) mctxt \<Rightarrow> 'f gmctxt" where
	+ "gmctxt_of_mctxt MHole = GMHole"
	+\| "gmctxt_of_mctxt (MFun f Cs) = GMFun f (map gmctxt_of_mctxt Cs)"
	+
	+primrec mctxt_of_gmctxt :: "'f gmctxt \<Rightarrow> ('f, 'v) mctxt" where
	+ "mctxt_of_gmctxt GMHole = MHole"
	+\| "mctxt_of_gmctxt (GMFun f Cs) = MFun f (map mctxt_of_gmctxt Cs)"
	+
	+fun funas_gmctxt where
	+ "funas_gmctxt (GMFun f Cs) = {(f, length Cs)} \<union> \<Union>(funas_gmctxt ` set Cs)" \|
	+ "funas_gmctxt _ = {}"
	+
	+abbreviation "partition_gholes xs Cs \<equiv> partition_by xs (map num_gholes Cs)"
	+
	+fun fill_gholes :: "'f gmctxt \<Rightarrow> 'f gterm list \<Rightarrow> 'f gterm" where
	+ "fill_gholes GMHole [t] = t"
	+\| "fill_gholes (GMFun f cs) ts = GFun f (map (\<lambda> i. fill_gholes (cs ! i)
	+ (partition_gholes ts cs ! i)) [0 ..< length cs])"
	+
	+fun fill_gholes_gmctxt :: "'f gmctxt \<Rightarrow> 'f gmctxt list \<Rightarrow> 'f gmctxt" where
	+ "fill_gholes_gmctxt GMHole [] = GMHole" \|
	+ "fill_gholes_gmctxt GMHole [t] = t" \|
	+ "fill_gholes_gmctxt (GMFun f cs) ts = (GMFun f (map (\<lambda> i. fill_gholes_gmctxt (cs ! i)
	+ (partition_gholes ts cs ! i)) [0 ..< length cs]))"
	+
	+subsubsection \<open>An inverse of @{term fill_gholes}\<close>
	+fun unfill_gholes :: "'f gmctxt \<Rightarrow> 'f gterm \<Rightarrow> 'f gterm list" where
	+ "unfill_gholes GMHole t = [t]"
	+\| "unfill_gholes (GMFun g Cs) (GFun f ts) = (if f = g \<and> length ts = length Cs then
	+ concat (map (\<lambda>i. unfill_gholes (Cs ! i) (ts ! i)) [0..<length ts]) else undefined)"
	+
	+fun sup_gmctxt_args :: "'f gmctxt \<Rightarrow> 'f gmctxt \<Rightarrow> 'f gmctxt list" where
	+ "sup_gmctxt_args GMHole D = [D]" \|
	+ "sup_gmctxt_args C GMHole = replicate (num_gholes C) GMHole" \|
	+ "sup_gmctxt_args (GMFun f Cs) (GMFun g Ds) =
	+ (if f = g \<and> length Cs = length Ds then concat (map (case_prod sup_gmctxt_args) (zip Cs Ds))
	+ else undefined)"
	+
	+fun ghole_poss :: "'f gmctxt \<Rightarrow> pos set" where
	+ "ghole_poss GMHole = {[]}" \|
	+ "ghole_poss (GMFun f cs) = \<Union>(set (map (\<lambda> i. (\<lambda> p. i # p) ` ghole_poss (cs ! i)) [0 ..< length cs]))"
	+
	+abbreviation "poss_rec f ts \<equiv> map2 (\<lambda> i t. map ((#) i) (f t)) ([0 ..< length ts]) ts"
	+fun ghole_poss_list :: "'f gmctxt \<Rightarrow> pos list" where
	+ "ghole_poss_list GMHole = [[]]"
	+\| "ghole_poss_list (GMFun f cs) = concat (poss_rec ghole_poss_list cs)"
	+
	+
	+fun poss_gmctxt :: "'f gmctxt \<Rightarrow> pos set" where
	+ "poss_gmctxt GMHole = {}" \|
	+ "poss_gmctxt (GMFun f cs) = {[]} \<union> \<Union>(set (map (\<lambda> i. (\<lambda> p. i # p) ` poss_gmctxt (cs ! i)) [0 ..< length cs]))"
	+
	+lemma poss_simps [simp]:
	+ "ghole_poss (GMFun f Cs) = {i # p \| i p. i < length Cs \<and> p \<in> ghole_poss (Cs ! i)}"
	+ "poss_gmctxt (GMFun f Cs) = {[]} \<union> {i # p \| i p. i < length Cs \<and> p \<in> poss_gmctxt (Cs ! i)}"
	+ by auto
	+
	+fun ghole_num_bef_pos where
	+ "ghole_num_bef_pos [] _ = 0" \|
	+ "ghole_num_bef_pos (i # q) (GMFun f Cs) = sum_list (map num_gholes (take i Cs)) + ghole_num_bef_pos q (Cs ! i)"
	+
	+fun ghole_num_at_pos where
	+ "ghole_num_at_pos [] C = num_gholes C" \|
	+ "ghole_num_at_pos (i # q) (GMFun f Cs) = ghole_num_at_pos q (Cs ! i)"
	+
	+fun subgm_at :: "'f gmctxt \<Rightarrow> pos \<Rightarrow> 'f gmctxt" where
	+ "subgm_at C [] = C"
	+\| "subgm_at (GMFun f Cs) (i # p) = subgm_at (Cs ! i) p"
	+
	+definition gmctxt_subtgm_at_fill_args where
	+ "gmctxt_subtgm_at_fill_args p C ts = take (ghole_num_at_pos p C) (drop (ghole_num_bef_pos p C) ts)"
	+
	+(*
	+declare hole_poss.simps(2)[simp del]
	+declare poss_mctxt.simps(2)[simp del]
	+*)
	+
	+instantiation gmctxt :: (type) inf
	+begin
	+
	+fun inf_gmctxt :: "'a gmctxt \<Rightarrow> 'a gmctxt \<Rightarrow> 'a gmctxt" where
	+ "GMHole \<sqinter> D = GMHole" \|
	+ "C \<sqinter> GMHole = GMHole" \|
	+ "GMFun f Cs \<sqinter> GMFun g Ds =
	+ (if f = g \<and> length Cs = length Ds then GMFun f (map (case_prod (\<sqinter>)) (zip Cs Ds))
	+ else GMHole)"
	+
	+instance ..
	+end
	+
	+instantiation gmctxt :: (type) sup
	+begin
	+
	+fun sup_gmctxt :: "'a gmctxt \<Rightarrow> 'a gmctxt \<Rightarrow> 'a gmctxt" where
	+ "GMHole \<squnion> D = D" \|
	+ "C \<squnion> GMHole = C" \|
	+ "GMFun f Cs \<squnion> GMFun g Ds =
	+ (if f = g \<and> length Cs = length Ds then GMFun f (map (case_prod (\<squnion>)) (zip Cs Ds))
	+ else undefined)"
	+
	+instance ..
	+end
	+
	+subsubsection \<open>Orderings and compatibility of ground multihole contexts\<close>
	+
	+inductive less_eq_gmctxt :: "'f gmctxt \<Rightarrow> 'f gmctxt \<Rightarrow> bool" where
	+ base [simp]: "less_eq_gmctxt GMHole u"
	+\| ind[intro]: "length cs = length ds \<Longrightarrow> (\<And>i. i < length cs \<Longrightarrow> less_eq_gmctxt (cs ! i) (ds ! i)) \<Longrightarrow>
	+ less_eq_gmctxt (GMFun f cs) (GMFun f ds)"
	+
	+inductive_set comp_gmctxt :: "('f gmctxt \<times> 'f gmctxt) set" where
	+ GMHole1 [simp]: "(GMHole, D) \<in> comp_gmctxt" \|
	+ GMHole2 [simp]: "(C, GMHole) \<in> comp_gmctxt" \|
	+ GMFun [intro]: "f = g \<Longrightarrow> length Cs = length Ds \<Longrightarrow> \<forall>i < length Ds. (Cs ! i, Ds ! i) \<in> comp_gmctxt \<Longrightarrow>
	+ (GMFun f Cs, GMFun g Ds) \<in> comp_gmctxt"
	+
	+definition gmctxt_closing where
	+ "gmctxt_closing C D \<longleftrightarrow> less_eq_gmctxt C D \<and> ghole_poss D \<subseteq> ghole_poss C"
	+
	+
	+inductive eq_gfill ("(_/ =\<^sub>G\<^sub>f _)" [51, 51] 50) where
	+ eqfI [intro]: "t = fill_gholes D ss \<Longrightarrow> num_gholes D = length ss \<Longrightarrow> t =\<^sub>G\<^sub>f (D, ss)"
	+
	+subsubsection \<open>Conversions from and to ground multihole contexts\<close>
	+
	+lemma num_gholes_o_gmctxt_of_gterm [simp]:
	+ "num_gholes \<circ> gmctxt_of_gterm = (\<lambda>x. 0)"
	+ by (rule ext, induct_tac x) simp_all
	+
	+lemma mctxt_of_term_term_of_mctxt_id [simp]:
	+ "num_gholes C = 0 \<Longrightarrow> gmctxt_of_gterm (gterm_of_gmctxt C) = C"
	+ by (induct C) (simp_all add: map_idI)
	+
	+lemma num_holes_mctxt_of_term [simp]:
	+ "num_gholes (gmctxt_of_gterm t) = 0"
	+ by (induct t) simp_all
	+
	+lemma num_gholes_gmctxt_of_mctxt [simp]:
	+ "ground_mctxt C \<Longrightarrow> num_gholes (gmctxt_of_mctxt C) = num_holes C"
	+ by (induct C) (auto intro: nth_sum_listI)
	+
	+lemma num_holes_mctxt_of_gmctxt [simp]:
	+ "num_holes (mctxt_of_gmctxt C) = num_gholes C"
	+ by (induct C) (auto intro: nth_sum_listI)
	+
	+lemma num_holes_mctxt_of_gmctxt_fun_comp [simp]:
	+ "num_holes \<circ> mctxt_of_gmctxt = num_gholes"
	+ by (auto simp: comp_def)
	+
	+lemma gmctxt_of_gctxt_num_gholes [simp]:
	+ "num_gholes (gmctxt_of_gctxt C) = Suc 0"
	+ by (induct C) auto
	+
	+lemma ground_mctxt_list_num_gholes_gmctxt_of_mctxt_conv [simp]:
	+ "\<forall>x\<in>set Cs. ground_mctxt x \<Longrightarrow> map (num_gholes \<circ> gmctxt_of_mctxt) Cs = map num_holes Cs"
	+ by auto
	+
	+
	+lemma num_gholes_map_gmctxt [simp]:
	+ "num_gholes (map_gmctxt f C) = num_gholes C"
	+ by (induct C) (auto simp: comp_def, metis (no_types, lifting) map_eq_conv)
	+
	+lemma map_num_gholes_map_gmctxt [simp]:
	+ "map (num_gholes \<circ> map_gmctxt f) Cs = map num_gholes Cs"
	+ by (induct Cs) auto
	+
	+lemma gterm_of_gmctxt_gmctxt_of_gterm_id [simp]:
	+ "gterm_of_gmctxt (gmctxt_of_gterm t) = t"
	+ by (induct t) (simp_all add: map_idI)
	+
	+lemma no_gholes_gmctxt_of_gterm_gterm_of_gmctxt_id [simp]:
	+ "num_gholes C = 0 \<Longrightarrow> gmctxt_of_gterm (gterm_of_gmctxt C) = C"
	+ by (induct C) (auto simp: comp_def intro: nth_equalityI)
	+
	+lemma no_gholes_term_of_gterm_gterm_of_gmctxt [simp]:
	+ "num_gholes C = 0 \<Longrightarrow> term_of_gterm (gterm_of_gmctxt C) = term_of_gmctxt C"
	+ by (induct C) (auto simp: comp_def intro: nth_equalityI)
	+
	+lemma no_gholes_term_of_mctxt_mctxt_of_gmctxt [simp]:
	+ "num_gholes C = 0 \<Longrightarrow> term_of_mctxt (mctxt_of_gmctxt C) = term_of_gmctxt C"
	+ by (induct C) (auto simp: comp_def intro: nth_equalityI)
	+
	+lemma nthWhile_gmctxt_of_gctxt [simp]:
	+ "length (takeWhile (\<lambda>C. num_gholes C = 0) (map gmctxt_of_gterm ss @ gmctxt_of_gctxt C # ts)) = length ss"
	+ by (induct ss) auto
	+
	+lemma sum_list_nthWhile_length [simp]:
	+ "sum_list (map num_gholes Cs) = Suc 0 \<Longrightarrow> length (takeWhile (\<lambda>C. num_gholes C = 0) Cs) < length Cs"
	+ by (induct Cs) auto
	+
	+lemma gctxt_of_gmctxt_gmctxt_of_gctxt [simp]:
	+ "gctxt_of_gmctxt (gmctxt_of_gctxt C) = C"
	+ by (induct C) (auto simp: Let_def comp_def nth_append)
	+
	+lemma gmctxt_of_gctxt_GMHole_Hole:
	+ "gmctxt_of_gctxt C = GMHole \<Longrightarrow> C = \<box>\<^sub>G"
	+ by (metis gctxt_of_gmctxt.simps(1) gctxt_of_gmctxt_gmctxt_of_gctxt)
	+
	+lemma gmctxt_of_gctxt_gctxt_of_gmctxt:
	+ "num_gholes C = Suc 0 \<Longrightarrow> gmctxt_of_gctxt (gctxt_of_gmctxt C) = C"
	+proof (induct C)
	+ case (GMFun f Cs)
	+ then obtain i where nth: "i < length Cs" "i = length (takeWhile (\<lambda>C. num_gholes C = 0) Cs)"
	+ using sum_list_nthWhile_length by auto
	+ then have "0 < num_gholes (Cs ! i)" unfolding nth(2) using nth_length_takeWhile
	+ by auto
	+ from nth(1) this have num: "num_gholes (Cs ! i) = Suc 0" using GMFun(2)
	+ by (auto elim!: sum_list_1_E)
	+ then have [simp]: "map (gmctxt_of_gterm \<circ> gterm_of_gmctxt) (drop (Suc i) Cs) = drop (Suc i) Cs" using GMFun(2) nth(1)
	+ by (auto elim!: sum_list_1_E simp: comp_def intro!: nth_equalityI)
	+ (metis add.commute add_Suc_right lessI less_diff_conv no_gholes_gmctxt_of_gterm_gterm_of_gmctxt_id not_add_less1)
	+ have [simp]: "map (gmctxt_of_gterm \<circ> gterm_of_gmctxt) (take i Cs) = take i Cs"
	+ using nth(1) unfolding nth(2) by (induct Cs) auto
	+ show ?case using id_take_nth_drop[OF nth(1)]
	+ by (auto simp: Let_def GMFun(1)[OF nth_mem[OF nth(1)] num] simp flip: nth(2))
	+qed auto
	+
	+lemma inj_gmctxt_of_gctxt: "inj gmctxt_of_gctxt"
	+ unfolding inj_def by (metis gctxt_of_gmctxt_gmctxt_of_gctxt)
	+
	+lemma inj_gctxt_of_gmctxt_on_single_hole:
	+ "inj_on gctxt_of_gmctxt (Collect (\<lambda> C. num_gholes C = Suc 0))"
	+ by (metis (mono_tags, lifting) gmctxt_of_gctxt_gctxt_of_gmctxt inj_onI mem_Collect_eq)
	+
	+lemma gctxt_of_gmctxt_hole_dest:
	+ "num_gholes C = Suc 0 \<Longrightarrow> gctxt_of_gmctxt C = \<box>\<^sub>G \<Longrightarrow> C = GMHole"
	+ by (cases C) (auto simp: Let_def split!: if_splits)
	+
	+lemma mctxt_of_gmctxt_inv [simp]:
	+ "gmctxt_of_mctxt (mctxt_of_gmctxt C) = C"
	+ by (induct C) (simp_all add: map_idI)
	+
	+lemma ground_mctxt_of_gmctxt [simp]:
	+ "ground_mctxt (mctxt_of_gmctxt C)"
	+ by (induct C) auto
	+
	+lemma ground_mctxt_of_gmctxt' [simp]:
	+ "mctxt_of_gmctxt C = MFun f D \<Longrightarrow> ground_mctxt (MFun f D)"
	+ by (induct C) auto
	+
	+lemma gmctxt_of_mctxt_inv [simp]:
	+ "ground_mctxt C \<Longrightarrow> mctxt_of_gmctxt (gmctxt_of_mctxt C) = C"
	+ by (induct C) (auto 0 0 intro!: nth_equalityI)
	+
	+lemma ground_mctxt_of_gmctxtD:
	+ "ground_mctxt C \<Longrightarrow> \<exists> D. C = mctxt_of_gmctxt D"
	+ by (metis gmctxt_of_mctxt_inv)
	+
	+lemma inj_mctxt_of_gmctxt: "inj_on mctxt_of_gmctxt X"
	+ by (metis inj_on_def mctxt_of_gmctxt_inv)
	+
	+lemma inj_gmctxt_of_mctxt_ground:
	+ "inj_on gmctxt_of_mctxt (Collect ground_mctxt)"
	+ using gmctxt_of_mctxt_inv inj_on_def by force
	+
	+lemma map_gmctxt_comp [simp]:
	+ "map_gmctxt f (map_gmctxt g C) = map_gmctxt (f \<circ> g) C"
	+ by (induct C) auto
	+
	+lemma map_mctxt_of_gmctxt:
	+ "map_mctxt f (mctxt_of_gmctxt C) = mctxt_of_gmctxt (map_gmctxt f C)"
	+ by (induct C) auto
	+
	+lemma map_gmctxt_of_mctxt:
	+ "ground_mctxt C \<Longrightarrow> map_gmctxt f (gmctxt_of_mctxt C) = gmctxt_of_mctxt (map_mctxt f C)"
	+ by (induct C) auto
	+
	+lemma map_gmctxt_nempty [simp]:
	+ "C \<noteq> GMHole \<Longrightarrow> map_gmctxt f C \<noteq> GMHole"
	+ by (cases C) auto
	+
	+
	+lemma vars_mctxt_of_gmctxt [simp]:
	+ "vars_mctxt (mctxt_of_gmctxt C) = {}"
	+ by (induct C) auto
	+
	+lemma vars_mctxt_of_gmctxt_subseteq [simp]:
	+ "vars_mctxt (mctxt_of_gmctxt C) \<subseteq> Q \<longleftrightarrow> True"
	+ by auto
	+
	+subsubsection \<open>Equivalences and simplification rules\<close>
	+
	+lemma eqgfE:
	+ assumes "t =\<^sub>G\<^sub>f (D, ss)" shows "t = fill_gholes D ss" "num_gholes D = length ss"
	+ using assms[unfolded eq_gfill.simps] by auto
	+
	+lemma eqgf_GMHoleE:
	+ assumes "t =\<^sub>G\<^sub>f (GMHole, ss)" shows "ss = [t]" using eqgfE[OF assms]
	+ by (cases ss) auto
	+
	+lemma eqgf_GMFunE:
	+ assumes "s =\<^sub>G\<^sub>f (GMFun f Cs, ss)"
	+ obtains ts sss where "s = GFun f ts" "length ts = length Cs" "length sss = length Cs"
	+ "\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>G\<^sub>f (Cs ! i, sss ! i)" "ss = concat sss"
	+proof -
	+ from eqgfE[OF assms] have fh: "s = fill_gholes (GMFun f Cs) ss"
	+ and nh: "sum_list (map num_gholes Cs) = length ss" by auto
	+ from fh obtain ts where s: "s = GFun f ts" by (cases s, auto)
	+ from fh[unfolded s]
	+ have ts: "ts = map (\<lambda>i. fill_gholes (Cs ! i) (partition_gholes ss Cs ! i)) [0..<length Cs]"
	+ (is "_ = map (?f Cs ss) _")
	+ by auto
	+ let ?sss = "partition_gholes ss Cs"
	+ from nh have *: "length ?sss = length Cs"
	+ "\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>G\<^sub>f (Cs ! i, ?sss ! i)" "ss = concat ?sss"
	+ by (auto simp: ts length_partition_by_nth)
	+ have len: "length ts = length Cs" unfolding ts by auto
	+ assume ass: "\<And>ts sss. s = GFun f ts \<Longrightarrow>
	+ length ts = length Cs \<Longrightarrow>
	+ length sss = length Cs \<Longrightarrow> (\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>G\<^sub>f (Cs ! i, sss ! i)) \<Longrightarrow> ss = concat sss \<Longrightarrow> thesis"
	+ show thesis by (rule ass[OF s len *])
	+qed
	+
	+lemma partition_holes_subseteq [simp]:
	+ assumes "sum_list (map num_holes Cs) = length xs" "i < length Cs"
	+ and "x \<in> set (partition_holes xs Cs ! i)"
	+ shows "x \<in> set xs"
	+ using assms partition_by_nth_nth_elem length_partition_by_nth
	+ by (auto simp: in_set_conv_nth) fastforce
	+
	+lemma partition_gholes_subseteq [simp]:
	+ assumes "sum_list (map num_gholes Cs) = length xs" "i < length Cs"
	+ and "x \<in> set (partition_gholes xs Cs ! i)"
	+ shows "x \<in> set xs"
	+ using assms partition_by_nth_nth_elem length_partition_by_nth
	+ by (auto simp: in_set_conv_nth) fastforce
	+
	+lemma list_elem_to_partition_nth [elim]:
	+ assumes "sum_list (map num_gholes Cs) = length xs" "x \<in> set xs"
	+ obtains i where "i < length Cs" "x \<in> set (partition_gholes xs Cs ! i)" using assms
	+ by (metis concat_partition_by in_set_idx length_map length_partition_by nth_concat_split nth_mem)
	+
	+lemma partition_holes_fill_gholes_conv':
	+ "fill_gholes (GMFun f Cs) ts =
	+ GFun f (map (case_prod fill_gholes) (zip Cs (partition_gholes ts Cs)))"
	+ unfolding zip_nth_conv [of Cs "partition_gholes ts Cs", simplified]
	+ and partition_holes_fill_holes_conv by simp
	+
	+lemma unfill_gholes_conv:
	+ assumes "length Cs = length ts"
	+ shows "unfill_gholes (GMFun f Cs) (GFun f ts) =
	+ concat (map (case_prod unfill_gholes) (zip Cs ts))" using assms
	+ by (auto simp: zip_nth_conv [of Cs ts, simplified] comp_def)
	+
	+lemma partition_holes_fill_gholes_gmctxt_conv:
	+ "fill_gholes_gmctxt (GMFun f Cs) ts =
	+ GMFun f [fill_gholes_gmctxt (Cs ! i) (partition_gholes ts Cs ! i). i \<leftarrow> [0 ..< length Cs]]"
	+ by (simp add: partition_by_nth take_map)
	+
	+lemma partition_holes_fill_gholes_gmctxt_conv':
	+ "fill_gholes_gmctxt (GMFun f Cs) ts =
	+ GMFun f (map (case_prod fill_gholes_gmctxt) (zip Cs (partition_gholes ts Cs)))"
	+ unfolding zip_nth_conv [of Cs "partition_gholes ts Cs", simplified]
	+ and partition_holes_fill_gholes_gmctxt_conv by simp
	+
	+lemma fill_gholes_no_holes [simp]:
	+ "num_gholes C = 0 \<Longrightarrow> fill_gholes C [] = gterm_of_gmctxt C"
	+ by (induct C) (auto simp: partition_holes_fill_gholes_conv'
	+ simp del: fill_gholes.simps intro: nth_equalityI)
	+
	+lemma fill_gholes_gmctxt_no_holes [simp]:
	+ "num_gholes C = 0 \<Longrightarrow> fill_gholes_gmctxt C [] = C"
	+ by (induct C) (auto intro: nth_equalityI)
	+
	+lemma eqgf_GMFunI:
	+ assumes "\<And> i. i < length Cs \<Longrightarrow> ss ! i =\<^sub>G\<^sub>f (Cs ! i, ts ! i)"
	+ and "length Cs = length ss" "length ss = length ts"
	+ shows "GFun f ss =\<^sub>G\<^sub>f (GMFun f Cs, concat ts)" using assms
	+ apply (auto simp del: fill_gholes.simps
	+ simp: partition_holes_fill_gholes_conv' intro!: eq_gfill.intros nth_equalityI)
	+ apply (metis eqgfE length_map map_nth_eq_conv partition_by_concat_id)
	+ by (metis eqgfE(2) length_concat nth_map_conv)
	+
	+lemma length_partition_gholes_nth:
	+ assumes "sum_list (map num_gholes cs) = length ts"
	+ and "i < length cs"
	+ shows "length (partition_gholes ts cs ! i) = num_gholes (cs ! i)"
	+ using assms by (simp add: length_partition_by_nth)
	+
	+lemma fill_gholes_induct2[consumes 2, case_names GMHole GMFun]:
	+ fixes P :: "'f gmctxt \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool"
	+ assumes len1: "num_gholes C = length xs" and len2: "num_gholes C = length ys"
	+ and Hole: "\<And>x y. P GMHole [x] [y]"
	+ and Fun: "\<And>f Cs xs ys. sum_list (map num_gholes Cs) = length xs \<Longrightarrow>
	+ sum_list (map num_gholes Cs) = length ys \<Longrightarrow>
	+ (\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_gholes xs Cs ! i) (partition_gholes ys Cs ! i)) \<Longrightarrow>
	+ P (GMFun f Cs) (concat (partition_gholes xs Cs)) (concat (partition_gholes ys Cs))"
	+ shows "P C xs ys"
	+proof (insert len1 len2, induct C arbitrary: xs ys)
	+ case GMHole
	+ then show ?case using Hole by (cases xs; cases ys) auto
	+next
	+ case (GMFun f Cs)
	+ then show ?case using Fun[of Cs xs ys f] by (auto simp: length_partition_by_nth)
	+qed
	+
	+lemma fill_gholes_induct[consumes 1, case_names GMHole GMFun]:
	+ fixes P :: "'f gmctxt \<Rightarrow> 'a list \<Rightarrow> bool"
	+ assumes len: "num_gholes C = length xs"
	+ and Hole: "\<And>x. P GMHole [x]"
	+ and Fun: "\<And>f Cs xs. sum_list (map num_gholes Cs) = length xs \<Longrightarrow>
	+ (\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_gholes xs Cs ! i)) \<Longrightarrow>
	+ P (GMFun f Cs) (concat (partition_gholes xs Cs))"
	+ shows "P C xs"
	+ using fill_gholes_induct2[of C xs xs "\<lambda> C xs _. P C xs"] assms by simp
	+
	+lemma eq_gfill_induct [consumes 1, case_names GMHole GMFun]:
	+ assumes "t =\<^sub>G\<^sub>f (C, ts)"
	+ and "\<And>t. P t GMHole [t]"
	+ and "\<And>f ss Cs ts. \<lbrakk>length Cs = length ss; sum_list (map num_gholes Cs) = length ts;
	+ \<forall>i < length ss. ss ! i =\<^sub>G\<^sub>f (Cs ! i, partition_gholes ts Cs ! i) \<and>
	+ P (ss ! i) (Cs ! i) (partition_gholes ts Cs ! i)\<rbrakk>
	+ \<Longrightarrow> P (GFun f ss) (GMFun f Cs) ts"
	+ shows "P t C ts" using assms(1)
	+proof (induct t arbitrary: C ts)
	+ case (GFun f ss)
	+ {assume "C = GMHole" and "ts = [GFun f ss]"
	+ then have ?case using assms(2) by auto}
	+ moreover
	+ {fix Cs
	+ assume C: "C = GMFun f Cs" and "sum_list (map num_gholes Cs) = length ts"
	+ and "length Cs = length ss"
	+ and "GFun f ss = fill_gholes (GMFun f Cs) ts"
	+ moreover then have "\<forall>i < length ss. ss ! i =\<^sub>G\<^sub>f (Cs ! i, partition_gholes ts Cs ! i)"
	+ by (auto simp del: fill_gholes.simps
	+ simp: partition_holes_fill_gholes_conv' length_partition_gholes_nth intro!: eq_gfill.intros)
	+ moreover have "\<forall>i < length ss. P (ss ! i) (Cs ! i) (partition_gholes ts Cs ! i)"
	+ using GFun calculation(5) nth_mem by blast
	+ ultimately have ?case using assms(3)[of Cs ss ts f] by auto}
	+ ultimately show ?case using GFun
	+ by (elim eq_gfill.cases) (auto simp del: fill_gholes.simps,
	+ metis GFun.prems eqgf_GMFunE eqgf_GMHoleE gterm.inject num_gholes.elims)
	+qed
	+
	+lemma nempty_ground_mctxt_gmctxt [simp]:
	+ "C \<noteq> MHole \<Longrightarrow> ground_mctxt C \<Longrightarrow> gmctxt_of_mctxt C \<noteq> GMHole"
	+ by (induct C) auto
	+
	+lemma mctxt_of_gmctxt_fill_holes [simp]:
	+ assumes "num_gholes C = length ss"
	+ shows "gterm_of_term (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss)) = fill_gholes C ss" using assms
	+ by (induct rule: fill_gholes_induct) auto
	+
	+lemma mctxt_of_gmctxt_terms_fill_holes:
	+ assumes "num_gholes C = length ss"
	+ shows "gterm_of_term (fill_holes (mctxt_of_gmctxt C) ss) = fill_gholes C (map gterm_of_term ss)" using assms
	+ by (induct rule: fill_gholes_induct) auto
	+
	+lemma ground_gmctxt_of_mctxt_gterm_fill_holes:
	+ assumes "num_holes C = length ss" and "ground_mctxt C"
	+ shows "term_of_gterm (fill_gholes (gmctxt_of_mctxt C) ss) = fill_holes C (map term_of_gterm ss)" using assms
	+ by (induct rule: fill_holes_induct)
	+ (auto simp: comp_def, metis (no_types, lifting) map_eq_conv num_gholes_gmctxt_of_mctxt)
	+
	+lemma ground_gmctxt_of_gterm_of_term:
	+ assumes "num_holes C = length ss" and "ground_mctxt C"
	+ shows "gterm_of_term (fill_holes C (map term_of_gterm ss)) = fill_gholes (gmctxt_of_mctxt C) ss" using assms
	+ by (induct rule: fill_holes_induct)
	+ (auto simp: comp_def, metis (no_types, lifting) map_eq_conv num_gholes_gmctxt_of_mctxt)
	+
	+lemma ground_gmctxt_of_mctxt_fill_holes [simp]:
	+ assumes "num_holes C = length ss" and "ground_mctxt C" "\<forall> s \<in> set ss. ground s"
	+ shows "term_of_gterm (fill_gholes (gmctxt_of_mctxt C) (map gterm_of_term ss)) = fill_holes C ss" using assms
	+ by (induct rule: fill_holes_induct) auto
	+
	+lemma fill_holes_mctxt_of_gmctxt_to_fill_gholes:
	+ assumes "num_gholes C = length ss"
	+ shows "fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss) = term_of_gterm (fill_gholes C ss)"
	+ using assms
	+ by (metis ground_gmctxt_of_mctxt_gterm_fill_holes ground_mctxt_of_gmctxt mctxt_of_gmctxt_inv num_holes_mctxt_of_gmctxt)
	+
	+lemma fill_gholes_gmctxt_of_gterm [simp]:
	+ "fill_gholes (gmctxt_of_gterm s) [] = s"
	+ by (induct s) (auto simp add: map_nth_eq_conv)
	+
	+lemma fill_gholes_GMHole [simp]:
	+ "length ss = Suc 0 \<Longrightarrow> fill_gholes GMHole ss = ss ! 0"
	+ by (cases ss) auto
	+
	+lemma apply_gctxt_fill_gholes:
	+ "C\<langle>s\<rangle>\<^sub>G = fill_gholes (gmctxt_of_gctxt C) [s]"
	+ by (induct C) (auto simp: partition_holes_fill_gholes_conv'
	+ simp del: fill_gholes.simps intro!: nth_equalityI)
	+
	+lemma fill_gholes_apply_gctxt:
	+ "num_gholes C = Suc 0 \<Longrightarrow> fill_gholes C [s] = (gctxt_of_gmctxt C)\<langle>s\<rangle>\<^sub>G"
	+ by (simp add: apply_gctxt_fill_gholes gmctxt_of_gctxt_gctxt_of_gmctxt)
	+
	+
	+lemma ctxt_of_gctxt_gctxt_of_gmctxt_apply:
	+ "num_gholes C = Suc 0 \<Longrightarrow> fill_holes (mctxt_of_gmctxt C) [s] = (ctxt_of_gctxt (gctxt_of_gmctxt C))\<langle>s\<rangle>"
	+proof (induct C)
	+ case (GMFun f Cs)
	+ obtain i where split: "i < length Cs" "num_gholes (Cs ! i) = Suc 0"
	+ "\<forall> j < length Cs. j \<noteq> i \<longrightarrow> num_gholes (Cs ! j) = 0" using GMFun(2)
	+ by auto
	+ then have [simp]: "sum_list (take i (map num_gholes Cs)) = 0"
	+ by (auto simp: sum_list_eq_0_iff dest: set_take_nth)
	+ from split have [simp]: "j < length Cs \<Longrightarrow> j \<noteq> i \<Longrightarrow>
	+ fill_holes (mctxt_of_gmctxt (Cs ! j)) [] = term_of_mctxt (mctxt_of_gmctxt (Cs ! j))" for j
	+ by (intro fill_holes_term_of_mctxt) auto
	+ from split have [simp]: "gctxt_of_gmctxt (GMFun f Cs) =
	+ GMore f (map gterm_of_gmctxt (take i Cs)) (gctxt_of_gmctxt (Cs ! i)) (map gterm_of_gmctxt (drop (Suc i) Cs))"
	+ using nth_length_takeWhile GMFun(2) sum_list_nthWhile_length by (auto simp: Let_def)
	+ show ?case using GMFun(1)[OF nth_mem[OF split(1)] split(2)] split
	+ by (auto simp: min_def nth_append_Cons partition_by_nth simp del: gctxt_of_gmctxt.simps intro!: nth_equalityI)
	+qed auto
	+
	+
	+lemma fill_gholes_replicate [simp]:
	+ "n = length ss \<Longrightarrow> fill_gholes (GMFun f (replicate n GMHole)) ss = GFun f ss"
	+ unfolding partition_holes_fill_gholes_conv'
	+ by (induct ss arbitrary: n) auto
	+
	+lemma fill_gholes_gmctxt_replicate_MHole [simp]:
	+ "fill_gholes_gmctxt C (replicate (num_gholes C) GMHole) = C"
	+proof (induct C)
	+ case (GMFun f Cs)
	+ {fix i assume "i < length Cs"
	+ then have "partition_gholes (replicate (sum_list (map num_gholes Cs)) GMHole) Cs ! i =
	+ replicate (num_gholes (Cs ! i)) GMHole"
	+ using partition_by_nth_nth[of "map num_gholes Cs" "replicate (sum_list (map num_gholes Cs)) MHole"]
	+ by (auto simp: length_partition_by_nth partition_by_nth_nth intro!: nth_equalityI)}
	+ note * = this
	+ show ?case using GMFun[OF nth_mem] by (auto simp: * intro!: nth_equalityI)
	+qed auto
	+
	+lemma fill_gholes_gmctxt_GMFun_replicate_length [simp]:
	+ "fill_gholes_gmctxt (GMFun f (replicate (length Cs) GMHole)) Cs = GMFun f Cs"
	+ unfolding partition_holes_fill_gholes_gmctxt_conv'
	+ by (induct Cs) simp_all
	+
	+lemma fill_gholes_gmctxt_MFun:
	+ assumes lCs: "length Cs = length ts"
	+ and lss: "length ss = length ts"
	+ and rec: "\<And> i. i < length ts \<Longrightarrow> num_gholes (Cs ! i) = length (ss ! i) \<and>
	+ fill_gholes_gmctxt (Cs ! i) (ss ! i) = ts ! i"
	+ shows "fill_gholes_gmctxt (GMFun f Cs) (concat ss) = GMFun f ts"
	+ using assms unfolding fill_gholes_gmctxt.simps gmctxt.simps
	+ by (auto intro!: nth_equalityI)
	+ (metis length_map map_nth_eq_conv partition_by_concat_id)
	+
	+lemma fill_gholes_gmctxt_nHole [simp]:
	+ "C \<noteq> GMHole \<Longrightarrow> num_gholes C = length Ds \<Longrightarrow> fill_gholes_gmctxt C Ds \<noteq> GMHole"
	+ using fill_gholes_gmctxt.elims by blast
	+
	+lemma num_gholes_fill_gholes_gmctxt [simp]:
	+ assumes "num_gholes C = length Ds"
	+ shows "num_gholes (fill_gholes_gmctxt C Ds) = sum_list (map num_gholes Ds)" using assms
	+proof (induct C arbitrary: Ds)
	+ case GMHole then show ?case
	+ by (cases Ds) simp_all
	+next
	+ case (GMFun f Cs)
	+ then have *: "map (num_gholes \<circ> (\<lambda>i. fill_gholes_gmctxt (Cs ! i) (partition_gholes Ds Cs ! i))) [0..<length Cs] =
	+ map (\<lambda>i. sum_list (map num_gholes (partition_gholes Ds Cs ! i))) [0 ..< length Cs]"
	+ and "sum_list (map num_gholes Cs) = length Ds"
	+ by (auto simp add: length_partition_by_nth)
	+ then show ?case
	+ using map_upt_len_conv [of "\<lambda>x. sum_list (map num_gholes x)" "partition_gholes Ds Cs"]
	+ unfolding partition_holes_fill_holes_mctxt_conv by (simp add: *)
	+qed
	+
	+lemma num_gholes_greater0_fill_gholes_gmctxt [intro!]:
	+ assumes "num_gholes C = length Ds"
	+ and "\<exists> D \<in> set Ds. 0 < num_gholes D"
	+ shows "0 < sum_list (map num_gholes Ds)"
	+ using assms gr_zeroI by force
	+
	+lemma fill_gholes_gmctxt_fill_gholes:
	+ assumes len_ds: "length Ds = num_gholes C"
	+ and nh: "num_gholes (fill_gholes_gmctxt C Ds) = length ss"
	+ shows "fill_gholes (fill_gholes_gmctxt C Ds) ss =
	+ fill_gholes C [fill_gholes (Ds ! i) (partition_gholes ss Ds ! i). i \<leftarrow> [0 ..< num_gholes C]]"
	+ using assms(1)[symmetric] assms(2)
	+proof (induct C Ds arbitrary: ss rule: fill_gholes_induct)
	+ case (GMFun f Cs ds ss)
	+ define qs where "qs = map (\<lambda>i. fill_gholes_gmctxt (Cs ! i) (partition_gholes ds Cs ! i)) [0..<length Cs]"
	+ then have qs: "\<And>i. i < length Cs \<Longrightarrow> fill_gholes_gmctxt (Cs ! i) (partition_gholes ds Cs ! i) = qs ! i"
	+ "length qs = length Cs" by auto
	+ define zs where "zs = map (\<lambda>i. fill_gholes (ds ! i) (partition_gholes ss ds ! i)) [0..<length ds]"
	+ {fix i assume i: "i < length Cs"
	+ from GMFun(1) have *: "map length (partition_gholes ds Cs) = map num_gholes Cs" by auto
	+ have **: "length ss = sum_list (map sum_list (partition_gholes (map num_gholes ds) Cs))"
	+ using GMFun(1) GMFun(3)[symmetric] num_gholes_fill_gholes_gmctxt[of "GMFun f Cs" ds]
	+ by (auto simp: comp_def map_map_partition_by[symmetric])
	+ have "partition_by (partition_by ss
	+ (map (\<lambda>i. num_gholes (fill_gholes_gmctxt (Cs ! i) (partition_gholes ds Cs ! i))) [0..<length Cs]) ! i)
	+ (partition_gholes (map num_gholes ds) Cs ! i) = partition_gholes (partition_gholes ss ds) Cs ! i"
	+ using i GMFun(1) GMFun(3) partition_by_partition_by[OF **]
	+ by (auto simp: comp_def num_gholes_fill_gholes_gmctxt length_partition_by_nth
	+ intro!: arg_cong[of _ _ "\<lambda>x. partition_by (partition_by ss x ! _) _"] nth_equalityI)
	+ then have "map (\<lambda>j. fill_gholes (partition_gholes ds Cs ! i ! j)
	+ (partition_gholes (partition_gholes ss qs ! i)
	+ (partition_gholes ds Cs ! i) ! j)) [0..<num_gholes (Cs ! i)] =
	+ partition_gholes zs Cs ! i" using GMFun(1,3)
	+ by (auto simp: length_partition_by_nth zs_def qs_def i comp_def partition_by_nth_nth intro: nth_equalityI)}
	+ then show ?case using GMFun
	+ by (simp add: qs_def [symmetric] qs zs_def [symmetric] length_partition_by_nth)
	+qed auto
	+
	+lemma fill_gholes_gmctxt_sound:
	+ assumes len_ds: "length Ds = num_gholes C"
	+ and len_sss: "length sss = num_gholes C"
	+ and len_ts: "length ts = num_gholes C"
	+ and insts: "\<And> i. i < length Ds \<Longrightarrow> ts ! i =\<^sub>G\<^sub>f (Ds ! i, sss ! i)"
	+ shows "fill_gholes C ts =\<^sub>G\<^sub>f (fill_gholes_gmctxt C Ds, concat sss)"
	+proof (rule eqfI)
	+ note l_nh_i = eqgfE(2)[OF insts]
	+ from len_ds len_sss have concat_sss: "partition_gholes (concat sss) Ds = sss"
	+ by (metis l_nh_i length_map map_nth_eq_conv partition_by_concat_id)
	+ then show nh: "num_gholes (fill_gholes_gmctxt C Ds) = length (concat sss)"
	+ unfolding num_gholes_fill_gholes_gmctxt [OF len_ds [symmetric]] length_concat
	+ by (metis l_nh_i len_ds len_sss nth_map_conv)
	+ have ts: "ts = [fill_gholes (Ds ! i) (partition_gholes (concat sss) Ds ! i) . i \<leftarrow> [0..<num_gholes C]]" (is "_ = ?fhs")
	+ proof (rule nth_equalityI)
	+ show l_fhs: "length ts = length ?fhs" unfolding length_map
	+ by (metis diff_zero len_ts length_upt)
	+ fix i
	+ assume i: "i < length ts"
	+ then have i': "i < length [0..<num_gholes C]"
	+ by (metis diff_zero len_ts length_upt)
	+ show "ts!i = ?fhs ! i"
	+ unfolding nth_map[OF i']
	+ using eqgfE(1)[OF insts[unfolded len_ds, OF i[unfolded len_ts]]]
	+ by (metis concat_sss i' len_ds len_sss map_nth nth_map)
	+ qed
	+ note ts = this
	+ show "fill_gholes C ts = fill_gholes (fill_gholes_gmctxt C Ds) (concat sss)"
	+ unfolding fill_gholes_gmctxt_fill_gholes[OF len_ds nh] ts ..
	+qed
	+
	+subsubsection \<open>Semilattice Structures\<close>
	+
	+lemma inf_gmctxt_idem [simp]:
	+ "(C :: 'f gmctxt) \<sqinter> C = C"
	+ by (induct C) (auto simp: zip_same_conv_map intro: map_idI)
	+
	+lemma inf_gmctxt_GMHole2 [simp]:
	+ "C \<sqinter> GMHole = GMHole"
	+ by (induct C) simp_all
	+
	+lemma inf_gmctxt_comm [ac_simps]:
	+ "(C :: 'f gmctxt) \<sqinter> D = D \<sqinter> C"
	+ by (induct C D rule: inf_gmctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+
	+
	+lemma inf_gmctxt_assoc [ac_simps]:
	+ fixes C :: "'f gmctxt"
	+ shows "C \<sqinter> D \<sqinter> E = C \<sqinter> (D \<sqinter> E)"
	+ apply (induct C D arbitrary: E rule: inf_gmctxt.induct)
	+ apply (auto)
	+ apply (case_tac E, auto)+
	+ apply (fastforce simp: in_set_conv_nth intro!: nth_equalityI)
	+ apply (case_tac E, auto)+
	+done
	+
	+instantiation gmctxt :: (type) order
	+begin
	+
	+definition "(C :: 'a gmctxt) \<le> D \<longleftrightarrow> C \<sqinter> D = C"
	+definition "(C :: 'a gmctxt) < D \<longleftrightarrow> C \<le> D \<and> \<not> D \<le> C"
	+
	+instance
	+ by (standard, simp_all add: less_eq_gmctxt_def less_gmctxt_def ac_simps, metis inf_gmctxt_assoc)
	+
	+end
	+
	+lemma less_eq_gmctxt_prime: "C \<le> D \<longleftrightarrow> less_eq_gmctxt C D"
	+proof
	+ assume "less_eq_gmctxt C D" then show "C \<le> D"
	+ by (induct C D rule: less_eq_gmctxt.induct) (auto simp: less_eq_gmctxt_def intro: nth_equalityI)
	+next
	+ assume "C \<le> D" then show "less_eq_gmctxt C D" unfolding less_eq_gmctxt_def
	+ by (induct C D rule: inf_gmctxt.induct)
	+ (auto split: if_splits simp: set_zip intro!: less_eq_gmctxt.intros nth_equalityI elim!: nth_equalityE, metis)
	+qed
	+
	+lemmas less_eq_gmctxt_induct = less_eq_gmctxt.induct[folded less_eq_gmctxt_prime, consumes 1]
	+lemmas less_eq_gmctxt_intros = less_eq_gmctxt.intros[folded less_eq_gmctxt_prime]
	+
	+lemma less_eq_gmctxt_Hole:
	+ "less_eq_gmctxt C GMHole \<Longrightarrow> C = GMHole"
	+ using less_eq_gmctxt.cases by blast
	+
	+lemma num_gholes_at_least1:
	+ "0 < num_gholes C \<Longrightarrow> 0 < num_gholes (C \<sqinter> D)"
	+proof (induct C arbitrary: D)
	+ case (GMFun f Cs)
	+ from GMFun(2) obtain i where wit: "i < length Cs" "0 < num_gholes (Cs ! i)"
	+ by (auto, metis (mono_tags, lifting) in_set_conv_nth length_map map_nth_eq_conv not_less sum_list_nonpos)
	+ note IS = GMFun(1)[OF nth_mem, OF wit]
	+ show ?case
	+ proof (cases D)
	+ case [simp]: (GMFun g Ds)
	+ {assume "f = g" "length Cs = length Ds"
	+ then have "0 < num_gholes (Cs ! i \<sqinter> Ds ! i)" using IS[of "Ds ! i"]
	+ by auto}
	+ then show ?thesis using wit(1)
	+ by (auto simp: split!: prod.splits)
	+ (smt (verit, del_insts) length_map length_zip map_nth_eq_conv min_less_iff_conj not_gr0 nth_mem nth_zip o_apply prod.simps(2) sum_list_eq_0_iff)
	+ qed auto
	+qed auto
	+
	+text \<open>
	+ @{const sup} is defined on compatible multihole contexts.
	+ Note that compatibility is not transitive.
	+\<close>
	+instance gmctxt :: (type) semilattice_inf
	+ apply (standard)
	+ apply (auto simp: less_eq_gmctxt_def inf_gmctxt_assoc [symmetric])
	+ apply (metis inf_gmctxt_comm inf_gmctxt_assoc inf_gmctxt_idem)+
	+ done
	+
	+
	+lemma sup_gmctxt_idem [simp]:
	+ fixes C :: "'f gmctxt"
	+ shows "C \<squnion> C = C"
	+ by (induct C) (auto simp: zip_same_conv_map intro: map_idI)
	+
	+lemma sup_gmctxt_MHole [simp]: "C \<squnion> GMHole = C"
	+ by (induct C) simp_all
	+
	+lemma sup_gmctxt_comm [ac_simps]:
	+ fixes C :: "'f gmctxt"
	+ shows "C \<squnion> D = D \<squnion> C"
	+ by (induct C D rule: sup_gmctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+
	+
	+
	+lemma comp_gmctxt_refl:
	+ "(C, C) \<in> comp_gmctxt"
	+ by (induct C) auto
	+
	+lemma comp_gmctxt_sym:
	+ assumes "(C, D) \<in> comp_gmctxt"
	+ shows "(D, C) \<in> comp_gmctxt"
	+ using assms by (induct) auto
	+
	+lemma sup_gmctxt_assoc [ac_simps]:
	+ assumes "(C, D) \<in> comp_gmctxt" and "(D, E) \<in> comp_gmctxt"
	+ shows "C \<squnion> D \<squnion> E = C \<squnion> (D \<squnion> E)"
	+ using assms by (induct C D arbitrary: E) (auto elim!: comp_gmctxt.cases intro!: nth_equalityI)
	+
	+text \<open>
	+ No instantiation to @{class semilattice_sup} possible, since @{const sup} is only
	+ partially defined on terms (e.g., it is not associative in general).
	+\<close>
	+
	+interpretation gmctxt_order_bot: order_bot GMHole "(\<le>)" "(<)"
	+ by (standard) (simp add: less_eq_gmctxt_def)
	+
	+lemma sup_gmctxt_ge1 [simp]:
	+ assumes "(C, D) \<in> comp_gmctxt"
	+ shows "C \<le> C \<squnion> D"
	+ using assms by (induct C D) (auto simp: less_eq_gmctxt_def intro: nth_equalityI)
	+
	+lemma sup_gmctxt_ge2 [simp]:
	+ assumes "(C, D) \<in> comp_gmctxt"
	+ shows "D \<le> C \<squnion> D"
	+ using assms by (induct) (auto simp: less_eq_gmctxt_def intro: nth_equalityI)
	+
	+lemma sup_gmctxt_least:
	+ assumes "(D, E) \<in> comp_gmctxt"
	+ and "D \<le> C" and "E \<le> C"
	+ shows "D \<squnion> E \<le> C"
	+ using assms
	+ apply (induct arbitrary: C)
	+ apply (auto simp: less_eq_gmctxt_def elim!: inf_gmctxt.elims intro!: nth_equalityI)
	+ apply (metis (erased, lifting) length_map nth_map nth_zip split_conv)
	+ apply (case_tac "fb = gb \<and> length Csb = length Dsb", simp_all)+
	+ done
	+
	+lemma sup_gmctxt_args_MHole2 [simp]:
	+ "sup_gmctxt_args C GMHole = replicate (num_gholes C) GMHole"
	+ by (cases C) simp_all
	+
	+lemma num_gholes_sup_gmctxt_args:
	+ assumes "(C, D) \<in> comp_gmctxt"
	+ shows "num_gholes C = length (sup_gmctxt_args C D)"
	+ using assms by (induct) (auto simp: length_concat intro!: arg_cong [of _ _ sum_list] nth_equalityI)
	+
	+lemma sup_gmctxt_sup_gmctxt_args:
	+ assumes "(C, D) \<in> comp_gmctxt"
	+ shows "fill_gholes_gmctxt C (sup_gmctxt_args C D) = C \<squnion> D" using assms
	+proof (induct)
	+ note fill_gholes_gmctxt.simps [simp del]
	+ case (GMFun f g Cs Ds)
	+ then show ?case
	+ proof (cases "f = g \<and> length Cs = length Ds")
	+ case True
	+ with GMFun have "\<forall>i < length Cs.
	+ fill_gholes_gmctxt (Cs ! i) (sup_gmctxt_args (Cs ! i) (Ds ! i)) = Cs ! i \<squnion> Ds ! i"
	+ and *: "\<forall>i < length Cs. (Cs ! i, Ds ! i) \<in> comp_gmctxt" by (force simp: set_zip)+
	+ moreover have "partition_gholes (concat (map (case_prod sup_gmctxt_args) (zip Cs Ds)))
	+ Cs = map (case_prod sup_gmctxt_args) (zip Cs Ds)"
	+ using True and * by (intro partition_by_concat_id) (auto simp: num_gholes_sup_gmctxt_args)
	+ ultimately show ?thesis
	+ using * and True by (auto simp: partition_holes_fill_gholes_gmctxt_conv intro!: nth_equalityI)
	+ qed auto
	+qed auto
	+
	+lemma eqgf_comp_gmctxt:
	+ assumes "s =\<^sub>G\<^sub>f (C, ss)" and "s =\<^sub>G\<^sub>f (D, ts)"
	+ shows "(C, D) \<in> comp_gmctxt" using assms
	+proof (induct s arbitrary: C D ss ts)
	+ case (GFun f ss C D us vs)
	+ { fix Cs and Ds
	+ assume : "C = GMFun f Cs" "D = GMFun f Ds" and *: "length Cs = length Ds"
	+ have ?case
	+ proof (unfold , intro comp_gmctxt.GMFun [OF refl *] allI impI)
	+ fix i
	+ assume "i < length Ds" then show "(Cs ! i, Ds ! i) \<in> comp_gmctxt"
	+ using GFun by (auto simp: * ** elim!: eqgf_GMFunE) (metis nth_mem)
	+ qed}
	+ from GFun.prems this show ?case
	+ by (cases C D rule: gmctxt.exhaust [case_product gmctxt.exhaust])
	+ (auto simp: eq_gfill.simps dest: map_eq_imp_length_eq)
	+qed
	+
	+lemma eqgf_less_eq [simp]:
	+ assumes "s =\<^sub>G\<^sub>f (C, ss)"
	+ shows "C \<le> gmctxt_of_gterm s" using assms
	+ by (induct rule: eq_gfill_induct) (auto simp: less_eq_gmctxt_prime)
	+
	+lemma less_eq_comp_gmctxt [simp]:
	+ "C \<le> D \<Longrightarrow> (C, D) \<in> comp_gmctxt"
	+ by (induct rule: less_eq_gmctxt_induct) auto
	+
	+lemma gmctxt_less_eq_sup:
	+ "(C :: 'f gmctxt) \<le> D \<Longrightarrow> C \<squnion> D = D"
	+ by (induct rule: less_eq_gmctxt_induct) (auto intro: nth_equalityI)
	+
	+lemma fill_gholes_gmctxt_less_eq:
	+ assumes "num_gholes C = length Ds"
	+ shows "C \<le> fill_gholes_gmctxt C Ds" using assms
	+proof (induct C arbitrary: Ds)
	+ case (GMFun f Cs)
	+ show ?case using GMFun(1)[OF nth_mem] GMFun(2)
	+ unfolding partition_holes_fill_gholes_gmctxt_conv'
	+ by (intro less_eq_gmctxt_intros) (auto simp: length_partition_by_nth)
	+qed simp
	+
	+
	+lemma less_eq_to_sup_mctxt_args [elim]:
	+ assumes "C \<le> D"
	+ obtains Ds where "num_gholes C = length Ds" "D = fill_gholes_gmctxt C Ds"
	+ using assms gmctxt_less_eq_sup[OF assms]
	+ using sup_gmctxt_sup_gmctxt_args[OF less_eq_comp_gmctxt[OF assms]]
	+ using less_eq_comp_gmctxt num_gholes_sup_gmctxt_args
	+ by force
	+
	+lemma fill_gholes_gmctxt_sup_mctxt_args [simp]:
	+ assumes "num_gholes C = length Ds"
	+ shows "sup_gmctxt_args C (fill_gholes_gmctxt C Ds) = Ds" using assms
	+proof (induct C arbitrary: Ds)
	+ case GMHole then show ?case
	+ by (cases Ds) auto
	+next
	+ case (GMFun f Cs)
	+ have "map2 sup_gmctxt_args Cs (map2 fill_gholes_gmctxt Cs (partition_gholes Ds Cs)) = partition_gholes Ds Cs"
	+ using GMFun(1)[OF nth_mem] GMFun(2)
	+ by (auto simp: length_partition_by_nth intro!: nth_equalityI)
	+ then show ?case using GMFun(1)[OF nth_mem] GMFun(2)
	+ unfolding partition_holes_fill_gholes_gmctxt_conv'
	+ using concat_partition_by[of "map num_gholes Cs" Ds]
	+ by auto
	+qed
	+
	+lemma map2_fill_gholes_gmctxt_id [simp]:
	+ assumes "\<And> i. i < length Ds \<Longrightarrow> num_gholes (Ds ! i) = 0"
	+ shows "map2 fill_gholes_gmctxt Ds (replicate (length Ds) []) = Ds"
	+ using assms fill_gholes_gmctxt_no_holes[of "Ds ! i" for i]
	+ by (auto simp: map_nth_eq_conv)
	+
	+lemma fill_gholes_gmctxt_GMFun_replicate_append [simp]:
	+ assumes "length Cs = n" and "\<And> t. t \<in> set Ds \<Longrightarrow> num_gholes t = 0"
	+ shows "fill_gholes_gmctxt (GMFun f ((replicate n GMHole) @ Ds)) Cs = GMFun f (Cs @ Ds)" using assms
	+proof (induct n arbitrary: Cs)
	+ case 0 note [simp] = 0(1)
	+ have "i < length Ds \<Longrightarrow> num_gholes (Ds ! i) = 0" for i using 0 by fastforce
	+ then show ?case using 0 unfolding partition_holes_fill_gholes_gmctxt_conv'
	+ by (cases Cs) auto
	+next
	+ case (Suc n) then show ?case unfolding partition_holes_fill_gholes_gmctxt_conv'
	+ by (simp add: Cons_nth_drop_Suc take_Suc_conv_app_nth)
	+qed
	+
	+lemma finite_ghole_poss:
	+ "finite (ghole_poss C)"
	+ by (induct C) auto
	+
	+lemma ghole_poss_simp [simp]:
	+ "ghole_poss (GMFun f cs) = {i # p \| i p. i < length cs \<and> p \<in> ghole_poss (cs ! i)}" by auto
	+declare ghole_poss.simps(2)[simp del]
	+
	+lemma num_gholes_zero_ghole_poss:
	+ "num_gholes D = 0 \<Longrightarrow> ghole_poss D = {}"
	+ by (induct D) auto
	+
	+lemma ghole_poss_num_gholes_zero:
	+ "ghole_poss D = {} \<Longrightarrow> num_gholes D = 0"
	+proof (induct D)
	+ case (GMFun f Ds)
	+ then show ?case
	+ by (simp, metis Collect_empty_eq Collect_mem_eq in_set_idx)
	+qed simp
	+
	+lemma num_ghloes_nzero_ghole_poss_nempty:
	+ "num_gholes D \<noteq> 0 \<Longrightarrow> ghole_poss D \<noteq> {}"
	+ by (induct D) (auto simp: in_set_conv_nth, fastforce)
	+
	+lemma ghole_poss_epsE [elim]:
	+ "ghole_poss D = {[]} \<Longrightarrow> D = GMHole"
	+ by (induct D) auto
	+
	+lemma ghole_poss_gmctxt_of_gterm [simp]:
	+ "ghole_poss (gmctxt_of_gterm t) = {}"
	+ by (induct t) auto
	+
	+lemma ghole_poss_subseteq_args [simp]:
	+ assumes "ghole_poss (GMFun f Ds) \<subseteq> ghole_poss (GMFun g Cs)"
	+ shows "\<forall> i < min (length Ds) (length Cs). ghole_poss (Ds ! i) \<subseteq> ghole_poss (Cs ! i)" using assms
	+ by auto
	+
	+lemma factor_ghole_pos_by_prefix:
	+ assumes "C \<le> D" "p \<in> ghole_poss D"
	+ obtains q where "q \<le>\<^sub>p p" "q \<in> ghole_poss C"
	+ using assms
	+ by (induct C D arbitrary: p thesis rule: less_eq_gmctxt_induct)
	+ (auto, metis position_less_eq_Cons)
	+
	+lemma prefix_and_fewer_gholes_implies_equal_gmctxt:
	+ "C \<le> D \<Longrightarrow> ghole_poss C \<subseteq> ghole_poss D \<Longrightarrow> C = D"
	+proof (induct C D rule: less_eq_gmctxt_induct)
	+ case (1 D) then show ?case by (cases D) auto
	+next
	+ case (2 Cs Ds f)
	+ have "i < length Ds \<Longrightarrow> ghole_poss (Cs ! i) \<subseteq> ghole_poss (Ds ! i)" for i using 2(1,4) by auto
	+ then show ?case using 2 by (auto intro!: nth_equalityI)
	+qed
	+
	+lemma set_sup_gmctxt_args_split:
	+ "length Cs = length Ds \<Longrightarrow> set (sup_gmctxt_args (GMFun f Cs) (GMFun f Ds)) =
	+ (\<Union> i \<in> {0..< length Ds}. set (sup_gmctxt_args (Cs ! i) (Ds ! i)))"
	+ by (auto simp: atLeast0LessThan in_set_zip)
	+ (metis length_map map_fst_zip nth_mem nth_zip)
	+
	+lemma gmctxt_closing_trans:
	+ "gmctxt_closing C D \<Longrightarrow> gmctxt_closing D E \<Longrightarrow> gmctxt_closing C E"
	+ unfolding gmctxt_closing_def using less_eq_gmctxt_prime
	+ by (metis (full_types) order_trans)
	+
	+lemma gmctxt_closing_sup_args_ghole_or_gterm:
	+ assumes "gmctxt_closing C D"
	+ shows "\<forall> E \<in> set (sup_gmctxt_args C D). E = GMHole \<or> num_gholes E = 0"
	+ using assms unfolding gmctxt_closing_def
	+proof -
	+ from assms have "C \<le> D" "ghole_poss D \<subseteq> ghole_poss C" unfolding gmctxt_closing_def
	+ by (auto simp: less_eq_gmctxt_prime)
	+ then show ?thesis
	+ proof (induct rule: less_eq_gmctxt_induct)
	+ case (1 D)
	+ then show ?case
	+ by (cases D) (auto simp: in_set_conv_nth intro!: ghole_poss_num_gholes_zero, blast)
	+ next
	+ case (2 cs ds f) note IS = this
	+ show ?case using IS set_sup_gmctxt_args_split[OF IS(1)]
	+ by auto
	+ qed
	+qed
	+
	+lemma inv_imples_ghole_poss_subseteq:
	+ "C \<le> D \<Longrightarrow> \<forall> E \<in> set (sup_gmctxt_args C D). E = GMHole \<or> num_gholes E = 0 \<Longrightarrow> ghole_poss D \<subseteq> ghole_poss C"
	+proof (induct rule: less_eq_gmctxt_induct)
	+ case (1 D) then show ?case
	+ by (cases D) (auto simp: num_gholes_zero_ghole_poss)
	+next
	+ case (2 cs ds f)
	+ then show ?case using set_sup_gmctxt_args_split[OF 2(1)]
	+ by auto (metis (no_types, lifting) fst_conv in_set_zip snd_conv subsetD)
	+qed
	+
	+lemma fill_gholes_gmctxt_ghole_poss_subseteq:
	+ assumes "num_gholes C = length Ds" "\<forall> i < length Ds. Ds ! i = GMHole \<or> num_gholes (Ds ! i) = 0"
	+ shows "ghole_poss (fill_gholes_gmctxt C Ds) \<subseteq> ghole_poss C" using assms
	+proof (induct rule: fill_gholes_induct)
	+ case (GMFun f Cs xs)
	+ then show ?case unfolding partition_holes_fill_gholes_gmctxt_conv'
	+ by auto (metis (no_types, lifting) length_map length_partition_by_nth partition_by_nth_nth(1, 2) subsetD)
	+qed (auto simp: num_gholes_zero_ghole_poss)
	+
	+lemma ghole_poss_not_in_poss_gmctxt:
	+ assumes "p \<in> ghole_poss C"
	+ shows "p \<notin> poss_gmctxt C" using assms
	+ by (induct C arbitrary: p) auto
	+
	+lemma comp_gmctxt_inf_ghole_poss_cases:
	+ assumes "(C, D) \<in> comp_gmctxt" "p \<in> ghole_poss (C \<sqinter> D)"
	+ shows "p \<in> ghole_poss C \<and> p \<in> ghole_poss D \<or>
	+ p \<in> ghole_poss C \<and> p \<in> poss_gmctxt D \<or>
	+ p \<in> ghole_poss D \<and> p \<in> poss_gmctxt C" using assms
	+proof (induct arbitrary: p)
	+ case (GMHole1 D) then show ?case
	+ by (cases D) auto
	+next
	+ case (GMHole2 C) then show ?case
	+ by (cases C) auto
	+next
	+ case (GMFun f g Cs Ds)
	+ then show ?case
	+ by (auto simp: atLeast0LessThan) blast+
	+qed
	+
	+lemma length_ghole_poss_list_num_gholes:
	+ "num_gholes C = length (ghole_poss_list C)"
	+ by (induct C) (auto simp: length_concat intro: nth_sum_listI)
	+
	+lemma ghole_poss_list_distict:
	+ "distinct (ghole_poss_list C)"
	+proof (induct C)
	+ case (GMFun f Cs)
	+ then show ?case proof (induct Cs rule: rev_induct)
	+ case (snoc x xs)
	+ then have "distinct (ghole_poss_list (GMFun f xs))" "distinct (ghole_poss_list x)" by auto
	+ then show ?case using snoc by (auto simp add: map_cons_presv_distinct dest: set_zip_leftD)
	+ qed auto
	+qed auto
	+
	+lemma ghole_poss_ghole_poss_list_conv:
	+ "ghole_poss C = set (ghole_poss_list C)"
	+proof (induct C)
	+ case (GMFun f Cs) note IS = GMFun[OF nth_mem]
	+ {fix p assume "p \<in> ghole_poss (GMFun f Cs)"
	+ then obtain i ps where w: "p = i # ps" "i < length Cs"
	+ "ps \<in> ghole_poss (Cs ! i)" by auto
	+ then have "(i, Cs ! i) \<in> set (zip [0..<length Cs] Cs)"
	+ by (force simp: in_set_zip)
	+ then have "p \<in> set (ghole_poss_list (GMFun f Cs))" using IS[of i] w
	+ by auto}
	+ then show ?case using IS
	+ by (auto simp: in_set_zip)
	+qed auto
	+
	+lemma card_ghole_poss_num_gholes:
	+ "card (ghole_poss C) = num_gholes C"
	+ unfolding ghole_poss_ghole_poss_list_conv
	+ unfolding length_ghole_poss_list_num_gholes
	+ using ghole_poss_list_distict
	+ using distinct_card by blast
	+
	+lemma subgm_at_hole_poss [simp]:
	+ "p \<in> ghole_poss C \<Longrightarrow> subgm_at C p = GMHole"
	+ by (induct C arbitrary: p) auto
	+
	+lemma subgm_at_mctxt_of_term:
	+ "p \<in> gposs t \<Longrightarrow> subgm_at (gmctxt_of_gterm t) p = gmctxt_of_gterm (gsubt_at t p)"
	+ by (induct t arbitrary: p) auto
	+
	+lemma num_gholes_subgm_at:
	+ assumes "p \<in> poss_gmctxt C"
	+ shows "num_gholes (subgm_at C p) = ghole_num_at_pos p C" using assms
	+ by (induct C arbitrary: p) auto
	+
	+lemma gmctxt_subtgm_at_fill_args_empty_pos [simp]:
	+ assumes "num_gholes C = length ts"
	+ shows "gmctxt_subtgm_at_fill_args [] C ts = ts"
	+ using assms by (auto simp: gmctxt_subtgm_at_fill_args_def)
	+
	+lemma ghole_num_bef_at_pos_num_gholes_less_eq:
	+ assumes "p \<in> poss_gmctxt C"
	+ shows "ghole_num_bef_pos p C + ghole_num_at_pos p C \<le> num_gholes C" using assms
	+proof (induct C arbitrary: p)
	+ case (GMFun f Cs)
	+ show ?case
	+ proof (cases p)
	+ case (Cons i ps)
	+ have *: "num_gholes (GMFun f Cs) = sum_list (map num_gholes (take i Cs)) + num_gholes (Cs ! i) + sum_list (map num_gholes (drop (Suc i) Cs))"
	+ using GMFun(2) unfolding Cons
	+ by (auto simp flip: take_map take_drop)
	+ (metis Cons_nth_drop_Suc add.assoc append_take_drop_id drop_map length_map nth_map sum_list.Cons sum_list.append)
	+ from Cons have
	+ "(sum_list (map num_gholes (take i Cs)) + (ghole_num_bef_pos ps (Cs ! i) + ghole_num_at_pos ps (Cs ! i)))
	+ + sum_list (map num_gholes (drop (Suc i) Cs)) \<le>
	+ (sum_list (map num_gholes (take i Cs)) + num_gholes (Cs ! i)) + sum_list (map num_gholes (drop (Suc i) Cs))"
	+ using GMFun(1)[OF nth_mem, of i ps] GMFun(2)
	+ by auto
	+ from add_le_imp_le_right[OF this] show ?thesis using GMFun(2) *
	+ unfolding Cons
	+ by simp
	+ qed auto
	+qed auto
	+
	+lemma ghole_num_at_pos_fill_args_length:
	+ assumes "p \<in> poss_gmctxt C" "num_gholes C = length ts"
	+ shows "ghole_num_at_pos p C = length (gmctxt_subtgm_at_fill_args p C ts)"
	+ using ghole_num_bef_at_pos_num_gholes_less_eq[OF assms(1)] assms(2)
	+ by (auto simp: gmctxt_subtgm_at_fill_args_def)
	+
	+lemma ghole_poss_nth_subt_at:
	+ assumes "t =\<^sub>G\<^sub>f (C, ts)" and "p \<in> ghole_poss C"
	+ shows "ghole_num_bef_pos p C < length ts \<and> gsubt_at t p = ts ! ghole_num_bef_pos p C" using assms
	+proof (induct arbitrary: p rule: eq_gfill_induct)
	+ case (GMFun f ss Cs ts)
	+ let ?ts = "partition_gholes ts Cs"
	+ from GMFun obtain i and q where [simp]: "p = i # q"
	+ and "i < length ss" and "q \<in> ghole_poss (Cs ! i)" by auto
	+ with GMFun.hyps have "ss ! i =\<^sub>G\<^sub>f (Cs ! i, ?ts ! i)"
	+ and j: "ghole_num_bef_pos q (Cs ! i) < length (?ts ! i)" (is "?j < length _")
	+ and *: "?ts ! i ! ghole_num_bef_pos q (Cs ! i) = gsubt_at (ss ! i) q"
	+ by auto
	+ let ?k = "sum_list (map length (take i ?ts)) + ?j"
	+ have "i < length ?ts" using \<open>i < length ss\<close> and GMFun by auto
	+ with partition_by_nth_nth_old [OF this j] and GMFun and concat_nth_length [OF this j]
	+ have "?ts ! i ! ?j = ts ! ?k" and "?k < length ts" by (auto)
	+ moreover with * have "ts ! ?k = gsubt_at (GFun f ss) p" using \<open>i < length ss\<close> by simp
	+ ultimately show ?case using GMFun.hyps(2) by (auto simp: take_map [symmetric])
	+qed auto
	+
	+lemma poss_gmctxt_fill_gholes_split:
	+ assumes "t =\<^sub>G\<^sub>f (C, ts)" and "p \<in> poss_gmctxt C"
	+ shows "gsubt_at t p =\<^sub>G\<^sub>f (subgm_at C p , gmctxt_subtgm_at_fill_args p C ts)"
	+ using assms
	+proof (induct arbitrary: p rule: eq_gfill_induct)
	+ case (GMFun f ss Cs ts)
	+ let ?ts = "partition_gholes ts Cs"
	+ from GMFun have "\<And> i. i < length Cs \<Longrightarrow> ss ! i =\<^sub>G\<^sub>f (Cs ! i, ?ts ! i)" by auto
	+ show ?case
	+ proof (cases p)
	+ case Nil
	+ then have "GFun f ss =\<^sub>G\<^sub>f (GMFun f Cs, concat ?ts)" using GMFun
	+ by (intro eqgf_GMFunI) (auto simp del: fill_gholes.simps)
	+ then show ?thesis using GMFun unfolding Nil
	+ by simp
	+ next
	+ case (Cons i q)
	+ then have "ghole_num_at_pos q (Cs ! i) \<le> num_gholes (Cs ! i) - ghole_num_bef_pos q (Cs ! i)"
	+ using GMFun(1, 2, 4) ghole_num_bef_at_pos_num_gholes_less_eq[of q "Cs ! i"]
	+ by auto
	+ then show ?thesis using GMFun
	+ by (auto simp: Cons add.commute gmctxt_subtgm_at_fill_args_def partition_by_nth drop_take take_map min_def split!: if_splits)
	+ qed
	+qed auto
	+
	+lemma fill_gholes_ghole_poss:
	+ assumes "t =\<^sub>G\<^sub>f (C, ts)" and "i < length ts"
	+ shows "gsubt_at t (ghole_poss_list C ! i) = ts ! i" using assms
	+proof (induct arbitrary: i rule: eq_gfill_induct)
	+ case (GMFun f ss Cs ts)
	+ have *: "length (concat (poss_rec ghole_poss_list Cs)) = num_gholes (GMFun f Cs)"
	+ using GMFun(1, 2, 4)
	+ unfolding length_ghole_poss_list_num_gholes[of "GMFun f Cs", symmetric, unfolded ghole_poss_list.simps]
	+ by auto
	+ from GMFun have b: "i < length (concat (partition_gholes ts Cs))" by simp
	+ then have ts: "ts ! i = (\<lambda> (j, k). partition_gholes ts Cs ! j ! k) (concat_index_split (0, i) (partition_gholes ts Cs))"
	+ by (metis GMFun.hyps(2) concat_index_split_sound concat_partition_by)
	+ obtain o_idx i_idx where csp: "concat_index_split (0, i) (partition_gholes ts Cs) = (o_idx, i_idx)"
	+ using old.prod.exhaust by blast
	+ have idx: "o_idx < length Cs" "i_idx < length (partition_gholes ts Cs ! o_idx)"
	+ using concat_index_split_sound_bounds[OF b csp] by auto
	+ have "concat_index_split (0, i) (poss_rec ghole_poss_list Cs) = (o_idx, i_idx)"
	+ using GMFun(1, 2, 4) * unfolding csp[symmetric]
	+ by (intro concat_index_split_unique, unfold *)
	+ (auto, simp add: length_ghole_poss_list_num_gholes length_partition_gholes_nth)
	+ then have gp: "ghole_poss_list (GMFun f Cs) ! i = poss_rec ghole_poss_list Cs ! o_idx ! i_idx"
	+ by (simp add: "*" GMFun.hyps(2) GMFun.prems concat_index_split_less_length_concat(4))
	+ from idx GMFun have r: "o_idx < length (zip [0..<length ss] Cs)" by auto
	+ then show ?case using GMFun idx unfolding ts csp gp
	+ by (auto simp: nth_map[OF r] length_ghole_poss_list_num_gholes length_partition_gholes_nth split: prod.splits)
	+qed auto
	+
	+lemma length_unfill_gholes [simp]:
	+ assumes "C \<le> gmctxt_of_gterm t"
	+ shows "length (unfill_gholes C t) = num_gholes C"
	+ using assms
	+proof (induct C t rule: unfill_gholes.induct)
	+ case (2 f Cs g ts) with 2(1)[OF _ nth_mem] 2(2) show ?case
	+ by (auto simp: less_eq_gmctxt_def length_concat
	+ intro!: cong[of sum_list, OF refl] nth_equalityI elim!: nth_equalityE)
	+qed auto
	+
	+lemma fill_gholes_arbitrary:
	+ assumes lCs: "length Cs = length ts"
	+ and lss: "length ss = length ts"
	+ and rec: "\<And> i. i < length ts \<Longrightarrow> num_gholes (Cs ! i) = length (ss ! i) \<and> f (Cs ! i) (ss ! i) = ts ! i"
	+ shows "map (\<lambda>i. f (Cs ! i) (partition_gholes (concat ss) Cs ! i)) [0 ..< length Cs] = ts"
	+proof -
	+ have "sum_list (map num_gholes Cs) = length (concat ss)" using assms
	+ by (auto simp: length_concat map_nth_eq_conv intro: arg_cong[of _ _ "sum_list"])
	+ moreover have "partition_gholes (concat ss) Cs = ss"
	+ using assms by (auto intro: partition_by_concat_id)
	+ ultimately show ?thesis using assms by (auto intro: nth_equalityI)
	+qed
	+
	+lemma fill_unfill_gholes:
	+ assumes "C \<le> gmctxt_of_gterm t"
	+ shows "fill_gholes C (unfill_gholes C t) = t"
	+ using assms
	+proof (induct C t rule: unfill_gholes.induct)
	+ case (2 f Cs g ts) with 2(1)[OF _ nth_mem] 2(2) show ?case
	+ by (auto simp: less_eq_gmctxt_def unfill_gholes_conv intro!: fill_gholes_arbitrary elim!: nth_equalityE)
	+qed (auto split: if_splits)
	+
	+lemma funas_gmctxt_of_mctxt [simp]:
	+ "ground_mctxt C \<Longrightarrow> funas_gmctxt (gmctxt_of_mctxt C) = funas_mctxt C"
	+ by (induct C) (auto simp: funas_gterm_gterm_of_term)
	+
	+lemma funas_mctxt_of_gmctxt_conv:
	+ "funas_mctxt (mctxt_of_gmctxt C) = funas_gmctxt C"
	+ by (induct C) (auto simp flip: funas_gterm_gterm_of_term)
	+
	+lemma funas_gterm_ctxt_apply [simp]:
	+ assumes "num_gholes C = length ss"
	+ shows "funas_gterm (fill_gholes C ss) = funas_gmctxt C \<union> \<Union> (set (map funas_gterm ss))" using assms
	+proof (induct rule: fill_gholes_induct)
	+ case (GMFun f Cs ss)
	+ show ?case using GMFun partition_gholes_subseteq[OF GMFun(1)]
	+ by (auto simp add: Un_Union_image simp del: map_partition_by_nth)
	+qed simp
	+
	+lemma funas_gmctxt_gmctxt_of_gterm [simp]:
	+ "funas_gmctxt (gmctxt_of_gterm s) = funas_gterm s"
	+ by (induct s) auto
	+
	+lemma funas_gmctxt_replicate_GMHole [simp]:
	+ "funas_gmctxt (GMFun f (replicate n GMHole)) = {(f, n)}"
	+ by auto
	+
	+lemma funas_gmctxt_gmctxt_of_gctxt [simp]:
	+ "funas_gmctxt (gmctxt_of_gctxt C) = funas_gctxt C"
	+ by (induct C) auto
	+
	+lemma funas_gmctxt_fill_gholes_gmctxt [simp]:
	+ assumes "num_gholes C = length Ds"
	+ shows "funas_gmctxt (fill_gholes_gmctxt C Ds) = funas_gmctxt C \<union> \<Union>(set (map funas_gmctxt Ds))"
	+ (is "?f C Ds = ?g C Ds") using assms
	+proof (induct C arbitrary: Ds)
	+ case GMHole then show ?case by (cases Ds) simp_all
	+next
	+ case (GMFun f Cs)
	+ then have num_gholes: "sum_list (map num_gholes Cs) = length Ds" by simp
	+ let ?ys = "partition_gholes Ds Cs"
	+ have "\<And>i. i < length Cs \<Longrightarrow> ?f (Cs ! i) (?ys ! i) = ?g (Cs ! i) (?ys ! i)"
	+ by (simp add: GMFun.hyps length_partition_by_nth num_gholes)
	+ then have "(\<Union>i \<in> {0 ..< length Cs}. ?f (Cs ! i) (?ys ! i)) =
	+ (\<Union>i \<in> {0 ..< length Cs}. ?g (Cs ! i) (?ys ! i))" by simp
	+ then show ?case
	+ using num_gholes unfolding partition_holes_fill_holes_mctxt_conv
	+ by (simp add: UN_Un_distrib UN_upt_len_conv [of _ _ "\<lambda>x. \<Union>(set x)"] UN_set_partition_by_map)
	+qed
	+
	+lemma funas_supremum:
	+ "C \<le> D \<Longrightarrow> funas_gmctxt D = funas_gmctxt C \<union> \<Union> (set (map funas_gmctxt (sup_gmctxt_args C D)))"
	+ using fill_gholes_gmctxt_sup_mctxt_args[of C]
	+ by (auto simp: fill_gholes_gmctxt_sup_mctxt_args[of C] elim!: less_eq_to_sup_mctxt_args[of C D])
	+
	+lemma funas_gctxt_gctxt_of_gmctxt [simp]:
	+ "num_gholes D = Suc 0 \<Longrightarrow> funas_gctxt (gctxt_of_gmctxt D) = funas_gmctxt D"
	+ by (metis One_nat_def funas_gmctxt_gmctxt_of_gctxt gmctxt_of_gctxt_gctxt_of_gmctxt)
	+
	+lemma funas_gterm_gterm_of_gmctxt [simp]:
	+ "num_gholes C = 0 \<Longrightarrow> funas_gterm (gterm_of_gmctxt C) = funas_gmctxt C"
	+ by (metis funas_gmctxt_gmctxt_of_gterm no_gholes_gmctxt_of_gterm_gterm_of_gmctxt_id)
	+
	+lemma less_sup_gmctxt_args_funas_gmctxt:
	+ "C \<le> D \<Longrightarrow> funas_gmctxt C \<subseteq> \<F> \<Longrightarrow> \<forall> Ds \<in> set (sup_gmctxt_args C D). funas_gmctxt Ds \<subseteq> \<F> \<Longrightarrow> funas_gmctxt D \<subseteq> \<F>"
	+ using funas_supremum[of C D] by auto
	+
	+lemma funas_gmctxt_poss_gmctxt_subgm_at_funas:
	+ assumes "funas_gmctxt C \<subseteq> \<F>" "p \<in> poss_gmctxt C"
	+ shows "funas_gmctxt (subgm_at C p) \<subseteq> \<F>"
	+ using assms
	+proof (induct C arbitrary: p)
	+ case (GMFun f Cs)
	+ then show ?case
	+ by (auto, blast) (metis SUP_le_iff nth_mem subsetD)
	+qed auto
	+
	+lemma inf_funas_gmctxt_subset1:
	+ "funas_gmctxt (C \<sqinter> D) \<subseteq> funas_gmctxt C"
	+ using funas_supremum[of C "C \<sqinter> D"]
	+ by (metis funas_supremum inf_le1 le_sup_iff order_refl)
	+
	+lemma inf_funas_gmctxt_subset2:
	+ "funas_gmctxt (C \<sqinter> D) \<subseteq> funas_gmctxt D"
	+ using funas_supremum[of D "C \<sqinter> D"]
	+ by (metis funas_supremum inf_le2 le_sup_iff order_refl)
	+
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Util/Multihole_Context.thy b/thys/FO_Theory_Rewriting/Util/Multihole_Context.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Util/Multihole_Context.thy
	@@ -0,0 +1,803 @@
	+(*
	+Author: Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at> (2015)
	+Author: Christian Sternagel <c.sternagel@gmail.com> (2013-2016)
	+Author: Martin Avanzini <martin.avanzini@uibk.ac.at> (2014)
	+Author: René Thiemann <rene.thiemann@uibk.ac.at> (2013-2015)
	+Author: Julian Nagele <julian.nagele@uibk.ac.at> (2016)
	+License: LGPL (see file COPYING.LESSER)
	+*)
	+
	+section \<open>Preliminaries\<close>
	+subsection \<open>Multihole Contexts\<close>
	+
	+theory Multihole_Context
	+imports
	+ Utils
	+begin
	+
	+unbundle lattice_syntax
	+
	+subsubsection \<open>Partitioning lists into chunks of given length\<close>
	+
	+lemma concat_nth:
	+ assumes "m < length xs" and "n < length (xs ! m)"
	+ and "i = sum_list (map length (take m xs)) + n"
	+ shows "concat xs ! i = xs ! m ! n"
	+using assms
	+proof (induct xs arbitrary: m n i)
	+ case (Cons x xs)
	+ show ?case
	+ proof (cases m)
	+ case 0
	+ then show ?thesis using Cons by (simp add: nth_append)
	+ next
	+ case (Suc k)
	+ with Cons(1) [of k n "i - length x"] and Cons(2-)
	+ show ?thesis by (simp_all add: nth_append)
	+ qed
	+qed simp
	+
	+lemma sum_list_take_eq:
	+ fixes xs :: "nat list"
	+ shows "k < i \<Longrightarrow> i < length xs \<Longrightarrow> sum_list (take i xs) =
	+ sum_list (take k xs) + xs ! k + sum_list (take (i - Suc k) (drop (Suc k) xs))"
	+ by (subst id_take_nth_drop [of k]) (auto simp: min_def drop_take)
	+
	+fun partition_by where
	+ "partition_by xs [] = []" \|
	+ "partition_by xs (y#ys) = take y xs # partition_by (drop y xs) ys"
	+
	+lemma partition_by_map0_append [simp]:
	+ "partition_by xs (map (\<lambda>x. 0) ys @ zs) = replicate (length ys) [] @ partition_by xs zs"
	+by (induct ys) simp_all
	+
	+lemma concat_partition_by [simp]:
	+ "sum_list ys = length xs \<Longrightarrow> concat (partition_by xs ys) = xs"
	+by (induct ys arbitrary: xs) simp_all
	+
	+definition partition_by_idx where
	+ "partition_by_idx l ys i j = partition_by [0..<l] ys ! i ! j"
	+
	+lemma partition_by_nth_nth_old:
	+ assumes "i < length (partition_by xs ys)"
	+ and "j < length (partition_by xs ys ! i)"
	+ and "sum_list ys = length xs"
	+ shows "partition_by xs ys ! i ! j = xs ! (sum_list (map length (take i (partition_by xs ys))) + j)"
	+ using concat_nth [OF assms(1, 2) refl]
	+ unfolding concat_partition_by [OF assms(3)] by simp
	+
	+lemma map_map_partition_by:
	+ "map (map f) (partition_by xs ys) = partition_by (map f xs) ys"
	+by (induct ys arbitrary: xs) (auto simp: take_map drop_map)
	+
	+lemma length_partition_by [simp]:
	+ "length (partition_by xs ys) = length ys"
	+ by (induct ys arbitrary: xs) simp_all
	+
	+lemma partition_by_Nil [simp]:
	+ "partition_by [] ys = replicate (length ys) []"
	+ by (induct ys) simp_all
	+
	+lemma partition_by_concat_id [simp]:
	+ assumes "length xss = length ys"
	+ and "\<And>i. i < length ys \<Longrightarrow> length (xss ! i) = ys ! i"
	+ shows "partition_by (concat xss) ys = xss"
	+ using assms by (induct ys arbitrary: xss) (simp, case_tac xss, simp, fastforce)
	+
	+lemma partition_by_nth:
	+ "i < length ys \<Longrightarrow> partition_by xs ys ! i = take (ys ! i) (drop (sum_list (take i ys)) xs)"
	+ by (induct ys arbitrary: xs i) (simp, case_tac i, simp_all add: ac_simps)
	+
	+lemma partition_by_nth_less:
	+ assumes "k < i" and "i < length zs"
	+ and "length xs = sum_list (take i zs) + j"
	+ shows "partition_by (xs @ y # ys) zs ! k = take (zs ! k) (drop (sum_list (take k zs)) xs)"
	+proof -
	+ have "partition_by (xs @ y # ys) zs ! k =
	+ take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
	+ using assms by (auto simp: partition_by_nth)
	+ moreover have "zs ! k + sum_list (take k zs) \<le> length xs"
	+ using assms by (simp add: sum_list_take_eq)
	+ ultimately show ?thesis by simp
	+qed
	+
	+lemma partition_by_nth_greater:
	+ assumes "i < k" and "k < length zs" and "j < zs ! i"
	+ and "length xs = sum_list (take i zs) + j"
	+ shows "partition_by (xs @ y # ys) zs ! k =
	+ take (zs ! k) (drop (sum_list (take k zs) - 1) (xs @ ys))"
	+proof -
	+ have "partition_by (xs @ y # ys) zs ! k =
	+ take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
	+ using assms by (auto simp: partition_by_nth)
	+ moreover have "sum_list (take k zs) > length xs"
	+ using assms by (auto simp: sum_list_take_eq)
	+ ultimately show ?thesis by (auto) (metis Suc_diff_Suc drop_Suc_Cons)
	+qed
	+
	+lemma length_partition_by_nth:
	+ "sum_list ys = length xs \<Longrightarrow> i < length ys \<Longrightarrow> length (partition_by xs ys ! i) = ys ! i"
	+by (induct ys arbitrary: xs i; case_tac i) auto
	+
	+lemma partition_by_nth_nth_elem:
	+ assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
	+ shows "partition_by xs ys ! i ! j \<in> set xs"
	+proof -
	+ from assms have "j < length (partition_by xs ys ! i)" by (simp only: length_partition_by_nth)
	+ then have "partition_by xs ys ! i ! j \<in> set (partition_by xs ys ! i)" by auto
	+ with assms(2) have "partition_by xs ys ! i ! j \<in> set (concat (partition_by xs ys))" by auto
	+ then show ?thesis using assms by simp
	+qed
	+
	+lemma partition_by_nth_nth:
	+ assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
	+ shows "partition_by xs ys ! i ! j = xs ! partition_by_idx (length xs) ys i j"
	+ "partition_by_idx (length xs) ys i j < length xs"
	+unfolding partition_by_idx_def
	+proof -
	+ let ?n = "partition_by [0..<length xs] ys ! i ! j"
	+ show "?n < length xs"
	+ using partition_by_nth_nth_elem[OF _ assms(2,3), of "[0..<length xs]"] assms(1) by simp
	+ have li: "i < length (partition_by [0..<length xs] ys)" using assms(2) by simp
	+ have lj: "j < length (partition_by [0..<length xs] ys ! i)"
	+ using assms by (simp add: length_partition_by_nth)
	+ have "partition_by (map ((!) xs) [0..<length xs]) ys ! i ! j = xs ! ?n"
	+ by (simp only: map_map_partition_by[symmetric] nth_map[OF li] nth_map[OF lj])
	+ then show "partition_by xs ys ! i ! j = xs ! ?n" by (simp add: map_nth)
	+qed
	+
	+lemma map_length_partition_by [simp]:
	+ "sum_list ys = length xs \<Longrightarrow> map length (partition_by xs ys) = ys"
	+ by (intro nth_equalityI, auto simp: length_partition_by_nth)
	+
	+lemma map_partition_by_nth [simp]:
	+ "i < length ys \<Longrightarrow> map f (partition_by xs ys ! i) = partition_by (map f xs) ys ! i"
	+ by (induct ys arbitrary: i xs) (simp, case_tac i, simp_all add: take_map drop_map)
	+
	+lemma sum_list_partition_by [simp]:
	+ "sum_list ys = length xs \<Longrightarrow>
	+ sum_list (map (\<lambda>x. sum_list (map f x)) (partition_by xs ys)) = sum_list (map f xs)"
	+ by (induct ys arbitrary: xs) (simp_all, metis append_take_drop_id sum_list_append map_append)
	+
	+lemma partition_by_map_conv:
	+ "partition_by xs ys = map (\<lambda>i. take (ys ! i) (drop (sum_list (take i ys)) xs)) [0 ..< length ys]"
	+ by (rule nth_equalityI) (simp_all add: partition_by_nth)
	+
	+lemma UN_set_partition_by_map:
	+ "sum_list ys = length xs \<Longrightarrow> (\<Union>x\<in>set (partition_by (map f xs) ys). \<Union> (set x)) = \<Union>(set (map f xs))"
	+ by (induct ys arbitrary: xs)
	+ (simp_all add: drop_map take_map, metis UN_Un append_take_drop_id set_append)
	+
	+lemma UN_set_partition_by:
	+ "sum_list ys = length xs \<Longrightarrow> (\<Union>zs \<in> set (partition_by xs ys). \<Union>x \<in> set zs. f x) = (\<Union>x \<in> set xs. f x)"
	+ by (induct ys arbitrary: xs) (simp_all, metis UN_Un append_take_drop_id set_append)
	+
	+lemma Ball_atLeast0LessThan_partition_by_conv:
	+ "(\<forall>i\<in>{0..<length ys}. \<forall>x\<in>set (partition_by xs ys ! i). P x) =
	+ (\<forall>x \<in> \<Union>(set (map set (partition_by xs ys))). P x)"
	+ by auto (metis atLeast0LessThan in_set_conv_nth length_partition_by lessThan_iff)
	+
	+lemma Ball_set_partition_by:
	+ "sum_list ys = length xs \<Longrightarrow>
	+ (\<forall>x \<in> set (partition_by xs ys). \<forall>y \<in> set x. P y) = (\<forall>x \<in> set xs. P x)"
	+proof (induct ys arbitrary: xs)
	+ case (Cons y ys)
	+ then show ?case
	+ apply (subst (2) append_take_drop_id [of y xs, symmetric])
	+ apply (simp only: set_append)
	+ apply auto
	+ done
	+qed simp
	+
	+lemma partition_by_append2:
	+ "partition_by xs (ys @ zs) = partition_by (take (sum_list ys) xs) ys @ partition_by (drop (sum_list ys) xs) zs"
	+by (induct ys arbitrary: xs) (auto simp: drop_take ac_simps split: split_min)
	+
	+lemma partition_by_concat2:
	+ "partition_by xs (concat ys) =
	+ concat (map (\<lambda>i . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys])"
	+proof -
	+ have *: "map (\<lambda>i . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys] =
	+ map (\<lambda>(x,y). partition_by x y) (zip (partition_by xs (map sum_list ys)) ys)"
	+ using zip_nth_conv[of "partition_by xs (map sum_list ys)" ys] by auto
	+ show ?thesis unfolding * by (induct ys arbitrary: xs) (auto simp: partition_by_append2)
	+qed
	+
	+lemma partition_by_partition_by:
	+ "length xs = sum_list (map sum_list ys) \<Longrightarrow>
	+ partition_by (partition_by xs (concat ys)) (map length ys) =
	+ map (\<lambda>i. partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys]"
	+by (auto simp: partition_by_concat2 intro: partition_by_concat_id)
	+
	+subsubsection \<open>Multihole contexts definition and functionalities\<close>
	+datatype ('f, vars_mctxt : 'v) mctxt = MVar 'v \| MHole \| MFun 'f "('f, 'v) mctxt list"
	+
	+subsubsection \<open>Conversions from and to multihole contexts\<close>
	+
	+primrec mctxt_of_term :: "('f, 'v) term \<Rightarrow> ('f, 'v) mctxt" where
	+ "mctxt_of_term (Var x) = MVar x" \|
	+ "mctxt_of_term (Fun f ts) = MFun f (map mctxt_of_term ts)"
	+
	+primrec term_of_mctxt :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term" where
	+ "term_of_mctxt (MVar x) = Var x" \|
	+ "term_of_mctxt (MFun f Cs) = Fun f (map term_of_mctxt Cs)"
	+
	+fun num_holes :: "('f, 'v) mctxt \<Rightarrow> nat" where
	+ "num_holes (MVar _) = 0" \|
	+ "num_holes MHole = 1" \|
	+ "num_holes (MFun _ ctxts) = sum_list (map num_holes ctxts)"
	+
	+fun ground_mctxt :: "('f, 'v) mctxt \<Rightarrow> bool" where
	+ "ground_mctxt (MVar _) = False" \|
	+ "ground_mctxt MHole = True" \|
	+ "ground_mctxt (MFun f Cs) = Ball (set Cs) ground_mctxt"
	+
	+fun map_mctxt :: "('f \<Rightarrow> 'g) \<Rightarrow> ('f, 'v) mctxt \<Rightarrow> ('g, 'v) mctxt"
	+where
	+ "map_mctxt _ (MVar x) = (MVar x)" \|
	+ "map_mctxt _ (MHole) = MHole" \|
	+ "map_mctxt fg (MFun f Cs) = MFun (fg f) (map (map_mctxt fg) Cs)"
	+
	+abbreviation "partition_holes xs Cs \<equiv> partition_by xs (map num_holes Cs)"
	+abbreviation "partition_holes_idx l Cs \<equiv> partition_by_idx l (map num_holes Cs)"
	+
	+fun fill_holes :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term list \<Rightarrow> ('f, 'v) term" where
	+ "fill_holes (MVar x) _ = Var x" \|
	+ "fill_holes MHole [t] = t" \|
	+ "fill_holes (MFun f cs) ts = Fun f (map (\<lambda> i. fill_holes (cs ! i)
	+ (partition_holes ts cs ! i)) [0 ..< length cs])"
	+
	+fun fill_holes_mctxt :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) mctxt list \<Rightarrow> ('f, 'v) mctxt" where
	+ "fill_holes_mctxt (MVar x) _ = MVar x" \|
	+ "fill_holes_mctxt MHole [] = MHole" \|
	+ "fill_holes_mctxt MHole [t] = t" \|
	+ "fill_holes_mctxt (MFun f cs) ts = (MFun f (map (\<lambda> i. fill_holes_mctxt (cs ! i)
	+ (partition_holes ts cs ! i)) [0 ..< length cs]))"
	+
	+
	+fun unfill_holes :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) term list" where
	+ "unfill_holes MHole t = [t]"
	+\| "unfill_holes (MVar w) (Var v) = (if v = w then [] else undefined)"
	+\| "unfill_holes (MFun g Cs) (Fun f ts) = (if f = g \<and> length ts = length Cs then
	+ concat (map (\<lambda>i. unfill_holes (Cs ! i) (ts ! i)) [0..<length ts]) else undefined)"
	+
	+fun funas_mctxt where
	+ "funas_mctxt (MFun f Cs) = {(f, length Cs)} \<union> \<Union>(funas_mctxt ` set Cs)" \|
	+ "funas_mctxt _ = {}"
	+
	+fun split_vars :: "('f, 'v) term \<Rightarrow> (('f, 'v) mctxt \<times> 'v list)" where
	+ "split_vars (Var x) = (MHole, [x])" \|
	+ "split_vars (Fun f ts) = (MFun f (map (fst \<circ> split_vars) ts), concat (map (snd \<circ> split_vars) ts))"
	+
	+
	+fun hole_poss_list :: "('f, 'v) mctxt \<Rightarrow> pos list" where
	+ "hole_poss_list (MVar x) = []" \|
	+ "hole_poss_list MHole = [[]]" \|
	+ "hole_poss_list (MFun f cs) = concat (poss_args hole_poss_list cs)"
	+
	+fun map_vars_mctxt :: "('v \<Rightarrow> 'w) \<Rightarrow> ('f, 'v) mctxt \<Rightarrow> ('f, 'w) mctxt"
	+where
	+ "map_vars_mctxt vw MHole = MHole" \|
	+ "map_vars_mctxt vw (MVar v) = (MVar (vw v))" \|
	+ "map_vars_mctxt vw (MFun f Cs) = MFun f (map (map_vars_mctxt vw) Cs)"
	+
	+inductive eq_fill :: "('f, 'v) term \<Rightarrow> ('f, 'v) mctxt \<times> ('f, 'v) term list \<Rightarrow> bool" ("(_/ =\<^sub>f _)" [51, 51] 50)
	+where
	+ eqfI [intro]: "t = fill_holes D ss \<Longrightarrow> num_holes D = length ss \<Longrightarrow> t =\<^sub>f (D, ss)"
	+
	+subsubsection \<open>Semilattice Structures\<close>
	+
	+instantiation mctxt :: (type, type) inf
	+
	+begin
	+
	+fun inf_mctxt :: "('a, 'b) mctxt \<Rightarrow> ('a, 'b) mctxt \<Rightarrow> ('a, 'b) mctxt"
	+where
	+ "MHole \<sqinter> D = MHole" \|
	+ "C \<sqinter> MHole = MHole" \|
	+ "MVar x \<sqinter> MVar y = (if x = y then MVar x else MHole)" \|
	+ "MFun f Cs \<sqinter> MFun g Ds =
	+ (if f = g \<and> length Cs = length Ds then MFun f (map (case_prod (\<sqinter>)) (zip Cs Ds))
	+ else MHole)" \|
	+ "C \<sqinter> D = MHole"
	+
	+instance ..
	+
	+end
	+
	+lemma inf_mctxt_idem [simp]:
	+ fixes C :: "('f, 'v) mctxt"
	+ shows "C \<sqinter> C = C"
	+ by (induct C) (auto simp: zip_same_conv_map intro: map_idI)
	+
	+lemma inf_mctxt_MHole2 [simp]:
	+ "C \<sqinter> MHole = MHole"
	+ by (induct C) simp_all
	+
	+lemma inf_mctxt_comm [ac_simps]:
	+ "(C :: ('f, 'v) mctxt) \<sqinter> D = D \<sqinter> C"
	+ by (induct C D rule: inf_mctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+
	+
	+lemma inf_mctxt_assoc [ac_simps]:
	+ fixes C :: "('f, 'v) mctxt"
	+ shows "C \<sqinter> D \<sqinter> E = C \<sqinter> (D \<sqinter> E)"
	+ apply (induct C D arbitrary: E rule: inf_mctxt.induct)
	+ apply (auto simp: )
	+ apply (case_tac E, auto)+
	+ apply (fastforce simp: in_set_conv_nth intro!: nth_equalityI)
	+ apply (case_tac E, auto)+
	+done
	+
	+instantiation mctxt :: (type, type) order
	+begin
	+
	+definition "(C :: ('a, 'b) mctxt) \<le> D \<longleftrightarrow> C \<sqinter> D = C"
	+definition "(C :: ('a, 'b) mctxt) < D \<longleftrightarrow> C \<le> D \<and> \<not> D \<le> C"
	+
	+instance
	+ by (standard, simp_all add: less_eq_mctxt_def less_mctxt_def ac_simps, metis inf_mctxt_assoc)
	+
	+end
	+
	+inductive less_eq_mctxt' :: "('f, 'v) mctxt \<Rightarrow> ('f,'v) mctxt \<Rightarrow> bool" where
	+ "less_eq_mctxt' MHole u"
	+\| "less_eq_mctxt' (MVar v) (MVar v)"
	+\| "length cs = length ds \<Longrightarrow> (\<And>i. i < length cs \<Longrightarrow> less_eq_mctxt' (cs ! i) (ds ! i)) \<Longrightarrow> less_eq_mctxt' (MFun f cs) (MFun f ds)"
	+
	+
	+subsubsection \<open>Lemmata\<close>
	+
	+lemma partition_holes_fill_holes_conv:
	+ "fill_holes (MFun f cs) ts =
	+ Fun f [fill_holes (cs ! i) (partition_holes ts cs ! i). i \<leftarrow> [0 ..< length cs]]"
	+ by (simp add: partition_by_nth take_map)
	+
	+lemma partition_holes_fill_holes_mctxt_conv:
	+ "fill_holes_mctxt (MFun f Cs) ts =
	+ MFun f [fill_holes_mctxt (Cs ! i) (partition_holes ts Cs ! i). i \<leftarrow> [0 ..< length Cs]]"
	+ by (simp add: partition_by_nth take_map)
	+
	+text \<open>The following induction scheme provides the @{term MFun} case with the list argument split
	+ according to the argument contexts. This feature is quite delicate: its benefit can be
	+ destroyed by premature simplification using the @{thm concat_partition_by} simplification rule.\<close>
	+
	+lemma fill_holes_induct2[consumes 2, case_names MHole MVar MFun]:
	+ fixes P :: "('f,'v) mctxt \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool"
	+ assumes len1: "num_holes C = length xs" and len2: "num_holes C = length ys"
	+ and Hole: "\<And>x y. P MHole [x] [y]"
	+ and Var: "\<And>v. P (MVar v) [] []"
	+ and Fun: "\<And>f Cs xs ys. sum_list (map num_holes Cs) = length xs \<Longrightarrow>
	+ sum_list (map num_holes Cs) = length ys \<Longrightarrow>
	+ (\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_holes xs Cs ! i) (partition_holes ys Cs ! i)) \<Longrightarrow>
	+ P (MFun f Cs) (concat (partition_holes xs Cs)) (concat (partition_holes ys Cs))"
	+ shows "P C xs ys"
	+proof (insert len1 len2, induct C arbitrary: xs ys)
	+ case MHole then show ?case using Hole by (cases xs; cases ys) auto
	+next
	+ case (MVar v) then show ?case using Var by auto
	+next
	+ case (MFun f Cs) then show ?case using Fun[of Cs xs ys f] by (auto simp: length_partition_by_nth)
	+qed
	+
	+lemma fill_holes_induct[consumes 1, case_names MHole MVar MFun]:
	+ fixes P :: "('f,'v) mctxt \<Rightarrow> 'a list \<Rightarrow> bool"
	+ assumes len: "num_holes C = length xs"
	+ and Hole: "\<And>x. P MHole [x]"
	+ and Var: "\<And>v. P (MVar v) []"
	+ and Fun: "\<And>f Cs xs. sum_list (map num_holes Cs) = length xs \<Longrightarrow>
	+ (\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_holes xs Cs ! i)) \<Longrightarrow>
	+ P (MFun f Cs) (concat (partition_holes xs Cs))"
	+ shows "P C xs"
	+ using fill_holes_induct2[of C xs xs "\<lambda> C xs _. P C xs"] assms by simp
	+
	+lemma length_partition_holes_nth [simp]:
	+ assumes "sum_list (map num_holes cs) = length ts"
	+ and "i < length cs"
	+ shows "length (partition_holes ts cs ! i) = num_holes (cs ! i)"
	+ using assms by (simp add: length_partition_by_nth)
	+
	+(some compatibility lemmas (which should be dropped eventually))
	+lemmas
	+ map_partition_holes_nth [simp] =
	+ map_partition_by_nth [of _ "map num_holes Cs" for Cs, unfolded length_map] and
	+ length_partition_holes [simp] =
	+ length_partition_by [of _ "map num_holes Cs" for Cs, unfolded length_map]
	+
	+lemma fill_holes_term_of_mctxt:
	+ "num_holes C = 0 \<Longrightarrow> fill_holes C [] = term_of_mctxt C"
	+ by (induct C) (auto simp add: map_eq_nth_conv)
	+
	+lemma fill_holes_MHole:
	+ "length ts = Suc 0 \<Longrightarrow> ts ! 0 = u \<Longrightarrow> fill_holes MHole ts = u"
	+ by (cases ts) simp_all
	+
	+lemma fill_holes_arbitrary:
	+ assumes lCs: "length Cs = length ts"
	+ and lss: "length ss = length ts"
	+ and rec: "\<And> i. i < length ts \<Longrightarrow> num_holes (Cs ! i) = length (ss ! i) \<and> f (Cs ! i) (ss ! i) = ts ! i"
	+ shows "map (\<lambda>i. f (Cs ! i) (partition_holes (concat ss) Cs ! i)) [0 ..< length Cs] = ts"
	+proof -
	+ have "sum_list (map num_holes Cs) = length (concat ss)" using assms
	+ by (auto simp: length_concat map_nth_eq_conv intro: arg_cong[of _ _ "sum_list"])
	+ moreover have "partition_holes (concat ss) Cs = ss"
	+ using assms by (auto intro: partition_by_concat_id)
	+ ultimately show ?thesis using assms by (auto intro: nth_equalityI)
	+qed
	+
	+lemma fill_holes_MFun:
	+ assumes lCs: "length Cs = length ts"
	+ and lss: "length ss = length ts"
	+ and rec: "\<And> i. i < length ts \<Longrightarrow> num_holes (Cs ! i) = length (ss ! i) \<and> fill_holes (Cs ! i) (ss ! i) = ts ! i"
	+ shows "fill_holes (MFun f Cs) (concat ss) = Fun f ts"
	+ unfolding fill_holes.simps term.simps
	+ by (rule conjI[OF refl], rule fill_holes_arbitrary[OF lCs lss rec])
	+
	+lemma eqfE:
	+ assumes "t =\<^sub>f (D, ss)" shows "t = fill_holes D ss" "num_holes D = length ss"
	+ using assms[unfolded eq_fill.simps] by auto
	+
	+lemma eqf_MFunE:
	+ assumes "s =\<^sub>f (MFun f Cs,ss)"
	+ obtains ts sss where "s = Fun f ts" "length ts = length Cs" "length sss = length Cs"
	+ "\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)"
	+ "ss = concat sss"
	+proof -
	+ from eqfE[OF assms] have fh: "s = fill_holes (MFun f Cs) ss"
	+ and nh: "sum_list (map num_holes Cs) = length ss" by auto
	+ from fh obtain ts where s: "s = Fun f ts" by (cases s, auto)
	+ from fh[unfolded s]
	+ have ts: "ts = map (\<lambda>i. fill_holes (Cs ! i) (partition_holes ss Cs ! i)) [0..<length Cs]"
	+ (is "_ = map (?f Cs ss) _")
	+ by auto
	+ let ?sss = "partition_holes ss Cs"
	+ from nh
	+ have *: "length ?sss = length Cs" "\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, ?sss ! i)" "ss = concat ?sss"
	+ by (auto simp: ts)
	+ have len: "length ts = length Cs" unfolding ts by auto
	+ assume ass: "\<And>ts sss. s = Fun f ts \<Longrightarrow>
	+ length ts = length Cs \<Longrightarrow>
	+ length sss = length Cs \<Longrightarrow> (\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)) \<Longrightarrow> ss = concat sss \<Longrightarrow> thesis"
	+ show thesis
	+ by (rule ass[OF s len *])
	+qed
	+
	+lemma eqf_MFunI:
	+ assumes "length sss = length Cs"
	+ and "length ts = length Cs"
	+ and"\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)"
	+ shows "Fun f ts =\<^sub>f (MFun f Cs, concat sss)"
	+proof
	+ have "num_holes (MFun f Cs) = sum_list (map num_holes Cs)" by simp
	+ also have "map num_holes Cs = map length sss"
	+ by (rule nth_equalityI, insert assms eqfE[OF assms(3)], auto)
	+ also have "sum_list (\<dots>) = length (concat sss)" unfolding length_concat ..
	+ finally show "num_holes (MFun f Cs) = length (concat sss)" .
	+ show "Fun f ts = fill_holes (MFun f Cs) (concat sss)"
	+ by (rule fill_holes_MFun[symmetric], insert assms(1,2) eqfE[OF assms(3)], auto)
	+qed
	+
	+lemma split_vars_ground_vars:
	+ assumes "ground_mctxt C" and "num_holes C = length xs"
	+ shows "split_vars (fill_holes C (map Var xs)) = (C, xs)" using assms
	+proof (induct C arbitrary: xs)
	+ case (MHole xs)
	+ then show ?case by (cases xs, auto)
	+next
	+ case (MFun f Cs xs)
	+ have "fill_holes (MFun f Cs) (map Var xs) =\<^sub>f (MFun f Cs, map Var xs)"
	+ by (rule eqfI, insert MFun(3), auto)
	+ from eqf_MFunE[OF this]
	+ obtain ts xss where fh: "fill_holes (MFun f Cs) (map Var xs) = Fun f ts"
	+ and lent: "length ts = length Cs"
	+ and lenx: "length xss = length Cs"
	+ and args: "\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, xss ! i)"
	+ and id: "map Var xs = concat xss" by auto
	+ from arg_cong[OF id, of "map the_Var"] have id2: "xs = concat (map (map the_Var) xss)"
	+ by (metis map_concat length_map map_nth_eq_conv term.sel(1))
	+ {
	+ fix i
	+ assume i: "i < length Cs"
	+ then have mem: "Cs ! i \<in> set Cs" by auto
	+ with MFun(2) have ground: "ground_mctxt (Cs ! i)" by auto
	+ have "map Var (map the_Var (xss ! i)) = map id (xss ! i)" unfolding map_map o_def map_eq_conv
	+ proof
	+ fix x
	+ assume "x \<in> set (xss ! i)"
	+ with lenx i have "x \<in> set (concat xss)" by auto
	+ from this[unfolded id[symmetric]] show "Var (the_Var x) = id x" by auto
	+ qed
	+ then have idxss: "map Var (map the_Var (xss ! i)) = xss ! i" by auto
	+ note rec = eqfE[OF args[OF i]]
	+ note IH = MFun(1)[OF mem ground, of "map the_Var (xss ! i)", unfolded rec(2) idxss rec(1)[symmetric]]
	+ from IH have "split_vars (ts ! i) = (Cs ! i, map the_Var (xss ! i))" by auto
	+ note this idxss
	+ }
	+ note IH = this
	+ have "?case = (map fst (map split_vars ts) = Cs \<and> concat (map snd (map split_vars ts)) = concat (map (map the_Var) xss))"
	+ unfolding fh unfolding id2 by auto
	+ also have "\<dots>"
	+ proof (rule conjI[OF nth_equalityI arg_cong[of _ _ concat, OF nth_equalityI, rule_format]], unfold length_map lent lenx)
	+ fix i
	+ assume i: "i < length Cs"
	+ with arg_cong[OF IH(2)[OF this], of "map the_Var"]
	+ IH[OF this] show "map snd (map split_vars ts) ! i = map (map the_Var) xss ! i" using lent lenx by auto
	+ qed (insert IH lent, auto)
	+ finally show ?case .
	+qed auto
	+
	+
	+lemma split_vars_vars_term_list: "snd (split_vars t) = vars_term_list t"
	+proof (induct t)
	+ case (Fun f ts)
	+ then show ?case by (auto simp: vars_term_list.simps o_def, induct ts, auto)
	+qed (auto simp: vars_term_list.simps)
	+
	+
	+lemma split_vars_num_holes: "num_holes (fst (split_vars t)) = length (snd (split_vars t))"
	+proof (induct t)
	+ case (Fun f ts)
	+ then show ?case by (induct ts, auto)
	+qed simp
	+
	+lemma ground_eq_fill: "t =\<^sub>f (C,ss) \<Longrightarrow> ground t = (ground_mctxt C \<and> (\<forall> s \<in> set ss. ground s))"
	+proof (induct C arbitrary: t ss)
	+ case (MVar x)
	+ from eqfE[OF this] show ?case by simp
	+next
	+ case (MHole t ss)
	+ from eqfE[OF this] show ?case by (cases ss, auto)
	+next
	+ case (MFun f Cs s ss)
	+ from eqf_MFunE[OF MFun(2)] obtain ts sss where s: "s = Fun f ts" and len: "length ts = length Cs" "length sss = length Cs"
	+ and IH: "\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)" and ss: "ss = concat sss" by metis
	+ {
	+ fix i
	+ assume i: "i < length Cs"
	+ then have "Cs ! i \<in> set Cs" by simp
	+ from MFun(1)[OF this IH[OF i]]
	+ have "ground (ts ! i) = (ground_mctxt (Cs ! i) \<and> (\<forall>a\<in>set (sss ! i). ground a))" .
	+ } note IH = this
	+ note conv = set_conv_nth
	+ have "?case = ((\<forall>x\<in>set ts. ground x) = ((\<forall>x\<in>set Cs. ground_mctxt x) \<and> (\<forall>a\<in>set sss. \<forall>x\<in>set a. ground x)))"
	+ unfolding s ss by simp
	+ also have "..." unfolding conv[of ts] conv[of Cs] conv[of sss] len using IH by auto
	+ finally show ?case by simp
	+qed
	+
	+lemma ground_fill_holes:
	+ assumes nh: "num_holes C = length ss"
	+ shows "ground (fill_holes C ss) = (ground_mctxt C \<and> (\<forall> s \<in> set ss. ground s))"
	+ by (rule ground_eq_fill[OF eqfI[OF refl nh]])
	+
	+lemma split_vars_ground' [simp]:
	+ "ground_mctxt (fst (split_vars t))"
	+ by (induct t) auto
	+
	+lemma split_vars_funas_mctxt [simp]:
	+ "funas_mctxt (fst (split_vars t)) = funas_term t"
	+ by (induct t) auto
	+
	+
	+lemma less_eq_mctxt_prime: "C \<le> D \<longleftrightarrow> less_eq_mctxt' C D"
	+proof
	+ assume "less_eq_mctxt' C D" then show "C \<le> D"
	+ by (induct C D rule: less_eq_mctxt'.induct) (auto simp: less_eq_mctxt_def intro: nth_equalityI)
	+next
	+ assume "C \<le> D" then show "less_eq_mctxt' C D" unfolding less_eq_mctxt_def
	+ by (induct C D rule: inf_mctxt.induct)
	+ (auto split: if_splits simp: set_zip intro!: less_eq_mctxt'.intros nth_equalityI elim!: nth_equalityE, metis)
	+qed
	+
	+lemmas less_eq_mctxt_induct = less_eq_mctxt'.induct[folded less_eq_mctxt_prime, consumes 1]
	+lemmas less_eq_mctxt_intros = less_eq_mctxt'.intros[folded less_eq_mctxt_prime]
	+
	+lemma less_eq_mctxt_MHoleE2:
	+ assumes "C \<le> MHole"
	+ obtains (MHole) "C = MHole"
	+ using assms unfolding less_eq_mctxt_prime by (cases C, auto)
	+
	+lemma less_eq_mctxt_MVarE2:
	+ assumes "C \<le> MVar v"
	+ obtains (MHole) "C = MHole" \| (MVar) "C = MVar v"
	+ using assms unfolding less_eq_mctxt_prime by (cases C) auto
	+
	+lemma less_eq_mctxt_MFunE2:
	+ assumes "C \<le> MFun f ds"
	+ obtains (MHole) "C = MHole"
	+ \| (MFun) cs where "C = MFun f cs" "length cs = length ds" "\<And>i. i < length cs \<Longrightarrow> cs ! i \<le> ds ! i"
	+ using assms unfolding less_eq_mctxt_prime by (cases C) auto
	+
	+lemmas less_eq_mctxtE2 = less_eq_mctxt_MHoleE2 less_eq_mctxt_MVarE2 less_eq_mctxt_MFunE2
	+
	+
	+lemma less_eq_mctxt_MVarE1:
	+ assumes "MVar v \<le> D"
	+ obtains (MVar) "D = MVar v"
	+ using assms by (cases D) (auto elim: less_eq_mctxtE2)
	+
	+lemma MHole_Bot [simp]: "MHole \<le> D"
	+ by (simp add: less_eq_mctxt_intros(1))
	+
	+lemma less_eq_mctxt_MFunE1:
	+ assumes "MFun f cs \<le> D"
	+ obtains (MFun) ds where "D = MFun f ds" "length cs = length ds" "\<And>i. i < length cs \<Longrightarrow> cs ! i \<le> ds ! i"
	+ using assms by (cases D) (auto elim: less_eq_mctxtE2)
	+
	+
	+lemma length_unfill_holes [simp]:
	+ assumes "C \<le> mctxt_of_term t"
	+ shows "length (unfill_holes C t) = num_holes C"
	+ using assms
	+proof (induct C t rule: unfill_holes.induct)
	+ case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
	+ by (auto simp: less_eq_mctxt_def length_concat
	+ intro!: cong[of sum_list, OF refl] nth_equalityI elim!: nth_equalityE)
	+qed (auto simp: less_eq_mctxt_def)
	+
	+lemma map_vars_mctxt_id [simp]:
	+ "map_vars_mctxt (\<lambda> x. x) C = C"
	+ by (induct C, auto intro: nth_equalityI)
	+
	+
	+lemma split_vars_eqf_subst_map_vars_term:
	+ "t \<cdot> \<sigma> =\<^sub>f (map_vars_mctxt vw (fst (split_vars t)), map \<sigma> (snd (split_vars t)))"
	+proof (induct t)
	+ case (Fun f ts)
	+ have "?case = (Fun f (map (\<lambda>t. t \<cdot> \<sigma>) ts)
	+ =\<^sub>f (MFun f (map (map_vars_mctxt vw \<circ> (fst \<circ> split_vars)) ts), concat (map (map \<sigma> \<circ> (snd \<circ> split_vars)) ts)))"
	+ by (simp add: map_concat)
	+ also have "..."
	+ proof (rule eqf_MFunI, simp, simp, unfold length_map)
	+ fix i
	+ assume i: "i < length ts"
	+ then have mem: "ts ! i \<in> set ts" by auto
	+ show "map (\<lambda>t. t \<cdot> \<sigma>) ts ! i =\<^sub>f (map (map_vars_mctxt vw \<circ> (fst \<circ> split_vars)) ts ! i, map (map \<sigma> \<circ> (snd \<circ> split_vars)) ts ! i)"
	+ using Fun[OF mem] i by auto
	+ qed
	+ finally show ?case by simp
	+qed auto
	+
	+lemma split_vars_eqf_subst: "t \<cdot> \<sigma> =\<^sub>f (fst (split_vars t), (map \<sigma> (snd (split_vars t))))"
	+ using split_vars_eqf_subst_map_vars_term[of t \<sigma> "\<lambda> x. x"] by simp
	+
	+lemma split_vars_fill_holes:
	+ assumes "C = fst (split_vars s)" and "ss = map Var (snd (split_vars s))"
	+ shows "fill_holes C ss = s" using assms
	+ by (metis eqfE(1) split_vars_eqf_subst subst_apply_term_empty)
	+
	+
	+lemma fill_unfill_holes:
	+ assumes "C \<le> mctxt_of_term t"
	+ shows "fill_holes C (unfill_holes C t) = t"
	+ using assms
	+proof (induct C t rule: unfill_holes.induct)
	+ case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
	+ by (auto simp: less_eq_mctxt_def intro!: fill_holes_arbitrary elim!: nth_equalityE)
	+qed (auto simp: less_eq_mctxt_def split: if_splits)
	+
	+
	+lemma hole_poss_list_length:
	+ "length (hole_poss_list D) = num_holes D"
	+ by (induct D) (auto simp: length_concat intro!: nth_sum_listI)
	+
	+lemma unfill_holles_hole_poss_list_length:
	+ assumes "C \<le> mctxt_of_term t"
	+ shows "length (unfill_holes C t) = length (hole_poss_list C)" using assms
	+proof (induct C arbitrary: t)
	+ case (MVar x)
	+ then have [simp]: "t = Var x" by (cases t) (auto dest: less_eq_mctxt_MVarE1)
	+ show ?case by simp
	+next
	+ case (MFun f ts) then show ?case
	+ by (cases t) (auto simp: length_concat comp_def
	+ elim!: less_eq_mctxt_MFunE1 less_eq_mctxt_MVarE1 intro!: nth_sum_listI)
	+qed auto
	+
	+lemma unfill_holes_to_subst_at_hole_poss:
	+ assumes "C \<le> mctxt_of_term t"
	+ shows "unfill_holes C t = map ((\|_) t) (hole_poss_list C)" using assms
	+proof (induct C arbitrary: t)
	+ case (MVar x)
	+ then show ?case by (cases t) (auto elim: less_eq_mctxt_MVarE1)
	+next
	+ case (MFun f ts)
	+ from MFun(2) obtain ss where [simp]: "t = Fun f ss" and l: "length ts = length ss"
	+ by (cases t) (auto elim: less_eq_mctxt_MFunE1)
	+ let ?ts = "map (\<lambda>i. unfill_holes (ts ! i) (ss ! i)) [0..<length ts]"
	+ let ?ss = "map (\<lambda> x. map ((\|_) (Fun f ss)) (case x of (x, y) \<Rightarrow> map ((#) x) (hole_poss_list y))) (zip [0..<length ts] ts)"
	+ have eq_l [simp]: "length (concat ?ts) = length (concat ?ss)" using MFun
	+ by (auto simp: length_concat comp_def elim!: less_eq_mctxt_MFunE1 split!: prod.splits intro!: nth_sum_listI)
	+ {fix i assume ass: "i < length (concat ?ts)"
	+ then have lss: "i < length (concat ?ss)" by auto
	+ obtain m n where [simp]: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
	+ then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass, of ?ss 0] MFun(2)
	+ by (auto simp: unfill_holles_hole_poss_list_length[of "ts ! i" "ss ! i" for i]
	+ simp del: length_unfill_holes elim!: less_eq_mctxt_MFunE1)
	+ from concat_index_split_less_length_concat(2-)[OF ass ] concat_index_split_less_length_concat(2-)[OF lss]
	+ have "concat ?ts ! i = concat ?ss! i" using MFun(1)[OF nth_mem, of m "ss ! m"] MFun(2)
	+ by (auto elim!: less_eq_mctxt_MFunE1)} note nth = this
	+ show ?case using MFun
	+ by (auto simp: comp_def map_concat length_concat
	+ elim!: less_eq_mctxt_MFunE1 split!: prod.splits
	+ intro!: nth_equalityI nth_sum_listI nth)
	+qed auto
	+
	+lemma hole_poss_split_varposs_list_length [simp]:
	+ "length (hole_poss_list (fst (split_vars t))) = length (varposs_list t)"
	+ by (induct t)(auto simp: length_concat comp_def intro!: nth_sum_listI)
	+
	+lemma hole_poss_split_vars_varposs_list:
	+ "hole_poss_list (fst (split_vars t)) = varposs_list t"
	+proof (induct t)
	+ case (Fun f ts)
	+ let ?ts = "poss_args hole_poss_list (map (fst \<circ> split_vars) ts)"
	+ let ?ss = "poss_args varposs_list ts"
	+ have len: "length (concat ?ts) = length (concat ?ss)" "length ?ts = length ?ss"
	+ "\<forall> i < length ?ts. length (?ts ! i) = length (?ss ! i)" by (auto intro: eq_length_concat_nth)
	+ {fix i assume ass: "i < length (concat ?ts)"
	+ then have lss: "i < length (concat ?ss)" using len by auto
	+ obtain m n where int: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
	+ then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass len(2-)] by auto
	+ from concat_index_split_less_length_concat(2-)[OF ass int] concat_index_split_less_length_concat(2-)[OF lss]
	+ have "concat ?ts ! i = concat ?ss! i" using Fun[OF nth_mem, of m] by auto}
	+ then show ?case using len by (auto intro: nth_equalityI)
	+qed auto
	+
	+
	+
	+lemma funas_term_fill_holes_iff: "num_holes C = length ts \<Longrightarrow>
	+ g \<in> funas_term (fill_holes C ts) \<longleftrightarrow> g \<in> funas_mctxt C \<or> (\<exists>t \<in> set ts. g \<in> funas_term t)"
	+proof (induct C ts rule: fill_holes_induct)
	+ case (MFun f Cs ts)
	+ have "(\<exists>i < length Cs. g \<in> funas_term (fill_holes (Cs ! i) (partition_holes (concat (partition_holes ts Cs)) Cs ! i)))
	+ \<longleftrightarrow> (\<exists>C \<in> set Cs. g \<in> funas_mctxt C) \<or> (\<exists>us \<in> set (partition_holes ts Cs). \<exists>t \<in> set us. g \<in> funas_term t)"
	+ using MFun by (auto simp: ex_set_conv_ex_nth) blast
	+ then show ?case by auto
	+qed auto
	+
	+lemma vars_term_fill_holes [simp]:
	+ "num_holes C = length ts \<Longrightarrow> ground_mctxt C \<Longrightarrow>
	+ vars_term (fill_holes C ts) = \<Union>(vars_term ` set ts)"
	+proof (induct C arbitrary: ts)
	+ case MHole
	+ then show ?case by (cases ts) simp_all
	+next
	+ case (MFun f Cs)
	+ then have *: "length (partition_holes ts Cs) = length Cs" by simp
	+ let ?f = "\<lambda>x. \<Union>y \<in> set x. vars_term y"
	+ show ?case
	+ using MFun
	+ unfolding partition_holes_fill_holes_conv
	+ by (simp add: UN_upt_len_conv [OF *, of ?f] UN_set_partition_by)
	+qed simp
	+
	+
	+
	+lemma funas_mctxt_fill_holes [simp]:
	+ assumes "num_holes C = length ts"
	+ shows "funas_term (fill_holes C ts) = funas_mctxt C \<union> \<Union>(set (map funas_term ts))"
	+ using funas_term_fill_holes_iff[OF assms] by auto
	+
	+lemma funas_mctxt_fill_holes_mctxt [simp]:
	+ assumes "num_holes C = length Ds"
	+ shows "funas_mctxt (fill_holes_mctxt C Ds) = funas_mctxt C \<union> \<Union>(set (map funas_mctxt Ds))"
	+ (is "?f C Ds = ?g C Ds")
	+using assms
	+proof (induct C arbitrary: Ds)
	+ case MHole
	+ then show ?case by (cases Ds) simp_all
	+next
	+ case (MFun f Cs)
	+ then have num_holes: "sum_list (map num_holes Cs) = length Ds" by simp
	+ let ?ys = "partition_holes Ds Cs"
	+ have "\<And>i. i < length Cs \<Longrightarrow> ?f (Cs ! i) (?ys ! i) = ?g (Cs ! i) (?ys ! i)"
	+ using MFun by (metis nth_mem num_holes.simps(3) length_partition_holes_nth)
	+ then have "(\<Union>i \<in> {0 ..< length Cs}. ?f (Cs ! i) (?ys ! i)) =
	+ (\<Union>i \<in> {0 ..< length Cs}. ?g (Cs ! i) (?ys ! i))" by simp
	+ then show ?case
	+ using num_holes
	+ unfolding partition_holes_fill_holes_mctxt_conv
	+ by (simp add: UN_Un_distrib UN_upt_len_conv [of _ _ "\<lambda>x. \<Union>(set x)"] UN_set_partition_by_map)
	+qed simp
	+
	+end
	diff --git a/thys/FO_Theory_Rewriting/Util/Saturation.thy b/thys/FO_Theory_Rewriting/Util/Saturation.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Util/Saturation.thy
	@@ -0,0 +1,568 @@
	+theory Saturation
	+ imports Main
	+begin
	+
	+subsection \<open>Set operation closure for idempotent, associative, and commutative functions\<close>
	+
	+lemma inv_to_set:
	+ "(\<forall> i < length ss. ss ! i \<in> S) \<longleftrightarrow> set ss \<subseteq> S"
	+ by (induct ss) (auto simp: nth_Cons split: nat.splits)
	+
	+lemma ac_comp_fun_commute:
	+ assumes "\<And> x y. f x y = f y x" and "\<And> x y z. f x (f y z) = f (f x y) z"
	+ shows "comp_fun_commute f" using assms unfolding comp_fun_commute_def
	+ by (auto simp: comp_def) fastforce
	+
	+lemma (in comp_fun_commute) fold_list_swap:
	+ "fold f xs (fold f ys y) = fold f ys (fold f xs y)"
	+ by (metis comp_fun_commute fold_commute fold_commute_apply)
	+
	+lemma (in comp_fun_commute) foldr_list_swap:
	+ "foldr f xs (foldr f ys y) = foldr f ys (foldr f xs y)"
	+ by (simp add: fold_list_swap foldr_conv_fold)
	+
	+lemma (in comp_fun_commute) foldr_to_fold:
	+ "foldr f xs = fold f xs"
	+ using comp_fun_commute foldr_fold[of _ f]
	+ by (auto simp: comp_def)
	+
	+lemma (in comp_fun_commute) fold_commute_f:
	+ "f x (foldr f xs y) = foldr f xs (f x y)"
	+ using comp_fun_commute unfolding foldr_to_fold
	+ by (auto simp: comp_def intro: fold_commute_apply)
	+
	+lemma closure_sound:
	+ assumes cl: "\<And> s t. s \<in> S \<Longrightarrow> t \<in> S \<Longrightarrow> f s t \<in> S"
	+ and com: "\<And> x y. f x y = f y x" and ass: "\<And> x y z. f x (f y z) = f (f x y) z"
	+ and fin: "set ss \<subseteq> S" "ss \<noteq> []"
	+ shows "fold f (tl ss) (hd ss) \<in> S" using assms(4-)
	+proof (induct ss)
	+ case (Cons s ss) note IS = this show ?case
	+ proof (cases ss)
	+ case Nil
	+ then show ?thesis using IS by auto
	+ next
	+ case (Cons t ts) show ?thesis
	+ using IS assms(1) ac_comp_fun_commute[of f, OF com ass] unfolding Cons
	+ by (auto simp flip: comp_fun_commute.foldr_to_fold) (metis com comp_fun_commute.fold_commute_f)
	+ qed
	+qed auto
	+
	+(* Writing a fold that does not take a base element may simplify the proves *)
	+locale set_closure_oprator =
	+ fixes f
	+ assumes com [ac_simps]: "\<And> x y. f x y = f y x"
	+ and ass [ac_simps]: "\<And> x y z. f x (f y z) = f (f x y) z"
	+ and idem: "\<And> x. f x x = x"
	+
	+sublocale set_closure_oprator \<subseteq> comp_fun_idem
	+ using set_closure_oprator_axioms ac_comp_fun_commute
	+ by (auto simp: comp_fun_idem_def comp_fun_idem_axioms_def comp_def set_closure_oprator_def)
	+
	+context set_closure_oprator
	+begin
	+
	+inductive_set closure for S where
	+ base [simp]: "s \<in> S \<Longrightarrow> s \<in> closure S"
	+\| step [intro]: "s \<in> closure S \<Longrightarrow> t \<in> closure S \<Longrightarrow> f s t \<in> closure S"
	+
	+lemma closure_idem [simp]:
	+ "closure (closure S) = closure S" (is "?LS = ?RS")
	+proof -
	+ {fix s assume "s \<in> ?LS" then have "s \<in> ?RS" by induct auto}
	+ moreover
	+ {fix s assume "s \<in> ?RS" then have "s \<in> ?LS" by induct auto}
	+ ultimately show ?thesis by blast
	+qed
	+
	+lemma fold_dist:
	+ assumes "xs \<noteq> []"
	+ shows "f (fold f (tl xs) (hd xs)) t = fold f xs t" using assms
	+proof (induct xs)
	+ case (Cons a xs)
	+ show ?case using Cons com ass fold_commute_f
	+ by (auto simp: comp_def foldr_to_fold)
	+qed auto
	+
	+lemma closure_to_cons_list:
	+ assumes "s \<in> closure S"
	+ shows "\<exists> ss \<noteq> []. fold f (tl ss) (hd ss) = s \<and> (\<forall> i < length ss. ss ! i \<in> S)" using assms
	+proof (induct)
	+ case (base s) then show ?case by (auto intro: exI[of _ "[s]"])
	+next
	+ case (step s t)
	+ then obtain ss ts where
	+ s: "fold f (tl ss) (hd ss) = s" and inv_s: "ss \<noteq> []" "\<forall> i < length ss. ss ! i \<in> S" and
	+ t: "fold f (tl ts) (hd ts) = t" and inv_t: "ts \<noteq> []" "\<forall> i < length ts. ts ! i \<in> S"
	+ by auto
	+ then show ?case
	+ by (auto simp: fold_dist nth_append intro!: exI[of _ "ss @ ts"]) (metis com fold_dist)
	+qed
	+
	+lemma sound_fold:
	+ assumes "set ss \<subseteq> closure S" and "ss \<noteq> []"
	+ shows "fold f (tl ss) (hd ss) \<in> closure S" using assms
	+ using closure_sound[of "closure S" f] assms step
	+ by (auto simp add: com fun_left_comm)
	+
	+lemma closure_empty [simp]: "closure {} = {}"
	+ using closure_to_cons_list by auto
	+
	+lemma closure_mono:
	+ "S \<subseteq> T \<Longrightarrow> closure S \<subseteq> closure T"
	+proof
	+ fix s assume ass: "s \<in> closure S"
	+ then show "S \<subseteq> T \<Longrightarrow> s \<in> closure T"
	+ by (induct) (auto simp: closure_to_cons_list)
	+qed
	+
	+lemma closure_insert:
	+ "closure (insert x S) = {x} \<union> closure S \<union> {f x s \| s. s \<in> closure S}"
	+proof -
	+ {fix t assume ass: "t \<in> closure (insert x S)" "t \<noteq> x" "t \<notin> closure S"
	+ from closure_to_cons_list[OF ass(1)] obtain ss where
	+ t: "fold f (tl ss) (hd ss) = t" and inv_t: "ss \<noteq> []" "\<forall> i < length ss. ss ! i \<in> insert x S"
	+ by auto
	+ then have mem: "x \<in> set ss" using ass(3) sound_fold[of ss] in_set_conv_nth
	+ by (force simp add: inv_to_set)
	+ have "\<exists> s. t = f x s \<and> s \<in> closure S"
	+ proof (cases "set ss = {x}")
	+ case True then show ?thesis using ass(2) t
	+ by (metis com finite.emptyI fold_dist fold_empty fold_insert_idem fold_set_fold idem inv_t(1))
	+ next
	+ case False
	+ from False inv_t(1) mem obtain ts where split: "insert x (set ts) = set ss" "x \<notin> set ts" "ts \<noteq> []"
	+ by auto (metis False List.finite_set Set.set_insert empty_set finite_insert finite_list)
	+ then have "\<forall> i < length ts. ts ! i \<in> S" using inv_t(2) split unfolding inv_to_set by auto
	+ moreover have "t = f x (Finite_Set.fold f (hd ts) (set (tl ts)))"
	+ using split t inv_t(1)
	+ by (metis List.finite_set com fold_dist fold_insert_idem2 fold_set_fold fun_left_idem idem)
	+ ultimately show ?thesis using sound_fold[OF _ split(3)]
	+ by (auto simp: foldr_to_fold fold_set_fold inv_to_set) force
	+ qed}
	+ then show ?thesis
	+ by (auto simp: fold_set_fold in_mono[OF closure_mono[OF subset_insertI[of S x]]])
	+qed
	+
	+lemma finite_S_finite_closure [intro]:
	+ "finite S \<Longrightarrow> finite (closure S)"
	+ by (induct rule: finite.induct) (auto simp: closure_insert)
	+
	+end
	+
	+locale semilattice_closure_operator =
	+ cl: set_closure_oprator f for f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" +
	+fixes less_eq e
	+assumes neut_fun [simp]:"\<And> x. f e x = x"
	+ and neut_less [simp]: "\<And> x. less_eq e x"
	+ and sup_l: "\<And> x y. less_eq x (f x y)"
	+ and sup_r: "\<And> x y. less_eq y (f x y)"
	+ and upper_bound: "\<And> x y z. less_eq x z \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq (f x y) z"
	+ and trans: "\<And> x y z. less_eq x y \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq x z"
	+ and anti_sym: "\<And> x y. less_eq x y \<Longrightarrow> less_eq y x \<Longrightarrow> x = y"
	+begin
	+
	+lemma unique_neut_elem [simp]:
	+ "f x y = e \<longleftrightarrow> x = e \<and> y = e"
	+ using neut_fun cl.fun_left_idem
	+ by (metis cl.com)
	+
	+abbreviation "closure S \<equiv> cl.closure S"
	+
	+
	+lemma closure_to_cons_listE:
	+ assumes "s \<in> closure S"
	+ obtains ss where "ss \<noteq> []" "fold f ss e = s" "set ss \<subseteq> S"
	+ using cl.closure_to_cons_list[OF assms] cl.fold_dist
	+ by (auto simp: inv_to_set) (metis cl.com neut_fun)
	+
	+lemma sound_fold:
	+ assumes "set ss \<subseteq> closure S" "ss \<noteq> []"
	+ shows "fold f ss e \<in> closure S"
	+ using cl.sound_fold[OF assms] cl.fold_dist[OF assms(2)]
	+ by (metis cl.com neut_fun)
	+
	+abbreviation "supremum S \<equiv> Finite_Set.fold f e S"
	+definition "smaller_subset x S \<equiv> {y. less_eq y x \<and> y \<in> S}"
	+
	+lemma smaller_subset_empty [simp]:
	+ "smaller_subset x {} = {}"
	+ by (auto simp: smaller_subset_def)
	+
	+lemma finite_smaller_subset [simp, intro]:
	+ "finite S \<Longrightarrow> finite (smaller_subset x S)"
	+ by (auto simp: smaller_subset_def)
	+
	+lemma smaller_subset_mono:
	+ "smaller_subset x S \<subseteq> S"
	+ by (auto simp: smaller_subset_def)
	+
	+lemma sound_set_fold:
	+ assumes "set ss \<subseteq> closure S" and "ss \<noteq> []"
	+ shows "supremum (set ss) \<in> closure S"
	+ using sound_fold[OF assms]
	+ by (auto simp: cl.fold_set_fold)
	+
	+lemma supremum_neutral [simp]:
	+ assumes "finite S" and "supremum S = e"
	+ shows "S \<subseteq> {e}" using assms
	+ by (induct) auto
	+
	+lemma supremum_in_closure:
	+ assumes "finite S" and "R \<subseteq> closure S" and "R \<noteq> {}"
	+ shows "supremum R \<in> closure S"
	+proof -
	+ obtain L where [simp]: "R = set L"
	+ using cl.finite_S_finite_closure[OF assms(1)] assms(2) finite_list
	+ by (metis infinite_super)
	+ then show ?thesis using sound_set_fold[of L S] assms
	+ by (cases L) auto
	+qed
	+
	+lemma supremum_sound:
	+ assumes "finite S"
	+ shows "\<And> t. t \<in> S \<Longrightarrow> less_eq t (supremum S)"
	+ using assms sup_l sup_r trans
	+ by induct (auto, blast)
	+
	+lemma supremum_sound_list:
	+ "\<forall> i < length ss. less_eq (ss ! i) (fold f ss e)"
	+ unfolding cl.fold_set_fold[symmetric]
	+ using supremum_sound[of "set ss"]
	+ by auto
	+
	+lemma smaller_subset_insert [simp]:
	+ "less_eq y x \<Longrightarrow> smaller_subset x (insert y S) = insert y (smaller_subset x S)"
	+ "\<not> less_eq y x \<Longrightarrow> smaller_subset x (insert y S) = smaller_subset x S"
	+ by (auto simp: smaller_subset_def)
	+
	+lemma supremum_smaller_subset:
	+ assumes "finite S"
	+ shows "less_eq (supremum (smaller_subset x S)) x" using assms
	+proof (induct)
	+ case (insert y F) then show ?case
	+ by (cases "less_eq y x") (auto simp: upper_bound)
	+qed simp
	+
	+lemma pre_subset_eq_pos_subset [simp]:
	+ shows "smaller_subset x (closure S) = closure (smaller_subset x S)" (is "?LS = ?RS")
	+proof -
	+ {fix s assume "s \<in> ?RS" then have "s \<in> ?LS"
	+ using upper_bound by induct (auto simp: smaller_subset_def)}
	+ moreover
	+ {fix s assume ass: "s \<in> ?LS"
	+ then have "s \<in> closure S" using smaller_subset_mono by auto
	+ then obtain ss where wit: "ss \<noteq> [] \<and> fold f ss e = s \<and> (set ss \<subseteq> S)"
	+ using closure_to_cons_listE by blast
	+ then have "\<forall> i < length ss. less_eq (ss ! i) x"
	+ using supremum_sound[of "set ss"] supremum_smaller_subset[of "set ss" x]
	+ unfolding cl.fold_set_fold[symmetric]
	+ by auto (metis ass local.trans mem_Collect_eq nth_mem smaller_subset_def)
	+ then have "s \<in> ?RS" using wit sound_fold[of ss]
	+ by (auto simp: smaller_subset_def)
	+ (metis (mono_tags, lifting) cl.closure.base inv_to_set mem_Collect_eq)}
	+ ultimately show ?thesis by blast
	+qed
	+
	+
	+lemma supremum_in_smaller_closure:
	+ assumes "finite S"
	+ shows "supremum (smaller_subset x S) \<in> {e} \<union> (closure S)"
	+ using supremum_in_closure[OF assms, of "smaller_subset x S"]
	+ by (metis UnI1 UnI2 cl.closure.base fold_empty singletonI smaller_subset_mono subset_iff)
	+
	+
	+lemma supremum_subset_less_eq:
	+ assumes "finite S" and "R \<subseteq> S"
	+ shows "less_eq (supremum R) (supremum S)" using assms
	+proof (induct arbitrary: R)
	+ case (insert x F)
	+ from insert(1, 2, 4) insert(3)[of "R - {x}"]
	+ have "less_eq (supremum (R - {x})) (f x (supremum F))"
	+ by (metis Diff_subset_conv insert_is_Un local.trans sup_r)
	+ then show ?case using insert(1, 2, 4)
	+ by auto (metis Diff_empty Diff_insert0 cl.fold_rec finite.insertI finite_subset sup_l upper_bound)
	+qed (auto)
	+
	+
	+lemma supremum_smaller_closure [simp]:
	+ assumes "finite S"
	+ shows "supremum (smaller_subset x (closure S)) = supremum (smaller_subset x S)"
	+proof (cases "smaller_subset x S = {}")
	+ case [simp]: True show ?thesis by auto
	+next
	+ case False
	+ have "smaller_subset x S \<subseteq> smaller_subset x (closure S)"
	+ unfolding pre_subset_eq_pos_subset by auto
	+ then have l: "less_eq (supremum (smaller_subset x S)) (supremum (smaller_subset x (closure S)))"
	+ using assms unfolding pre_subset_eq_pos_subset
	+ by (intro supremum_subset_less_eq) auto
	+ from False have "supremum (closure (smaller_subset x S)) \<in> closure S"
	+ using assms cl.closure_mono[OF smaller_subset_mono]
	+ using \<open>smaller_subset x S \<subseteq> smaller_subset x (closure S)\<close>
	+ by (auto simp add: assms intro!: supremum_in_closure)
	+ from closure_to_cons_listE[OF this] obtain ss where
	+ dec : "supremum (smaller_subset x (closure S)) = Finite_Set.fold f e (set ss)"
	+ and inv: "ss \<noteq> []" "set ss \<subseteq> S"
	+ by (auto simp: cl.fold_set_fold) force
	+ then have "set ss \<subseteq> smaller_subset x S"
	+ using supremum_sound[OF assms]
	+ using supremum_smaller_subset[OF assms]
	+ by (auto simp: smaller_subset_def)
	+ (metis List.finite_set assms cl.finite_S_finite_closure dec trans supremum_smaller_subset supremum_sound)
	+ then have "less_eq (supremum (smaller_subset x (closure S))) (supremum (smaller_subset x S))"
	+ using inv assms unfolding dec
	+ by (intro supremum_subset_less_eq) auto
	+ then show ?thesis using l anti_sym
	+ by auto
	+qed
	+
	+end
	+
	+fun lift_f_total where
	+ "lift_f_total P f None _ = None"
	+\| "lift_f_total P f _ None = None"
	+\| "lift_f_total P f (Some s) (Some t) = (if P s t then Some (f s t) else None)"
	+
	+fun lift_less_eq_total where
	+ "lift_less_eq_total f _ None = True"
	+\| "lift_less_eq_total f None _ = False"
	+\| "lift_less_eq_total f (Some s) (Some t) = (f s t)"
	+
	+
	+locale set_closure_partial_oprator =
	+ fixes P f
	+ assumes refl: "\<And> x. P x x"
	+ and sym: "\<And> x y. P x y \<Longrightarrow> P y x"
	+ and dist: "\<And> x y z. P y z \<Longrightarrow> P x (f y z) \<Longrightarrow> P x y"
	+ and assP: "\<And> x y z. P x (f y z) \<Longrightarrow> P y z \<Longrightarrow> P (f x y) z"
	+ and com [ac_simps]: "\<And> x y. P x y \<Longrightarrow> f x y = f y x"
	+ and ass [ac_simps]: "\<And> x y z. P x y \<Longrightarrow> P y z \<Longrightarrow> f x (f y z) = f (f x y) z"
	+ and idem: "\<And> x. f x x = x"
	+begin
	+
	+lemma lift_f_total_com:
	+ "lift_f_total P f x y = lift_f_total P f y x"
	+ using com by (cases x; cases y) (auto simp: sym)
	+
	+lemma lift_f_total_ass:
	+ "lift_f_total P f x (lift_f_total P f y z) = lift_f_total P f (lift_f_total P f x y) z"
	+proof (cases x)
	+ case [simp]: (Some s) show ?thesis
	+ proof (cases y)
	+ case [simp]: (Some t) show ?thesis
	+ proof (cases z)
	+ case [simp]: (Some u) show ?thesis
	+ by (auto simp add: ass dist[of t u s])
	+ (metis com dist assP sym)+
	+ qed auto
	+ qed auto
	+qed auto
	+
	+lemma lift_f_total_idem:
	+ "lift_f_total P f x x = x"
	+ by (cases x) (auto simp: idem refl)
	+
	+lemma lift_f_totalE[elim]:
	+ assumes "lift_f_total P f s u = Some t"
	+ obtains v w where "s = Some v" "u = Some w"
	+ using assms by (cases s; cases u) auto
	+
	+lemma lift_set_closure_oprator:
	+ "set_closure_oprator (lift_f_total P f)"
	+ using lift_f_total_com lift_f_total_ass lift_f_total_idem by unfold_locales blast+
	+
	+end
	+
	+sublocale set_closure_partial_oprator \<subseteq> lift_fun: set_closure_oprator "lift_f_total P f"
	+ by (simp add: lift_set_closure_oprator)
	+
	+
	+context set_closure_partial_oprator begin
	+
	+abbreviation "lift_closure S \<equiv> lift_fun.closure (Some ` S)"
	+
	+inductive_set pred_closure for S where
	+ base [simp]: "s \<in> S \<Longrightarrow> s \<in> pred_closure S"
	+\| step [intro]: "s \<in> pred_closure S \<Longrightarrow> t \<in> pred_closure S \<Longrightarrow> P s t \<Longrightarrow> f s t \<in> pred_closure S"
	+
	+lemma pred_closure_to_some_lift_closure:
	+ assumes "s \<in> pred_closure S"
	+ shows "Some s \<in> lift_closure S" using assms
	+proof (induct)
	+ case (step s t)
	+ then have "lift_f_total P f (Some s) (Some t) \<in> lift_closure S"
	+ by (intro lift_fun.closure.step) auto
	+ then show ?case using step(5)
	+ by (auto split: if_splits)
	+qed auto
	+
	+lemma some_lift_closure_pred_closure:
	+ fixes t defines "s \<equiv> Some t"
	+ assumes "Some t \<in> lift_closure S"
	+ shows "t \<in> pred_closure S" using assms(2)
	+ unfolding assms(1)[symmetric] using assms(1)
	+proof (induct arbitrary: t)
	+ case (step s u)
	+ from step(5) obtain v w where [simp]: "s = Some v" "u = Some w" by auto
	+ show ?case using step by (auto split: if_splits)
	+qed auto
	+
	+lemma pred_closure_lift_closure:
	+ "pred_closure S = the ` (lift_closure S - {None})" (is "?LS = ?RS")
	+proof
	+ {fix s assume "s \<in> ?LS"
	+ from pred_closure_to_some_lift_closure[OF this] have "s \<in> ?RS"
	+ by (metis DiffI empty_iff image_iff insertE option.distinct(1) option.sel)}
	+ then show "?LS \<subseteq> ?RS" by blast
	+next
	+ {fix s assume ass: "s \<in> ?RS"
	+ then have "Some s \<in> lift_closure S"
	+ using option.collapse by fastforce
	+ from some_lift_closure_pred_closure[OF this] have "s \<in> ?LS"
	+ using option.collapse by auto}
	+ then show "?RS \<subseteq> ?LS" by blast
	+qed
	+
	+lemma finite_S_finite_closure [simp, intro]:
	+ "finite S \<Longrightarrow> finite (pred_closure S)"
	+ using finite_subset[of "Some ` pred_closure S" "lift_closure S"]
	+ using pred_closure_to_some_lift_closure lift_fun.finite_S_finite_closure[of "Some ` S"]
	+ by (auto simp add: pred_closure_lift_closure set_closure_partial_oprator_axioms)
	+
	+lemma closure_mono:
	+ assumes "S \<subseteq> T"
	+ shows "pred_closure S \<subseteq> pred_closure T"
	+proof -
	+ have "Some ` S \<subseteq> Some ` T" using assms by auto
	+ from lift_fun.closure_mono[OF this] show ?thesis
	+ using pred_closure_to_some_lift_closure some_lift_closure_pred_closure set_closure_partial_oprator_axioms
	+ by fastforce
	+qed
	+
	+lemma pred_closure_empty [simp]:
	+ "pred_closure {} = {}"
	+ using pred_closure_lift_closure by fastforce
	+end
	+
	+locale semilattice_closure_partial_operator =
	+ cl: set_closure_partial_oprator P f for P and f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" +
	+fixes less_eq e
	+assumes neut_elm :"\<And> x. f e x = x"
	+ and neut_pred: "\<And> x. P e x"
	+ and neut_less: "\<And> x. less_eq e x"
	+ and pred_less: "\<And> x y z. less_eq x y \<Longrightarrow> less_eq z y \<Longrightarrow> P x z"
	+ and sup_l: "\<And> x y. P x y \<Longrightarrow> less_eq x (f x y)"
	+ and sup_r: "\<And> x y. P x y \<Longrightarrow> less_eq y (f x y)"
	+ and upper_bound: "\<And> x y z. less_eq x z \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq (f x y) z"
	+ and trans: "\<And> x y z. less_eq x y \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq x z"
	+ and anti_sym: "\<And> x y. less_eq x y \<Longrightarrow> less_eq y x \<Longrightarrow> x = y"
	+begin
	+
	+abbreviation "lifted_less_eq \<equiv> lift_less_eq_total less_eq"
	+abbreviation "lifted_fun \<equiv> lift_f_total P f"
	+
	+lemma lift_less_eq_None [simp]:
	+ "lifted_less_eq None y \<longleftrightarrow> y = None"
	+ by (cases y) auto
	+
	+lemma lift_less_eq_neut_elm [simp]:
	+ "lifted_fun (Some e) s = s"
	+ using neut_elm neut_pred by (cases s) auto
	+
	+lemma lift_less_eq_neut_less [simp]:
	+ "lifted_less_eq (Some e) s \<longleftrightarrow> True"
	+ using neut_less by (cases s) auto
	+
	+lemma lift_less_eq_sup_l [simp]:
	+ "lifted_less_eq x (lifted_fun x y) \<longleftrightarrow> True"
	+ using sup_l by (cases x; cases y) auto
	+
	+lemma lift_less_eq_sup_r [simp]:
	+ "lifted_less_eq y (lifted_fun x y) \<longleftrightarrow> True"
	+ using sup_r by (cases x; cases y) auto
	+
	+lemma lifted_less_eq_trans [trans]:
	+ "lifted_less_eq x y \<Longrightarrow> lifted_less_eq y z \<Longrightarrow> lifted_less_eq x z"
	+ using trans by (auto elim!: lift_less_eq_total.elims)
	+
	+lemma lifted_less_eq_anti_sym [trans]:
	+ "lifted_less_eq x y \<Longrightarrow> lifted_less_eq y x \<Longrightarrow> x = y"
	+ using anti_sym by (auto elim!: lift_less_eq_total.elims)
	+
	+lemma lifted_less_eq_upper:
	+ "lifted_less_eq x z \<Longrightarrow> lifted_less_eq y z \<Longrightarrow> lifted_less_eq (lifted_fun x y) z"
	+ using upper_bound pred_less by (auto elim!: lift_less_eq_total.elims)
	+
	+lemma semilattice_closure_operator_axioms:
	+ "semilattice_closure_operator_axioms (lift_f_total P f) (lift_less_eq_total less_eq) (Some e)"
	+ using lifted_less_eq_upper lifted_less_eq_trans lifted_less_eq_anti_sym
	+ by unfold_locales (auto elim!: lift_f_total.cases)
	+
	+end
	+
	+sublocale semilattice_closure_partial_operator \<subseteq> lift_ord: semilattice_closure_operator "lift_f_total P f" "lift_less_eq_total less_eq" "Some e"
	+ by (simp add: cl.lift_set_closure_oprator semilattice_closure_operator.intro semilattice_closure_operator_axioms)
	+
	+
	+context semilattice_closure_partial_operator
	+begin
	+
	+abbreviation "supremum \<equiv> lift_ord.supremum"
	+abbreviation "smaller_subset \<equiv> lift_ord.smaller_subset"
	+
	+
	+lemma supremum_impl:
	+ assumes "supremum (set (map Some ss)) = Some t"
	+ shows "foldr f ss e = t" using assms
	+proof (induct ss arbitrary: t)
	+ case (Cons a ss)
	+ then show ?case
	+ by auto (metis cl.lift_f_totalE lift_f_total.simps(3) option.distinct(1) option.sel)
	+qed auto
	+
	+lemma supremum_smaller_exists_unique:
	+ assumes "finite S"
	+ shows "\<exists>! p. supremum (smaller_subset (Some t) (Some ` S)) = Some p" using assms
	+proof (induct)
	+ case (insert x F) show ?case
	+ proof (cases "lifted_less_eq (Some x) (Some t)")
	+ case True
	+ obtain p where wit: "supremum (smaller_subset (Some t) (Some ` F)) = Some p"
	+ using insert by auto
	+ then have pred: "less_eq p t" "less_eq x t" using True insert(1)
	+ using lift_ord.supremum_smaller_subset
	+ by auto (metis finite_imageI lift_less_eq_total.simps(3))
	+ show ?thesis using insert pred wit pred_less
	+ by auto
	+ next
	+ case False then show ?thesis
	+ using insert by auto
	+ qed
	+qed auto
	+
	+lemma supremum_neut_or_in_closure:
	+ assumes "finite S"
	+ shows "the (supremum (smaller_subset (Some t) (Some ` S))) \<in> {e} \<union> cl.pred_closure S"
	+ using supremum_smaller_exists_unique[OF assms]
	+ using lift_ord.supremum_in_smaller_closure[of "Some ` S" "Some t"] assms
	+ by auto (metis cl.some_lift_closure_pred_closure option.sel)
	+
	+end
	+
	+(* At the moment we remove duplicates in each iteration,
	+ use data structure that can deal better with duplication i.e red black trees *)
	+fun closure_impl where
	+ "closure_impl f [] = []"
	+\| "closure_impl f (x # S) = (let cS = closure_impl f S in remdups (x # cS @ map (f x) cS))"
	+
	+lemma (in set_closure_oprator) closure_impl [simp]:
	+ "set (closure_impl f S) = closure (set S)"
	+ by (induct S, auto simp: closure_insert Let_def)
	+
	+lemma (in set_closure_partial_oprator) closure_impl [simp]:
	+ "set (map the (removeAll None (closure_impl (lift_f_total P f) (map Some S)))) = pred_closure (set S)"
	+ using lift_set_closure_oprator set_closure_oprator.closure_impl pred_closure_lift_closure
	+ by auto
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Util/Tree_Automata_Derivation_Split.thy b/thys/FO_Theory_Rewriting/Util/Tree_Automata_Derivation_Split.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Util/Tree_Automata_Derivation_Split.thy
	@@ -0,0 +1,406 @@
	+theory Tree_Automata_Derivation_Split
	+ imports Regular_Tree_Relations.Tree_Automata
	+ Ground_MCtxt
	+begin
	+
	+lemma ta_der'_inf_mctxt:
	+ assumes "t \|\<in>\| ta_der' \<A> s"
	+ shows "fst (split_vars t) \<le> (mctxt_of_term s)" using assms
	+proof (induct s arbitrary: t)
	+ case (Fun f ts) then show ?case
	+ by (cases t) (auto simp: comp_def less_eq_mctxt_prime intro: less_eq_mctxt'.intros)
	+qed (auto simp: ta_der'.simps)
	+
	+lemma ta_der'_poss_subt_at_ta_der':
	+ assumes "t \|\<in>\| ta_der' \<A> s" and "p \<in> poss t"
	+ shows "t \|_ p \|\<in>\| ta_der' \<A> (s \|_ p)" using assms
	+ by (induct s arbitrary: t p) (auto simp: ta_der'.simps, blast+)
	+
	+lemma ta_der'_varposs_to_ta_der:
	+ assumes "t \|\<in>\| ta_der' \<A> s" and "p \<in> varposs t"
	+ shows "the_Var (t \|_ p) \|\<in>\| ta_der \<A> (s \|_ p)" using assms
	+ by (induct s arbitrary: t p) (auto simp: ta_der'.simps, blast+)
	+
	+definition "ta_der'_target_mctxt t \<equiv> fst (split_vars t)"
	+definition "ta_der'_target_args t \<equiv> snd (split_vars t)"
	+definition "ta_der'_source_args t s \<equiv> unfill_holes (fst (split_vars t)) s"
	+
	+lemmas ta_der'_mctxt_simps = ta_der'_target_mctxt_def ta_der'_target_args_def ta_der'_source_args_def
	+
	+lemma ta_der'_target_mctxt_funas [simp]:
	+ "funas_mctxt (ta_der'_target_mctxt u) = funas_term u"
	+ by (auto simp: ta_der'_target_mctxt_def)
	+
	+lemma ta_der'_target_mctxt_ground [simp]:
	+ "ground_mctxt (ta_der'_target_mctxt t)"
	+ by (auto simp: ta_der'_target_mctxt_def)
	+
	+lemma ta_der'_source_args_ground:
	+ "t \|\<in>\| ta_der' \<A> s \<Longrightarrow> ground s \<Longrightarrow> \<forall> u \<in> set (ta_der'_source_args t s). ground u"
	+ by (metis fill_unfill_holes ground_fill_holes length_unfill_holes ta_der'_inf_mctxt ta_der'_mctxt_simps)
	+
	+lemma ta_der'_source_args_term_of_gterm:
	+ "t \|\<in>\| ta_der' \<A> (term_of_gterm s) \<Longrightarrow> \<forall> u \<in> set (ta_der'_source_args t (term_of_gterm s)). ground u"
	+ by (intro ta_der'_source_args_ground) auto
	+
	+lemma ta_der'_source_args_length:
	+ "t \|\<in>\| ta_der' \<A> s \<Longrightarrow> num_holes (ta_der'_target_mctxt t) = length (ta_der'_source_args t s)"
	+ by (auto simp: ta_der'_mctxt_simps ta_der'_inf_mctxt)
	+
	+lemma ta_der'_target_args_length:
	+ "num_holes (ta_der'_target_mctxt t) = length (ta_der'_target_args t)"
	+ by (auto simp: ta_der'_mctxt_simps split_vars_num_holes)
	+
	+lemma ta_der'_target_args_vars_term_conv:
	+ "vars_term t = set (ta_der'_target_args t)"
	+ by (auto simp: ta_der'_target_args_def split_vars_vars_term_list)
	+
	+lemma ta_der'_target_args_vars_term_list_conv:
	+ "ta_der'_target_args t = vars_term_list t"
	+ by (auto simp: ta_der'_target_args_def split_vars_vars_term_list)
	+
	+
	+lemma mctxt_args_ta_der':
	+ assumes "num_holes C = length qs" "num_holes C = length ss"
	+ and "\<forall> i < length ss. qs ! i \|\<in>\| ta_der \<A> (ss ! i)"
	+ shows "(fill_holes C (map Var qs)) \|\<in>\| ta_der' \<A> (fill_holes C ss)" using assms
	+proof (induct rule: fill_holes_induct2)
	+ case MHole then show ?case
	+ by (cases ss; cases qs) (auto simp: ta_der_to_ta_der')
	+next
	+ case (MFun f ts) then show ?case
	+ by (simp add: partition_by_nth_nth(1, 2))
	+qed auto
	+
	+\<comment> \<open>Splitting derivation into multihole context containing the remaining function symbols and
	+ the states, where each state is reached via the automata\<close>
	+lemma ta_der'_mctxt_structure:
	+ assumes "t \|\<in>\| ta_der' \<A> s"
	+ shows "t = fill_holes (ta_der'_target_mctxt t) (map Var (ta_der'_target_args t))" (is "?G1")
	+ "s = fill_holes (ta_der'_target_mctxt t) (ta_der'_source_args t s)" (is "?G2")
	+ "num_holes (ta_der'_target_mctxt t) = length (ta_der'_source_args t s) \<and>
	+ length (ta_der'_source_args t s) = length (ta_der'_target_args t)" (is "?G3")
	+ "i < length (ta_der'_source_args t s) \<Longrightarrow> ta_der'_target_args t ! i \|\<in>\| ta_der \<A> (ta_der'_source_args t s ! i)"
	+proof -
	+ let ?C = "ta_der'_target_mctxt t" let ?ss = "ta_der'_source_args t s"
	+ let ?qs = "ta_der'_target_args t"
	+ have t_split: "?G1" by (auto simp: ta_der'_mctxt_simps split_vars_fill_holes)
	+ have s_split: "?G2" by (auto simp: ta_der'_mctxt_simps ta_der'_inf_mctxt[OF assms]
	+ intro!: fill_unfill_holes[symmetric])
	+ have len: "num_holes ?C = length ?ss" "length ?ss = length ?qs" using assms
	+ by (auto simp: ta_der'_mctxt_simps split_vars_num_holes ta_der'_inf_mctxt)
	+ have "i < length (ta_der'_target_args t) \<Longrightarrow>
	+ ta_der'_target_args t ! i \|\<in>\| ta_der \<A> (ta_der'_source_args t s ! i)" for i
	+ using ta_der'_poss_subt_at_ta_der'[OF assms, of "varposs_list t ! i"]
	+ unfolding ta_der'_mctxt_simps split_vars_vars_term_list length_map
	+ by (auto simp: unfill_holes_to_subst_at_hole_poss[OF ta_der'_inf_mctxt[OF assms]]
	+ simp flip: varposs_list_to_var_term_list[of i t, unfolded varposs_list_var_terms_length])
	+ (metis assms hole_poss_split_vars_varposs_list nth_map nth_mem
	+ ta_der'_varposs_to_ta_der ta_der_to_ta_der' varposs_eq_varposs_list varposs_list_var_terms_length)
	+ then show ?G1 ?G2 ?G3 "i < length (ta_der'_source_args t s) \<Longrightarrow>
	+ ta_der'_target_args t ! i \|\<in>\| ta_der \<A> (ta_der'_source_args t s ! i)" using len t_split s_split
	+ by (simp_all add: ta_der'_mctxt_simps)
	+qed
	+
	+lemma ta_der'_ground_mctxt_structure:
	+ assumes "t \|\<in>\| ta_der' \<A> (term_of_gterm s)"
	+ shows "t = fill_holes (ta_der'_target_mctxt t) (map Var (ta_der'_target_args t))"
	+ "term_of_gterm s = fill_holes (ta_der'_target_mctxt t) (ta_der'_source_args t (term_of_gterm s))"
	+ "num_holes (ta_der'_target_mctxt t) = length (ta_der'_source_args t (term_of_gterm s)) \<and>
	+ length (ta_der'_source_args t (term_of_gterm s)) = length (ta_der'_target_args t)"
	+ "i < length (ta_der'_target_args t) \<Longrightarrow> ta_der'_target_args t ! i \|\<in>\| ta_der \<A> (ta_der'_source_args t (term_of_gterm s) ! i)"
	+ using ta_der'_mctxt_structure[OF assms]
	+ by force+
	+
	+
	+\<comment> \<open>Splitting derivation into context containing the remaining function symbols and state\<close>
	+
	+definition "ta_der'_gctxt t \<equiv> gctxt_of_gmctxt (gmctxt_of_mctxt (fst (split_vars t)))"
	+abbreviation "ta_der'_ctxt t \<equiv> ctxt_of_gctxt (ta_der'_gctxt t)"
	+definition "ta_der'_source_ctxt_arg t s \<equiv> hd (unfill_holes (fst (split_vars t)) s)"
	+
	+abbreviation "ta_der'_source_gctxt_arg t s \<equiv> gterm_of_term (ta_der'_source_ctxt_arg t (term_of_gterm s))"
	+
	+lemma ta_der'_ctxt_structure:
	+ assumes "t \|\<in>\| ta_der' \<A> s" "vars_term_list t = [q]"
	+ shows "t = (ta_der'_ctxt t)\<langle>Var q\<rangle>" (is "?G1")
	+ "s = (ta_der'_ctxt t)\<langle>ta_der'_source_ctxt_arg t s\<rangle>" (is "?G2")
	+ "ground_ctxt (ta_der'_ctxt t)" (is "?G3")
	+ "q \|\<in>\| ta_der \<A> (ta_der'_source_ctxt_arg t s)" (is "?G4")
	+proof -
	+ have *: "length xs = Suc 0 \<Longrightarrow> xs = [hd xs]" for xs
	+ by (metis length_0_conv length_Suc_conv list.sel(1))
	+ have [simp]: "length (snd (split_vars t)) = Suc 0" using assms(2) ta_der'_inf_mctxt[OF assms(1)]
	+ by (auto simp: split_vars_vars_term_list)
	+ have [simp]: "num_gholes (gmctxt_of_mctxt (fst (split_vars t))) = Suc 0" using assms(2)
	+ by (simp add: split_vars_num_holes split_vars_vars_term_list)
	+ have [simp]: "ta_der'_source_args t s = [ta_der'_source_ctxt_arg t s]"
	+ using assms(2) ta_der'_inf_mctxt[OF assms(1)]
	+ by (auto simp: ta_der'_source_args_def ta_der'_source_ctxt_arg_def split_vars_num_holes intro!: *)
	+ have t_split: ?G1 using assms(2)
	+ by (auto simp: ta_der'_gctxt_def split_vars_fill_holes
	+ split_vars_vars_term_list simp flip: ctxt_of_gctxt_gctxt_of_gmctxt_apply)
	+ have s_split: ?G2 using ta_der'_mctxt_structure[OF assms(1)] assms(2)
	+ by (auto simp: ta_der'_gctxt_def ta_der'_target_mctxt_def
	+ simp flip: ctxt_of_gctxt_gctxt_of_gmctxt_apply)
	+ from ta_der'_mctxt_structure[OF assms(1)] have ?G4
	+ by (auto simp: ta_der'_target_args_def assms(2) split_vars_vars_term_list)
	+ moreover have ?G3 unfolding ta_der'_gctxt_def by auto
	+ ultimately show ?G1 ?G2 ?G3 ?G4 using t_split s_split
	+ by force+
	+qed
	+
	+
	+lemma ta_der'_ground_ctxt_structure:
	+ assumes "t \|\<in>\| ta_der' \<A> (term_of_gterm s)" "vars_term_list t = [q]"
	+ shows "t = (ta_der'_ctxt t)\<langle>Var q\<rangle>"
	+ "s = (ta_der'_gctxt t)\<langle>ta_der'_source_gctxt_arg t s\<rangle>\<^sub>G"
	+ "ground (ta_der'_source_ctxt_arg t (term_of_gterm s))"
	+ "q \|\<in>\| ta_der \<A> (ta_der'_source_ctxt_arg t (term_of_gterm s))"
	+ using ta_der'_ctxt_structure[OF assms] term_of_gterm_ctxt_apply
	+ by force+
	+
	+subsection \<open>Sufficient condition for splitting the reachability relation induced by a tree automaton\<close>
	+
	+locale derivation_split =
	+ fixes A :: "('q, 'f) ta" and \<A> and \<B>
	+ assumes rule_split: "rules A = rules \<A> \|\<union>\| rules \<B>"
	+ and eps_split: "eps A = eps \<A> \|\<union>\| eps \<B>"
	+ and B_target_states: "rule_target_states (rules \<B>) \|\<union>\| (snd \|`\| (eps \<B>)) \|\<inter>\|
	+ (rule_arg_states (rules \<A>) \|\<union>\| (fst \|`\| (eps \<A>))) = {\|\|}"
	+begin
	+
	+abbreviation "\<Delta>\<^sub>A \<equiv> rules \<A>"
	+abbreviation "\<Delta>\<^sub>\<E>\<^sub>A \<equiv> eps \<A>"
	+abbreviation "\<Delta>\<^sub>B \<equiv> rules \<B>"
	+abbreviation "\<Delta>\<^sub>\<E>\<^sub>B \<equiv> eps \<B>"
	+
	+abbreviation "\<Q>\<^sub>A \<equiv> \<Q> \<A>"
	+definition "\<Q>\<^sub>B \<equiv> rule_target_states \<Delta>\<^sub>B \|\<union>\| (snd \|`\| \<Delta>\<^sub>\<E>\<^sub>B)"
	+lemmas B_target_states' = B_target_states[folded \<Q>\<^sub>B_def]
	+
	+lemma states_split [simp]: "\<Q> A = \<Q> \<A> \|\<union>\| \<Q> \<B>"
	+ by (auto simp add: \<Q>_def rule_split eps_split)
	+
	+lemma A_args_states_not_B:
	+ "TA_rule f qs q \|\<in>\| \<Delta>\<^sub>A \<Longrightarrow> p \|\<in>\| fset_of_list qs \<Longrightarrow> p \|\<notin>\| \<Q>\<^sub>B"
	+ using B_target_states
	+ by (force simp add: \<Q>\<^sub>B_def)
	+
	+lemma rule_statesD:
	+ "r \|\<in>\| \<Delta>\<^sub>A \<Longrightarrow> r_rhs r \|\<in>\| \<Q>\<^sub>A"
	+ "r \|\<in>\| \<Delta>\<^sub>B \<Longrightarrow> r_rhs r \|\<in>\| \<Q>\<^sub>B"
	+ "r \|\<in>\| \<Delta>\<^sub>A \<Longrightarrow> p \|\<in>\| fset_of_list (r_lhs_states r) \<Longrightarrow> p \|\<in>\| \<Q>\<^sub>A"
	+ "TA_rule f qs q \|\<in>\| \<Delta>\<^sub>A \<Longrightarrow> q \|\<in>\| \<Q>\<^sub>A"
	+ "TA_rule f qs q \|\<in>\| \<Delta>\<^sub>B \<Longrightarrow> q \|\<in>\| \<Q>\<^sub>B"
	+ "TA_rule f qs q \|\<in>\| \<Delta>\<^sub>A \<Longrightarrow> p \|\<in>\| fset_of_list qs \<Longrightarrow> p \|\<in>\| \<Q>\<^sub>A"
	+ by (auto simp: rule_statesD \<Q>\<^sub>B_def rev_fimage_eqI)
	+
	+lemma eps_states_dest:
	+ "(p, q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>A \<Longrightarrow> p \|\<in>\| \<Q>\<^sub>A"
	+ "(p, q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>A \<Longrightarrow> q \|\<in>\| \<Q>\<^sub>A"
	+ "(p, q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>A\|\<^sup>+\| \<Longrightarrow> p \|\<in>\| \<Q>\<^sub>A"
	+ "(p, q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>A\|\<^sup>+\| \<Longrightarrow> q \|\<in>\| \<Q>\<^sub>A"
	+ "(p, q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>B \<Longrightarrow> q \|\<in>\| \<Q>\<^sub>B"
	+ "(p, q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>B\|\<^sup>+\| \<Longrightarrow> q \|\<in>\| \<Q>\<^sub>B"
	+ by (auto simp: eps_dest_all \<Q>\<^sub>B_def rev_fimage_eqI elim: ftranclE)
	+
	+lemma transcl_eps_simp:
	+ "(eps A)\|\<^sup>+\| = \<Delta>\<^sub>\<E>\<^sub>A\|\<^sup>+\| \|\<union>\| \<Delta>\<^sub>\<E>\<^sub>B\|\<^sup>+\| \|\<union>\| (\<Delta>\<^sub>\<E>\<^sub>A\|\<^sup>+\| \|O\| \<Delta>\<^sub>\<E>\<^sub>B\|\<^sup>+\|)"
	+proof -
	+ have "\<Delta>\<^sub>\<E>\<^sub>B \|O\| \<Delta>\<^sub>\<E>\<^sub>A = {\|\|}" using B_target_states'
	+ by (metis eps_states_dest(5) ex_fin_conv fimageI finterI frelcompE fst_conv inf_sup_distrib1 sup_eq_bot_iff)
	+ from ftrancl_Un2_separatorE[OF this] show ?thesis
	+ unfolding eps_split by auto
	+qed
	+
	+lemma B_rule_eps_A_False:
	+ "f qs \<rightarrow> q \|\<in>\| \<Delta>\<^sub>B \<Longrightarrow> (q, p) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>A\|\<^sup>+\| \<Longrightarrow> False"
	+ using B_target_states unfolding \<Q>\<^sub>B_def
	+ by (metis B_target_states' equalsffemptyD fimage_eqI finter_iff fst_conv ftranclD funion_iff local.rule_statesD(5))
	+
	+lemma to_A_rule_set:
	+ assumes "TA_rule f qs q \|\<in>\| rules A" and "q = p \<or> (q, p) \|\<in>\| (eps A)\|\<^sup>+\|" and "p \|\<notin>\| \<Q>\<^sub>B"
	+ shows "TA_rule f qs q \|\<in>\| \<Delta>\<^sub>A" "q = p \<or> (q, p) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>A\|\<^sup>+\|" using assms
	+ unfolding transcl_eps_simp rule_split
	+ by (auto dest: rule_statesD eps_states_dest dest: B_rule_eps_A_False)
	+
	+lemma to_B_rule_set:
	+ assumes "TA_rule f qs q \|\<in>\| rules A" and "q \|\<notin>\| \<Q>\<^sub>A"
	+ shows "TA_rule f qs q \|\<in>\| \<Delta>\<^sub>B" using assms
	+ unfolding transcl_eps_simp rule_split
	+ by (auto dest: rule_statesD eps_states_dest)
	+
	+
	+declare fsubsetI[rule del]
	+lemma ta_der_monos:
	+ "ta_der \<A> t \|\<subseteq>\| ta_der A t" "ta_der \<B> t \|\<subseteq>\| ta_der A t"
	+ by (auto simp: sup.coboundedI1 rule_split eps_split intro!: ta_der_mono)
	+declare fsubsetI[intro!]
	+
	+
	+lemma ta_der_from_\<Delta>\<^sub>A:
	+ assumes "q \|\<in>\| ta_der A (term_of_gterm t)" and "q \|\<notin>\| \<Q>\<^sub>B"
	+ shows "q \|\<in>\| ta_der \<A> (term_of_gterm t)" using assms
	+proof (induct rule: ta_der_gterm_induct)
	+ case (GFun f ts ps p q)
	+ have "i < length ts \<Longrightarrow> ps ! i \|\<notin>\| \<Q>\<^sub>B" for i using GFun A_args_states_not_B
	+ by (metis fnth_mem to_A_rule_set(1))
	+ then show ?case using GFun(2, 5) to_A_rule_set[OF GFun(1, 3, 6)]
	+ by (auto simp: transcl_eps_simp)
	+qed
	+
	+lemma ta_state:
	+ assumes "q \|\<in>\| ta_der A (term_of_gterm s)"
	+ shows "q \|\<in>\| \<Q>\<^sub>A \<or> q \|\<in>\| \<Q>\<^sub>B" using assms
	+ by (cases s) (auto simp: rule_split transcl_eps_simp dest: rule_statesD eps_states_dest)
	+
	+(* Main lemmas *)
	+
	+lemma ta_der_split:
	+ assumes "q \|\<in>\| ta_der A (term_of_gterm s)" and "q \|\<in>\| \<Q>\<^sub>B"
	+ shows "\<exists> t. t \|\<in>\| ta_der' \<A> (term_of_gterm s) \<and> q \|\<in>\| ta_der \<B> t"
	+ (is "\<exists>t . ?P s q t") using assms
	+proof (induct rule: ta_der_gterm_induct)
	+ case (GFun f ts ps p q)
	+ {fix i assume ass: "i < length ts"
	+ then have "\<exists> t. t \|\<in>\| ta_der' \<A> (term_of_gterm (ts ! i)) \<and> ps ! i \|\<in>\| ta_der \<B> t"
	+ proof (cases "ps ! i \|\<notin>\| \<Q>\<^sub>B")
	+ case True then show ?thesis
	+ using ta_state GFun(2, 4) ta_der_from_\<Delta>\<^sub>A[of "ps ! i" "ts ! i"] ass
	+ by (intro exI[of _ "Var (ps ! i)"]) (auto simp: ta_der_to_ta_der' \<Q>\<^sub>B_def)
	+ next
	+ case False
	+ then have "ps ! i \|\<in>\| \<Q>\<^sub>B" using ta_state[OF GFun(4)[OF ass]]
	+ by auto
	+ from GFun(5)[OF ass this] show ?thesis .
	+ qed}
	+ then obtain h where IH:
	+ "\<forall> i < length ts. h i \|\<in>\| ta_der' \<A> (term_of_gterm (ts ! i))"
	+ "\<forall> i < length ts. ps ! i \|\<in>\| ta_der \<B> (h i)"
	+ using GFun(1 - 4) choice_nat[of "length ts" "\<lambda> t i. ?P (ts ! i) (ps ! i) t"]
	+ by blast
	+ from GFun(1) consider (A) "f ps \<rightarrow> p \|\<in>\| \<Delta>\<^sub>A" \| (B) "f ps \<rightarrow> p \|\<in>\| \<Delta>\<^sub>B" by (auto simp: rule_split)
	+ then show ?case
	+ proof cases
	+ case A then obtain q' where eps_sp: "p = q' \<or> (p, q') \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>A\|\<^sup>+\|"
	+ "q' = q \<or> (q', q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>B\|\<^sup>+\|" using GFun(3, 6)
	+ by (auto simp: transcl_eps_simp dest: eps_states_dest)
	+ from GFun(4)[THEN ta_der_from_\<Delta>\<^sub>A] A GFun(2, 4)
	+ have reach_fst: "p \|\<in>\| ta_der \<A> (term_of_gterm (GFun f ts))"
	+ using A_args_states_not_B by auto
	+ then have "q' \|\<in>\| ta_der \<A> (term_of_gterm (GFun f ts))" using eps_sp
	+ by (meson ta_der_trancl_eps)
	+ then show ?thesis using eps_sp(2)
	+ by (intro exI[of _ "Var q'"]) (auto simp flip: ta_der_to_ta_der' simp del: ta_der'_simps)
	+ next
	+ case B
	+ then have "p = q \<or> (p, q) \|\<in>\| \<Delta>\<^sub>\<E>\<^sub>B\|\<^sup>+\|" using GFun(3)
	+ by (auto simp: transcl_eps_simp dest: B_rule_eps_A_False)
	+ then show ?thesis using GFun(2, 4, 6) IH B
	+ by (auto intro!: exI[of _ "Fun f (map h [0 ..< length ts])"] exI[of _ ps])
	+ qed
	+qed
	+
	+
	+lemma ta_der'_split:
	+ assumes "t \|\<in>\| ta_der' A (term_of_gterm s)"
	+ shows "\<exists> u. u \|\<in>\| ta_der' \<A> (term_of_gterm s) \<and> t \|\<in>\| ta_der' \<B> u"
	+ (is "\<exists> u. ?P s t u") using assms
	+proof (induct s arbitrary: t)
	+ case (GFun f ts) show ?case
	+ proof (cases t)
	+ case [simp]: (Var q)
	+ have "q \|\<in>\| ta_der A (term_of_gterm (GFun f ts))" using GFun(2)
	+ by (auto simp flip: ta_der_to_ta_der')
	+ from ta_der_split[OF this] ta_der_from_\<Delta>\<^sub>A[OF this] ta_state[OF this]
	+ show ?thesis unfolding Var
	+ by (metis ta_der'_refl ta_der_to_ta_der')
	+ next
	+ case [simp]: (Fun g ss)
	+ obtain h where IH:
	+ "\<forall> i < length ts. h i \|\<in>\| ta_der' \<A> (term_of_gterm (ts ! i))"
	+ "\<forall> i < length ts. ss ! i \|\<in>\| ta_der' \<B> (h i)"
	+ using GFun choice_nat[of "length ts" "\<lambda> t i. ?P (ts ! i) (ss ! i) t"]
	+ by auto
	+ then show ?thesis using GFun(2)
	+ by (auto intro!: exI[of _ "Fun f (map h [0..<length ts])"])
	+ qed
	+qed
	+
	+(* TODO rewrite using ta_der'_mctxt_structure *)
	+lemma ta_der_to_mcxtx:
	+ assumes "q \|\<in>\| ta_der A (term_of_gterm s)" and "q \|\<in>\| \<Q>\<^sub>B"
	+ shows "\<exists> C ss qs. length qs = length ss \<and> num_holes C = length ss \<and>
	+ (\<forall> i < length ss. qs ! i \|\<in>\| ta_der \<A> (term_of_gterm (ss ! i))) \<and>
	+ q \|\<in>\| ta_der \<B> (fill_holes C (map Var qs)) \<and>
	+ ground_mctxt C \<and> fill_holes C (map term_of_gterm ss) = term_of_gterm s"
	+ (is "\<exists>C ss qs. ?P s q C ss qs")
	+proof -
	+ from ta_der_split[OF assms] obtain t where
	+ wit: "t \|\<in>\| ta_der' \<A> (term_of_gterm s)" "q \|\<in>\| ta_der \<B> t" by auto
	+ let ?C = "fst (split_vars t)" let ?ss = "map (gsubt_at s) (varposs_list t)"
	+ let ?qs = "snd (split_vars t)"
	+ have poss [simp]:"i < length (varposs_list t) \<Longrightarrow> varposs_list t ! i \<in> gposs s" for i
	+ by (metis nth_mem ta_der'_poss[OF wit(1)] poss_gposs_conv subset_eq varposs_eq_varposs_list
	+ varposs_imp_poss varposs_list_var_terms_length)
	+ have len: "num_holes ?C = length ?ss" "length ?ss = length ?qs"
	+ by (simp_all add: split_vars_num_holes split_vars_vars_term_list varposs_list_var_terms_length)
	+ from unfill_holes_to_subst_at_hole_poss[OF ta_der'_inf_mctxt[OF wit(1)]]
	+ have "unfill_holes (fst (split_vars t)) (term_of_gterm s) = map (term_of_gterm \<circ> gsubt_at s) (varposs_list t)"
	+ by (auto simp: comp_def hole_poss_split_vars_varposs_list
	+ dest: in_set_idx intro!: nth_equalityI term_of_gterm_gsubt)
	+ from fill_unfill_holes[OF ta_der'_inf_mctxt[OF wit(1)]] this
	+ have rep: "fill_holes ?C (map term_of_gterm ?ss) = term_of_gterm s"
	+ by simp
	+ have reach_int: "i < length ?ss \<Longrightarrow> ?qs ! i \|\<in>\| ta_der \<A> (term_of_gterm (?ss ! i))" for i
	+ using wit(1) ta_der'_varposs_to_ta_der
	+ unfolding split_vars_vars_term_list length_map
	+ unfolding varposs_list_to_var_term_list[symmetric]
	+ by (metis nth_map nth_mem poss term_of_gterm_gsubt varposs_eq_varposs_list)
	+ have reach_end: "q \|\<in>\| ta_der \<B> (fill_holes ?C (map Var ?qs))" using wit
	+ using split_vars_fill_holes[of ?C t "map Var ?qs"]
	+ by auto
	+ show ?thesis using len rep reach_end reach_int
	+ by (metis split_vars_ground')
	+qed
	+
	+lemma ta_der_to_gmcxtx:
	+ assumes "q \|\<in>\| ta_der A (term_of_gterm s)" and "q \|\<in>\| \<Q>\<^sub>B"
	+ shows "\<exists> C ss qs qs'. length qs' = length qs \<and> length qs = length ss \<and> num_gholes C = length ss \<and>
	+ (\<forall> i < length ss. qs ! i \|\<in>\| ta_der \<A> (term_of_gterm (ss ! i))) \<and>
	+ q \|\<in>\| ta_der \<B> (fill_holes (mctxt_of_gmctxt C) (map Var qs')) \<and>
	+ fill_gholes C ss = s"
	+ using ta_der_to_mcxtx[OF assms]
	+ by (metis gmctxt_of_mctxt_inv ground_gmctxt_of_gterm_of_term num_gholes_gmctxt_of_mctxt term_of_gterm_inv)
	+
	+(* Reconstuction *)
	+
	+lemma mctxt_const_to_ta_der:
	+ assumes "num_holes C = length ss" "length ss = length qs"
	+ and "\<forall> i < length qs. qs ! i \|\<in>\| ta_der \<A> (ss ! i)"
	+ and "q \|\<in>\| ta_der \<B> (fill_holes C (map Var qs))"
	+ shows "q \|\<in>\| ta_der A (fill_holes C ss)"
	+proof -
	+ have mid: "fill_holes C (map Var qs) \|\<in>\| ta_der' A (fill_holes C ss)"
	+ using assms(1 - 3) ta_der_monos(1)
	+ by (intro mctxt_args_ta_der') auto
	+ then show ?thesis using assms(1, 2) ta_der_monos(2)[THEN fsubsetD, OF assms(4)]
	+ using ta_der'_trans
	+ by (simp add: ta_der'_ta_der)
	+qed
	+
	+lemma ctxt_const_to_ta_der:
	+ assumes "q \|\<in>\| ta_der \<A> s"
	+ and "p \|\<in>\| ta_der \<B> C\<langle>Var q\<rangle>"
	+ shows "p \|\<in>\| ta_der A C\<langle>s\<rangle>" using assms
	+ by (meson fin_mono ta_der_ctxt ta_der_monos(1) ta_der_monos(2))
	+
	+lemma gctxt_const_to_ta_der:
	+ assumes "q \|\<in>\| ta_der \<A> (term_of_gterm s)"
	+ and "p \|\<in>\| ta_der \<B> (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
	+ shows "p \|\<in>\| ta_der A (term_of_gterm C\<langle>s\<rangle>\<^sub>G)" using assms
	+ by (metis ctxt_const_to_ta_der ctxt_of_gctxt_inv ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply_gterm)
	+
	+end
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/Util/Utils.thy b/thys/FO_Theory_Rewriting/Util/Utils.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/Util/Utils.thy
	@@ -0,0 +1,536 @@
	+theory Utils
	+ imports Regular_Tree_Relations.Term_Context
	+ Regular_Tree_Relations.FSet_Utils
	+begin
	+
	+subsection \<open>Misc\<close>
	+
	+definition "funas_trs \<R> = \<Union> ((\<lambda> (s, t). funas_term s \<union> funas_term t) ` \<R>)"
	+
	+fun linear_term :: "('f, 'v) term \<Rightarrow> bool" where
	+ "linear_term (Var _) = True" \|
	+ "linear_term (Fun _ ts) = (is_partition (map vars_term ts) \<and> (\<forall>t\<in>set ts. linear_term t))"
	+
	+fun vars_term_list :: "('f, 'v) term \<Rightarrow> 'v list" where
	+ "vars_term_list (Var x) = [x]" \|
	+ "vars_term_list (Fun _ ts) = concat (map vars_term_list ts)"
	+
	+fun varposs :: "('f, 'v) term \<Rightarrow> pos set" where
	+ "varposs (Var x) = {[]}" \|
	+ "varposs (Fun f ts) = (\<Union>i<length ts. {i # p \| p. p \<in> varposs (ts ! i)})"
	+
	+abbreviation "poss_args f ts \<equiv> map2 (\<lambda> i t. map ((#) i) (f t)) ([0 ..< length ts]) ts"
	+
	+fun varposs_list :: "('f, 'v) term \<Rightarrow> pos list" where
	+ "varposs_list (Var x) = [[]]" \|
	+ "varposs_list (Fun f ts) = concat (poss_args varposs_list ts)"
	+
	+fun concat_index_split where
	+ "concat_index_split (o_idx, i_idx) (x # xs) =
	+ (if i_idx < length x
	+ then (o_idx, i_idx)
	+ else concat_index_split (Suc o_idx, i_idx - length x) xs)"
	+
	+inductive_set trancl_list for \<R> where
	+ base[intro, Pure.intro] : "length xs = length ys \<Longrightarrow>
	+ (\<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>) \<Longrightarrow> (xs, ys) \<in> trancl_list \<R>"
	+\| list_trancl [Pure.intro]: "(xs, ys) \<in> trancl_list \<R> \<Longrightarrow> i < length ys \<Longrightarrow> (ys ! i, z) \<in> \<R> \<Longrightarrow>
	+ (xs, ys[i := z]) \<in> trancl_list \<R>"
	+
	+
	+lemma sorted_append_bigger:
	+ "sorted xs \<Longrightarrow> \<forall>x \<in> set xs. x \<le> y \<Longrightarrow> sorted (xs @ [y])"
	+proof (induct xs)
	+ case Nil
	+ then show ?case by simp
	+next
	+ case (Cons x xs)
	+ then have s: "sorted xs" by (cases xs) simp_all
	+ from Cons have a: "\<forall>x\<in>set xs. x \<le> y" by simp
	+ from Cons(1)[OF s a] Cons(2-) show ?case by (cases xs) simp_all
	+qed
	+
	+lemma find_SomeD:
	+ "List.find P xs = Some x \<Longrightarrow> P x"
	+ "List.find P xs = Some x \<Longrightarrow> x\<in>set xs"
	+ by (auto simp add: find_Some_iff)
	+
	+lemma sum_list_replicate_length' [simp]:
	+ "sum_list (replicate n (Suc 0)) = n"
	+ by (induct n) simp_all
	+
	+lemma arg_subteq [simp]:
	+ assumes "t \<in> set ts" shows "Fun f ts \<unrhd> t"
	+ using assms by auto
	+
	+lemma finite_funas_term: "finite (funas_term s)"
	+ by (induct s) auto
	+
	+lemma finite_funas_trs:
	+ "finite \<R> \<Longrightarrow> finite (funas_trs \<R>)"
	+ by (induct rule: finite.induct) (auto simp: finite_funas_term funas_trs_def)
	+
	+fun subterms where
	+ "subterms (Var x) = {Var x}"\|
	+ "subterms (Fun f ts) = {Fun f ts} \<union> (\<Union> (subterms ` set ts))"
	+
	+lemma finite_subterms_fun: "finite (subterms s)"
	+ by (induct s) auto
	+
	+lemma subterms_supteq_conv: "t \<in> subterms s \<longleftrightarrow> s \<unrhd> t"
	+ by (induct s) (auto elim: supteq.cases)
	+
	+lemma set_all_subteq_subterms:
	+ "subterms s = {t. s \<unrhd> t}"
	+ using subterms_supteq_conv by auto
	+
	+lemma finite_subterms: "finite {t. s \<unrhd> t}"
	+ unfolding set_all_subteq_subterms[symmetric]
	+ by (simp add: finite_subterms_fun)
	+
	+lemma finite_strict_subterms: "finite {t. s \<rhd> t}"
	+ by (intro finite_subset[OF _ finite_subterms]) auto
	+
	+lemma finite_UN_I2:
	+ "finite A \<Longrightarrow> (\<forall> B \<in> A. finite B) \<Longrightarrow> finite (\<Union> A)"
	+ by blast
	+
	+lemma root_substerms_funas_term:
	+ "the ` (root ` (subterms s) - {None}) = funas_term s" (is "?Ls = ?Rs")
	+proof -
	+ thm subterms.induct
	+ {fix x assume "x \<in> ?Ls" then have "x \<in> ?Rs"
	+ proof (induct s arbitrary: x)
	+ case (Fun f ts)
	+ then show ?case
	+ by auto (metis DiffI Fun.hyps imageI option.distinct(1) singletonD)
	+ qed auto}
	+ moreover
	+ {fix g assume "g \<in> ?Rs" then have "g \<in> ?Ls"
	+ proof (induct s arbitrary: g)
	+ case (Fun f ts)
	+ from Fun(2) consider "g = (f, length ts)" \| "\<exists> t \<in> set ts. g \<in> funas_term t"
	+ by (force simp: in_set_conv_nth)
	+ then show ?case
	+ proof cases
	+ case 1 then show ?thesis
	+ by (auto simp: image_iff intro: bexI[of _ "Some (f, length ts)"])
	+ next
	+ case 2
	+ then obtain t where wit: "t \<in> set ts" "g \<in> funas_term t" by blast
	+ have "g \<in> the ` (root ` subterms t - {None})" using Fun(1)[OF wit] .
	+ then show ?thesis using wit(1)
	+ by (auto simp: image_iff)
	+ qed
	+ qed auto}
	+ ultimately show ?thesis by auto
	+qed
	+
	+lemma root_substerms_funas_term_set:
	+ "the ` (root ` \<Union> (subterms ` R) - {None}) = \<Union> (funas_term ` R)"
	+ using root_substerms_funas_term
	+ by auto (smt DiffE DiffI UN_I image_iff)
	+
	+
	+lemma subst_merge:
	+ assumes part: "is_partition (map vars_term ts)"
	+ shows "\<exists>\<sigma>. \<forall>i<length ts. \<forall>x\<in>vars_term (ts ! i). \<sigma> x = \<tau> i x"
	+proof -
	+ let ?\<tau> = "map \<tau> [0 ..< length ts]"
	+ let ?\<sigma> = "fun_merge ?\<tau> (map vars_term ts)"
	+ show ?thesis
	+ by (rule exI[of _ ?\<sigma>], intro allI impI ballI,
	+ insert fun_merge_part[OF part, of _ _ ?\<tau>], auto)
	+qed
	+
	+
	+lemma rel_comp_empty_trancl_simp: "R O R = {} \<Longrightarrow> R\<^sup>+ = R"
	+ by (metis O_assoc relcomp_empty2 sup_bot_right trancl_unfold trancl_unfold_right)
	+
	+lemma choice_nat:
	+ assumes "\<forall>i<n. \<exists>x. P x i"
	+ shows "\<exists>f. \<forall>x<n. P (f x) x" using assms
	+proof -
	+ from assms have "\<forall> i. \<exists> x. i < n \<longrightarrow> P x i" by simp
	+ from choice[OF this] show ?thesis by auto
	+qed
	+
	+
	+lemma subseteq_set_conv_nth:
	+ "(\<forall> i < length ss. ss ! i \<in> T) \<longleftrightarrow> set ss \<subseteq> T"
	+ by (metis in_set_conv_nth subset_code(1))
	+
	+lemma singelton_trancl [simp]: "{a}\<^sup>+ = {a}"
	+ using tranclD tranclD2 by fastforce
	+
	+context
	+includes fset.lifting
	+begin
	+lemmas frelcomp_empty_ftrancl_simp = rel_comp_empty_trancl_simp [Transfer.transferred]
	+lemmas in_fset_idx = in_set_idx [Transfer.transferred]
	+lemmas fsubseteq_fset_conv_nth = subseteq_set_conv_nth [Transfer.transferred]
	+lemmas singelton_ftrancl [simp] = singelton_trancl [Transfer.transferred]
	+end
	+
	+lemma set_take_nth:
	+ assumes "x \<in> set (take i xs)"
	+ shows "\<exists> j < length xs. j < i \<and> xs ! j = x" using assms
	+ by (metis in_set_conv_nth length_take min_less_iff_conj nth_take)
	+
	+lemma nth_sum_listI:
	+ assumes "length xs = length ys"
	+ and "\<forall> i < length xs. xs ! i = ys ! i"
	+ shows "sum_list xs = sum_list ys"
	+ using assms nth_equalityI by blast
	+
	+lemma concat_nth_length:
	+ "i < length uss \<Longrightarrow> j < length (uss ! i) \<Longrightarrow>
	+ sum_list (map length (take i uss)) + j < length (concat uss)"
	+by (induct uss arbitrary: i j) (simp, case_tac i, auto)
	+
	+lemma sum_list_1_E [elim]:
	+ assumes "sum_list xs = Suc 0"
	+ obtains i where "i < length xs" "xs ! i = Suc 0" "\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j = 0"
	+proof -
	+ have "\<exists> i < length xs. xs ! i = Suc 0 \<and> (\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j = 0)" using assms
	+ proof (induct xs)
	+ case (Cons a xs) show ?case
	+ proof (cases a)
	+ case [simp]: 0
	+ obtain i where "i < length xs" "xs ! i = Suc 0" "(\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j = 0)"
	+ using Cons by auto
	+ then show ?thesis using less_Suc_eq_0_disj
	+ by (intro exI[of _ "Suc i"]) auto
	+ next
	+ case (Suc nat) then show ?thesis using Cons by auto
	+ qed
	+ qed auto
	+ then show " (\<And>i. i < length xs \<Longrightarrow> xs ! i = Suc 0 \<Longrightarrow> \<forall>j<length xs. j \<noteq> i \<longrightarrow> xs ! j = 0 \<Longrightarrow> thesis) \<Longrightarrow> thesis"
	+ by blast
	+qed
	+
	+
	+lemma nth_equalityE:
	+ "xs = ys \<Longrightarrow> (length xs = length ys \<Longrightarrow> (\<And>i. i < length xs \<Longrightarrow> xs ! i = ys ! i) \<Longrightarrow> P) \<Longrightarrow> P"
	+ by simp
	+
	+lemma map_cons_presv_distinct:
	+ "distinct t \<Longrightarrow> distinct (map ((#) i) t)"
	+ by (simp add: distinct_conv_nth)
	+
	+lemma concat_nth_nthI:
	+ assumes "length ss = length ts" "\<forall> i < length ts. length (ss ! i) = length (ts ! i)"
	+ and "\<forall> i < length ts. \<forall> j < length (ts ! i). P (ss ! i ! j) (ts ! i ! j)"
	+ shows "\<forall> i < length (concat ts). P (concat ss ! i) (concat ts ! i)"
	+ using assms by (metis nth_concat_two_lists)
	+
	+
	+lemma last_nthI:
	+ assumes "i < length ts" "\<not> i < length ts - Suc 0"
	+ shows "ts ! i = last ts" using assms
	+ by (induct ts arbitrary: i)
	+ (auto, metis last_conv_nth length_0_conv less_antisym nth_Cons')
	+
	+(* induction scheme for transitive closures of lists *)
	+lemma trancl_list_appendI [simp, intro]:
	+ "(xs, ys) \<in> trancl_list \<R> \<Longrightarrow> (x, y) \<in> \<R> \<Longrightarrow> (x # xs, y # ys) \<in> trancl_list \<R>"
	+proof (induct rule: trancl_list.induct)
	+ case (base xs ys)
	+ then show ?case using less_Suc_eq_0_disj
	+ by (intro trancl_list.base) auto
	+next
	+ case (list_trancl xs ys i z)
	+ from list_trancl(3) have *: "y # ys[i := z] = (y # ys)[Suc i := z]" by auto
	+ show ?case using list_trancl unfolding *
	+ by (intro trancl_list.list_trancl) auto
	+qed
	+
	+lemma trancl_list_append_tranclI [intro]:
	+ "(x, y) \<in> \<R>\<^sup>+ \<Longrightarrow> (xs, ys) \<in> trancl_list \<R> \<Longrightarrow> (x # xs, y # ys) \<in> trancl_list \<R>"
	+proof (induct rule: trancl.induct)
	+ case (trancl_into_trancl a b c)
	+ then have "(a # xs, b # ys) \<in> trancl_list \<R>" by auto
	+ from trancl_list.list_trancl[OF this, of 0 c]
	+ show ?case using trancl_into_trancl(3)
	+ by auto
	+qed auto
	+
	+lemma trancl_list_conv:
	+ "(xs, ys) \<in> trancl_list \<R> \<longleftrightarrow> length xs = length ys \<and> (\<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>\<^sup>+)" (is "?Ls \<longleftrightarrow> ?Rs")
	+proof
	+ assume "?Ls" then show ?Rs
	+ proof (induct)
	+ case (list_trancl xs ys i z)
	+ then show ?case
	+ by auto (metis nth_list_update trancl.trancl_into_trancl)
	+ qed auto
	+next
	+ assume ?Rs then show ?Ls
	+ proof (induct ys arbitrary: xs)
	+ case Nil
	+ then show ?case by (cases xs) auto
	+ next
	+ case (Cons y ys)
	+ from Cons(2) obtain x xs' where *: "xs = x # xs'" and
	+ inv: "(x, y) \<in> \<R>\<^sup>+"
	+ by (cases xs) auto
	+ show ?case using Cons(1)[of "tl xs"] Cons(2) unfolding *
	+ by (intro trancl_list_append_tranclI[OF inv]) force
	+ qed
	+qed
	+
	+lemma trancl_list_induct [consumes 2, case_names base step]:
	+ assumes "length ss = length ts" "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>\<^sup>+"
	+ and "\<And>xs ys. length xs = length ys \<Longrightarrow> \<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R> \<Longrightarrow> P xs ys"
	+ and "\<And>xs ys i z. length xs = length ys \<Longrightarrow> \<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>\<^sup>+ \<Longrightarrow> P xs ys
	+ \<Longrightarrow> i < length ys \<Longrightarrow> (ys ! i, z) \<in> \<R> \<Longrightarrow> P xs (ys[i := z])"
	+ shows "P ss ts" using assms
	+ by (intro trancl_list.induct[of ss ts \<R> P]) (auto simp: trancl_list_conv)
	+
	+
	+lemma swap_trancl:
	+ "(prod.swap ` R)\<^sup>+ = prod.swap ` (R\<^sup>+)"
	+proof -
	+ have [simp]: "prod.swap ` X = X\<inverse>" for X by auto
	+ show ?thesis by (simp add: trancl_converse)
	+qed
	+
	+lemma swap_rtrancl:
	+ "(prod.swap ` R)\<^sup>* = prod.swap ` (R\<^sup>*)"
	+proof -
	+ have [simp]: "prod.swap ` X = X\<inverse>" for X by auto
	+ show ?thesis by (simp add: rtrancl_converse)
	+qed
	+
	+lemma Restr_simps:
	+ "R \<subseteq> X \<times> X \<Longrightarrow> Restr (R\<^sup>+) X = R\<^sup>+"
	+ "R \<subseteq> X \<times> X \<Longrightarrow> Restr Id X O R = R"
	+ "R \<subseteq> X \<times> X \<Longrightarrow> R O Restr Id X = R"
	+ "R \<subseteq> X \<times> X \<Longrightarrow> S \<subseteq> X \<times> X \<Longrightarrow> Restr (R O S) X = R O S"
	+ "R \<subseteq> X \<times> X \<Longrightarrow> R\<^sup>+ \<subseteq> X \<times> X"
	+ subgoal using trancl_mono_set[of R "X \<times> X"] by (auto simp: trancl_full_on)
	+ subgoal by auto
	+ subgoal by auto
	+ subgoal by auto
	+ subgoal using trancl_subset_Sigma .
	+ done
	+
	+lemma Restr_tracl_comp_simps:
	+ "\<R> \<subseteq> X \<times> X \<Longrightarrow> \<L> \<subseteq> X \<times> X \<Longrightarrow> \<L>\<^sup>+ O \<R> \<subseteq> X \<times> X"
	+ "\<R> \<subseteq> X \<times> X \<Longrightarrow> \<L> \<subseteq> X \<times> X \<Longrightarrow> \<L> O \<R>\<^sup>+ \<subseteq> X \<times> X"
	+ "\<R> \<subseteq> X \<times> X \<Longrightarrow> \<L> \<subseteq> X \<times> X \<Longrightarrow> \<L>\<^sup>+ O \<R> O \<L>\<^sup>+ \<subseteq> X \<times> X"
	+ by (auto dest: subsetD[OF Restr_simps(5)[of \<L>]] subsetD[OF Restr_simps(5)[of \<R>]])
	+
	+
	+text \<open>Conversions of the Nth function between lists and a spliting of the list into lists of lists\<close>
	+
	+lemma concat_index_split_mono_first_arg:
	+ "i < length (concat xs) \<Longrightarrow> o_idx \<le> fst (concat_index_split (o_idx, i) xs)"
	+ by (induct xs arbitrary: o_idx i) (auto, metis Suc_leD add_diff_inverse_nat nat_add_left_cancel_less)
	+
	+lemma concat_index_split_sound_fst_arg_aux:
	+ "i < length (concat xs) \<Longrightarrow> fst (concat_index_split (o_idx, i) xs) < length xs + o_idx"
	+ by (induct xs arbitrary: o_idx i) (auto, metis add_Suc_right add_diff_inverse_nat nat_add_left_cancel_less)
	+
	+lemma concat_index_split_sound_fst_arg:
	+ "i < length (concat xs) \<Longrightarrow> fst (concat_index_split (0, i) xs) < length xs"
	+ using concat_index_split_sound_fst_arg_aux[of i xs 0] by auto
	+
	+lemma concat_index_split_sound_snd_arg_aux:
	+ assumes "i < length (concat xs)"
	+ shows "snd (concat_index_split (n, i) xs) < length (xs ! (fst (concat_index_split (n, i) xs) - n))" using assms
	+proof (induct xs arbitrary: i n)
	+ case (Cons x xs)
	+ show ?case proof (cases "i < length x")
	+ case False then have size: "i - length x < length (concat xs)"
	+ using Cons(2) False by auto
	+ obtain k j where [simp]: "concat_index_split (Suc n, i - length x) xs = (k, j)"
	+ using old.prod.exhaust by blast
	+ show ?thesis using False Cons(1)[OF size, of "Suc n"] concat_index_split_mono_first_arg[OF size, of "Suc n"]
	+ by (auto simp: nth_append)
	+ qed (auto simp add: nth_append)
	+qed auto
	+
	+lemma concat_index_split_sound_snd_arg:
	+ assumes "i < length (concat xs)"
	+ shows "snd (concat_index_split (0, i) xs) < length (xs ! fst (concat_index_split (0, i) xs))"
	+ using concat_index_split_sound_snd_arg_aux[OF assms, of 0] by auto
	+
	+lemma reconstr_1d_concat_index_split:
	+ assumes "i < length (concat xs)"
	+ shows "i = (\<lambda> (m, j). sum_list (map length (take (m - n) xs)) + j) (concat_index_split (n, i) xs)" using assms
	+proof (induct xs arbitrary: i n)
	+ case (Cons x xs) show ?case
	+ proof (cases "i < length x")
	+ case False
	+ obtain m k where res: "concat_index_split (Suc n, i - length x) xs = (m, k)"
	+ using prod_decode_aux.cases by blast
	+ then have unf_ind: "concat_index_split (n, i) (x # xs) = concat_index_split (Suc n, i - length x) xs" and
	+ size: "i - length x < length (concat xs)" using Cons(2) False by auto
	+ have "Suc n \<le> m" using concat_index_split_mono_first_arg[OF size, of "Suc n"] by (auto simp: res)
	+ then have [simp]: "sum_list (map length (take (m - n) (x # xs))) = sum_list (map length (take (m - Suc n) xs)) + length x"
	+ by (simp add: take_Cons')
	+ show ?thesis using Cons(1)[OF size, of "Suc n"] False unfolding unf_ind res by auto
	+ qed auto
	+qed auto
	+
	+lemma concat_index_split_larger_lists [simp]:
	+ assumes "i < length (concat xs)"
	+ shows "concat_index_split (n, i) (xs @ ys) = concat_index_split (n, i) xs" using assms
	+ by (induct xs arbitrary: ys n i) auto
	+
	+lemma concat_index_split_split_sound_aux:
	+ assumes "i < length (concat xs)"
	+ shows "concat xs ! i = (\<lambda> (k, j). xs ! (k - n) ! j) (concat_index_split (n, i) xs)" using assms
	+proof (induct xs arbitrary: i n)
	+ case (Cons x xs)
	+ show ?case proof (cases "i < length x")
	+ case False then have size: "i - length x < length (concat xs)"
	+ using Cons(2) False by auto
	+ obtain k j where [simp]: "concat_index_split (Suc n, i - length x) xs = (k, j)"
	+ using prod_decode_aux.cases by blast
	+ show ?thesis using False Cons(1)[OF size, of "Suc n"]
	+ using concat_index_split_mono_first_arg[OF size, of "Suc n"]
	+ by (auto simp: nth_append)
	+ qed (auto simp add: nth_append)
	+qed auto
	+
	+lemma concat_index_split_sound:
	+ assumes "i < length (concat xs)"
	+ shows "concat xs ! i = (\<lambda> (k, j). xs ! k ! j) (concat_index_split (0, i) xs)"
	+ using concat_index_split_split_sound_aux[OF assms, of 0] by auto
	+
	+lemma concat_index_split_sound_bounds:
	+ assumes "i < length (concat xs)" and "concat_index_split (0, i) xs = (m, n)"
	+ shows "m < length xs" "n < length (xs ! m)"
	+ using concat_index_split_sound_fst_arg[OF assms(1)] concat_index_split_sound_snd_arg[OF assms(1)]
	+ by (auto simp: assms(2))
	+
	+lemma concat_index_split_less_length_concat:
	+ assumes "i < length (concat xs)" and "concat_index_split (0, i) xs = (m, n)"
	+ shows "i = sum_list (map length (take m xs)) + n" "m < length xs" "n < length (xs ! m)"
	+ "concat xs ! i = xs ! m ! n"
	+ using concat_index_split_sound[OF assms(1)] reconstr_1d_concat_index_split[OF assms(1), of 0]
	+ using concat_index_split_sound_fst_arg[OF assms(1)] concat_index_split_sound_snd_arg[OF assms(1)] assms(2)
	+ by auto
	+
	+lemma nth_concat_split':
	+ assumes "i < length (concat xs)"
	+ obtains j k where "j < length xs" "k < length (xs ! j)" "concat xs ! i = xs ! j ! k" "i = sum_list (map length (take j xs)) + k"
	+ using concat_index_split_less_length_concat[OF assms]
	+ by (meson old.prod.exhaust)
	+
	+lemma sum_list_split [dest!, consumes 1]:
	+ assumes "sum_list (map length (take i xs)) + j = sum_list (map length (take k xs)) + l"
	+ and "i < length xs" "k < length xs"
	+ and "j < length (xs ! i)" "l < length (xs ! k)"
	+ shows "i = k \<and> j = l" using assms
	+proof (induct xs rule: rev_induct)
	+ case (snoc x xs)
	+ then show ?case
	+ by (auto simp: nth_append split: if_splits)
	+ (metis concat_nth_length length_concat not_add_less1)+
	+qed auto
	+
	+lemma concat_index_split_unique:
	+ assumes "i < length (concat xs)" and "length xs = length ys"
	+ and "\<forall> i < length xs. length (xs ! i) = length (ys ! i)"
	+ shows "concat_index_split (n, i) xs = concat_index_split (n, i) ys" using assms
	+proof (induct xs arbitrary: ys n i)
	+ case (Cons x xs) note IH = this show ?case
	+ proof (cases ys)
	+ case Nil then show ?thesis using Cons(3) by auto
	+ next
	+ case [simp]: (Cons y ys')
	+ have [simp]: "length y = length x" using IH(4) by force
	+ have [simp]: "\<not> i < length x \<Longrightarrow> i - length x < length (concat xs)" using IH(2) by auto
	+ have [simp]: "i < length ys' \<Longrightarrow> length (xs ! i) = length (ys' ! i)" for i using IH(3, 4)
	+ by (auto simp: All_less_Suc) (metis IH(4) Suc_less_eq length_Cons Cons nth_Cons_Suc)
	+ show ?thesis using IH(2-) IH(1)[of "i - length x" ys' "Suc n"] by auto
	+ qed
	+qed auto
	+
	+lemma set_vars_term_list [simp]:
	+ "set (vars_term_list t) = vars_term t"
	+ by (induct t) simp_all
	+
	+lemma vars_term_list_empty_ground [simp]:
	+ "vars_term_list t = [] \<longleftrightarrow> ground t"
	+ by (induct t) auto
	+
	+lemma varposs_imp_poss:
	+ assumes "p \<in> varposs t"
	+ shows "p \<in> poss t"
	+ using assms by (induct t arbitrary: p) auto
	+
	+lemma vaposs_list_fun:
	+ assumes "p \<in> set (varposs_list (Fun f ts))"
	+ obtains i ps where "i < length ts" "p = i # ps"
	+ using assms set_zip_leftD by fastforce
	+
	+lemma varposs_list_distinct:
	+ "distinct (varposs_list t)"
	+proof (induct t)
	+ case (Fun f ts)
	+ then show ?case proof (induct ts rule: rev_induct)
	+ case (snoc x xs)
	+ then have "distinct (varposs_list (Fun f xs))" "distinct (varposs_list x)" by auto
	+ then show ?case using snoc by (auto simp add: map_cons_presv_distinct dest: set_zip_leftD)
	+ qed auto
	+qed auto
	+
	+lemma varposs_append:
	+ "varposs (Fun f (ts @ [t])) = varposs (Fun f ts) \<union> ((#) (length ts)) ` varposs t"
	+ by (auto simp: nth_append split: if_splits)
	+
	+lemma varposs_eq_varposs_list:
	+ "set (varposs_list t) = varposs t"
	+proof (induct t)
	+ case (Fun f ts)
	+ then show ?case proof (induct ts rule: rev_induct)
	+ case (snoc x xs)
	+ then have "varposs (Fun f xs) = set (varposs_list (Fun f xs))"
	+ "varposs x = set (varposs_list x)" by auto
	+ then show ?case using snoc unfolding varposs_append
	+ by auto
	+ qed auto
	+qed auto
	+
	+lemma varposs_list_var_terms_length:
	+ "length (varposs_list t) = length (vars_term_list t)"
	+ by (induct t) (auto simp: vars_term_list.simps intro: eq_length_concat_nth)
	+
	+lemma vars_term_list_nth:
	+ assumes "i < length (vars_term_list (Fun f ts))"
	+ and "concat_index_split (0, i) (map vars_term_list ts) = (k, j)"
	+ shows "k < length ts \<and> j < length (vars_term_list (ts ! k)) \<and>
	+ vars_term_list (Fun f ts) ! i = map vars_term_list ts ! k ! j \<and>
	+ i = sum_list (map length (map vars_term_list (take k ts))) + j"
	+ using assms concat_index_split_less_length_concat[of i "map vars_term_list ts" k j]
	+ by (auto simp: vars_term_list.simps comp_def take_map)
	+
	+lemma varposs_list_nth:
	+ assumes "i < length (varposs_list (Fun f ts))"
	+ and "concat_index_split (0, i) (poss_args varposs_list ts) = (k, j)"
	+ shows "k < length ts \<and> j < length (varposs_list (ts ! k)) \<and>
	+ varposs_list (Fun f ts) ! i = k # (map varposs_list ts) ! k ! j \<and>
	+ i = sum_list (map length (map varposs_list (take k ts))) + j"
	+ using assms concat_index_split_less_length_concat[of i "poss_args varposs_list ts" k j]
	+ by (auto simp: comp_def take_map intro: nth_sum_listI)
	+
	+lemma varposs_list_to_var_term_list:
	+ assumes "i < length (varposs_list t)"
	+ shows "the_Var (t \|_ (varposs_list t ! i)) = (vars_term_list t) ! i" using assms
	+proof (induct t arbitrary: i)
	+ case (Fun f ts)
	+ have "concat_index_split (0, i) (poss_args varposs_list ts) = concat_index_split (0, i) (map vars_term_list ts)"
	+ using Fun(2) concat_index_split_unique[of i "poss_args varposs_list ts" "map vars_term_list ts" 0]
	+ using varposs_list_var_terms_length[of "ts ! i" for i]
	+ by (auto simp: vars_term_list.simps)
	+ then obtain k j where "concat_index_split (0, i) (poss_args varposs_list ts) = (k, j)"
	+ "concat_index_split (0, i) (map vars_term_list ts) = (k, j)" by fastforce
	+ from varposs_list_nth[OF Fun(2) this(1)] vars_term_list_nth[OF _ this(2)]
	+ show ?case using Fun(2) Fun(1)[OF nth_mem] varposs_list_var_terms_length[of "Fun f ts"] by auto
	+qed (auto simp: vars_term_list.simps)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/FO_Theory_Rewriting/document/root.bib b/thys/FO_Theory_Rewriting/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/document/root.bib
	@@ -0,0 +1,88 @@
	+@string{lipics = "Leibniz International Proceedings in Informatics"}
	+@string{proc = "Proc.\ "}
	+@string{lncs = "LNCS"}
	+@string{lics = "{IEEE} Symposium on Logic in Computer Science"}
	+@string{cpp = "ACM SIGPLAN International Conference on Certified Programs
	+ and Proofs"}
	+@string{tacas = "International Conference on Tools and Algorithms for the
	+ Construction and Analysis of Systems"}
	+
	+@inbook{KGTM,
	+author = {Kucherov, Gregory and Tajine, Mohamed},
	+year = {2006},
	+month = {01},
	+pages = {272-286},
	+title = {Decidability of Regularity and Related Properties of Ground Normal Form Languages},
	+volume = {118},
	+isbn = {978-3-540-56393-8},
	+journal = {Information and Computation},
	+doi = {10.1007/3-540-56393-8_20}
	+}
	+
	+@inproceedings{DT90,
	+ author = "Max Dauchet and Sophie Tison",
	+ title = "The Theory of Ground Rewrite Systems is Decidable",
	+ booktitle = proc # "5th " # lics,
	+ pages = "242--248",
	+ year = 1990,
	+ doi = "10.1109/LICS.1990.113750"
	+}
	+
	+@article{Collections-AFP,
	+ author = {Peter Lammich},
	+ title = {Collections Framework},
	+ journal = {Archive of Formal Proofs},
	+ month = nov,
	+ year = 2009,
	+ note = {\url{https://isa-afp.org/entries/Collections.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+
	+@inproceedings{LMMF21,
	+ author = "Alexander Lochmann and Aart Middeldorp and
	+ Fabian Mitterwallner and Bertram Felgenhauer",
	+ title = "A Verified Decision Procedure for the First-Order Theory of
	+ Rewriting for Linear Variable-Separated Rewrite Systems
	+ Variable-Separated Rewrite Systems in {Isabelle/HOL}",
	+ booktitle = proc # "10th " # cpp,
	+ editor = "Cătălin Hriţcu and Andrei Popescu",
	+ pages = "250--263",
	+ year = 2021,
	+ doi = "10.1145/3437992.3439918"
	+}
	+
	+@Misc{tata2007,
	+ author = {H. Comon and M. Dauchet and R. Gilleron and C. L\"oding
	+and F. Jacquemard
	+and D. Lugiez and S. Tison and M. Tommasi},
	+ title = {Tree Automata Techniques and Applications},
	+ howpublished = {Available on: \url{http://www.grappa.univ-lille3.fr/tata}},
	+ note = {release October, 12th 2007},
	+ year = 2007
	+}
	+
	+@inproceedings{MLMF21,
	+ author = "Fabian Mitterwallner and Alexander Lochmann and Aart
	+ Middeldorp and Bertram Felgenhauer",
	+ title = "Certifying Proofs in the First-Order Theory of Rewriting",
	+ editor = "Jan Friso Groote and Kim G. Larsen",
	+ booktitle = proc # "27th " # tacas,
	+ series = lncs,
	+ volume = 12652,
	+ pages = "127--144",
	+ year = 2021,
	+ doi = "10.1007/978-3-030-45237-7\_11"
	+}
	+
	+@article{B07,
	+ author = {Stefan Berghofer},
	+ title = {First-Order Logic According to Fitting},
	+ journal = {Archive of Formal Proofs},
	+ month = aug,
	+ year = 2007,
	+ note = {\url{https://isa-afp.org/entries/FOL-Fitting.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+
	diff --git a/thys/FO_Theory_Rewriting/document/root.tex b/thys/FO_Theory_Rewriting/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/FO_Theory_Rewriting/document/root.tex
	@@ -0,0 +1,69 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+
	+\usepackage{url}
	+\usepackage{amssymb}
	+\usepackage{xspace}
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+\newcommand\isafor{\textsf{Isa\kern-0.15exF\kern-0.15exo\kern-0.15exR}}
	+\newcommand\ceta{\textsf{C\kern-0.15exe\kern-0.45exT\kern-0.45exA}}
	+
	+\begin{document}
	+
	+
	+\title{A Formalization of the First Order Theory of Rewriting (FORT) \footnote{Supported by FWF (Austrian Science Fund) project P30301.}}
	+\author{Alexander Lochmann \and Bertram Felgenhauer}
	+\maketitle
	+
	+\begin{abstract}
	+The first-order theory of rewriting (FORT) is a decidable theory for
	+linear variable-separated rewrite systems. The decision
	+procedure is based on tree automata technique and an inference system presented in \cite{MLMF21}.
	+This AFP entry provides a formalization of the underlying decision procedure.
	+Moreover it allows to generate a function that can verify each inference step via the
	+code generation facility of Isabelle/HOL.
	+
	+Additionally it contains the specification of a certificate language
	+(that allows to state proofs in FORT) and a formalized function that
	+allows to verify the validity of the proof.
	+This gives software tool authors, that implement the decision procedure,
	+the possibility to verify their output.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+\section{Introduction}
	+
	+The first-order theory of rewriting (FORT) is a fragment of
	+first-order predicate logic with predefined predicates.
	+The language allows to state many interesting properties of
	+term rewrite systems and is decidable for left-linear right-ground systems.
	+This was proven by Dauchet and Tison \cite{DT90}.
	+
	+In this AFP entry we provide a formalized proof of an improved decision procedure
	+for the first-order theory of rewriting. We introduce basic definitions to
	+represent the rewrite semantics and connect FORT to first-order logic
	+via the AFP entry "First-Order Logic According to Fitting" by Stefan Berghofer \cite{B07}.
	+To prove the decidability and more importantly to allow code generation a relation between
	+formulas in FORT and regular tree language is constructed. The tree language
	+contains all witnesses of free variables satisfying the formula, details can be found in \cite{LMMF21}.
	+
	+Moreover we present a certificate language which is rich enough to express the various au-
	+tomata operations in decision procedures for the first-order theory of rewrit-
	+ing as well as numerous predicate symbols that may appear in formulas in
	+this theory, for more details see \cite{MLMF21}.
	+
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	+
	diff --git a/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy b/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy
	--- a/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy
	+++ b/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy
	@@ -1,781 +1,803 @@
	(* Title: Integration of IsaFoR Terms and the Knuth-Bendix Order
	Author: Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
	Author: Anders Schlichtkrull <andschl at dtu.dk>, 2017
	Maintainer: Anders Schlichtkrull <andschl at dtu.dk>
	*)

	section \<open>Integration of \textsf{IsaFoR} Terms and the Knuth--Bendix Order\<close>

	text \<open>
	This theory implements the abstract interface for atoms and substitutions using
	the \textsf{IsaFoR} library.
	\<close>

	theory IsaFoR_Term
	imports
	Deriving.Derive
	Ordered_Resolution_Prover.Abstract_Substitution
	First_Order_Terms.Unification
	First_Order_Terms.Subsumption
	"HOL-Cardinals.Wellorder_Extension"
	Open_Induction.Restricted_Predicates
	Knuth_Bendix_Order.KBO
	begin

	hide_const (open) mgu

	abbreviation subst_apply_literal ::
	"('f, 'v) term literal \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term literal" (infixl "\<cdot>lit" 60) where
	"L \<cdot>lit \<sigma> \<equiv> map_literal (\<lambda>A. A \<cdot> \<sigma>) L"

	definition subst_apply_clause ::
	"('f, 'v) term clause \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term clause" (infixl "\<cdot>cls" 60) where
	"C \<cdot>cls \<sigma> = image_mset (\<lambda>L. L \<cdot>lit \<sigma>) C"

	abbreviation vars_lit :: "('f, 'v) term literal \<Rightarrow> 'v set" where
	"vars_lit L \<equiv> vars_term (atm_of L)"

	definition vars_clause :: "('f, 'v) term clause \<Rightarrow> 'v set" where
	"vars_clause C = Union (set_mset (image_mset vars_lit C))"

	definition vars_clause_list :: "('f, 'v) term clause list \<Rightarrow> 'v set" where
	"vars_clause_list Cs = Union (vars_clause ` set Cs) "

	definition vars_partitioned :: "('f,'v) term clause list \<Rightarrow> bool" where
	"vars_partitioned Cs \<longleftrightarrow>
	(\<forall>i < length Cs. \<forall>j < length Cs. i \<noteq> j \<longrightarrow> (vars_clause (Cs ! i) \<inter> vars_clause (Cs ! j)) = {})"

	lemma vars_clause_mono: "S \<subseteq># C \<Longrightarrow> vars_clause S \<subseteq> vars_clause C"
	unfolding vars_clause_def by auto

	interpretation substitution_ops "(\<cdot>)" Var "(\<circ>\<^sub>s)" .

	lemma is_ground_atm_is_ground_on_var:
	assumes "is_ground_atm (A \<cdot> \<sigma>)" and "v \<in> vars_term A"
	shows "is_ground_atm (\<sigma> v)"
	using assms proof (induction A)
	case (Var x)
	then show ?case by auto
	next
	case (Fun f ts)
	then show ?case unfolding is_ground_atm_def
	by auto
	qed

	lemma is_ground_lit_is_ground_on_var:
	assumes ground_lit: "is_ground_lit (subst_lit L \<sigma>)" and v_in_L: "v \<in> vars_lit L"
	shows "is_ground_atm (\<sigma> v)"
	proof -
	let ?A = "atm_of L"
	from v_in_L have A_p: "v \<in> vars_term ?A"
	by auto
	then have "is_ground_atm (?A \<cdot> \<sigma>)"
	using ground_lit unfolding is_ground_lit_def by auto
	then show ?thesis
	using A_p is_ground_atm_is_ground_on_var by metis
	qed

	lemma is_ground_cls_is_ground_on_var:
	assumes
	ground_clause: "is_ground_cls (subst_cls C \<sigma>)" and
	v_in_C: "v \<in> vars_clause C"
	shows "is_ground_atm (\<sigma> v)"
	proof -
	from v_in_C obtain L where L_p: "L \<in># C" "v \<in> vars_lit L"
	unfolding vars_clause_def by auto
	then have "is_ground_lit (subst_lit L \<sigma>)"
	using ground_clause unfolding is_ground_cls_def subst_cls_def by auto
	then show ?thesis
	using L_p is_ground_lit_is_ground_on_var by metis
	qed

	lemma is_ground_cls_list_is_ground_on_var:
	assumes ground_list: "is_ground_cls_list (subst_cls_list Cs \<sigma>)"
	and v_in_Cs: "v \<in> vars_clause_list Cs"
	shows "is_ground_atm (\<sigma> v)"
	proof -
	from v_in_Cs obtain C where C_p: "C \<in> set Cs" "v \<in> vars_clause C"
	unfolding vars_clause_list_def by auto
	then have "is_ground_cls (subst_cls C \<sigma>)"
	using ground_list unfolding is_ground_cls_list_def subst_cls_list_def by auto
	then show ?thesis
	using C_p is_ground_cls_is_ground_on_var by metis
	qed

	lemma same_on_vars_lit:
	assumes "\<forall>v \<in> vars_lit L. \<sigma> v = \<tau> v"
	shows "subst_lit L \<sigma> = subst_lit L \<tau>"
	using assms
	proof (induction L)
	case (Pos x)
	then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
	using term_subst_eq by metis+
	then show ?case
	unfolding subst_lit_def using Pos by auto
	next
	case (Neg x)
	then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
	using term_subst_eq by metis+
	then show ?case
	unfolding subst_lit_def using Neg by auto
	qed

	lemma in_list_of_mset_in_S:
	assumes "i < length (list_of_mset S)"
	shows "list_of_mset S ! i \<in># S"
	proof -
	from assms have "list_of_mset S ! i \<in> set (list_of_mset S)"
	by auto
	then have "list_of_mset S ! i \<in># mset (list_of_mset S)"
	by (meson in_multiset_in_set)
	then show ?thesis
	by auto
	qed

	lemma same_on_vars_clause:
	assumes "\<forall>v \<in> vars_clause S. \<sigma> v = \<tau> v"
	shows "subst_cls S \<sigma> = subst_cls S \<tau>"
	by (smt assms image_eqI image_mset_cong2 mem_simps(9) same_on_vars_lit set_image_mset
	subst_cls_def vars_clause_def)

	+interpretation substitution "(\<cdot>)" "Var :: _ \<Rightarrow> ('f, nat) term" "(\<circ>\<^sub>s)"
	+proof unfold_locales
	+ show "\<And>A. A \<cdot> Var = A"
	+ by auto
	+next
	+ show "\<And>A \<tau> \<sigma>. A \<cdot> \<tau> \<circ>\<^sub>s \<sigma> = A \<cdot> \<tau> \<cdot> \<sigma>"
	+ by auto
	+next
	+ show "\<And>\<sigma> \<tau>. (\<And>A. A \<cdot> \<sigma> = A \<cdot> \<tau>) \<Longrightarrow> \<sigma> = \<tau>"
	+ by (simp add: subst_term_eqI)
	+next
	+ fix C :: "('f, nat) term clause"
	+ fix \<sigma>
	+ assume "is_ground_cls (subst_cls C \<sigma>)"
	+ then have ground_atms_\<sigma>: "\<And>v. v \<in> vars_clause C \<Longrightarrow> is_ground_atm (\<sigma> v)"
	+ by (meson is_ground_cls_is_ground_on_var)
	+
	+ define some_ground_trm :: "('f, nat) term" where "some_ground_trm = (Fun undefined [])"
	+ have ground_trm: "is_ground_atm some_ground_trm"
	+ unfolding is_ground_atm_def some_ground_trm_def by auto
	+ define \<tau> where "\<tau> = (\<lambda>v. if v \<in> vars_clause C then \<sigma> v else some_ground_trm)"
	+ then have \<tau>_\<sigma>: "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
	+ unfolding \<tau>_def by auto
	+
	+ have all_ground_\<tau>: "is_ground_atm (\<tau> v)" for v
	+ proof (cases "v \<in> vars_clause C")
	+ case True
	+ then show ?thesis
	+ using ground_atms_\<sigma> \<tau>_\<sigma> by auto
	+ next
	+ case False
	+ then show ?thesis
	+ unfolding \<tau>_def using ground_trm by auto
	+ qed
	+ have "is_ground_subst \<tau>"
	+ unfolding is_ground_subst_def
	+ proof
	+ fix A
	+ show "is_ground_atm (subst_atm_abbrev A \<tau>)"
	+ proof (induction A)
	+ case (Var v)
	+ then show ?case using all_ground_\<tau> by auto
	+ next
	+ case (Fun f As)
	+ then show ?case using all_ground_\<tau>
	+ by (simp add: is_ground_atm_def)
	+ qed
	+ qed
	+ moreover have "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
	+ using \<tau>_\<sigma> unfolding vars_clause_list_def
	+ by blast
	+ then have "subst_cls C \<sigma> = subst_cls C \<tau>"
	+ using same_on_vars_clause by auto
	+ ultimately show "\<exists>\<tau>. is_ground_subst \<tau> \<and> subst_cls C \<tau> = subst_cls C \<sigma>"
	+ by auto
	+next
	+ show "wfP (strictly_generalizes_atm :: ('f, 'v) term \<Rightarrow> _ \<Rightarrow> _)"
	+ unfolding wfP_def
	+ by (rule wf_subset[OF wf_subsumes])
	+ (auto simp: strictly_generalizes_atm_def generalizes_atm_def term_subsumable.subsumes_def
	+ subsumeseq_term.simps)
	+qed
	+
	lemma vars_partitioned_var_disjoint:
	assumes "vars_partitioned Cs"
	shows "var_disjoint Cs"
	unfolding var_disjoint_def
	proof (intro allI impI)
	fix \<sigma>s :: \<open>('b \<Rightarrow> ('a, 'b) term) list\<close>
	assume "length \<sigma>s = length Cs"
	with assms[unfolded vars_partitioned_def] Fun_More.fun_merge[of "map vars_clause Cs" "nth \<sigma>s"]
	obtain \<sigma> where
	\<sigma>_p: "\<forall>i < length (map vars_clause Cs). \<forall>x \<in> map vars_clause Cs ! i. \<sigma> x = (\<sigma>s ! i) x"
	by auto
	have "\<forall>i < length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
	proof (rule, rule, rule, rule)
	fix i :: nat and S :: "('a, 'b) term literal multiset"
	assume
	"i < length Cs" and
	"S \<subseteq># Cs ! i"
	then have "\<forall>v \<in> vars_clause S. (\<sigma>s ! i) v = \<sigma> v"
	using vars_clause_mono[of S "Cs ! i"] \<sigma>_p by auto
	then show "subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
	using same_on_vars_clause by auto
	qed
	then show "\<exists>\<tau>. \<forall>i<length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<tau>"
	by auto
	qed

	lemma vars_in_instance_in_range_term:
	"vars_term (subst_atm_abbrev A \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
	by (induction A) auto

	lemma vars_in_instance_in_range_lit: "vars_lit (subst_lit L \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
	proof (induction L)
	case (Pos A)
	have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
	using vars_in_instance_in_range_term[of A \<sigma>] by blast
	then show ?case by auto
	next
	case (Neg A)
	have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
	using vars_in_instance_in_range_term[of A \<sigma>] by blast
	then show ?case by auto
	qed

	lemma vars_in_instance_in_range_cls:
	"vars_clause (subst_cls C \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
	unfolding vars_clause_def subst_cls_def using vars_in_instance_in_range_lit[of _ \<sigma>] by auto

	primrec renamings_apart :: "('f, nat) term clause list \<Rightarrow> (('f, nat) subst) list" where
	"renamings_apart [] = []"
	\| "renamings_apart (C # Cs) =
	(let \<sigma>s = renamings_apart Cs in
	(\<lambda>v. Var (v + Max (vars_clause_list (subst_cls_lists Cs \<sigma>s) \<union> {0}) + 1)) # \<sigma>s)"

	definition var_map_of_subst :: "('f, nat) subst \<Rightarrow> nat \<Rightarrow> nat" where
	"var_map_of_subst \<sigma> v = the_Var (\<sigma> v)"

	lemma len_renamings_apart: "length (renamings_apart Cs) = length Cs"
	by (induction Cs) (auto simp: Let_def)

	lemma renamings_apart_is_Var: "\<forall>\<sigma> \<in> set (renamings_apart Cs). \<forall>x. is_Var (\<sigma> x)"
	by (induction Cs) (auto simp: Let_def)

	lemma renamings_apart_inj: "\<forall>\<sigma> \<in> set (renamings_apart Cs). inj \<sigma>"
	proof (induction Cs)
	case (Cons a Cs)
	then have "inj (\<lambda>v. Var (Suc (v + Max (vars_clause_list
	(subst_cls_lists Cs (renamings_apart Cs)) \<union> {0}))))"
	by (meson add_right_imp_eq injI nat.inject term.inject(1))
	then show ?case
	using Cons by (auto simp: Let_def)
	qed auto

	lemma finite_vars_clause[simp]: "finite (vars_clause x)"
	unfolding vars_clause_def by auto

	lemma finite_vars_clause_list[simp]: "finite (vars_clause_list Cs)"
	unfolding vars_clause_list_def by (induction Cs) auto

	lemma Suc_Max_notin_set: "finite X \<Longrightarrow> Suc (v + Max (insert 0 X)) \<notin> X"
	by (metis Max.boundedE Suc_n_not_le_n empty_iff finite.insertI le_add2 vimageE vimageI
	vimage_Suc_insert_0)

	lemma vars_partitioned_Nil[simp]: "vars_partitioned []"
	unfolding vars_partitioned_def by auto

	lemma subst_cls_lists_Nil[simp]: "subst_cls_lists Cs [] = []"
	unfolding subst_cls_lists_def by auto

	lemma vars_clause_hd_partitioned_from_tl:
	assumes "Cs \<noteq>[]"
	shows "vars_clause (hd (subst_cls_lists Cs (renamings_apart Cs)))
	\<inter> vars_clause_list (tl (subst_cls_lists Cs (renamings_apart Cs))) = {}"
	using assms
	proof (induction Cs)
	case (Cons C Cs)
	define \<sigma>' :: "nat \<Rightarrow> nat"
	where "\<sigma>' = (\<lambda>v. (Suc (v + Max ((vars_clause_list (subst_cls_lists Cs
	(renamings_apart Cs))) \<union> {0}))))"
	define \<sigma> :: "nat \<Rightarrow> ('a, nat) term"
	where "\<sigma> = (\<lambda>v. Var (\<sigma>' v))"

	have "vars_clause (subst_cls C \<sigma>) \<subseteq> \<Union> (vars_term ` range \<sigma>)"
	using vars_in_instance_in_range_cls[of C "hd (renamings_apart (C # Cs))"] \<sigma>_def \<sigma>'_def
	by (auto simp: Let_def)
	moreover have "\<Union> (vars_term ` range \<sigma>)
	\<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
	proof -
	have "range \<sigma>' \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
	unfolding \<sigma>'_def using Suc_Max_notin_set by auto
	then show ?thesis
	unfolding \<sigma>_def \<sigma>'_def by auto
	qed
	ultimately have "vars_clause (subst_cls C \<sigma>)
	\<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
	by auto
	then show ?case
	unfolding \<sigma>_def \<sigma>'_def unfolding subst_cls_lists_def
	by (simp add: Let_def subst_cls_lists_def)
	qed auto

	lemma vars_partitioned_renamings_apart: "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
	proof (induction Cs)
	case (Cons C Cs)
	{
	fix i :: nat and j :: nat
	assume ij:
	"i < Suc (length Cs)"
	"j < i"
	have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
	vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
	{}"
	proof (cases i; cases j)
	fix j' :: nat
	assume i'j':
	"i = 0"
	"j = Suc j'"
	then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
	vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
	{}"
	using ij by auto
	next
	fix i' :: nat
	assume i'j':
	"i = Suc i'"
	"j = 0"
	have disjoin_C_Cs: "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
	vars_clause_list ((subst_cls_lists Cs (renamings_apart Cs))) = {}"
	using vars_clause_hd_partitioned_from_tl[of "C # Cs"]
	by (simp add: Let_def subst_cls_lists_def)
	{
	fix x
	assume asm: "x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
	then have "(subst_cls_lists Cs (renamings_apart Cs) ! i')
	\<in> set (subst_cls_lists Cs (renamings_apart Cs))"
	using i'j' ij unfolding subst_cls_lists_def
	by (metis Suc_less_SucD length_map len_renamings_apart length_zip min_less_iff_conj
	nth_mem)
	moreover from asm have
	"x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
	using i'j' ij
	unfolding subst_cls_lists_def by simp
	ultimately have "\<exists>D \<in> set (subst_cls_lists Cs (renamings_apart Cs)). x \<in> vars_clause D"
	by auto
	}
	then have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')
	\<subseteq> Union (set (map vars_clause ((subst_cls_lists Cs (renamings_apart Cs)))))"
	by auto
	then have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
	vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') =
	{}" using disjoin_C_Cs unfolding vars_clause_list_def by auto
	moreover
	have "subst_cls_lists Cs (renamings_apart Cs) ! i' =
	subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i"
	using i'j' ij unfolding subst_cls_lists_def by (simp add: Let_def)
	ultimately
	show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
	vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
	{}"
	using i'j' by (simp add: Int_commute)
	next
	fix i' :: nat and j' :: nat
	assume i'j':
	"i = Suc i'"
	"j = Suc j'"
	have "i'<length (subst_cls_lists Cs (renamings_apart Cs))"
	using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
	moreover
	have "j'<length (subst_cls_lists Cs (renamings_apart Cs))"
	using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
	moreover
	have "i' \<noteq> j'"
	using \<open>i = Suc i'\<close> \<open>j = Suc j'\<close> ij by blast
	ultimately
	have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') \<inter>
	vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! j') =
	{}"
	using Cons unfolding vars_partitioned_def by auto
	then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
	vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
	{}"
	unfolding i'j'
	by (simp add: subst_cls_lists_def Let_def)
	next
	assume
	\<open>i = 0\<close> and
	\<open>j = 0\<close>
	then show \<open>vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
	vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
	{}\<close> using ij by auto
	qed
	}
	then show ?case
	unfolding vars_partitioned_def
	by (metis (no_types, lifting) Int_commute Suc_lessI len_renamings_apart length_map
	length_nth_simps(2) length_zip min.idem nat.inject not_less_eq subst_cls_lists_def)
	qed auto

	-interpretation substitution "(\<cdot>)" "Var :: _ \<Rightarrow> ('f, nat) term" "(\<circ>\<^sub>s)" renamings_apart "Fun undefined"
	-proof (standard)
	- show "\<And>A. A \<cdot> Var = A"
	- by auto
	-next
	- show "\<And>A \<tau> \<sigma>. A \<cdot> \<tau> \<circ>\<^sub>s \<sigma> = A \<cdot> \<tau> \<cdot> \<sigma>"
	- by auto
	-next
	- show "\<And>\<sigma> \<tau>. (\<And>A. A \<cdot> \<sigma> = A \<cdot> \<tau>) \<Longrightarrow> \<sigma> = \<tau>"
	- by (simp add: subst_term_eqI)
	-next
	- fix C :: "('f, nat) term clause"
	- fix \<sigma>
	- assume "is_ground_cls (subst_cls C \<sigma>)"
	- then have ground_atms_\<sigma>: "\<And>v. v \<in> vars_clause C \<Longrightarrow> is_ground_atm (\<sigma> v)"
	- by (meson is_ground_cls_is_ground_on_var)
	-
	- define some_ground_trm :: "('f, nat) term" where "some_ground_trm = (Fun undefined [])"
	- have ground_trm: "is_ground_atm some_ground_trm"
	- unfolding is_ground_atm_def some_ground_trm_def by auto
	- define \<tau> where "\<tau> = (\<lambda>v. if v \<in> vars_clause C then \<sigma> v else some_ground_trm)"
	- then have \<tau>_\<sigma>: "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
	- unfolding \<tau>_def by auto
	-
	- have all_ground_\<tau>: "is_ground_atm (\<tau> v)" for v
	- proof (cases "v \<in> vars_clause C")
	- case True
	- then show ?thesis
	- using ground_atms_\<sigma> \<tau>_\<sigma> by auto
	- next
	- case False
	- then show ?thesis
	- unfolding \<tau>_def using ground_trm by auto
	- qed
	- have "is_ground_subst \<tau>"
	- unfolding is_ground_subst_def
	- proof
	- fix A
	- show "is_ground_atm (subst_atm_abbrev A \<tau>)"
	- proof (induction A)
	- case (Var v)
	- then show ?case using all_ground_\<tau> by auto
	- next
	- case (Fun f As)
	- then show ?case using all_ground_\<tau>
	- by (simp add: is_ground_atm_def)
	- qed
	- qed
	- moreover have "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
	- using \<tau>_\<sigma> unfolding vars_clause_list_def
	- by blast
	- then have "subst_cls C \<sigma> = subst_cls C \<tau>"
	- using same_on_vars_clause by auto
	- ultimately show "\<exists>\<tau>. is_ground_subst \<tau> \<and> subst_cls C \<tau> = subst_cls C \<sigma>"
	- by auto
	-next
	+interpretation substitution_renamings "(\<cdot>)" "Var :: _ \<Rightarrow> ('f, nat) term" "(\<circ>\<^sub>s)" renamings_apart "Fun undefined"
	+proof unfold_locales
	fix Cs :: "('f, nat) term clause list"
	show "length (renamings_apart Cs) = length Cs"
	using len_renamings_apart by auto
	next
	fix Cs :: "('f, nat) term clause list"
	fix \<rho> :: "nat \<Rightarrow> ('f, nat) Term.term"
	assume \<rho>_renaming: "\<rho> \<in> set (renamings_apart Cs)"
	{
	have inj_is_renaming:
	"\<And>\<sigma> :: ('f, nat) subst. (\<And>x. is_Var (\<sigma> x)) \<Longrightarrow> inj \<sigma> \<Longrightarrow> is_renaming \<sigma>"
	proof -
	fix \<sigma> :: "('f, nat) subst"
	fix x
	assume is_var_\<sigma>: "\<And>x. is_Var (\<sigma> x)"
	assume inj_\<sigma>: "inj \<sigma>"
	define \<sigma>' where "\<sigma>' = var_map_of_subst \<sigma>"
	have \<sigma>: "\<sigma> = Var \<circ> \<sigma>'"
	unfolding \<sigma>'_def var_map_of_subst_def using is_var_\<sigma> by auto

	from is_var_\<sigma> inj_\<sigma> have "inj \<sigma>'"
	unfolding is_renaming_def unfolding subst_domain_def inj_on_def \<sigma>'_def var_map_of_subst_def
	by (metis term.collapse(1))
	then have "inv \<sigma>' \<circ> \<sigma>' = id"
	using inv_o_cancel[of \<sigma>'] by simp
	then have "Var \<circ> (inv \<sigma>' \<circ> \<sigma>') = Var"
	by simp
	then have "\<forall>x. (Var \<circ> (inv \<sigma>' \<circ> \<sigma>')) x = Var x"
	by metis
	then have "\<forall>x. ((Var \<circ> \<sigma>') \<circ>\<^sub>s (Var \<circ> (inv \<sigma>'))) x = Var x"
	unfolding subst_compose_def by auto
	then have "\<sigma> \<circ>\<^sub>s (Var \<circ> (inv \<sigma>')) = Var"
	using \<sigma> by auto
	then show "is_renaming \<sigma>"
	unfolding is_renaming_def by blast
	qed
	then have "\<forall>\<sigma> \<in> (set (renamings_apart Cs)). is_renaming \<sigma>"
	using renamings_apart_is_Var renamings_apart_inj by blast
	}
	then show "is_renaming \<rho>"
	using \<rho>_renaming by auto
	next
	fix Cs :: "('f, nat) term clause list"
	have "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
	using vars_partitioned_renamings_apart by auto
	then show "var_disjoint (subst_cls_lists Cs (renamings_apart Cs))"
	using vars_partitioned_var_disjoint by auto
	next
	show "\<And>\<sigma> As Bs. Fun undefined As \<cdot> \<sigma> = Fun undefined Bs \<longleftrightarrow> map (\<lambda>A. A \<cdot> \<sigma>) As = Bs"
	by simp
	-next
	- show "wfP (strictly_generalizes_atm :: ('f, 'v) term \<Rightarrow> _ \<Rightarrow> _)"
	- unfolding wfP_def
	- by (rule wf_subset[OF wf_subsumes])
	- (auto simp: strictly_generalizes_atm_def generalizes_atm_def term_subsumable.subsumes_def
	- subsumeseq_term.simps)
	qed

	fun pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
	"pairs (x # y # xs) = (x, y) # pairs (y # xs)" \|
	"pairs _ = []"

	derive compare "term"
	derive compare "literal"

	lemma class_linorder_compare: "class.linorder (le_of_comp compare) (lt_of_comp compare)"
	apply standard
	apply (simp_all add: lt_of_comp_def le_of_comp_def split: order.splits)
	apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
	apply (metis comparator_compare comparator_def order.distinct(5))
	apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
	by (metis comparator.sym comparator_compare invert_order.simps(2) order.distinct(5))

	context begin
	interpretation compare_linorder: linorder
	"le_of_comp compare"
	"lt_of_comp compare"
	by (rule class_linorder_compare)

	definition Pairs where
	"Pairs AAA = concat (compare_linorder.sorted_list_of_set
	((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))"

	lemma unifies_all_pairs_iff:
	"(\<forall>p \<in> set (pairs xs). fst p \<cdot> \<sigma> = snd p \<cdot> \<sigma>) \<longleftrightarrow> (\<forall>a \<in> set xs. \<forall>b \<in> set xs. a \<cdot> \<sigma> = b \<cdot> \<sigma>)"
	proof (induct xs rule: pairs.induct)
	case (1 x y xs)
	then show ?case
	unfolding pairs.simps list.set ball_Un ball_simps simp_thms fst_conv snd_conv by metis
	qed simp_all

	lemma in_pair_in_set:
	assumes "(A,B) \<in> set ((pairs As))"
	shows "A \<in> set As \<and> B \<in> set As"
	using assms
	proof (induction As)
	case (Cons A As)
	note Cons_outer = this
	show ?case
	proof (cases As)
	case Nil
	then show ?thesis
	using Cons_outer by auto
	next
	case (Cons B As')
	then show ?thesis using Cons_outer by auto
	qed
	qed auto

	lemma in_pairs_sorted_list_of_set_in_set:
	assumes
	"finite AAA"
	"\<forall>AA \<in> AAA. finite AA"
	"AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA" and
	"(A :: _ :: compare, B) \<in> set AB_pairs"
	shows "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
	proof -
	from assms have "AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA"
	by auto
	then obtain AA where
	AA_p: "AA \<in> AAA \<and> (pairs \<circ> compare_linorder.sorted_list_of_set) AA = AB_pairs"
	by auto
	have "(A, B) \<in> set (pairs (compare_linorder.sorted_list_of_set AA))"
	using AA_p[] assms(4) by auto
	then have "A \<in> set (compare_linorder.sorted_list_of_set AA)" and
	"B \<in> set (compare_linorder.sorted_list_of_set AA)"
	using in_pair_in_set[of A] by auto
	then show ?thesis
	using assms(2) AA_p by auto
	qed

	lemma unifiers_Pairs:
	assumes
	"finite AAA" and
	"\<forall>AA \<in> AAA. finite AA"
	shows "unifiers (set (Pairs AAA)) = {\<sigma>. is_unifiers \<sigma> AAA}"
	proof (rule; rule)
	fix \<sigma> :: "('a, 'b) subst"
	assume asm: "\<sigma> \<in> unifiers (set (Pairs AAA))"
	have "\<And>AA. AA \<in> AAA \<Longrightarrow> card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
	proof -
	fix AA :: "('a, 'b) term set"
	assume asm': "AA \<in> AAA"
	then have "\<forall>p \<in> set (pairs (compare_linorder.sorted_list_of_set AA)).
	subst_atm_abbrev (fst p) \<sigma> = subst_atm_abbrev (snd p) \<sigma>"
	using assms asm unfolding Pairs_def by auto
	then have "\<forall>A \<in> AA. \<forall>B \<in> AA. subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
	using assms asm' unfolding unifies_all_pairs_iff
	using compare_linorder.sorted_list_of_set by blast
	then show "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
	by (smt imageE card.empty card_Suc_eq card_mono finite.intros(1) finite_insert le_SucI
	singletonI subsetI)
	qed
	then show "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"
	using assms by (auto simp: is_unifiers_def is_unifier_def subst_atms_def)
	next
	fix \<sigma> :: "('a, 'b) subst"
	assume asm: "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"

	{
	fix AB_pairs A B
	assume
	"AB_pairs \<in> set (compare_linorder.sorted_list_of_set
	((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))" and
	"(A, B) \<in> set AB_pairs"
	then have "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
	using assms by (simp add: in_pairs_sorted_list_of_set_in_set)
	then obtain AA where
	a: "AA \<in> AAA" "A \<in> AA" "B \<in> AA"
	by blast
	from a assms asm have card_AA_\<sigma>: "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
	unfolding is_unifiers_def is_unifier_def subst_atms_def by auto
	have "subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
	proof (cases "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = Suc 0")
	case True
	moreover
	have "subst_atm_abbrev A \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
	using a assms asm card_AA_\<sigma> by auto
	moreover
	have "subst_atm_abbrev B \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
	using a assms asm card_AA_\<sigma> by auto
	ultimately
	show ?thesis
	using a assms asm card_AA_\<sigma> by (metis (no_types, lifting) card_Suc_eq singletonD)
	next
	case False
	then have "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = 0"
	using a assms asm card_AA_\<sigma>
	by arith
	then show ?thesis
	using a assms asm card_AA_\<sigma> by auto
	qed
	}
	then show "\<sigma> \<in> unifiers (set (Pairs AAA))"
	unfolding Pairs_def unifiers_def by auto
	qed

	end

	definition "mgu_sets AAA = map_option subst_of (unify (Pairs AAA) [])"

	-interpretation mgu "(\<cdot>)" "Var :: _ \<Rightarrow> ('f :: compare, nat) term" "(\<circ>\<^sub>s)" "Fun undefined"
	- renamings_apart mgu_sets
	-proof
	+lemma mgu_sets_is_imgu:
	+ fixes AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
	+ assumes fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
	+ shows "is_imgu \<sigma> AAA"
	+proof -
	+ have "Unifiers.is_imgu \<sigma> (set (Pairs AAA))"
	+ using assms unify_sound unfolding mgu_sets_def by blast
	+ thus ?thesis
	+ unfolding Unifiers.is_imgu_def is_imgu_def unifiers_Pairs[OF fin]
	+ by simp
	+qed
	+
	+interpretation mgu "(\<cdot>)" "Var :: _ \<Rightarrow> ('f :: compare, nat) term" "(\<circ>\<^sub>s)" renamings_apart
	+ "Fun undefined" mgu_sets
	+proof unfold_locales
	fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
	assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
	- then have "is_imgu \<sigma> (set (Pairs AAA))"
	- using unify_sound unfolding mgu_sets_def by blast
	- then show "is_mgu \<sigma> AAA"
	- unfolding is_imgu_def is_mgu_def unifiers_Pairs[OF fin] by auto
	+ thus "is_mgu \<sigma> AAA"
	+ using mgu_sets_is_imgu by auto
	next
	fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
	assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "is_unifiers \<sigma> AAA"
	then have "\<sigma> \<in> unifiers (set (Pairs AAA))"
	unfolding is_mgu_def unifiers_Pairs[OF fin] by auto
	then show "\<exists>\<tau>. mgu_sets AAA = Some \<tau>"
	using unify_complete unfolding mgu_sets_def by blast
	qed

	+interpretation imgu "(\<cdot>)" "Var :: _ \<Rightarrow> ('f :: compare, nat) term" "(\<circ>\<^sub>s)" renamings_apart
	+ "Fun undefined" mgu_sets
	+proof unfold_locales
	+ fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
	+ assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
	+ thus "is_imgu \<sigma> AAA"
	+ by (rule mgu_sets_is_imgu)
	+qed
	+
	derive linorder prod
	derive linorder list

	text \<open>
	This part extends and integrates and the Knuth--Bendix order defined in
	\textsf{IsaFoR}.
	\<close>

	record 'f weights =
	w :: "'f \<times> nat \<Rightarrow> nat"
	w0 :: nat
	pr_strict :: "'f \<times> nat \<Rightarrow> 'f \<times> nat \<Rightarrow> bool"
	least :: "'f \<Rightarrow> bool"
	scf :: "'f \<times> nat \<Rightarrow> nat \<Rightarrow> nat"

	class weighted =
	fixes weights :: "'a weights"
	assumes weights_adm:
	"admissible_kbo
	(w weights) (w0 weights) (pr_strict weights) ((pr_strict weights)\<^sup>=\<^sup>=) (least weights) (scf weights)"
	and pr_strict_total: "fi = gj \<or> pr_strict weights fi gj \<or> pr_strict weights gj fi"
	and pr_strict_asymp: "asymp (pr_strict weights)"
	and scf_ok: "i < n \<Longrightarrow> scf weights (f, n) i \<le> 1"

	instantiation unit :: weighted begin

	definition weights_unit :: "unit weights" where "weights_unit =
	\<lparr>w = Suc \<circ> snd, w0 = 1, pr_strict = \<lambda>(_, n) (_, m). n > m, least = \<lambda>_. True, scf = \<lambda>_ _. 1\<rparr>"

	instance
	by (intro_classes, unfold_locales) (auto simp: weights_unit_def SN_iff_wf asymp.simps irreflp_def
	intro!: wf_subset[OF wf_inv_image[OF wf], of _ snd])
	end

	global_interpretation KBO:
	admissible_kbo
	"w (weights :: 'f :: weighted weights)" "w0 (weights :: 'f :: weighted weights)"
	"pr_strict weights" "((pr_strict weights)\<^sup>=\<^sup>=)" "least weights" "scf weights"
	defines weight = KBO.weight
	and kbo = KBO.kbo
	by (simp add: weights_adm)

	lemma kbo_code[code]: "kbo s t =
	(let wt = weight t; ws = weight s in
	if vars_term_ms (KBO.SCF t) \<subseteq># vars_term_ms (KBO.SCF s) \<and> wt \<le> ws
	then
	(if wt < ws then (True, True)
	else
	(case s of
	Var y \<Rightarrow> (False, case t of Var x \<Rightarrow> True \| Fun g ts \<Rightarrow> ts = [] \<and> least weights g)
	\| Fun f ss \<Rightarrow>
	(case t of
	Var x \<Rightarrow> (True, True)
	\| Fun g ts \<Rightarrow>
	if pr_strict weights (f, length ss) (g, length ts) then (True, True)
	else if (f, length ss) = (g, length ts) then lex_ext_unbounded kbo ss ts
	else (False, False))))
	else (False, False))"
	by (subst KBO.kbo.simps) (auto simp: Let_def split: term.splits)

	definition "less_kbo s t = fst (kbo t s)"

	lemma less_kbo_gtotal: "ground s \<Longrightarrow> ground t \<Longrightarrow> s = t \<or> less_kbo s t \<or> less_kbo t s"
	unfolding less_kbo_def using KBO.S_ground_total by (metis pr_strict_total subset_UNIV)

	lemma less_kbo_subst:
	fixes \<sigma> :: "('f :: weighted, 'v) subst"
	shows "less_kbo s t \<Longrightarrow> less_kbo (s \<cdot> \<sigma>) (t \<cdot> \<sigma>)"
	unfolding less_kbo_def by (rule KBO.S_subst)

	lemma wfP_less_kbo: "wfP less_kbo"
	proof -
	have "SN {(x, y). fst (kbo x y)}"
	using pr_strict_asymp by (fastforce simp: asymp.simps irreflp_def intro!: KBO.S_SN scf_ok)
	then show ?thesis
	unfolding SN_iff_wf wfP_def by (rule wf_subset) (auto simp: less_kbo_def)
	qed

	instantiation "term" :: (weighted, type) linorder begin

	definition "leq_term = (SOME leq. {(s,t). less_kbo s t} \<subseteq> leq \<and> Well_order leq \<and> Field leq = UNIV)"

	lemma less_trm_extension: "{(s,t). less_kbo s t} \<subseteq> leq_term"
	unfolding leq_term_def
	by (rule someI2_ex[OF total_well_order_extension[OF wfP_less_kbo[unfolded wfP_def]]]) auto

	lemma less_trm_well_order: "well_order leq_term"
	unfolding leq_term_def
	by (rule someI2_ex[OF total_well_order_extension[OF wfP_less_kbo[unfolded wfP_def]]]) auto

	definition less_eq_term :: "('a :: weighted, 'b) term \<Rightarrow> _ \<Rightarrow> bool" where
	"less_eq_term = in_rel leq_term"
	definition less_term :: "('a :: weighted, 'b) term \<Rightarrow> _ \<Rightarrow> bool" where
	"less_term s t = strict (\<le>) s t"

	lemma leq_term_minus_Id: "leq_term - Id = {(x,y). x < y}"
	using less_trm_well_order
	unfolding well_order_on_def linear_order_on_def partial_order_on_def antisym_def less_term_def less_eq_term_def
	by auto

	lemma less_term_alt: "(<) = in_rel (leq_term - Id)"
	by (simp add: in_rel_Collect_case_prod_eq leq_term_minus_Id)

	instance
	proof (standard, goal_cases less_less_eq refl trans antisym total)
	case (less_less_eq x y)
	then show ?case unfolding less_term_def ..
	next
	case (refl x)
	then show ?case using less_trm_well_order
	unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
	less_eq_term_def by auto
	next
	case (trans x y z)
	then show ?case using less_trm_well_order
	unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def trans_def
	less_eq_term_def by auto
	next
	case (antisym x y)
	then show ?case using less_trm_well_order
	unfolding well_order_on_def linear_order_on_def partial_order_on_def antisym_def
	less_eq_term_def by auto
	next
	case (total x y)
	then show ?case using less_trm_well_order
	unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
	Relation.total_on_def less_eq_term_def by (cases "x = y") auto
	qed

	end

	instantiation "term" :: (weighted, type) wellorder begin
	instance
	using less_trm_well_order[unfolded well_order_on_def wf_def leq_term_minus_Id, THEN conjunct2]
	by intro_classes (atomize, auto)
	end

	lemma ground_less_less_kbo: "ground s \<Longrightarrow> ground t \<Longrightarrow> s < t \<Longrightarrow> less_kbo s t"
	using less_kbo_gtotal[of s t] less_trm_extension
	by (auto simp: less_term_def less_eq_term_def)

	lemma less_kbo_less: "less_kbo s t \<Longrightarrow> s < t"
	using less_trm_extension
	by (auto simp: less_term_alt less_kbo_def KBO.S_irrefl)

	lemma is_ground_atm_ground: "is_ground_atm t \<longleftrightarrow> ground t"
	unfolding is_ground_atm_def
	by (induct t) (fastforce simp: in_set_conv_nth list_eq_iff_nth_eq)+

	end
	diff --git a/thys/Gale_Shapley/Gale_Shapley1.thy b/thys/Gale_Shapley/Gale_Shapley1.thy
	--- a/thys/Gale_Shapley/Gale_Shapley1.thy
	+++ b/thys/Gale_Shapley/Gale_Shapley1.thy
	@@ -1,1284 +1,1508 @@
	(*
	Stepwise refinement of the Gale-Shapley algorithm down to executable functional code.

	Part 1: Refinement down to lists.

	Author: Tobias Nipkow
	*)

	theory Gale_Shapley1
	imports Main
	"HOL-Hoare.Hoare_Logic"
	"List-Index.List_Index"
	"HOL-Library.While_Combinator"
	"HOL-Library.LaTeXsugar"
	begin

	lemmas conj12 = conjunct1 conjunct2

	syntax
	"_assign_list" :: "idt \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'com" ("(2_[_] :=/ _)" [70, 0, 65] 61)

	translations
	"xs[n] := e" \<rightharpoonup> "xs := CONST list_update xs n e"

	abbreviation upt_set :: "nat \<Rightarrow> nat set" ("{<_}") where
	"{<n} \<equiv> {0..<n}"

	(* Maybe also require y : set P? *)
	definition prefers :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
	"prefers P x y = (index P x < index P y)"

	abbreviation prefa :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("(_ \<turnstile>/ _ < _)" [50,50,50] 50) where
	"P \<turnstile> x < y \<equiv> prefers P x y"

	lemma prefers_asym: "P \<turnstile> x < y \<Longrightarrow> \<not> P \<turnstile> y < x"
	by(simp add: prefers_def)

	lemma prefers_trans: "P \<turnstile> x < y \<Longrightarrow> P \<turnstile> y < z \<Longrightarrow> P \<turnstile> x < z"
	by (meson order_less_trans prefers_def)

	fun rk_of_pref :: "nat \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
	"rk_of_pref r rs (n#ns) = (rk_of_pref (r+1) rs ns)[n := r]" \|
	"rk_of_pref r rs [] = rs"

	definition ranking :: "nat list \<Rightarrow> nat list" where
	"ranking P = rk_of_pref 0 (replicate (length P) 0) P"

	lemma length_rk_of_pref[simp]: "length(rk_of_pref v vs P) = length vs"
	by(induction P arbitrary: v)(auto)

	lemma nth_rk_of_pref: "\<lbrakk> length P \<le> length rs; i \<in> set P; distinct P; set P \<subseteq> {<length rs} \<rbrakk>
	\<Longrightarrow> rk_of_pref r rs P ! i = index P i + r"
	by(induction P arbitrary: r i) (auto simp add: nth_list_update)

	lemma ranking_iff_pref: "\<lbrakk> set P = {<length P}; i < length P; j < length P \<rbrakk>
	\<Longrightarrow> ranking P ! i < ranking P ! j \<longleftrightarrow> P \<turnstile> i < j"
	by(simp add: ranking_def prefers_def nth_rk_of_pref card_distinct)


	subsection \<open>Fixing the preference lists\<close>

	type_synonym prefs = "nat list list"

	locale Pref =
	fixes n
	fixes P\<^sub>a :: prefs
	fixes P\<^sub>b :: prefs
	defines "n \<equiv> length P\<^sub>a"
	assumes length_P\<^sub>b: "length P\<^sub>b = n"
	assumes P\<^sub>a_set: "a < n \<Longrightarrow> length(P\<^sub>a!a) = n \<and> set(P\<^sub>a!a) = {<n}"
	assumes P\<^sub>b_set: "b < n \<Longrightarrow> length(P\<^sub>b!b) = n \<and> set(P\<^sub>b!b) = {<n}"
	begin


	abbreviation wf :: "nat list \<Rightarrow> bool" where
	"wf xs \<equiv> length xs = n \<and> set xs \<subseteq> {<n}"

	lemma wf_less_n: "\<lbrakk> wf A; a < n \<rbrakk> \<Longrightarrow> A!a < n"
	by (simp add: subset_eq)

	corollary wf_le_n1: "\<lbrakk> wf A; a < n \<rbrakk> \<Longrightarrow> A!a \<le> n-1"
	using wf_less_n by fastforce

	lemma sumA_ub: "wf A \<Longrightarrow> (\<Sum>a<n. A!a) \<le> n*(n-1)"
	using sum_bounded_above[of "{..<n}" "((!) A)" "n-1"] wf_le_n1[of A] by (simp)


	subsubsection \<open>The (termination) variant(s)\<close>

	text \<open>Basic idea: either some \<open>A!a\<close> is incremented or size of \<open>M\<close> is incremented, but this cannot
	go on forever because in the worst case all \<open>A!a = n-1\<close> and \<open>M = n\<close>. Because \<open>n*(n-1) + n = n^2\<close>,
	this leads to the following simple variant:\<close>

	definition var0 :: "nat list \<Rightarrow> nat set \<Rightarrow> nat" where
	[simp]: "var0 A M = (n^2 - ((\<Sum>a<n. A!a) + card M))"

	lemma var0_match:
	assumes "wf A" "M \<subseteq> {<n}" "a < n \<and> a \<notin> M"
	shows "var0 A (M \<union> {a}) < var0 A M"
	proof -
	have 2: "M \<subset> {<n}" using assms(2-3) by auto
	have 3: "card M < n" using psubset_card_mono[OF _ 2] by simp
	then show ?thesis
	using sumA_ub[OF assms(1)] assms(3) finite_subset[OF assms(2)]
	by (simp add: power2_eq_square algebra_simps le_diff_conv2)
	qed

	lemma var0_next:
	assumes "wf A" "M \<subseteq> {<n}" "M \<noteq> {<n}" "a' < n"
	shows "var0 (A[a' := A ! a' + 1]) M < var0 A M"
	proof -
	have 0: "card M < n" using assms(2,3)
	by (metis atLeast0LessThan card_lessThan card_subset_eq finite_lessThan lessThan_iff nat_less_le
	subset_eq_atLeast0_lessThan_card)
	have : "1 + (\<Sum>a<n. A!a) + card M \<le> nn"
	using sumA_ub[OF assms(1)] 0 by (simp add: algebra_simps le_diff_conv2)
	have "var0 (A[a' := A ! a' + 1]) M = n*n - (1 + (A ! a' + sum ((!) A) ({<n} - {a'})) + card M)"
	using assms by(simp add: power2_eq_square nth_list_update sum.If_cases lessThan_atLeast0 flip:Diff_eq)
	also have "\<dots> = n^2 - (1 + (\<Sum>a<n. A!a) + card M)"
	using sum.insert_remove[of "{<n}" "nth A" a',simplified,symmetric] assms(4)
	by (simp add:insert_absorb lessThan_atLeast0 power2_eq_square)
	also have "\<dots> < n^2 - ((\<Sum>a<n. A!a) + card M)" unfolding power2_eq_square using * by linarith
	finally show ?thesis unfolding var0_def .
	qed

	definition var :: "nat list \<Rightarrow> nat set \<Rightarrow> nat" where
	[simp]: "var A M = (n^2 - n + 1 - ((\<Sum>a<n. A!a) + card M))"

	lemma sumA_ub2:
	assumes "a' < n" "A!a' \<le> n-1" "\<forall>a < n. a \<noteq> a' \<longrightarrow> A!a \<le> n-2"
	shows "(\<Sum>a<n. A!a) \<le> (n-1)*(n-1)"
	proof -
	have "(\<Sum>a<n. A!a) = (\<Sum>a \<in> ({<n}-{a'}) \<union> {a'}. A!a)"
	by (simp add: assms(1) atLeast0LessThan insert_absorb)
	also have "\<dots> =(\<Sum>a \<in> {<n}-{a'}. A!a) + A!a'"
	by (simp add: sum.insert_remove)
	also have "\<dots> \<le> (\<Sum>a \<in> {<n}-{a'}. A!a) + (n-1)" using assms(2) by linarith
	also have "\<dots> \<le> (n-1)*(n-2) + (n-1)"
	using sum_bounded_above[of "{..<n}-{a'}" "((!) A)" "n-2"] assms(1,3)
	by (simp add: atLeast0LessThan)
	also have "\<dots> = (n-1)*(n-1)"
	by (metis Suc_diff_Suc Suc_eq_plus1 add.commute diff_is_0_eq' linorder_not_le mult_Suc_right mult_cancel_left nat_1_add_1)
	finally show ?thesis .
	qed

	definition "match A a = P\<^sub>a ! a ! (A ! a)"

	lemma match_less_n: "\<lbrakk> wf A; a < n \<rbrakk> \<Longrightarrow> match A a < n"
	by (metis P\<^sub>a_set atLeastLessThan_iff match_def nth_mem subset_eq)

	lemma match_upd_neq: "\<lbrakk> wf A; a < n; a \<noteq> a' \<rbrakk> \<Longrightarrow> match (A[a := b]) a' = match A a'"
	by (simp add: match_def)

	definition blocks :: "nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
	"blocks A a a' = (P\<^sub>a ! a \<turnstile> match A a' < match A a \<and> P\<^sub>b ! match A a' \<turnstile> a < a')"

	definition stable :: "nat list \<Rightarrow> nat set \<Rightarrow> bool" where
	"stable A M = (\<not>(\<exists>a\<in>M. \<exists>a'\<in>M. a \<noteq> a' \<and> blocks A a a'))"

	text \<open>The set of Bs that an A would prefer to its current match,
	i.e. all Bs above its current match \<open>A!a\<close>.\<close>
	abbreviation preferred where
	"preferred A a == nth (P\<^sub>a!a) ` {<A!a}"

	definition matching where [simp]:
	"matching A M = (wf A \<and> inj_on (match A) M)"


	text \<open>If \<open>a'\<close> is unmatched and final then all other \<open>a\<close> are matched:\<close>

	lemma final_last:
	assumes M: "M \<subseteq> {<n}" and inj: "inj_on (match A) M" and pref_match': "preferred A a \<subseteq> match A ` M"
	and a: "a < n \<and> a \<notin> M" and final: "A ! a + 1 = n"
	shows "insert a M = {<n}"
	proof -
	let ?B = "preferred A a"
	have "(!) (P\<^sub>a ! a) ` {<n} = {<n}" by (metis P\<^sub>a_set a map_nth set_map set_upt)
	hence "inj_on ((!) (P\<^sub>a ! a)) {<n}" by(simp add: eq_card_imp_inj_on)
	hence "inj_on ((!) (P\<^sub>a ! a)) {<A!a}" using final by(simp add: subset_inj_on)
	hence 1: "Suc(card ?B) = n" using P\<^sub>a_set a final by (simp add: card_image)
	have 2: "card ?B \<le> card M"
	by(rule surj_card_le[OF subset_eq_atLeast0_lessThan_finite[OF M] pref_match'])
	have 3: "card M < n" using M a
	by (metis atLeast0LessThan card_seteq order.refl finite_atLeastLessThan le_neq_implies_less lessThan_iff subset_eq_atLeast0_lessThan_card)
	have "Suc (card M) = n" using 1 2 3 by simp
	thus ?thesis using M a by (simp add: card_subset_eq finite_subset)
	qed

	lemma more_choices:
	assumes A: "matching A M" and M: "M \<subseteq> {<n}" "M \<noteq> {<n}"
	and pref_match': "preferred A a \<subseteq> match A ` M"
	and "a < n" and matched: "match A a \<in> match A ` M"
	shows "A ! a + 1 < n"
	proof (rule ccontr)
	have match: "match A ` M \<subseteq> {<n}" using A M P\<^sub>a_set unfolding matching_def
	by (smt (verit, best) atLeastLessThan_iff match_def image_subsetI in_mono nth_mem)
	have "card M < n" using M
	by (metis card_atLeastLessThan card_seteq diff_zero finite_atLeastLessThan not_less)
	assume "\<not> A ! a + 1 < n"
	hence "A ! a + 1 = n" using A \<open>a < n\<close> unfolding matching_def
	by (metis add.commute wf_less_n linorder_neqE_nat not_less_eq plus_1_eq_Suc)
	hence *: "nth (P\<^sub>a ! a) ` {<n} \<subseteq> match A ` M"
	using pref_match' matched less_Suc_eq match_def by fastforce
	have "nth (P\<^sub>a!a) ` {<n} = {<n}"
	by (metis \<open>a < n\<close> map_nth P\<^sub>a_set set_map set_upt)
	hence "match A ` M = {<n}"
	by (metis * match set_eq_subset)
	then show False using A M \<open>card M < n\<close> unfolding matching_def
	by (metis atLeast0LessThan card_image card_lessThan nat_neq_iff)
	qed

	corollary more_choices_matched:
	assumes "matching A M" "M \<subseteq> {<n}" "M \<noteq> {<n}"
	and "preferred A a \<subseteq> match A ` M" and "a \<in> M"
	shows "A ! a + 1 < n"
	using more_choices[OF assms(1-4)] \<open>a \<in> M\<close> \<open>M \<subseteq> {<n}\<close> atLeastLessThan_iff by blast

	lemma atmost1_final: assumes M: "M \<subseteq> {<n}" and inj: "inj_on (match A) M"
	and "\<forall>a<n. preferred A a \<subseteq> match A ` M"
	shows "\<exists>\<^sub>\<le>\<^sub>1 a. a < n \<and> a \<notin> M \<and> A ! a + 1 = n"
	apply rule
	subgoal for x y
	using final_last[OF M inj, of x] final_last[OF M inj, of y] assms(3) by blast
	done

	lemma sumA_UB:
	assumes "matching A M" "M \<subseteq> {<n}" "M \<noteq> {<n}" "\<forall>a<n. preferred A a \<subseteq> match A ` M"
	shows "(\<Sum>a<n. A!a) \<le> (n-1)^2"
	proof -
	have M: "\<forall>a\<in>M. A!a + 1 < n" using more_choices_matched[OF assms(1-3)] assms(4)
	\<open>M \<subseteq> {<n}\<close> atLeastLessThan_iff by blast
	note Ainj = conj12[OF assms(1)[unfolded matching_def]]
	show ?thesis
	proof (cases "\<exists>a'<n. a' \<notin> M \<and> A!a' + 1 = n")
	case True
	then obtain a' where a': "a'<n" "a' \<notin> M" "A!a' + 1 = n" using \<open>M \<subseteq> {<n}\<close> \<open>M \<noteq> {<n}\<close> by blast
	hence "\<forall>a<n. a \<noteq> a' \<longrightarrow> A!a \<le> n-2"
	using Uniq_D[OF atmost1_final[OF assms(2) Ainj(2) assms(4)], of a'] M wf_le_n1[OF Ainj(1)]
	by (metis Suc_1 Suc_eq_plus1 add_diff_cancel_right' add_le_imp_le_diff diff_diff_left less_eq_Suc_le order_less_le)
	from sumA_ub2[OF a'(1) _ this] a'(3) show ?thesis unfolding power2_eq_square by linarith
	next
	case False
	hence "\<forall>a'<n. a' \<notin> M \<longrightarrow> A ! a' + 1 < n"
	by (metis Suc_eq_plus1 Suc_lessI wf_less_n[OF Ainj(1)])
	with M have "\<forall>a<n. A ! a + 1 < n" by blast
	hence "(\<Sum>a<n. A!a) \<le> n*(n-2)" using sum_bounded_above[of "{..<n}" "((!) A)" "n-2"] by fastforce
	also have "\<dots> \<le> (n-1)*(n-1)" by(simp add: algebra_simps)
	finally show ?thesis unfolding power2_eq_square .
	qed
	qed

	lemma var_ub:
	assumes "matching A M" "M \<subseteq> {<n}" "M \<noteq> {<n}" "\<forall>a<n. preferred A a \<subseteq> match A ` M"
	shows "(\<Sum>a<n. A!a) + card M < n^2 - n + 1"
	proof -
	have 1: "M \<subset> {<n}" using assms(2,3) by auto
	have 2: "card M < n" using psubset_card_mono[OF _ 1] by simp
	have 3: "sum ((!) A) {..<n} \<le> n^2 + 1 - 2*n"
	using sumA_UB[OF assms(1-4)] by (simp add: power2_eq_square algebra_simps)
	have 4: "2*n \<le> Suc (n^2)" using le_square[of n] unfolding power2_eq_square
	by (metis Suc_1 add_mono_thms_linordered_semiring(1) le_SucI mult_2 mult_le_mono1 not_less_eq_eq plus_1_eq_Suc)
	show "(\<Sum>a<n. A!a) + card M < n^2 - n + 1" using 2 3 4 by linarith
	qed

	lemma var_match:
	assumes "matching A M" "M \<subseteq> {<n}" "M \<noteq> {<n}" "\<forall>a<n. preferred A a \<subseteq> match A ` M" "a \<notin> M"
	shows "var A (M \<union> {a}) < var A M"
	proof -
	have 2: "M \<subset> {<n}" using assms(2,3) by auto
	have 3: "card M < n" using psubset_card_mono[OF _ 2] by simp
	have 4: "sum ((!) A) {..<n} \<le> n^2 + 1 - 2*n"
	using sumA_UB[OF assms(1-4)] by (simp add: power2_eq_square algebra_simps)
	have 5: "2*n \<le> Suc (n^2)" using le_square[of n] unfolding power2_eq_square
	by (metis Suc_1 add_mono_thms_linordered_semiring(1) le_SucI mult_2 mult_le_mono1 not_less_eq_eq plus_1_eq_Suc)
	have 6: "(\<Sum>a<n. A!a) + card M < n^2 + 1 - n" using 3 4 5 by linarith
	from var_ub[OF assms(1-4)] show ?thesis using \<open>a \<notin> M\<close> finite_subset[OF assms(2)] by(simp)
	qed

	lemma var_next:
	assumes"matching A M" "M \<subseteq> {<n}" "M \<noteq> {<n}" "\<forall>a<n. preferred A a \<subseteq> match A ` M"
	"a < n"
	shows "var (A[a := A ! a + 1]) M < var A M"
	proof -
	have "var (A[a := A ! a + 1]) M = n*n - n + 1 - (1 + (A ! a + sum ((!) A) ({<n} - {a})) + card M)"
	using assms(1,5) by(simp add: power2_eq_square nth_list_update sum.If_cases lessThan_atLeast0 flip:Diff_eq)
	also have "\<dots> = n^2 - n + 1 - (1 + (\<Sum>a<n. A!a) + card M)"
	using sum.insert_remove[of "{<n}" "nth A" a,simplified,symmetric] assms(5)
	by (simp add:insert_absorb lessThan_atLeast0 power2_eq_square)
	also have "\<dots> < n^2 - n + 1 - ((\<Sum>a<n. A!a) + card M)" using var_ub[OF assms(1-4)] unfolding power2_eq_square
	by linarith
	finally show ?thesis unfolding var_def .
	qed


	text \<open>The following two predicates express the same property:
	if \<open>a\<close> prefers \<open>b\<close> over \<open>a\<close>'s current match,
	then \<open>b\<close> is matched with an \<open>a'\<close> that \<open>b\<close> prefers to \<open>a\<close>.\<close>

	definition pref_match where
	"pref_match A M = (\<forall>a<n. \<forall>b<n. P\<^sub>a!a \<turnstile> b < match A a \<longrightarrow> (\<exists>a'\<in>M. b = match A a' \<and> P\<^sub>b ! b \<turnstile> a' < a))"

	definition pref_match' where
	"pref_match' A M = (\<forall>a<n. \<forall>b \<in> preferred A a. \<exists>a'\<in>M. b = match A a' \<and> P\<^sub>b ! b \<turnstile> a' < a)"

	lemma pref_match'_iff: "wf A \<Longrightarrow> pref_match' A M = pref_match A M"
	apply (auto simp add: pref_match'_def pref_match_def imp_ex prefers_def match_def)
	apply (smt (verit) P\<^sub>a_set atLeast0LessThan order.strict_trans index_first lessThan_iff linorder_neqE_nat nth_index)
	by (smt (verit, best) P\<^sub>a_set atLeast0LessThan card_atLeastLessThan card_distinct diff_zero in_mono index_nth_id lessThan_iff less_trans nth_mem)

	definition opti\<^sub>a where
	"opti\<^sub>a A = (\<nexists>A'. matching A' {<n} \<and> stable A' {<n} \<and>
	(\<exists>a<n. P\<^sub>a ! a \<turnstile> match A' a < match A a))"

	definition pessi\<^sub>b where
	"pessi\<^sub>b A = (\<nexists>A'. matching A' {<n} \<and> stable A' {<n} \<and>
	(\<exists>a<n. \<exists>a'<n. match A a = match A' a' \<and> P\<^sub>b ! match A a \<turnstile> a < a'))"

	lemma opti\<^sub>a_pessi\<^sub>b: assumes "opti\<^sub>a A" shows "pessi\<^sub>b A"
	unfolding pessi\<^sub>b_def
	proof (safe, goal_cases)
	case (1 A' a a')
	have "\<not> P\<^sub>a!a \<turnstile> match A a < match A' a" using 1
	by (metis atLeast0LessThan blocks_def lessThan_iff prefers_asym stable_def)
	with 1 \<open>opti\<^sub>a A\<close> show ?case using P\<^sub>a_set match_less_n opti\<^sub>a_def prefers_def unfolding matching_def
	by (metis (no_types) atLeast0LessThan inj_on_contraD lessThan_iff less_not_refl linorder_neqE_nat nth_index)
	qed

	lemma opti\<^sub>a_inv:
	assumes A: "wf A" and a: "a < n" and a': "a' < n" and same_match: "match A a' = match A a"
	and pref: "P\<^sub>b ! match A a' \<turnstile> a' < a" and "opti\<^sub>a A"
	shows "opti\<^sub>a (A[a := A ! a + 1])"
	proof (unfold opti\<^sub>a_def matching_def, rule notI, elim exE conjE)
	note opti\<^sub>a = \<open>opti\<^sub>a A\<close>[unfolded opti\<^sub>a_def matching_def]
	let ?A = "A[a := A ! a + 1]"
	fix A' a''
	assume "a'' < n" and A': "length A' = n" "set A' \<subseteq> {<n}" "stable A' {<n}" "inj_on (match A') {<n}"
	and pref_a'': "P\<^sub>a ! a'' \<turnstile> match A' a'' < match ?A a''"
	show False
	proof cases
	assume [simp]: "a'' = a"
	have "A!a < n" using A a by(simp add: subset_eq)
	with A A' a pref_a'' have "P\<^sub>a ! a \<turnstile> match A' a < match A a \<or> match A' a = match A a"
	apply(auto simp: prefers_def match_def)
	by (smt (verit) P\<^sub>a_set wf_less_n card_atLeastLessThan card_distinct diff_zero index_nth_id
	not_less_eq not_less_less_Suc_eq)
	thus False
	proof
	assume "P\<^sub>a ! a \<turnstile> match A' a < match A a " thus False using opti\<^sub>a A' \<open>a < n\<close> by(fastforce)
	next
	assume "match A' a = match A a"
	have "a \<noteq> a'" using pref a' by(auto simp: prefers_def)
	hence "blocks A' a' a" using opti\<^sub>a pref A' same_match \<open>match A' a = match A a\<close> a a'
	unfolding blocks_def
	by (metis P\<^sub>a_set atLeast0LessThan match_less_n inj_onD lessThan_iff linorder_neqE_nat nth_index prefers_def)
	thus False using a a' \<open>a \<noteq> a'\<close> A'(3) by (metis stable_def atLeastLessThan_iff zero_le)
	qed
	next
	assume "a'' \<noteq> a" thus False using opti\<^sub>a A' pref_a'' \<open>a'' < n\<close> by(metis match_def nth_list_update_neq)
	qed
	qed

	lemma pref_match_stable:
	"\<lbrakk> matching A {<n}; pref_match A {<n} \<rbrakk> \<Longrightarrow> stable A {<n}"
	unfolding pref_match_def stable_def blocks_def matching_def
	by (metis atLeast0LessThan match_less_n inj_onD lessThan_iff prefers_asym)

	definition invAM where
	[simp]: "invAM A M = (matching A M \<and> M \<subseteq> {<n} \<and> pref_match A M \<and> opti\<^sub>a A)"

	lemma invAM_match:
	"\<lbrakk> invAM A M; a < n \<and> a \<notin> M; match A a \<notin> match A ` M \<rbrakk> \<Longrightarrow> invAM A (M \<union> {a})"
	by(simp add: pref_match_def)

	lemma invAM_swap:
	assumes "invAM A M"
	assumes a: "a < n \<and> a \<notin> M" and a': "a' \<in> M \<and> match A a' = match A a" and pref: "P\<^sub>b ! match A a' \<turnstile> a < a'"
	shows "invAM (A[a' := A!a'+1]) (M - {a'} \<union> {a})"
	proof -
	have A: "wf A" and M : "M \<subseteq> {<n}" and inj: "inj_on (match A) M" and pref_match: "pref_match A M"
	and "opti\<^sub>a A" by(insert \<open>invAM A M\<close>) (auto)
	have "M \<noteq> {<n}" "a' < n" "a \<noteq> a'" using a' a M by auto
	have pref_match': "pref_match' A M" using pref_match pref_match'_iff[OF A] by blast
	let ?A = "A[a' := A!a'+1]" let ?M = "M - {a'} \<union> {a}"
	have neq_a': "\<forall>x. x \<in> ?M \<longrightarrow> a' \<noteq> x" using \<open>a \<noteq> a'\<close> by blast
	have \<open>set ?A \<subseteq> {<n}\<close>
	apply(rule set_update_subsetI[OF A[THEN conjunct2]])
	using more_choices[OF _ M \<open>M \<noteq> {<n}\<close>] A inj pref_match' a' subsetD[OF M, of a']
	by(fastforce simp: pref_match'_def)
	hence "wf ?A" using A by(simp)
	moreover have "inj_on (match ?A) ?M" using a a' inj
	by(simp add: match_def inj_on_def)(metis Diff_iff insert_iff nth_list_update_neq)
	moreover have "pref_match' ?A ?M" using a a' pref_match' A pref \<open>a' < n\<close>
	apply(simp add: pref_match'_def match_upd_neq neq_a' Ball_def Bex_def image_iff imp_ex nth_list_update less_Suc_eq
	flip: match_def)
	by (metis prefers_trans)
	moreover have "opti\<^sub>a ?A" using opti\<^sub>a_inv[OF A \<open>a' < n\<close> _ _ _ \<open>opti\<^sub>a A\<close>] a a'[THEN conjunct2] pref by auto
	ultimately show ?thesis using a a' M pref_match'_iff by auto
	qed

	lemma invAM_next:
	assumes "invAM A M"
	assumes a: "a < n \<and> a \<notin> M" and a': "a' \<in> M \<and> match A a' = match A a" and pref: "\<not> P\<^sub>b ! match A a' \<turnstile> a < a'"
	shows "invAM (A[a := A!a + 1]) M"
	proof -
	have A: "wf A" and M : "M \<subseteq> {<n}" and inj: "inj_on (match A) M" and pref_match: "pref_match A M"
	and opti\<^sub>a: "opti\<^sub>a A" and "a' < n"
	by(insert \<open>invAM A M\<close> a') (auto)
	hence pref': "P\<^sub>b ! match A a' \<turnstile> a' < a"
	using pref a a' P\<^sub>b_set unfolding prefers_def
	by (metis match_def match_less_n index_eq_index_conv linorder_less_linear subsetD)
	have "M \<noteq> {<n}" using a by fastforce
	have neq_a: "\<forall>x. x\<in> M \<longrightarrow> a \<noteq> x" using a by blast
	have pref_match': "pref_match' A M" using pref_match pref_match'_iff[OF A,of M] by blast
	hence "\<forall>a<n. preferred A a \<subseteq> match A ` M" unfolding pref_match'_def by blast
	hence "A!a + 1 < n"
	using more_choices[OF _ M \<open>M \<noteq> {<n}\<close>] A inj a a' unfolding matching_def by (metis (no_types, lifting) imageI)
	let ?A = "A[a := A!a+1]"
	have "wf ?A" using A \<open>A!a + 1 < n\<close> by(simp add: set_update_subsetI)
	moreover have "inj_on (match ?A) M" using a inj
	by(simp add: match_def inj_on_def) (metis nth_list_update_neq)
	moreover have "pref_match' ?A M" using a pref_match' pref' A a' neq_a
	by(auto simp: match_upd_neq pref_match'_def Ball_def Bex_def image_iff nth_list_update imp_ex less_Suc_eq
	simp flip: match_def)
	moreover have "opti\<^sub>a ?A" using opti\<^sub>a_inv[OF A conjunct1[OF a] \<open>a' < n\<close> conjunct2[OF a'] pref' opti\<^sub>a] .
	ultimately show ?thesis using M by (simp add: pref_match'_iff)
	qed


	subsection \<open>Algorithm 1\<close>

	lemma Gale_Shapley1: "VARS M A a a'
	[M = {} \<and> A = replicate n 0]
	WHILE M \<noteq> {<n}
	INV { invAM A M }
	VAR {var A M}
	DO a := (SOME a. a < n \<and> a \<notin> M);
	IF match A a \<notin> match A ` M
	THEN M := M \<union> {a}
	ELSE a' := (SOME a'. a' \<in> M \<and> match A a' = match A a);
	IF P\<^sub>b ! match A a' \<turnstile> a < a'
	THEN A[a'] := A!a'+1; M := M - {a'} \<union> {a}
	ELSE A[a] := A!a+1
	FI
	FI
	OD
	[matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	proof (vcg_tc, goal_cases)
	case 1 thus ?case
	by(auto simp: stable_def opti\<^sub>a_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def)
	next
	case 3 thus ?case using pref_match_stable by auto
	next
	case (2 v M A a)
	hence invAM: "invAM A M" and m: "matching A M" and M: "M \<subseteq> {<n}" "M \<noteq> {<n}"
	and pref_match: "pref_match A M" and "opti\<^sub>a A" and v: "var A M = v" by auto
	note Ainj = conj12[OF m[unfolded matching_def]]
	note pref_match' = pref_match[THEN pref_match'_iff[OF Ainj(1), THEN iffD2]]
	hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` M" unfolding pref_match'_def by blast
	define a where "a = (SOME a. a < n \<and> a \<notin> M)"
	have a: "a < n \<and> a \<notin> M" unfolding a_def using M
	by (metis (no_types, lifting) atLeastLessThan_iff someI_ex subsetI subset_antisym)
	show ?case (is "?P((SOME a. a < n \<and> a \<notin> M))") unfolding a_def[symmetric]
	proof -
	show "?P a" (is "(?not_matched \<longrightarrow> ?THEN) \<and> (\<not> ?not_matched \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?not_matched
	show ?THEN
	proof(simp only:mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1 show ?case using invAM_match[OF invAM a \<open>?not_matched\<close>] .

	case 2 show ?case
	using var_match[OF m M pref_match1] var0_match[OF Ainj(1) M(1)] a unfolding v by blast
	qed
	next
	assume matched: "\<not> ?not_matched"
	define a' where "a' = (SOME a'. a' \<in> M \<and> match A a' = match A a)"
	have a': "a' \<in> M \<and> match A a' = match A a" unfolding a'_def using matched
	by (smt (verit) image_iff someI_ex)
	hence "a' < n" "a \<noteq> a'" using a M atLeast0LessThan by auto
	show ?ELSE (is "?P((SOME a'. a' \<in> M \<and> match A a' = match A a))") unfolding a'_def[symmetric]
	proof -
	show "?P a'" (is "(?pref \<longrightarrow> ?THEN) \<and> (\<not> ?pref \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?pref
	show ?THEN
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1 show ?case by(rule invAM_swap[OF invAM a a' \<open>?pref\<close>])

	case 2
	have "card(M - {a'} \<union> {a}) = card M"
	using a a' card.remove subset_eq_atLeast0_lessThan_finite[OF M(1)] by fastforce
	thus ?case using v var_next[OF m M pref_match1 \<open>a' < n\<close>] var0_next[OF Ainj(1) M \<open>a' < n\<close>]
	by simp
	qed
	next
	assume "\<not> ?pref"
	show ?ELSE
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1 show ?case using invAM_next[OF invAM a a' \<open>\<not> ?pref\<close>] .

	case 2
	show ?case using a v var_next[OF m M pref_match1, of a] var0_next[OF Ainj(1) M, of a]
	by simp
	qed
	qed
	qed
	qed
	qed
	qed

	text \<open>Proof also works for @{const var0} instead of @{const var}.\<close>


	subsection \<open>Algorithm 2: List of unmatched As\<close>

	abbreviation invas where
	"invas as == (set as \<subseteq> {<n} \<and> distinct as)"

	lemma Gale_Shapley2: "VARS A a a' as
	[as = [0..<n] \<and> A = replicate n 0]
	WHILE as \<noteq> []
	INV { invAM A ({<n} - set as) \<and> invas as}
	VAR {var A ({<n} - set as)}
	DO a := hd as;
	IF match A a \<notin> match A ` ({<n} - set as)
	THEN as := tl as
	ELSE a' := (SOME a'. a' \<in> {<n} - set as \<and> match A a' = match A a);
	IF P\<^sub>b ! match A a' \<turnstile> a < a'
	THEN A[a'] := A!a'+1; as := a' # tl as
	ELSE A[a] := A!a+1
	FI
	FI
	OD
	[matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	proof (vcg_tc, goal_cases)
	case 1 thus ?case
	by(auto simp: stable_def opti\<^sub>a_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def)
	next
	case 3 thus ?case using pref_match_stable by auto
	next
	case (2 v A _ a' as)
	let ?M = "{<n} - set as"
	have "invAM A ?M" and m: "matching A ?M" and A: "wf A" and M: "?M \<subseteq> {<n}"
	and pref_match: "pref_match A ?M" and "opti\<^sub>a A" and "as \<noteq> []" and v: "var A ?M = v"
	and as: "invas as" using 2 by auto
	note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	from \<open>as \<noteq> []\<close> obtain a as' where aseq: "as = a # as'" by (fastforce simp: neq_Nil_conv)
	have set_as: "?M \<union> {a} = {<n} - set as'" using as aseq by force
	have a: "a < n \<and> a \<notin> ?M" using as unfolding aseq by (simp)
	show ?case
	proof (simp only: aseq list.sel, goal_cases)
	case 1 show ?case (is "(?not_matched \<longrightarrow> ?THEN) \<and> (\<not> ?not_matched \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?not_matched
	then have nm: "match A a \<notin> match A ` ?M" unfolding aseq .
	show ?THEN
	proof(simp only:mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1 show ?case using invAM_match[OF \<open>invAM A ?M\<close> a nm] as unfolding set_as by (simp add: aseq)
	case 2 show ?case
	using var_match[OF m M _ pref_match1, of a] a atLeast0LessThan
	unfolding set_as v by blast
	qed
	next
	assume matched: "\<not> ?not_matched"
	define a' where "a' = (SOME a'. a' \<in> ?M \<and> match A a' = match A a)"
	have a': "a' \<in> ?M \<and> match A a' = match A a" unfolding a'_def aseq using matched
	by (smt (verit) image_iff someI_ex)
	hence "a' < n" "a \<noteq> a'" using a M atLeast0LessThan by auto
	show ?ELSE unfolding aseq[symmetric] a'_def[symmetric]
	proof (goal_cases)
	case 1
	show ?case (is "(?pref \<longrightarrow> ?THEN) \<and> (\<not> ?pref \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?pref
	show ?THEN
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	have *: "{<n} - set as - {a'} \<union> {a} = {<n} - set (a' # as')" using a a' as aseq by auto
	case 1 show ?case using invAM_swap[OF \<open>invAM A ?M\<close> a a' \<open>?pref\<close>] unfolding *
	using a' as aseq by force
	case 2
	have "card({<n} - set as) = card({<n} - set (a' # as'))" using a a' as aseq by auto
	thus ?case using v var_next[OF m M _ pref_match1, of a'] \<open>a' < n\<close> a atLeast0LessThan
	by (metis Suc_eq_plus1 lessThan_iff var_def)
	qed
	next
	assume "\<not> ?pref"
	show ?ELSE
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1 show ?case using invAM_next[OF \<open>invAM A ?M\<close> a a' \<open>\<not> ?pref\<close>] as by blast

	case 2
	show ?case using a v var_next[OF m M _ pref_match1, of a]
	by (metis Suc_eq_plus1 atLeast0LessThan lessThan_iff)
	qed
	qed
	qed
	qed
	qed
	qed


	abbreviation invAB :: "nat list \<Rightarrow> (nat \<Rightarrow> nat option) \<Rightarrow> nat set \<Rightarrow> bool" where
	"invAB A B M == (ran B = M \<and> (\<forall>b a. B b = Some a \<longrightarrow> match A a = b))"

	lemma invAB_swap:
	assumes invAB: "invAB A B M"
	assumes a: "a < n \<and> a \<notin> M" and a': "a' \<in> M \<and> match A a' = match A a"
	and "inj_on B (dom B)" "B(match A a) = Some a'"
	shows "invAB (A[a' := A!a'+1]) (B(match A a := Some a)) (M - {a'} \<union> {a})"
	proof -
	have "\<forall>b x. b \<noteq> match A a \<longrightarrow> B b = Some x \<longrightarrow> a'\<noteq> x" using invAB a' by blast
	moreover have "a \<noteq> a'" using a a' by auto
	ultimately show ?thesis using assms by(simp add: ran_map_upd_Some match_def)
	qed


	subsection \<open>Algorithm 3: Record matching of Bs to As\<close>

	lemma Gale_Shapley3: "VARS A B a a' as b
	[as = [0..<n] \<and> A = replicate n 0 \<and> B = (\<lambda>_. None)]
	WHILE as \<noteq> []
	INV { invAM A ({<n} - set as) \<and> invAB A B ({<n} - set as) \<and> invas as}
	VAR {var A ({<n} - set as)}
	DO a := hd as; b := match A a;
	IF B b = None
	THEN B := B(b := Some a); as := tl as
	ELSE a' := the(B b);
	IF P\<^sub>b ! match A a' \<turnstile> a < a'
	THEN B := B(b := Some a); A[a'] := A!a'+1; as := a' # tl as
	ELSE A[a] := A!a+1
	FI
	FI
	OD
	[matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	proof (vcg_tc, goal_cases)
	case 1 thus ?case
	by(auto simp: stable_def opti\<^sub>a_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def)
	next
	case 3 thus ?case using pref_match_stable by auto
	next
	case (2 v A B _ a' as)
	let ?M = "{<n} - set as"
	have invAM: "invAM A ?M" and m: "matching A ?M" and A: "wf A" and M: "?M \<subseteq> {<n}"
	and pref_match: "pref_match A ?M" and "opti\<^sub>a A" and "as \<noteq> []" and v: "var A ?M = v"
	and as: "invas as" and invAB: "invAB A B ?M" using 2 by auto
	note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	from \<open>as \<noteq> []\<close> obtain a as' where aseq: "as = a # as'" by (fastforce simp: neq_Nil_conv)
	have set_as: "?M \<union> {a} = {<n} - set as'" using as aseq by force
	have a: "a < n \<and> a \<notin> ?M" using as unfolding aseq by (simp)
	show ?case
	proof (simp only: aseq list.sel, goal_cases)
	case 1 show ?case (is "(?not_matched \<longrightarrow> ?THEN) \<and> (\<not> ?not_matched \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?not_matched
	then have nm: "match A a \<notin> match A ` ?M" using invAB unfolding aseq ran_def
	apply (clarsimp simp: set_eq_iff) using not_None_eq by blast
	show ?THEN
	proof(simp only:mem_Collect_eq prod.case, rule conjI, goal_cases)
	have invAM': "invAM A ({<n} - set as')"
	using invAM_match[OF invAM a nm] unfolding set_as[symmetric] by simp
	have invAB': "invAB A (B(match A a := Some a)) ({<n} - set as')"
	using invAB \<open>?not_matched\<close> set_as by (simp)
	case 1 show ?case using invAM' as invAB' unfolding set_as aseq
	by (metis distinct.simps(2) insert_subset list.simps(15))
	case 2 show ?case
	using var_match[OF m M _ pref_match1, of a] a atLeast0LessThan
	unfolding set_as v by blast
	qed
	next
	assume matched: "\<not> ?not_matched"
	then obtain a' where a'eq: "B(match A a) = Some a'" by auto
	have a': "a' \<in> ?M \<and> match A a' = match A a" unfolding aseq using a'eq invAB
	by (metis ranI aseq)
	hence "a' < n" "a \<noteq> a'" using a M atLeast0LessThan by auto
	show ?ELSE unfolding aseq[symmetric] a'eq option.sel
	proof (goal_cases)
	have inj_dom: "inj_on B (dom B)" by (metis (mono_tags) domD inj_onI invAB)
	case 1
	show ?case (is "(?pref \<longrightarrow> ?THEN) \<and> (\<not> ?pref \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?pref
	show ?THEN
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	have *: "{<n} - set as - {a'} \<union> {a} = {<n} - set (a' # as')" using a a' as aseq by auto
	have a'neq: "\<forall>b x. b \<noteq> match A a \<longrightarrow> B b = Some x \<longrightarrow> a'\<noteq> x"
	using invAB a' by blast
	have invAB': "invAB (A[a' := A ! a' + 1]) (B(match A a := Some a)) ({<n} - insert a' (set as'))"
	using invAB_swap[OF invAB a a' inj_dom a'eq] * by simp
	case 1 show ?case using invAM_swap[OF invAM a a' \<open>?pref\<close>] invAB' unfolding *
	using a' as aseq by simp
	case 2
	have "card({<n} - set as) = card({<n} - set (a' # as'))" using a a' as aseq by auto
	thus ?case using v var_next[OF m M _ pref_match1, of a'] \<open>a' < n\<close> a atLeast0LessThan
	by (metis Suc_eq_plus1 lessThan_iff var_def)
	qed
	next
	assume "\<not> ?pref"
	show ?ELSE
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1
	have "invAB (A[a := A ! a + 1]) B ?M" using invAB a
	by (metis match_def nth_list_update_neq ranI)
	thus ?case using invAM_next[OF invAM a a' \<open>\<not> ?pref\<close>] as by blast
	case 2
	show ?case using a v var_next[OF m M _ pref_match1, of a]
	by (metis Suc_eq_plus1 atLeast0LessThan lessThan_iff)
	qed
	qed
	qed
	qed
	qed
	qed

	(* begin unused: directly implement function B via lists B and M (data refinement);
	also done in Alg. 4 in a more principled manner *)

	abbreviation invAB' :: "nat list \<Rightarrow> nat list \<Rightarrow> bool list \<Rightarrow> nat set \<Rightarrow> bool" where
	"invAB' A B M M' == (length B = n \<and> length M = n \<and> M' = nth B ` {b. b < n \<and> M!b}
	\<and> (\<forall>b<n. M!b \<longrightarrow> B!b < n \<and> match A (B!b) = b))"

	-lemma Gale_Shapley4': "VARS A B M a a' as b
	+lemma Gale_Shapley4_unused: "VARS A B M a a' as b
	[as = [0..<n] \<and> A = replicate n 0 \<and> B = replicate n 0 \<and> M = replicate n False]
	WHILE as \<noteq> []
	INV { invAM A ({<n} - set as) \<and> invAB' A B M ({<n} - set as) \<and> invas as}
	VAR {var A ({<n} - set as)}
	DO a := hd as; b := match A a;
	IF \<not> (M ! b)
	THEN M[b] := True; B[b] := a; as := tl as
	ELSE a' := B ! b;
	IF P\<^sub>b ! match A a' \<turnstile> a < a'
	THEN B[b] := a; A[a'] := A!a'+1; as := a' # tl as
	ELSE A[a] := A!a+1
	FI
	FI
	OD
	[wf A \<and> inj_on (match A) {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	proof (vcg_tc, goal_cases)
	case 1 thus ?case
	by(auto simp: stable_def opti\<^sub>a_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def)
	next
	case 3 thus ?case using pref_match_stable by auto
	next
	case (2 v A B M _ a' as)
	let ?M = "{<n} - set as"
	have invAM: "invAM A ?M" and m: "matching A ?M" and A: "wf A" and M: "?M \<subseteq> {<n}"
	and pref_match: "pref_match A ?M" and "opti\<^sub>a A" and notall: "as \<noteq> []" and v: "var A ?M = v"
	and as: "invas as" and invAB: "invAB' A B M ?M" using 2 by auto
	note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	from notall obtain a as' where aseq: "as = a # as'" by (fastforce simp: neq_Nil_conv)
	have set_as: "?M \<union> {a} = {<n} - set as'" using as aseq by force
	have a: "a < n \<and> a \<notin> ?M" using as unfolding aseq by (simp)
	show ?case
	proof (simp only: aseq list.sel, goal_cases)
	case 1 show ?case (is "(?not_matched \<longrightarrow> ?THEN) \<and> (\<not> ?not_matched \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?not_matched
	then have nm: "match A a \<notin> match A ` ?M" using invAB set_as unfolding aseq by force
	show ?THEN
	proof(simp only:mem_Collect_eq prod.case, rule conjI, goal_cases)
	have invAM': "invAM A ({<n} - set as')"
	using invAM_match[OF invAM a nm] unfolding set_as[symmetric] by simp
	then have invAB': "invAB' A (B[match A a := a]) (M[match A a := True]) ({<n} - set as')"
	using invAB \<open>?not_matched\<close> set_as match_less_n[OF A] a
	by (auto simp add: image_def nth_list_update)
	case 1 show ?case using invAM' invAB as invAB' unfolding set_as aseq
	by (metis distinct.simps(2) insert_subset list.simps(15))
	case 2 show ?case
	using var_match[OF m M _ pref_match1, of a] a atLeast0LessThan
	unfolding set_as v by blast
	qed
	next
	assume matched: "\<not> ?not_matched"
	hence "match A a \<in> match A ` ({<n} - insert a (set as'))" using match_less_n[OF A] a invAB
	apply(auto) by (metis (lifting) image_eqI list.simps(15) mem_Collect_eq aseq)
	hence "Suc(A!a) < n" using more_choices[OF m M, of a] a pref_match1
	using aseq atLeast0LessThan by auto
	let ?a = "B ! match A a"
	have a': "?a \<in> ?M \<and> match A ?a = match A a"
	using invAB match_less_n[OF A] matched a by blast
	hence "?a < n" "a \<noteq> ?a" using a by auto
	show ?ELSE unfolding aseq option.sel
	proof (goal_cases)
	case 1
	show ?case (is "(?pref \<longrightarrow> ?THEN) \<and> (\<not> ?pref \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?pref
	show ?THEN
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	have *: "{<n} - set as - {?a} \<union> {a} = {<n} - set (?a # as')" using a a' as aseq by auto
	have a'neq: "\<forall>b<n. b \<noteq> match A a \<longrightarrow> M!b \<longrightarrow> ?a \<noteq> B!b"
	using invAB a' by metis
	have invAB': "invAB' (A[?a := A ! ?a + 1]) (B[match A a := a]) M ({<n} - set (?a#as'))"
	using invAB aseq * \<open>a \<noteq> ?a\<close> a' match_less_n[OF A, of a] a
	apply (simp add: nth_list_update)
	apply rule
	apply(auto simp add: image_def)[]
	apply (clarsimp simp add: match_def)
	apply (metis (opaque_lifting) nth_list_update_neq)
	done
	case 1 show ?case using invAM_swap[OF invAM a a' \<open>?pref\<close>] invAB' unfolding *
	using a' as aseq by (auto)
	case 2
	have "card({<n} - set as) = card({<n} - set (?a # as'))" using a a' as aseq by simp
	thus ?case using v var_next[OF m M _ pref_match1, of ?a] \<open>?a < n\<close> a atLeast0LessThan
	by (metis Suc_eq_plus1 lessThan_iff var_def)
	qed
	next
	assume "\<not> ?pref"
	show ?ELSE
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1
	have "invAB' (A[a := A ! a + 1]) B M ({<n} - set as)" using invAB a \<open>a \<noteq> ?a\<close>
	by (metis match_def nth_list_update_neq)
	thus ?case using invAM_next[OF invAM a a' \<open>\<not> ?pref\<close>] as aseq by fastforce
	case 2
	show ?case using a v var_next[OF m M _ pref_match1, of a] aseq
	by (metis Suc_eq_plus1 atLeast0LessThan lessThan_iff)
	qed
	qed
	qed
	qed
	qed
	qed

	(* end unused *)


	subsection \<open>Algorithm 4: remove list of unmatched As\<close>

	lemma Gale_Shapley4:
	"VARS A B ai a a'
	[ai = 0 \<and> A = replicate n 0 \<and> B = (\<lambda>_. None)]
	WHILE ai < n
	INV { invAM A {<ai} \<and> invAB A B {<ai} \<and> ai \<le> n }
	VAR {z = n - ai}
	DO a := ai;
	WHILE B (match A a) \<noteq> None
	INV { invAM A ({<ai+1} - {a}) \<and> invAB A B ({<ai+1} - {a}) \<and> (a \<le> ai \<and> ai < n) \<and> z = n-ai }
	VAR {var A {<ai}}
	DO a' := the(B (match A a));
	IF P\<^sub>b ! match A a' \<turnstile> a < a'
	THEN B := B(match A a := Some a); A[a'] := A!a'+1; a := a'
	ELSE A[a] := A!a+1
	FI
	OD;
	B := B(match A a := Some a); ai := ai+1
	OD
	[matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	proof (vcg_tc, goal_cases)
	case 1 thus ?case (* outer invar holds initially *)
	by(auto simp: stable_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def opti\<^sub>a_def)[]
	next
	case 2 (* outer invar and b ibplies inner invar *)
	thus ?case by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
	next
	case (4 z A B ai a) (* inner invar' and not b ibplies outer invar *)
	note inv = 4[THEN conjunct1]
	note invAM = inv[THEN conjunct1]
	note aai = inv[THEN conjunct2,THEN conjunct2]
	show ?case
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1
	have *: "{<Suc ai} = insert a ({<Suc ai} - {a})" using aai by (simp add: insert_absorb)
	have **: "inj_on (match A) {<Suc ai} = (inj_on (match A) ({<Suc ai} - {a}) \<and> match A a \<notin> match A ` ({<Suc ai} - {a}))"
	by (metis "*" Diff_idemp inj_on_insert)
	have nm: "match A a \<notin> match A ` ({<Suc ai} - {a})" using 4 unfolding ran_def
	apply (clarsimp simp: set_eq_iff) by (metis not_None_eq)
	have invAM': "invAM A {<ai+1}"
	using invAM_match[OF invAM, of a] aai nm by (simp add: ** insert_absorb)
	show ?case using 4 invAM' by (simp add: insert_absorb)
	next
	case 2 thus ?case using 4 by auto
	qed
	next
	case 5 (* outer invar and not b implies post *)
	thus ?case using pref_match_stable unfolding invAM_def by (metis le_neq_implies_less)
	next
	case (3 z v A B ai a a') (* preservation of inner invar *)
	let ?M = "{<ai+1} - {a}"
	have invAM: "invAM A ?M" and m: "matching A ?M" and A: "wf A" and M: "?M \<subseteq> {<n}"
	and pref_match: "pref_match A ?M" and matched: "B(match A a) \<noteq> None" and "a \<le> ai"
	and v: "var A ?M = v" and as: "a \<le> ai \<and> ai < n" and invAB: "invAB A B ?M" using 3 by auto
	note invar = 3[THEN conjunct1,THEN conjunct1]
	note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	from matched obtain a' where a'eq: "B(match A a) = Some a'" by auto
	have a': "a' \<in> ?M \<and> match A a' = match A a" using a'eq invAB by (metis ranI)
	have a: "a < n \<and> a \<notin> ?M" using invar by auto
	have "?M \<noteq> {<n}" and "a' < n" using M a a' atLeast0LessThan by auto
	have card: "card {<ai} = card ?M" using \<open>a \<le> ai\<close> by simp
	show ?case unfolding a'eq option.sel
	proof (goal_cases)
	case 1
	show ?case (is "(?unstab \<longrightarrow> ?THEN) \<and> (\<not> ?unstab \<longrightarrow> ?ELSE)")
	proof (rule; rule)
	assume ?unstab
	have *: "{<ai + 1} - {a} - {a'} \<union> {a} = {<ai + 1} - {a'}" using invar a' by auto
	show ?THEN
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	have inj_dom: "inj_on B (dom B)" by (metis (mono_tags) domD inj_onI invAB)
	have invAB': "invAB (A[a' := A ! a' + 1]) (B(match A a \<mapsto> a)) ({<ai + 1} - {a'})"
	using invAB_swap[OF invAB a a' inj_dom a'eq] * by simp
	case 1 show ?case
	using invAM_swap[OF invAM a a' \<open>?unstab\<close>] invAB' invar a' unfolding * by (simp)
	next
	case 2
	show ?case using v var_next[OF m M \<open>?M \<noteq> {<n}\<close> pref_match1 \<open>a' < n\<close>] card
	by (metis var_def Suc_eq_plus1 psubset_eq)
	qed
	next
	assume "\<not> ?unstab"
	show ?ELSE
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	have *: "\<forall>b a'. B b = Some a' \<longrightarrow> a \<noteq> a'" by (metis invAB ranI a)
	case 1 show ?case using invAM_next[OF invAM a a' \<open>\<not> ?unstab\<close>] invar * by (simp add: match_def)
	next
	case 2
	show ?case using v var_next[OF m M \<open>?M \<noteq> {<n}\<close> pref_match1, of a] a card
	by (metis Suc_eq_plus1 var_def)
	qed
	qed
	qed
	qed

	definition "\<alpha> B M = (\<lambda>b. if b < n \<and> M!b then Some(B!b) else None)"

	lemma \<alpha>_Some[simp]: "\<alpha> B M b = Some a \<longleftrightarrow> b < n \<and> M!b \<and> a = B!b"
	by(auto simp add: \<alpha>_def)

	lemma \<alpha>update1: "\<lbrakk> \<not> M ! b; b < length B; b < length M; n = length M \<rbrakk>
	\<Longrightarrow> ran(\<alpha> (B[b := a]) (M[b := True])) = ran(\<alpha> B M) \<union> {a}"
	by(force simp add: \<alpha>_def ran_def nth_list_update)

	lemma \<alpha>update2: "\<lbrakk> M!b; b < length B; b < length M; length M = n \<rbrakk>
	\<Longrightarrow> \<alpha> (B[b := a]) M = (\<alpha> B M)(b := Some a)"
	by(force simp add: \<alpha>_def nth_list_update)


	abbreviation invAB2 :: "nat list \<Rightarrow> nat list \<Rightarrow> bool list \<Rightarrow> nat set \<Rightarrow> bool" where
	"invAB2 A B M M' == (invAB A (\<alpha> B M) M' \<and> (length B = n \<and> length M = n))"

	definition invar1 where
	[simp]: "invar1 A B M ai = (invAM A {<ai} \<and> invAB2 A B M {<ai} \<and> ai \<le> n)"

	definition invar2 where
	[simp]: "invar2 A B M ai a \<equiv> (invAM A ({<ai+1} - {a}) \<and> invAB2 A B M ({<ai+1} - {a}) \<and> a \<le> ai \<and> ai < n)"

	+text \<open>A single-loop variant of the nested-loop version.\<close>
	+
	+lemma Gale_Shapley4': "VARS A B a a' ai b
	+ [ai = 0 \<and> a = 0 \<and> A = replicate n 0 \<and> B = (\<lambda>_. None)]
	+ WHILE ai < n
	+ INV { invAM A ({<ai+1} - {a}) \<and> invAB A B ({<ai+1} - {a}) \<and> (a \<le> ai \<and> ai \<le> n) \<and> (ai=n \<longrightarrow> a=ai)}
	+ VAR {var A ({<ai+1} - {a})}
	+ DO b := match A a;
	+ IF B b = None
	+ THEN B := B(b := Some a); ai := ai + 1; a := ai
	+ ELSE a' := the(B b);
	+ IF P\<^sub>b ! match A a' \<turnstile> a < a'
	+ THEN B := B(b := Some a); A[a'] := A!a'+1; a := a'
	+ ELSE A[a] := A!a+1
	+ FI
	+ FI
	+ OD
	+ [matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	+proof (vcg_tc, goal_cases)
	+ case 1 thus ?case
	+ by(auto simp: stable_def opti\<^sub>a_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def)
	+next
	+ case 3 thus ?case using pref_match_stable
	+ using atLeast0_lessThan_Suc by force
	+next
	+ case (2 v A B a a' ai b)
	+ let ?M = "{<ai+1} - {a}"
	+ have invAM: "invAM A ?M" and m: "matching A ?M" and A: "wf A" and M: "?M \<subseteq> {<n}"
	+ and pref_match: "pref_match A ?M" and "a \<le> ai"
	+ and v: "var A ?M = v" and as: "a \<le> ai \<and> ai < n" and invAB: "invAB A B ?M" using 2 by auto
	+ note invar = 2[THEN conjunct1,THEN conjunct1]
	+ note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	+ hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	+ have a: "a < n \<and> a \<notin> ?M" using as by (simp)
	+ show ?case
	+ proof (goal_cases)
	+ case 1 show ?case (is "(?not_matched \<longrightarrow> ?THEN) \<and> (\<not> ?not_matched \<longrightarrow> ?ELSE)")
	+ proof (rule; rule)
	+ assume ?not_matched
	+ then have nm: "match A a \<notin> match A ` ?M" using invAB unfolding ran_def
	+ apply (clarsimp simp: set_eq_iff) using not_None_eq by blast
	+ show ?THEN
	+ proof(simp only:mem_Collect_eq prod.case, rule conjI, goal_cases)
	+ have *: "{<ai + 1 + 1} - {ai + 1} = {<ai + 1}" by auto
	+ have **: "{<ai + 1} - {a} \<union> {a} = {<ai + 1}" using \<open>a \<le> ai\<close> by auto
	+ hence invAM': "invAM A {<ai+1}"using invAM_match[OF invAM a nm] by simp
	+ have invAB': "invAB A (B(match A a := Some a)) {<ai+1}"
	+ using invAB \<open>?not_matched\<close> ** by (simp)
	+ case 1 show ?case using invAM' as invAB' *
	+ by presburger
	+ case 2 show ?case
	+ using var_match[OF m M _ pref_match1, of a] a atLeast0LessThan * **
	+ unfolding v by (metis lessThan_iff)
	+ qed
	+ next
	+ assume matched: "\<not> ?not_matched"
	+ then obtain a' where a'eq: "B(match A a) = Some a'" by auto
	+ have a': "a' \<in> ?M \<and> match A a' = match A a" using a'eq invAB
	+ by (metis ranI)
	+ hence "a' < n" "a \<noteq> a'" using a M atLeast0LessThan by auto
	+ show ?ELSE unfolding a'eq option.sel
	+ proof (goal_cases)
	+ have inj_dom: "inj_on B (dom B)" by (metis (mono_tags) domD inj_onI invAB)
	+ case 1
	+ show ?case (is "(?pref \<longrightarrow> ?THEN) \<and> (\<not> ?pref \<longrightarrow> ?ELSE)")
	+ proof (rule; rule)
	+ assume ?pref
	+ show ?THEN
	+ proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	+ have *: "{<ai + 1} - {a} - {a'} \<union> {a} = {<ai + 1} - {a'}" using a a' as by auto
	+ have a'neq: "\<forall>b x. b \<noteq> match A a \<longrightarrow> B b = Some x \<longrightarrow> a'\<noteq> x"
	+ using invAB a' by blast
	+ have invAB': "invAB (A[a' := A ! a' + 1]) (B(match A a := Some a)) ({<ai + 1} - {a'})"
	+ using invAB_swap[OF invAB a a' inj_dom a'eq] * by simp
	+ case 1 show ?case using invAM_swap[OF invAM a a' \<open>?pref\<close>] invAB' unfolding *
	+ using a' as by simp
	+ case 2
	+ have "card({<ai + 1} - {a'}) = card({<ai + 1} - {a})" using a a' as by auto
	+ thus ?case using v var_next[OF m M _ pref_match1, of a'] \<open>a' < n\<close> a atLeast0LessThan
	+ by (metis Suc_eq_plus1 lessThan_iff var_def)
	+ qed
	+ next
	+ assume "\<not> ?pref"
	+ show ?ELSE
	+ proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	+ case 1
	+ have "invAB (A[a := A ! a + 1]) B ?M" using invAB a
	+ by (metis match_def nth_list_update_neq ranI)
	+ thus ?case using invAM_next[OF invAM a a' \<open>\<not> ?pref\<close>] using "2" by presburger
	+ case 2
	+ show ?case using a v var_next[OF m M _ pref_match1, of a]
	+ by (metis Suc_eq_plus1 atLeast0LessThan lessThan_iff)
	+ qed
	+ qed
	+ qed
	+ qed
	+ qed
	+qed
	+

	subsection \<open>Algorithm 5: Data refinement of \<open>B\<close>\<close>

	lemma Gale_Shapley5:
	"VARS A B M ai a a'
	[ai = 0 \<and> A = replicate n 0 \<and> length B = n \<and> M = replicate n False]
	WHILE ai < n
	INV { invar1 A B M ai }
	VAR { z = n - ai}
	DO a := ai;
	WHILE M ! match A a
	INV { invar2 A B M ai a \<and> z = n-ai }
	VAR {var A {<ai}}
	DO a' := B ! match A a;
	IF P\<^sub>b ! match A a' \<turnstile> a < a'
	THEN B[match A a] := a; A[a'] := A!a'+1; a := a'
	ELSE A[a] := A!a+1
	FI
	OD;
	B[match A a] := a; M[match A a] := True; ai := ai+1
	OD
	[matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	proof (vcg_tc, goal_cases)
	case 1 thus ?case (* outer invar holds initially *)
	by(auto simp: stable_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
	next
	case 2 (* outer invar and b ibplies inner invar *)
	thus ?case by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
	next
	case (4 z A B M ai a) (* inner invar' and not b ibplies outer invar *)
	note inv = 4[THEN conjunct1, unfolded invar2_def]
	note invAM = inv[THEN conjunct1,THEN conjunct1]
	note aai = inv[THEN conjunct1, THEN conjunct2, THEN conjunct2]
	show ?case
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1
	have *: "{<Suc ai} = insert a ({<Suc ai} - {a})" using aai by (simp add: insert_absorb)
	have **: "inj_on (match A) {<Suc ai} = (inj_on (match A) ({<Suc ai} - {a}) \<and> match A a \<notin> match A ` ({<Suc ai} - {a}))"
	by (metis "*" Diff_idemp inj_on_insert)
	have nm: "match A a \<notin> match A ` ({<Suc ai} - {a})" using 4 unfolding invar2_def ran_def
	apply (clarsimp simp: set_eq_iff) by (metis)
	have invAM': "invAM A {<ai+1}"
	using invAM_match[OF invAM, of a] aai nm by (simp add: ** insert_absorb)
	show ?case using 4 invAM' by (simp add: \<alpha>update1 match_less_n insert_absorb nth_list_update)
	next
	case 2 thus ?case using 4 by auto
	qed
	next
	case 5 (* outer invar and not b ibplies post *)
	thus ?case using pref_match_stable unfolding invAM_def invar1_def by(metis le_neq_implies_less)
	next
	case (3 z v A B M ai a) (* preservation of inner invar *)
	let ?M = "{<ai+1} - {a}"
	have invAM: "invAM A ?M" and m: "matching A ?M" and A: "wf A" and M: "?M \<subseteq> {<n}"
	and pref_match: "pref_match A ?M" and matched: "M ! match A a"
	and v: "var A {<ai} = v" and as: "a \<le> ai \<and> ai < n" and invAB: "invAB2 A B M ?M"
	using 3 by auto
	note invar = 3[THEN conjunct1, THEN conjunct1, unfolded invar2_def]
	note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	let ?a = "B ! match A a"
	have a: "a < n \<and> a \<notin> ?M" using invar by auto
	have a': "?a \<in> ?M \<and> match A ?a = match A a"
	using invAB match_less_n[OF A] a matched by (metis \<alpha>_Some ranI)
	have "?M \<noteq> {<n}" and "?a < n" using M a a' atLeast0LessThan by auto
	have card: "card {<ai} = card ?M" using as by simp
	have *: "{<ai + 1} - {a} - {?a} \<union> {a} = {<ai + 1} - {?a}" using invar a' by auto
	show ?case
	proof (simp only: mem_Collect_eq prod.case, goal_cases)
	case 1
	show ?case
	proof ((rule;rule;rule), goal_cases)
	case unstab: 1
	have inj_dom: "inj_on (\<alpha> B M) (dom (\<alpha> B M))" by (metis (mono_tags) domD inj_onI invAB)
	have invAB': "invAB (A[B ! match A a := A ! ?a + 1]) (\<alpha> (B[match A a := a]) M) ({<ai + 1} - {?a})"
	using invAB_swap[OF invAB[THEN conjunct1] a a' inj_dom] * match_less_n[OF A] a matched invAB
	by(simp add:\<alpha>update2)
	show ?case using invAM_swap[OF invAM a a' unstab] invAB' invar a'
	unfolding * by (simp add: insert_absorb \<alpha>update2)

	case 2
	show ?case using v var_next[OF m M \<open>?M \<noteq> {<n}\<close> pref_match1 \<open>?a < n\<close>] card
	by (metis var_def Suc_eq_plus1)
	next
	case stab: 3
	have *: "\<forall>b. b < n \<and> M!b \<longrightarrow> a \<noteq> B!b" by (metis invAB ranI \<alpha>_Some a)
	show ?case using invAM_next[OF invAM a a' stab] invar * by (simp add: match_def)

	case 4
	show ?case using v var_next[OF m M \<open>?M \<noteq> {<n}\<close> pref_match1, of a] a card
	by (metis Suc_eq_plus1 var_def)
	qed
	qed
	qed

	lemma inner_to_outer:
	assumes inv: "invar2 A B M ai a \<and> b = match A a" and not_b: "\<not> M ! b"
	shows "invar1 A (B[b := a]) (M[b := True]) (ai+1)"
	proof -
	note invAM = inv[unfolded invar2_def, THEN conjunct1,THEN conjunct1]
	have *: "{<Suc ai} = insert a ({<Suc ai} - {a})" using inv by (simp add: insert_absorb)
	have **: "inj_on (match A) {<Suc ai} = (inj_on (match A) ({<Suc ai} - {a}) \<and> match A a \<notin> match A ` ({<Suc ai} - {a}))"
	by (metis "*" Diff_idemp inj_on_insert)
	have nm: "match A a \<notin> match A ` ({<Suc ai} - {a})" using inv not_b unfolding invar2_def ran_def
	apply (clarsimp simp: set_eq_iff) by (metis)
	have invAM': "invAM A {<ai+1}"
	using invAM_match[OF invAM, of a] inv nm by (simp add: ** insert_absorb)
	show ?thesis using inv not_b invAM' match_less_n by (clarsimp simp: \<alpha>update1 insert_absorb nth_list_update)
	qed

	lemma inner_pres:
	assumes R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R ! b ! a1 < R ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2" and
	inv: "invar2 A B M ai a" and m: "M ! b" and v: "var A {<ai} = v"
	and after: "A1 = A[B ! b := A ! (B ! b) + 1]" "A2 = A[a := A ! a + 1]"
	"a' = B!b" "r = R ! match A a'" "b = match A a"
	shows "(r ! a < r ! a' \<longrightarrow> invar2 A1 (B[b:=a]) M ai a' \<and> var A1 {<ai} < v) \<and>
	(\<not> r ! a < r ! a' \<longrightarrow> invar2 A2 B M ai a \<and> var A2 {<ai} < v)"
	proof -
	let ?M = "{<ai+1} - {a}"
	note [simp] = after
	note inv' = inv[unfolded invar2_def]
	have A: "wf A" and M: "?M \<subseteq> {<n}" and invAM: "invAM A ?M" and invAB: "invAB A (\<alpha> B M) ?M"
	and mat: "matching A ?M" and pref_match: "pref_match A ?M"
	and as: "a \<le> ai \<and> ai < n" using inv' by auto
	note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	let ?a = "B ! match A a"
	have a: "a < n \<and> a \<notin> ?M" using inv by auto
	have a': "?a \<in> ?M \<and> match A ?a = match A a"
	using invAB match_less_n[OF A] a m inv by (metis \<alpha>_Some ranI \<open>b = _\<close>)
	have "?M \<noteq> {<n}" and "?a < n" using M a a' atLeast0LessThan by auto
	have card: "card {<ai} = card ?M" using as by simp
	show ?thesis
	proof ((rule;rule;rule), goal_cases)
	have *: "{<ai + 1} - {a} - {?a} \<union> {a} = {<ai + 1} - {?a}" using inv a' by auto
	case 1
	hence unstab: "P\<^sub>b ! match A a' \<turnstile> a < a'"
	using R a a' as P\<^sub>b_set P\<^sub>a_set match_less_n[OF A] n_def length_P\<^sub>b R by (simp)
	have inj_dom: "inj_on (\<alpha> B M) (dom (\<alpha> B M))" by (metis (mono_tags) domD inj_onI invAB)
	have invAB': "invAB A1 (\<alpha> (B[match A a := a]) M) ({<ai + 1} - {?a})"
	using invAB_swap[OF invAB a a' inj_dom] * match_less_n[OF A] a m
	by (simp add: \<alpha>update2 inv')
	show ?case using invAM_swap[OF invAM a a'] unstab invAB' inv a'
	unfolding * by (simp add: insert_absorb \<alpha>update2)
	next
	case 2
	show ?case using v var_next[OF mat M \<open>?M \<noteq> {<n}\<close> pref_match1 \<open>?a < n\<close>] card assms(5,9)
	by (metis Suc_eq_plus1 var_def)
	next
	have *: "\<forall>b. b < n \<and> M!b \<longrightarrow> a \<noteq> B!b" by (metis invAB ranI \<alpha>_Some a)
	case 3
	hence unstab: "\<not> P\<^sub>b ! match A a' \<turnstile> a < a'"
	using R a a' as P\<^sub>b_set P\<^sub>a_set match_less_n[OF A] n_def length_P\<^sub>b
	by (simp add: ranking_iff_pref)
	then show ?case using invAM_next[OF invAM a a'] 3 inv * by (simp add: match_def)
	next
	case 4
	show ?case using v var_next[OF mat M \<open>?M \<noteq> {<n}\<close> pref_match1, of a] a card assms(6)
	by (metis Suc_eq_plus1 var_def)
	qed
	qed


	-subsection \<open>Algorithm 6: replace \<open>P\<^sub>b\<close> by ranking \<open>R\<close>\<close>
	+subsection \<open>Algorithm 6: replace \<open>P\<^sub>b\<close> by ranking \<open>R\<^sub>b\<close>\<close>

	lemma Gale_Shapley6:
	-assumes "R = map ranking P\<^sub>b"
	+assumes "R\<^sub>b = map ranking P\<^sub>b"
	shows
	"VARS A B M ai a a' b r
	[ai = 0 \<and> A = replicate n 0 \<and> length B = n \<and> M = replicate n False]
	WHILE ai < n
	INV { invar1 A B M ai }
	VAR {z = n - ai}
	DO a := ai; b := match A a;
	WHILE M ! b
	INV { invar2 A B M ai a \<and> b = match A a \<and> z = n-ai }
	VAR {var A {<ai}}
	- DO a' := B ! b; r := R ! match A a';
	+ DO a' := B ! b; r := R\<^sub>b ! match A a';
	IF r ! a < r ! a'
	THEN B[b] := a; A[a'] := A!a'+1; a := a'
	ELSE A[a] := A!a+1
	FI;
	b := match A a
	OD;
	B[b] := a; M[b] := True; ai := ai+1
	OD
	[matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	proof (vcg_tc, goal_cases)
	case 1 thus ?case (* outer invar holds initially *)
	by(auto simp: stable_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
	next
	case 2 (* outer invar and b ibplies inner invar *)
	thus ?case by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
	next
	case 3 (* preservation of inner invar *)
	- have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R ! b ! a1 < R ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
	- by (simp add: P\<^sub>b_set \<open>R = _\<close> length_P\<^sub>b ranking_iff_pref)
	+ have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R\<^sub>b ! b ! a1 < R\<^sub>b ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
	+ by (simp add: P\<^sub>b_set \<open>R\<^sub>b = _\<close> length_P\<^sub>b ranking_iff_pref)
	show ?case
	proof (simp only: mem_Collect_eq prod.case, goal_cases)
	case 1 show ?case using inner_pres[OF R _ _ refl refl refl] 3 by blast
	qed
	next
	case 4 (* inner invar' and not b ibplies outer invar *)
	show ?case
	proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	case 1 show ?case using 4 inner_to_outer by blast
	next
	case 2 thus ?case using 4 by auto
	qed
	next
	case 5 (* outer invar and not b ibplies post *)
	thus ?case using pref_match_stable unfolding invAM_def invar1_def by(metis le_neq_implies_less)
	qed

	+text \<open>A version where the inner variant does not depend on variables changed in the outer loop.
	+Thus the inner variant is an upper bound on the number of executions of the inner loop test/body.\<close>
	+
	+lemma var0_next2:
	+assumes "wf (A[a' := A ! a' + 1])" "a' < n"
	+shows "var0 (A[a' := A ! a' + 1]) {<n} < var0 A {<n}"
	+proof -
	+ let ?A = "A[a' := A ! a' + 1]"
	+ have 0: "card {<n} = n" by simp
	+ have *: "(\<Sum>a<n. ?A!a) + card {<n} \<le> n^2"
	+ using sumA_ub[OF assms(1)] 0 by (simp add: power2_eq_square algebra_simps le_diff_conv2)
	+ have "(\<Sum>a<n. A!a) < (\<Sum>a<n. ?A!a) "
	+ using assms sum.remove[of "{<n}" a' "(!) A"]
	+ by(simp add: nth_list_update sum.If_cases lessThan_atLeast0 Diff_eq)
	+ thus ?thesis using * unfolding var0_def by linarith
	+qed
	+
	+
	+lemma inner_pres2:
	+assumes R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R\<^sub>b ! b ! a1 < R\<^sub>b ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2" and
	+ inv: "invar2 A B M ai a" and m: "M ! b" and v: "var0 A {<n} = v"
	+ and after: "A1 = A[B ! b := A ! (B ! b) + 1]" "A2 = A[a := A ! a + 1]"
	+ "a' = B!b" "r = R\<^sub>b ! match A a'" "b = match A a"
	+shows "(r ! a < r ! a' \<longrightarrow> invar2 A1 (B[b:=a]) M ai a' \<and> var0 A1 {<n} < v) \<and>
	+ (\<not> r ! a < r ! a' \<longrightarrow> invar2 A2 B M ai a \<and> var0 A2 {<n} < v)"
	+proof -
	+ let ?M = "{<ai+1} - {a}"
	+ note [simp] = after
	+ note inv' = inv[unfolded invar2_def]
	+ have A: "wf A" and M: "?M \<subseteq> {<n}" and invAM: "invAM A ?M" and invAB: "invAB A (\<alpha> B M) ?M"
	+ and mat: "matching A ?M" and pref_match: "pref_match A ?M"
	+ and as: "a \<le> ai \<and> ai < n" using inv' by auto
	+ note pref_match' = pref_match[THEN pref_match'_iff[OF A, THEN iffD2]]
	+ hence pref_match1: "\<forall>a<n. preferred A a \<subseteq> match A ` ?M" unfolding pref_match'_def by blast
	+ let ?a = "B ! match A a"
	+ have a: "a < n \<and> a \<notin> ?M" using inv by auto
	+ have a': "?a \<in> ?M \<and> match A ?a = match A a"
	+ using invAB match_less_n[OF A] a m inv by (metis \<alpha>_Some ranI \<open>b = _\<close>)
	+ have "?M \<noteq> {<n}" and "?a < n" using M a a' atLeast0LessThan by auto
	+ have card: "card {<ai} = card ?M" using as by simp
	+ show ?thesis
	+ proof ((rule;rule;rule), goal_cases)
	+ have *: "{<ai + 1} - {a} - {?a} \<union> {a} = {<ai + 1} - {?a}" using inv a' by auto
	+ case 1
	+ hence unstab: "P\<^sub>b ! match A a' \<turnstile> a < a'"
	+ using R a a' as P\<^sub>b_set P\<^sub>a_set match_less_n[OF A] n_def length_P\<^sub>b R by (simp)
	+ have inj_dom: "inj_on (\<alpha> B M) (dom (\<alpha> B M))" by (metis (mono_tags) domD inj_onI invAB)
	+ have invAB': "invAB A1 (\<alpha> (B[match A a := a]) M) ({<ai + 1} - {?a})"
	+ using invAB_swap[OF invAB a a' inj_dom] * match_less_n[OF A] a m
	+ by (simp add: \<alpha>update2 inv')
	+ show ?case using invAM_swap[OF invAM a a'] unstab invAB' inv a'
	+ unfolding * by (simp add: insert_absorb \<alpha>update2)
	+ next
	+ case 2
	+ hence unstab: "P\<^sub>b ! match A a' \<turnstile> a < a'"
	+ using R a a' as P\<^sub>b_set P\<^sub>a_set match_less_n[OF A] n_def length_P\<^sub>b R by (simp)
	+ from invAM_swap[OF invAM a a'] unstab have wf: "wf (A[a' := A ! a' + 1])" by auto
	+ show ?case using v var0_next2[OF wf] using \<open>B ! match A a < n\<close> assms(5,7,9) by blast
	+ next
	+ have *: "\<forall>b. b < n \<and> M!b \<longrightarrow> a \<noteq> B!b" by (metis invAB ranI \<alpha>_Some a)
	+ case 3
	+ hence unstab: "\<not> P\<^sub>b ! match A a' \<turnstile> a < a'"
	+ using R a a' as P\<^sub>b_set P\<^sub>a_set match_less_n[OF A] n_def length_P\<^sub>b
	+ by (simp add: ranking_iff_pref)
	+ then show ?case using invAM_next[OF invAM a a'] 3 inv * by (simp add: match_def)
	+ next
	+ case 4
	+ hence unstab: "\<not> P\<^sub>b ! match A a' \<turnstile> a < a'"
	+ using R a a' as P\<^sub>b_set P\<^sub>a_set match_less_n[OF A] n_def length_P\<^sub>b
	+ by (simp add: ranking_iff_pref)
	+ from invAM_next[OF invAM a a'] unstab have wf: "wf (A[a := A ! a + 1])" by auto
	+ show ?case using v var0_next2[OF wf] a using assms(6) by presburger
	+ qed
	+qed
	+
	+lemma Gale_Shapley6':
	+assumes "R\<^sub>b = map ranking P\<^sub>b"
	+shows
	+"VARS A B M ai a a' b r
	+ [ai = 0 \<and> A = replicate n 0 \<and> length B = n \<and> M = replicate n False]
	+ WHILE ai < n
	+ INV { invar1 A B M ai }
	+ VAR {z = n - ai}
	+ DO a := ai; b := match A a;
	+ WHILE M ! b
	+ INV { invar2 A B M ai a \<and> b = match A a \<and> z = n-ai }
	+ VAR {var0 A {<n}}
	+ DO a' := B ! b; r := R\<^sub>b ! match A a';
	+ IF r ! a < r ! a'
	+ THEN B[b] := a; A[a'] := A!a'+1; a := a'
	+ ELSE A[a] := A!a+1
	+ FI;
	+ b := match A a
	+ OD;
	+ B[b] := a; M[b] := True; ai := ai+1
	+ OD
	+ [matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A]"
	+proof (vcg_tc, goal_cases)
	+ case 1 thus ?case (* outer invar holds initially *)
	+ by(auto simp: stable_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
	+next
	+ case 2 (* outer invar and b ibplies inner invar *)
	+ thus ?case by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
	+next
	+ case 3 (* preservation of inner invar *)
	+ have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R\<^sub>b ! b ! a1 < R\<^sub>b ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
	+ by (simp add: P\<^sub>b_set \<open>R\<^sub>b = _\<close> length_P\<^sub>b ranking_iff_pref)
	+ show ?case
	+ proof (simp only: mem_Collect_eq prod.case, goal_cases)
	+ case 1 show ?case using inner_pres2[OF R _ _ refl refl refl] 3 by blast
	+ qed
	+next
	+ case 4 (* inner invar' and not b ibplies outer invar *)
	+ show ?case
	+ proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
	+ case 1 show ?case using 4 inner_to_outer by blast
	+ next
	+ case 2 thus ?case using 4 by auto
	+ qed
	+next
	+ case 5 (* outer invar and not b ibplies post *)
	+ thus ?case using pref_match_stable unfolding invAM_def invar1_def by(metis le_neq_implies_less)
	+qed
	+
	+
	end


	subsection \<open>Functional implementation\<close>

	definition
	-"gs_inner P\<^sub>a R M =
	+"gs_inner P\<^sub>a R\<^sub>b M =
	while (\<lambda>(A,B,a,b). M!b)
	(\<lambda>(A,B,a,b).
	let a' = B ! b;
	- r = R ! (P\<^sub>a ! a' ! (A ! a')) in
	+ r = R\<^sub>b ! (P\<^sub>a ! a' ! (A ! a')) in
	let (A, B, a) =
	if r ! a < r ! a'
	then (A[a' := A!a' + 1], B[b := a], a')
	else (A[a := A!a + 1], B, a)
	in (A, B, a, P\<^sub>a ! a ! (A ! a)))"

	definition
	-"gs n P\<^sub>a R =
	+"gs n P\<^sub>a R\<^sub>b =
	while (\<lambda>(A,B,M,ai). ai < n)
	(\<lambda>(A,B,M,ai).
	- let (A,B,a,b) = gs_inner P\<^sub>a R M (A, B, ai, P\<^sub>a ! ai ! (A ! ai))
	+ let (A,B,a,b) = gs_inner P\<^sub>a R\<^sub>b M (A, B, ai, P\<^sub>a ! ai ! (A ! ai))
	in (A, B[b:=a], M[b:=True], ai+1))
	(replicate n 0, replicate n 0, replicate n False,0)"

	context Pref
	begin

	lemma gs_inner:
	-assumes "R = map ranking P\<^sub>b"
	+assumes "R\<^sub>b = map ranking P\<^sub>b"
	assumes "invar2 A B M ai a" "b = match A a"
	-shows "gs_inner P\<^sub>a R M (A, B, a, b) = (A',B',a',b') \<longrightarrow> invar1 A' (B'[b' := a']) (M[b' := True]) (ai+1)"
	+shows "gs_inner P\<^sub>a R\<^sub>b M (A, B, a, b) = (A',B',a',b') \<longrightarrow> invar1 A' (B'[b' := a']) (M[b' := True]) (ai+1)"
	unfolding gs_inner_def
	proof(rule while_rule2[where P = "\<lambda>(A,B,a,b). invar2 A B M ai a \<and> b = match A a"
	and r = "measure (%(A, B, a, b). Pref.var P\<^sub>a A {<ai})"], goal_cases)
	case 1
	show ?case using assms unfolding var_def by simp
	next
	case inv: (2 s)
	obtain A B a b where s: "s = (A, B, a, b)"
	using prod_cases4 by blast
	- have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R ! b ! a1 < R ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
	- by (simp add: P\<^sub>b_set \<open>R = _\<close> length_P\<^sub>b ranking_iff_pref)
	+ have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R\<^sub>b ! b ! a1 < R\<^sub>b ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
	+ by (simp add: P\<^sub>b_set \<open>R\<^sub>b = _\<close> length_P\<^sub>b ranking_iff_pref)
	show ?case
	proof(rule, goal_cases)
	case 1 show ?case
	using inv apply(simp only: s prod.case Let_def split: if_split)
	using inner_pres[OF R _ _ refl refl refl refl refl, of A B M ai a b]
	unfolding invar2_def match_def by presburger
	case 2 show ?case
	using inv apply(simp only: s prod.case Let_def in_measure split: if_split)
	using inner_pres[OF R _ _ refl refl refl refl refl, of A B M ai a b]
	unfolding invar2_def match_def by presburger
	qed
	next
	case 3
	show ?case
	proof (rule, goal_cases)
	case 1 show ?case by(rule inner_to_outer[OF 3[unfolded 1 prod.case]])
	qed
	next
	case 4
	show ?case by simp
	qed

	-lemma gs: assumes "R = map ranking P\<^sub>b"
	-shows "gs n P\<^sub>a R = (A,BMai) \<longrightarrow> matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A"
	+lemma gs: assumes "R\<^sub>b = map ranking P\<^sub>b"
	+shows "gs n P\<^sub>a R\<^sub>b = (A,BMai) \<longrightarrow> matching A {<n} \<and> stable A {<n} \<and> opti\<^sub>a A"
	unfolding gs_def
	proof(rule while_rule2[where P = "\<lambda>(A,B,M,ai). invar1 A B M ai"
	and r = "measure(\<lambda>(A,B,M,ai). n - ai)"], goal_cases)
	case 1 show ?case
	by(auto simp: stable_def pref_match_def P\<^sub>a_set card_distinct match_def index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
	next
	case (2 s)
	obtain A B M ai where s: "s = (A, B, M, ai)"
	using prod_cases4 by blast
	have 1: "invar2 A B M ai ai" using 2 s
	by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
	- show ?case using 2 s gs_inner[OF \<open>R = _ \<close> 1] by (auto simp: match_def simp del: invar1_def split: prod.split)
	+ show ?case using 2 s gs_inner[OF \<open>R\<^sub>b = _ \<close> 1] by (auto simp: match_def simp del: invar1_def split: prod.split)
	next
	case 3
	thus ?case using pref_match_stable by auto
	next
	case 4
	show ?case by simp
	qed

	end


	subsection \<open>Executable functional Code\<close>

	definition
	"Gale_Shapley P\<^sub>a P\<^sub>b = (if Pref P\<^sub>a P\<^sub>b then Some (fst (gs (length P\<^sub>a) P\<^sub>a (map ranking P\<^sub>b))) else None)"

	theorem gs: "\<lbrakk> Pref P\<^sub>a P\<^sub>b; n = length P\<^sub>a \<rbrakk> \<Longrightarrow>
	\<exists>A. Gale_Shapley P\<^sub>a P\<^sub>b = Some(A) \<and> Pref.matching P\<^sub>a A {<n} \<and>
	Pref.stable P\<^sub>a P\<^sub>b A {<n} \<and> Pref.opti\<^sub>a P\<^sub>a P\<^sub>b A"
	unfolding Gale_Shapley_def using Pref.gs
	by (metis fst_conv surj_pair)

	declare Pref_def [code]

	text \<open>Two examples from Gusfield and Irving:\<close>

	lemma "Gale_Shapley
	[[3,0,1,2], [1,2,0,3], [1,3,2,0], [2,0,3,1]]
	[[3,0,2,1], [0,2,1,3], [0,1,2,3], [3,0,2,1]]
	= Some[0,1,0,1]"
	by eval

	lemma "Gale_Shapley
	[[4,6,0,1,5,7,3,2], [1,2,6,4,3,0,7,5], [7,4,0,3,5,1,2,6], [2,1,6,3,0,5,7,4],
	[6,1,4,0,2,5,7,3], [0,5,6,4,7,3,1,2], [1,4,6,5,2,3,7,0], [2,7,3,4,6,1,5,0]]
	[[4,2,6,5,0,1,7,3], [7,5,2,4,6,1,0,3], [0,4,5,1,3,7,6,2], [7,6,2,1,3,0,4,5],
	[5,3,6,2,7,0,1,4], [1,7,4,2,3,5,6,0], [6,4,1,0,7,5,3,2], [6,3,0,4,1,2,5,7]]
	= Some [0, 1, 0, 5, 0, 0, 0, 2]"
	by eval

	end
	\ No newline at end of file
	diff --git a/thys/Girth_Chromatic/Ugraphs.thy b/thys/Girth_Chromatic/Ugraphs.thy
	--- a/thys/Girth_Chromatic/Ugraphs.thy
	+++ b/thys/Girth_Chromatic/Ugraphs.thy
	@@ -1,290 +1,293 @@
	theory Ugraphs
	imports
	Girth_Chromatic_Misc
	begin

	section \<open>Undirected Simple Graphs\<close>

	text \<open>
	In this section, we define some basics of graph theory needed to formalize
	the Chromatic-Girth theorem.
	\<close>

	text \<open>
	For readability, we introduce synonyms for the types of vertexes, edges,
	graphs and walks.
	\<close>
	type_synonym uvert = nat
	type_synonym uedge = "nat set"
	type_synonym ugraph = "uvert set \<times> uedge set"
	type_synonym uwalk = "uvert list"

	abbreviation uedges :: "ugraph \<Rightarrow> uedge set" where
	"uedges G \<equiv> snd G"

	abbreviation uverts :: "ugraph \<Rightarrow> uvert set" where
	"uverts G \<equiv> fst G"

	fun mk_uedge :: "uvert \<times> uvert \<Rightarrow> uedge" where
	"mk_uedge (u,v) = {u,v}"

	text \<open>All edges over a set of vertexes @{term S}:\<close>
	definition "all_edges S \<equiv> mk_uedge ` {uv \<in> S \<times> S. fst uv \<noteq> snd uv}"

	definition uwellformed :: "ugraph \<Rightarrow> bool" where
	"uwellformed G \<equiv> (\<forall>e\<in>uedges G. card e = 2 \<and> (\<forall>u \<in> e. u \<in> uverts G))"

	fun uwalk_edges :: "uwalk \<Rightarrow> uedge list" where
	"uwalk_edges [] = []"
	\| "uwalk_edges [x] = []"
	\| "uwalk_edges (x # y # ys) = {x,y} # uwalk_edges (y # ys)"

	definition uwalk_length :: "uwalk \<Rightarrow> nat" where
	"uwalk_length p \<equiv> length (uwalk_edges p)"

	definition uwalks :: "ugraph \<Rightarrow> uwalk set" where
	"uwalks G \<equiv> {p. set p \<subseteq> uverts G \<and> set (uwalk_edges p) \<subseteq> uedges G \<and> p \<noteq> []}"

	definition ucycles :: "ugraph \<Rightarrow> uwalk set" where
	"ucycles G \<equiv> {p. uwalk_length p \<ge> 3 \<and> p \<in> uwalks G \<and> distinct (tl p) \<and> hd p = last p}"

	definition remove_vertex :: "ugraph \<Rightarrow> nat \<Rightarrow> ugraph" ("_ -- _" [60,60] 60) where
	"remove_vertex G u \<equiv> (uverts G - {u}, uedges G - {A \<in> uedges G. u \<in> A})"


	subsection \<open>Basic Properties\<close>

	lemma uwalk_length_conv: "uwalk_length p = length p - 1"
	by (induct p rule: uwalk_edges.induct) (auto simp: uwalk_length_def)

	lemma all_edges_mono:
	"vs \<subseteq> ws \<Longrightarrow> all_edges vs \<subseteq> all_edges ws"
	unfolding all_edges_def by auto

	lemma all_edges_subset_Pow: "all_edges A \<subseteq> Pow A"
	by (auto simp: all_edges_def)

	lemma in_mk_uedge_img: "(a,b) \<in> A \<or> (b,a) \<in> A \<Longrightarrow> {a,b} \<in> mk_uedge ` A"
	by (auto intro: rev_image_eqI)

	+lemma in_mk_uedge_img_iff: "{a,b} \<in> mk_uedge ` A \<longleftrightarrow> (a,b) \<in> A \<or> (b,a) \<in> A"
	+ by (auto simp: doubleton_eq_iff intro: rev_image_eqI)
	+
	lemma distinct_edgesI:
	assumes "distinct p" shows "distinct (uwalk_edges p)"
	proof -
	from assms have "?thesis" "\<And>u. u \<notin> set p \<Longrightarrow> (\<And>v. u \<noteq> v \<Longrightarrow> {u,v} \<notin> set (uwalk_edges p))"
	by (induct p rule: uwalk_edges.induct) auto
	then show ?thesis by simp
	qed

	lemma finite_ucycles:
	assumes "finite (uverts G)"
	shows "finite (ucycles G)"
	proof -
	have "ucycles G \<subseteq> {xs. set xs \<subseteq> uverts G \<and> length xs \<le> Suc (card (uverts G))}"
	proof (rule, simp)
	fix p assume "p \<in> ucycles G"
	then have "distinct (tl p)" and "set p \<subseteq> uverts G"
	unfolding ucycles_def uwalks_def by auto
	moreover
	then have "set (tl p) \<subseteq> uverts G"
	by (auto simp: list_set_tl)
	with assms have "card (set (tl p)) \<le> card (uverts G)"
	by (rule card_mono)
	then have "length (p) \<le> 1 + card (uverts G)"
	using distinct_card[OF \<open>distinct (tl p)\<close>] by auto
	ultimately show "set p \<subseteq> uverts G \<and> length p \<le> Suc (card (uverts G))" by auto
	qed
	moreover
	have "finite {xs. set xs \<subseteq> uverts G \<and> length xs \<le> Suc (card (uverts G))}"
	using assms by (rule finite_lists_length_le)
	ultimately
	show ?thesis by (rule finite_subset)
	qed

	lemma ucycles_distinct_edges:
	assumes "c \<in> ucycles G" shows "distinct (uwalk_edges c)"
	proof -
	from assms have c_props: "distinct (tl c)" "4 \<le> length c" "hd c = last c"
	by (auto simp add: ucycles_def uwalk_length_conv)
	then have "{hd c, hd (tl c)} \<notin> set (uwalk_edges (tl c))"
	proof (induct c rule: uwalk_edges.induct)
	case (3 x y ys)
	then have "hd ys \<noteq> last ys" by (cases ys) auto
	moreover
	from 3 have "uwalk_edges (y # ys) = {y, hd ys} # uwalk_edges ys"
	by (cases ys) auto
	moreover
	{ fix xs have "set (uwalk_edges xs) \<subseteq> Pow (set xs)"
	by (induct xs rule: uwalk_edges.induct) auto }
	ultimately
	show ?case using 3 by auto
	qed simp_all
	moreover
	from assms have "distinct (uwalk_edges (tl c))"
	by (intro distinct_edgesI) (simp add: ucycles_def)
	ultimately
	show ?thesis by (cases c rule: list_exhaust3) auto
	qed

	lemma card_left_less_pair:
	fixes A :: "('a :: linorder) set"
	assumes "finite A"
	shows "card {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}
	= (card A * (card A - 1)) div 2"
	using assms
	proof (induct A)
	case (insert x A)

	show ?case
	proof (cases "card A")
	case (Suc n)
	have "{(a,b). a \<in> insert x A \<and> b \<in> insert x A \<and> a < b}
	= {(a,b). a \<in> A \<and> b \<in> A \<and> a < b} \<union> (\<lambda>a. if a < x then (a,x) else (x,a)) ` A"
	using \<open>x \<notin> A\<close> by (auto simp: order_less_le)
	moreover
	have "finite {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}"
	using insert by (auto intro: finite_subset[of _ "A \<times> A"])
	moreover
	have "{(a,b). a \<in> A \<and> b \<in> A \<and> a < b} \<inter> (\<lambda>a. if a < x then (a,x) else (x,a)) ` A = {}"
	using \<open>x \<notin> A\<close> by auto
	moreover have "inj_on (\<lambda>a. if a < x then (a, x) else (x, a)) A"
	by (auto intro: inj_onI split: if_split_asm)
	ultimately show ?thesis using insert Suc
	by (simp add: card_Un_disjoint card_image del: if_image_distrib)
	qed (simp add: card_eq_0_iff insert)
	qed simp

	lemma card_all_edges:
	assumes "finite A"
	shows "card (all_edges A) = card A choose 2"
	proof -
	have inj_on_mk_uedge: "inj_on mk_uedge {(a,b). a < b}"
	by (rule inj_onI) (auto simp: doubleton_eq_iff)
	have "all_edges A = mk_uedge ` {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}" (is "?L = ?R")
	by (auto simp: all_edges_def intro!: in_mk_uedge_img)
	then have "card ?L = card ?R" by simp
	also have "\<dots> = card {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}"
	using inj_on_mk_uedge by (blast intro: card_image subset_inj_on)
	also have "\<dots> = (card A * (card A - 1)) div 2"
	using card_left_less_pair using assms by simp
	also have "\<dots> = (card A choose 2)"
	by (simp add: n_choose_2_nat)
	finally show ?thesis .
	qed

	lemma verts_Gu: "uverts (G -- u) = uverts G - {u}"
	unfolding remove_vertex_def by simp

	lemma edges_Gu: "uedges (G -- u) \<subseteq> uedges G"
	unfolding remove_vertex_def by auto


	subsection \<open>Girth, Independence and Vertex Colorings\<close>

	definition girth :: "ugraph \<Rightarrow> enat" where
	"girth G \<equiv> INF p\<in> ucycles G. enat (uwalk_length p)"

	definition independent_sets :: "ugraph \<Rightarrow> uvert set set" where
	"independent_sets Gr \<equiv> {vs. vs \<subseteq> uverts Gr \<and> all_edges vs \<inter> uedges Gr = {}}"

	definition \<alpha> :: "ugraph \<Rightarrow> enat" where
	"\<alpha> G \<equiv> SUP vs \<in> independent_sets G. enat (card vs)"

	definition vertex_colorings :: "ugraph \<Rightarrow> uvert set set set" where
	"vertex_colorings G \<equiv> {C. \<Union>C = uverts G \<and> (\<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}) \<and>
	(\<forall>c\<in>C. c \<noteq> {} \<and> (\<forall>u \<in> c. \<forall>v \<in> c. {u,v} \<notin> uedges G))}"

	text \<open>The chromatic number $\chi$:\<close>
	definition chromatic_number :: "ugraph \<Rightarrow> enat" where
	"chromatic_number G \<equiv> INF c\<in> (vertex_colorings G). enat (card c)"

	lemma independent_sets_mono:
	"vs \<in> independent_sets G \<Longrightarrow> us \<subseteq> vs \<Longrightarrow> us \<in> independent_sets G"
	using Int_mono[OF all_edges_mono, of us vs "uedges G" "uedges G"]
	unfolding independent_sets_def by auto

	lemma le_\<alpha>_iff:
	assumes "0 < k"
	shows "k \<le> \<alpha> Gr \<longleftrightarrow> k \<in> card ` independent_sets Gr" (is "?L \<longleftrightarrow> ?R")
	proof
	assume ?L
	then obtain vs where "vs \<in> independent_sets Gr" and "k \<le> card vs"
	using assms unfolding \<alpha>_def enat_le_Sup_iff by auto
	moreover
	then obtain us where "us \<subseteq> vs" and "k = card us"
	using card_Ex_subset by auto
	ultimately
	have "us \<in> independent_sets Gr" by (auto intro: independent_sets_mono)
	then show ?R using \<open>k = card us\<close> by auto
	qed (auto intro: SUP_upper simp: \<alpha>_def)

	lemma zero_less_\<alpha>:
	assumes "uverts G \<noteq> {}"
	shows "0 < \<alpha> G"
	proof -
	from assms obtain a where "a \<in> uverts G" by auto
	then have "0 < enat (card {a})" "{a} \<in> independent_sets G"
	by (auto simp: independent_sets_def all_edges_def)
	then show ?thesis unfolding \<alpha>_def less_SUP_iff ..
	qed

	lemma \<alpha>_le_card:
	assumes "finite (uverts G)"
	shows "\<alpha> G \<le> card(uverts G)"
	proof -
	{ fix x assume "x \<in> independent_sets G"
	then have "x \<subseteq> uverts G" by (auto simp: independent_sets_def) }
	with assms show ?thesis unfolding \<alpha>_def
	by (intro SUP_least) (auto intro: card_mono)
	qed

	lemma \<alpha>_fin: "finite (uverts G) \<Longrightarrow> \<alpha> G \<noteq> \<infinity>"
	using \<alpha>_le_card[of G] by (cases "\<alpha> G") auto

	lemma \<alpha>_remove_le:
	shows "\<alpha> (G -- u) \<le> \<alpha> G"
	proof -
	have "independent_sets (G -- u) \<subseteq> independent_sets G" (is "?L \<subseteq> ?R")
	using all_edges_subset_Pow by (simp add: independent_sets_def remove_vertex_def) blast
	then show ?thesis unfolding \<alpha>_def
	by (rule SUP_subset_mono) simp
	qed

	text \<open>
	A lower bound for the chromatic number of a graph can be given in terms of
	the independence number
	\<close>
	lemma chromatic_lb:
	assumes wf_G: "uwellformed G"
	and fin_G: "finite (uverts G)"
	and neG: "uverts G \<noteq> {}"
	shows "card (uverts G) / \<alpha> G \<le> chromatic_number G"
	proof -
	from wf_G have "(\<lambda>v. {v}) ` uverts G \<in> vertex_colorings G"
	by (auto simp: vertex_colorings_def uwellformed_def)
	then have "chromatic_number G \<noteq> top"
	by (simp add: chromatic_number_def) (auto simp: top_enat_def)
	then obtain vc where vc_vc: "vc \<in> vertex_colorings G"
	and vc_size:"chromatic_number G = card vc"
	unfolding chromatic_number_def by (rule enat_in_INF)

	have fin_vc_elems: "\<And>c. c \<in> vc \<Longrightarrow> finite c"
	using vc_vc by (intro finite_subset[OF _ fin_G]) (auto simp: vertex_colorings_def)

	have sum_vc_card: "(\<Sum>c \<in> vc. card c) = card (uverts G)"
	using fin_vc_elems vc_vc unfolding vertex_colorings_def
	by (simp add: card_Union_disjoint[symmetric] pairwise_def disjnt_def)

	have "\<And>c. c \<in> vc \<Longrightarrow> c \<in> independent_sets G"
	using vc_vc by (auto simp: vertex_colorings_def independent_sets_def all_edges_def)
	then have "\<And>c. c \<in> vc \<Longrightarrow> card c \<le> \<alpha> G"
	using vc_vc fin_vc_elems by (subst le_\<alpha>_iff) (auto simp add: vertex_colorings_def)
	then have "(\<Sum>c\<in>vc. card c) \<le> card vc * \<alpha> G"
	using sum_bounded_above[of vc card "\<alpha> G"]
	by (simp add: of_nat_eq_enat[symmetric] of_nat_sum)
	then have "ereal_of_enat (card (uverts G)) \<le> ereal_of_enat (\<alpha> G) * ereal_of_enat (card vc)"
	by (simp add: sum_vc_card ereal_of_enat_pushout ac_simps del: ereal_of_enat_simps)
	with zero_less_\<alpha>[OF neG] \<alpha>_fin[OF fin_G] vc_size show ?thesis
	by (simp add: ereal_divide_le_pos)
	qed

	end
	diff --git a/thys/Groebner_Macaulay/Cone_Decomposition.thy b/thys/Groebner_Macaulay/Cone_Decomposition.thy
	--- a/thys/Groebner_Macaulay/Cone_Decomposition.thy
	+++ b/thys/Groebner_Macaulay/Cone_Decomposition.thy
	@@ -1,4888 +1,4888 @@
	(* Author: Alexander Maletzky *)

	section \<open>Cone Decompositions\<close>

	theory Cone_Decomposition
	imports Groebner_Bases.Groebner_PM Monomial_Module Hilbert_Function
	begin

	subsection \<open>More Properties of Reduced Gr\"obner Bases\<close>

	context pm_powerprod
	begin

	lemmas reduced_GB_subset_monic_Polys =
	punit.reduced_GB_subset_monic_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
	lemmas reduced_GB_is_monomial_set_Polys =
	punit.reduced_GB_is_monomial_set_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
	lemmas is_red_reduced_GB_monomial_lt_GB_Polys =
	punit.is_red_reduced_GB_monomial_lt_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
	lemmas reduced_GB_monomial_lt_reduced_GB_Polys =
	punit.reduced_GB_monomial_lt_reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]

	end

	subsection \<open>Quotient Ideals\<close>

	definition quot_set :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a::semigroup_mult set" (infixl "\<div>" 55)
	where "quot_set A x = (*) x -` A"

	lemma quot_set_iff: "a \<in> A \<div> x \<longleftrightarrow> x * a \<in> A"
	by (simp add: quot_set_def)

	lemma quot_setI: "x * a \<in> A \<Longrightarrow> a \<in> A \<div> x"
	by (simp only: quot_set_iff)

	lemma quot_setD: "a \<in> A \<div> x \<Longrightarrow> x * a \<in> A"
	by (simp only: quot_set_iff)

	lemma quot_set_quot_set [simp]: "A \<div> x \<div> y = A \<div> x * y"
	by (rule set_eqI) (simp add: quot_set_iff mult.assoc)

	lemma quot_set_one [simp]: "A \<div> (1::_::monoid_mult) = A"
	by (rule set_eqI) (simp add: quot_set_iff)

	lemma ideal_quot_set_ideal [simp]: "ideal (ideal B \<div> x) = (ideal B) \<div> (x::_::comm_ring)"
	proof
	show "ideal (ideal B \<div> x) \<subseteq> ideal B \<div> x"
	proof
	fix b
	assume "b \<in> ideal (ideal B \<div> x)"
	thus "b \<in> ideal B \<div> x"
	proof (induct b rule: ideal.span_induct')
	case base
	show ?case by (simp add: quot_set_iff ideal.span_zero)
	next
	case (step b q p)
	hence "x * b \<in> ideal B" and "x * p \<in> ideal B" by (simp_all add: quot_set_iff)
	hence "x * b + q * (x * p) \<in> ideal B"
	by (intro ideal.span_add ideal.span_scale[where c=q])
	thus ?case by (simp only: quot_set_iff algebra_simps)
	qed
	qed
	qed (fact ideal.span_superset)

	lemma quot_set_image_times: "inj (() x) \<Longrightarrow> (() x ` A) \<div> x = A"
	by (simp add: quot_set_def inj_vimage_image_eq)

	subsection \<open>Direct Decompositions of Polynomial Rings\<close>

	context pm_powerprod
	begin

	definition normal_form :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) set \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field)"
	where "normal_form F p = (SOME q. (punit.red (punit.reduced_GB F))\<^sup>\<^sup> p q \<and> \<not> punit.is_red (punit.reduced_GB F) q)"

	text \<open>Of course, @{const normal_form} could be defined in a much more general context.\<close>

	context
	fixes X :: "'x set"
	assumes fin_X: "finite X"
	begin

	context
	fixes F :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field) set"
	assumes F_sub: "F \<subseteq> P[X]"
	begin

	lemma normal_form:
	shows "(punit.red (punit.reduced_GB F))\<^sup>\<^sup> p (normal_form F p)" (is ?thesis1)
	and "\<not> punit.is_red (punit.reduced_GB F) (normal_form F p)" (is ?thesis2)
	proof -
	from fin_X F_sub have "finite (punit.reduced_GB F)" by (rule finite_reduced_GB_Polys)
	hence "wfP (punit.red (punit.reduced_GB F))\<inverse>\<inverse>" by (rule punit.red_wf_finite)
	then obtain q where "(punit.red (punit.reduced_GB F))\<^sup>\<^sup> p q"
	and "\<not> punit.is_red (punit.reduced_GB F) q" unfolding punit.is_red_def not_not
	by (rule relation.wf_imp_nf_ex)
	hence "(punit.red (punit.reduced_GB F))\<^sup>\<^sup> p q \<and> \<not> punit.is_red (punit.reduced_GB F) q" ..
	hence "?thesis1 \<and> ?thesis2" unfolding normal_form_def by (rule someI)
	thus ?thesis1 and ?thesis2 by simp_all
	qed

	lemma normal_form_unique:
	assumes "(punit.red (punit.reduced_GB F))\<^sup>\<^sup> p q" and "\<not> punit.is_red (punit.reduced_GB F) q"
	shows "normal_form F p = q"
	proof (rule relation.ChurchRosser_unique_final)
	from fin_X F_sub have "punit.is_Groebner_basis (punit.reduced_GB F)" by (rule reduced_GB_is_GB_Polys)
	thus "relation.is_ChurchRosser (punit.red (punit.reduced_GB F))"
	by (simp only: punit.is_Groebner_basis_def)
	next
	show "(punit.red (punit.reduced_GB F))\<^sup>\<^sup> p (normal_form F p)" by (rule normal_form)
	next
	have "\<not> punit.is_red (punit.reduced_GB F) (normal_form F p)" by (rule normal_form)
	thus "relation.is_final (punit.red (punit.reduced_GB F)) (normal_form F p)"
	by (simp add: punit.is_red_def)
	next
	from assms(2) show "relation.is_final (punit.red (punit.reduced_GB F)) q"
	by (simp add: punit.is_red_def)
	qed fact

	lemma normal_form_id_iff: "normal_form F p = p \<longleftrightarrow> (\<not> punit.is_red (punit.reduced_GB F) p)"
	proof
	assume "normal_form F p = p"
	with normal_form(2)[of p] show "\<not> punit.is_red (punit.reduced_GB F) p" by simp
	next
	assume "\<not> punit.is_red (punit.reduced_GB F) p"
	with rtranclp.rtrancl_refl show "normal_form F p = p" by (rule normal_form_unique)
	qed

	lemma normal_form_normal_form: "normal_form F (normal_form F p) = normal_form F p"
	by (simp add: normal_form_id_iff normal_form)

	lemma normal_form_zero: "normal_form F 0 = 0"
	by (simp add: normal_form_id_iff punit.irred_0)

	lemma normal_form_map_scale: "normal_form F (c \<cdot> p) = c \<cdot> (normal_form F p)"
	by (intro normal_form_unique punit.is_irred_map_scale normal_form)
	(simp add: punit.map_scale_eq_monom_mult punit.red_rtrancl_mult normal_form)

	lemma normal_form_uminus: "normal_form F (- p) = - normal_form F p"
	by (intro normal_form_unique punit.red_rtrancl_uminus normal_form)
	(simp add: punit.is_red_uminus normal_form)

	lemma normal_form_plus_normal_form:
	"normal_form F (normal_form F p + normal_form F q) = normal_form F p + normal_form F q"
	by (intro normal_form_unique rtranclp.rtrancl_refl punit.is_irred_plus normal_form)

	lemma normal_form_minus_normal_form:
	"normal_form F (normal_form F p - normal_form F q) = normal_form F p - normal_form F q"
	by (intro normal_form_unique rtranclp.rtrancl_refl punit.is_irred_minus normal_form)

	lemma normal_form_ideal_Polys: "normal_form (ideal F \<inter> P[X]) = normal_form F"
	proof -
	let ?F = "ideal F \<inter> P[X]"
	from fin_X have eq: "punit.reduced_GB ?F = punit.reduced_GB F"
	proof (rule reduced_GB_unique_Polys)
	from fin_X F_sub show "punit.is_reduced_GB (punit.reduced_GB F)"
	by (rule reduced_GB_is_reduced_GB_Polys)
	next
	from fin_X F_sub have "ideal (punit.reduced_GB F) = ideal F" by (rule reduced_GB_ideal_Polys)
	also have "\<dots> = ideal (ideal F \<inter> P[X])"
	proof (intro subset_antisym ideal.span_subset_spanI)
	from ideal.span_superset[of F] F_sub have "F \<subseteq> ideal F \<inter> P[X]" by simp
	thus "F \<subseteq> ideal (ideal F \<inter> P[X])" using ideal.span_superset by (rule subset_trans)
	qed blast
	finally show "ideal (punit.reduced_GB F) = ideal (ideal F \<inter> P[X])" .
	qed blast
	show ?thesis by (rule ext) (simp only: normal_form_def eq)
	qed

	lemma normal_form_diff_in_ideal: "p - normal_form F p \<in> ideal F"
	proof -
	from normal_form(1) have "p - normal_form F p \<in> ideal (punit.reduced_GB F)"
	by (rule punit.red_rtranclp_diff_in_pmdl[simplified])
	also from fin_X F_sub have "\<dots> = ideal F" by (rule reduced_GB_ideal_Polys)
	finally show ?thesis .
	qed

	lemma normal_form_zero_iff: "normal_form F p = 0 \<longleftrightarrow> p \<in> ideal F"
	proof
	assume "normal_form F p = 0"
	with normal_form_diff_in_ideal[of p] show "p \<in> ideal F" by simp
	next
	assume "p \<in> ideal F"
	hence "p - (p - normal_form F p) \<in> ideal F" using normal_form_diff_in_ideal
	by (rule ideal.span_diff)
	also from fin_X F_sub have "\<dots> = ideal (punit.reduced_GB F)" by (rule reduced_GB_ideal_Polys[symmetric])
	finally have *: "normal_form F p \<in> ideal (punit.reduced_GB F)" by simp
	show "normal_form F p = 0"
	proof (rule ccontr)
	from fin_X F_sub have "punit.is_Groebner_basis (punit.reduced_GB F)" by (rule reduced_GB_is_GB_Polys)
	moreover note *
	moreover assume "normal_form F p \<noteq> 0"
	ultimately obtain g where "g \<in> punit.reduced_GB F" and "g \<noteq> 0"
	and a: "lpp g adds lpp (normal_form F p)" by (rule punit.GB_adds_lt[simplified])
	note this(1, 2)
	moreover from \<open>normal_form F p \<noteq> 0\<close> have "lpp (normal_form F p) \<in> keys (normal_form F p)"
	by (rule punit.lt_in_keys)
	ultimately have "punit.is_red (punit.reduced_GB F) (normal_form F p)"
	using a by (rule punit.is_red_addsI[simplified])
	with normal_form(2) show False ..
	qed
	qed

	lemma normal_form_eq_iff: "normal_form F p = normal_form F q \<longleftrightarrow> p - q \<in> ideal F"
	proof -
	have "p - q - (normal_form F p - normal_form F q) = (p - normal_form F p) - (q - normal_form F q)"
	by simp
	also from normal_form_diff_in_ideal normal_form_diff_in_ideal have "\<dots> \<in> ideal F"
	by (rule ideal.span_diff)
	finally have *: "p - q - (normal_form F p - normal_form F q) \<in> ideal F" .
	show ?thesis
	proof
	assume "normal_form F p = normal_form F q"
	with * show "p - q \<in> ideal F" by simp
	next
	assume "p - q \<in> ideal F"
	hence "p - q - (p - q - (normal_form F p - normal_form F q)) \<in> ideal F" using *
	by (rule ideal.span_diff)
	hence "normal_form F (normal_form F p - normal_form F q) = 0" by (simp add: normal_form_zero_iff)
	thus "normal_form F p = normal_form F q" by (simp add: normal_form_minus_normal_form)
	qed
	qed

	lemma Polys_closed_normal_form:
	assumes "p \<in> P[X]"
	shows "normal_form F p \<in> P[X]"
	proof -
	from fin_X F_sub have "punit.reduced_GB F \<subseteq> P[X]" by (rule reduced_GB_Polys)
	with fin_X show ?thesis using assms normal_form(1)
	by (rule punit.dgrad_p_set_closed_red_rtrancl[OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum])
	qed

	lemma image_normal_form_iff:
	"p \<in> normal_form F ` P[X] \<longleftrightarrow> (p \<in> P[X] \<and> \<not> punit.is_red (punit.reduced_GB F) p)"
	proof
	assume "p \<in> normal_form F ` P[X]"
	then obtain q where "q \<in> P[X]" and p: "p = normal_form F q" ..
	from this(1) show "p \<in> P[X] \<and> \<not> punit.is_red (punit.reduced_GB F) p" unfolding p
	by (intro conjI Polys_closed_normal_form normal_form)
	next
	assume "p \<in> P[X] \<and> \<not> punit.is_red (punit.reduced_GB F) p"
	hence "p \<in> P[X]" and "\<not> punit.is_red (punit.reduced_GB F) p" by simp_all
	from this(2) have "normal_form F p = p" by (simp add: normal_form_id_iff)
	from this[symmetric] \<open>p \<in> P[X]\<close> show "p \<in> normal_form F ` P[X]" by (rule image_eqI)
	qed

	end

	lemma direct_decomp_ideal_insert:
	fixes F and f
	defines "I \<equiv> ideal (insert f F)"
	defines "L \<equiv> (ideal F \<div> f) \<inter> P[X]"
	assumes "F \<subseteq> P[X]" and "f \<in> P[X]"
	shows "direct_decomp (I \<inter> P[X]) [ideal F \<inter> P[X], (*) f ` normal_form L ` P[X]]"
	(is "direct_decomp _ ?ss")
	proof (rule direct_decompI_alt)
	fix qs
	assume "qs \<in> listset ?ss"
	then obtain x y where x: "x \<in> ideal F \<inter> P[X]" and y: "y \<in> (*) f ` normal_form L ` P[X]"
	and qs: "qs = [x, y]" by (rule listset_doubletonE)
	have "sum_list qs = x + y" by (simp add: qs)
	also have "\<dots> \<in> I \<inter> P[X]" unfolding I_def
	proof (intro IntI ideal.span_add Polys_closed_plus)
	have "ideal F \<subseteq> ideal (insert f F)" by (rule ideal.span_mono) blast
	with x show "x \<in> ideal (insert f F)" and "x \<in> P[X]" by blast+
	next
	from y obtain p where "p \<in> P[X]" and y: "y = f * normal_form L p" by blast
	have "f \<in> ideal (insert f F)" by (rule ideal.span_base) simp
	hence "normal_form L p * f \<in> ideal (insert f F)" by (rule ideal.span_scale)
	thus "y \<in> ideal (insert f F)" by (simp only: mult.commute y)

	have "L \<subseteq> P[X]" by (simp add: L_def)
	hence "normal_form L p \<in> P[X]" using \<open>p \<in> P[X]\<close> by (rule Polys_closed_normal_form)
	with assms(4) show "y \<in> P[X]" unfolding y by (rule Polys_closed_times)
	qed
	finally show "sum_list qs \<in> I \<inter> P[X]" .
	next
	fix a
	assume "a \<in> I \<inter> P[X]"
	hence "a \<in> I" and "a \<in> P[X]" by simp_all
	from assms(3, 4) have "insert f F \<subseteq> P[X]" by simp
	then obtain F0 q0 where "F0 \<subseteq> insert f F" and "finite F0" and q0: "\<And>f0. q0 f0 \<in> P[X]"
	and a: "a = (\<Sum>f0\<in>F0. q0 f0 * f0)"
	using \<open>a \<in> P[X]\<close> \<open>a \<in> I\<close> unfolding I_def by (rule in_idealE_Polys) blast
	obtain q a' where a': "a' \<in> ideal F" and "a' \<in> P[X]" and "q \<in> P[X]" and a: "a = q * f + a'"
	proof (cases "f \<in> F0")
	case True
	with \<open>F0 \<subseteq> insert f F\<close> have "F0 - {f} \<subseteq> F" by blast
	show ?thesis
	proof
	have "(\<Sum>f0\<in>F0 - {f}. q0 f0 * f0) \<in> ideal (F0 - {f})" by (rule ideal.sum_in_spanI)
	also from \<open>F0 - {f} \<subseteq> F\<close> have "\<dots> \<subseteq> ideal F" by (rule ideal.span_mono)
	finally show "(\<Sum>f0\<in>F0 - {f}. q0 f0 * f0) \<in> ideal F" .
	next
	show "(\<Sum>f0\<in>F0 - {f}. q0 f0 * f0) \<in> P[X]"
	proof (intro Polys_closed_sum Polys_closed_times q0)
	fix f0
	assume "f0 \<in> F0 - {f}"
	also have "\<dots> \<subseteq> F0" by blast
	also have "\<dots> \<subseteq> insert f F" by fact
	also have "\<dots> \<subseteq> P[X]" by fact
	finally show "f0 \<in> P[X]" .
	qed
	next
	from \<open>finite F0\<close> True show "a = q0 f * f + (\<Sum>f0\<in>F0 - {f}. q0 f0 * f0)"
	by (simp only: a sum.remove)
	qed fact
	next
	case False
	with \<open>F0 \<subseteq> insert f F\<close> have "F0 \<subseteq> F" by blast
	show ?thesis
	proof
	have "a \<in> ideal F0" unfolding a by (rule ideal.sum_in_spanI)
	also from \<open>F0 \<subseteq> F\<close> have "\<dots> \<subseteq> ideal F" by (rule ideal.span_mono)
	finally show "a \<in> ideal F" .
	next
	show "a = 0 * f + a" by simp
	qed (fact \<open>a \<in> P[X]\<close>, fact zero_in_Polys)
	qed
	let ?a = "f * (normal_form L q)"
	have "L \<subseteq> P[X]" by (simp add: L_def)
	hence "normal_form L q \<in> P[X]" using \<open>q \<in> P[X]\<close> by (rule Polys_closed_normal_form)
	with assms(4) have "?a \<in> P[X]" by (rule Polys_closed_times)
	from \<open>L \<subseteq> P[X]\<close> have "q - normal_form L q \<in> ideal L" by (rule normal_form_diff_in_ideal)
	also have "\<dots> \<subseteq> ideal (ideal F \<div> f)" unfolding L_def by (rule ideal.span_mono) blast
	finally have "f * (q - normal_form L q) \<in> ideal F" by (simp add: quot_set_iff)
	with \<open>a' \<in> ideal F\<close> have "a' + f * (q - normal_form L q) \<in> ideal F" by (rule ideal.span_add)
	hence "a - ?a \<in> ideal F" by (simp add: a algebra_simps)

	define qs where "qs = [a - ?a, ?a]"
	show "\<exists>!qs\<in>listset ?ss. a = sum_list qs"
	proof (intro ex1I conjI allI impI)
	have "a - ?a \<in> ideal F \<inter> P[X]"
	proof
	from assms(4) \<open>a \<in> P[X]\<close> \<open>normal_form L q \<in> P[X]\<close> show "a - ?a \<in> P[X]"
	by (intro Polys_closed_minus Polys_closed_times)
	qed fact
	moreover from \<open>q \<in> P[X]\<close> have "?a \<in> (*) f ` normal_form L ` P[X]" by (intro imageI)
	ultimately show "qs \<in> listset ?ss" using qs_def by (rule listset_doubletonI)
	next
	fix qs0
	assume "qs0 \<in> listset ?ss \<and> a = sum_list qs0"
	hence "qs0 \<in> listset ?ss" and "a = sum_list qs0" by simp_all
	from this(1) obtain x y where "x \<in> ideal F \<inter> P[X]" and "y \<in> (*) f ` normal_form L ` P[X]"
	and qs0: "qs0 = [x, y]" by (rule listset_doubletonE)
	from this(2) obtain a0 where "a0 \<in> P[X]" and y: "y = f * normal_form L a0" by blast
	from \<open>x \<in> ideal F \<inter> P[X]\<close> have "x \<in> ideal F" by simp
	have x: "x = a - y" by (simp add: \<open>a = sum_list qs0\<close> qs0)
	have "f * (normal_form L q - normal_form L a0) = x - (a - ?a)" by (simp add: x y a algebra_simps)
	also from \<open>x \<in> ideal F\<close> \<open>a - ?a \<in> ideal F\<close> have "\<dots> \<in> ideal F" by (rule ideal.span_diff)
	finally have "normal_form L q - normal_form L a0 \<in> ideal F \<div> f" by (rule quot_setI)
	moreover from \<open>L \<subseteq> P[X]\<close> \<open>q \<in> P[X]\<close> \<open>a0 \<in> P[X]\<close> have "normal_form L q - normal_form L a0 \<in> P[X]"
	by (intro Polys_closed_minus Polys_closed_normal_form)
	ultimately have "normal_form L q - normal_form L a0 \<in> L" by (simp add: L_def)
	also have "\<dots> \<subseteq> ideal L" by (fact ideal.span_superset)
	finally have "normal_form L q - normal_form L a0 = 0" using \<open>L \<subseteq> P[X]\<close>
	by (simp only: normal_form_minus_normal_form flip: normal_form_zero_iff)
	thus "qs0 = qs" by (simp add: qs0 qs_def x y)
	qed (simp_all add: qs_def)
	qed

	corollary direct_decomp_ideal_normal_form:
	assumes "F \<subseteq> P[X]"
	shows "direct_decomp P[X] [ideal F \<inter> P[X], normal_form F ` P[X]]"
	proof -
	from assms one_in_Polys have "direct_decomp (ideal (insert 1 F) \<inter> P[X]) [ideal F \<inter> P[X],
	(*) 1 ` normal_form ((ideal F \<div> 1) \<inter> P[X]) ` P[X]]"
	by (rule direct_decomp_ideal_insert)
	moreover have "ideal (insert 1 F) = UNIV"
	by (simp add: ideal_eq_UNIV_iff_contains_one ideal.span_base)
	moreover from refl have "((*) 1 \<circ> normal_form F) ` P[X] = normal_form F ` P[X]"
	by (rule image_cong) simp
	ultimately show ?thesis using assms by (simp add: image_comp normal_form_ideal_Polys)
	qed

	end

	subsection \<open>Basic Cone Decompositions\<close>

	definition cone :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_0) set"
	where "cone hU = (*) (fst hU) ` P[snd hU]"

	lemma coneI: "p = a * h \<Longrightarrow> a \<in> P[U] \<Longrightarrow> p \<in> cone (h, U)"
	by (auto simp: cone_def mult.commute[of a])

	lemma coneE:
	assumes "p \<in> cone (h, U)"
	obtains a where "a \<in> P[U]" and "p = a * h"
	using assms by (auto simp: cone_def mult.commute)

	lemma cone_empty: "cone (h, {}) = range (\<lambda>c. c \<cdot> h)"
	by (auto simp: Polys_empty map_scale_eq_times intro: coneI elim!: coneE)

	lemma cone_zero [simp]: "cone (0, U) = {0}"
	by (auto simp: cone_def intro: zero_in_Polys)

	lemma cone_one [simp]: "cone (1::_ \<Rightarrow>\<^sub>0 'a::comm_semiring_1, U) = P[U]"
	by (auto simp: cone_def)

	lemma zero_in_cone: "0 \<in> cone hU"
	by (auto simp: cone_def intro!: image_eqI zero_in_Polys)

	corollary empty_not_in_map_cone: "{} \<notin> set (map cone ps)"
	using zero_in_cone by fastforce

	lemma tip_in_cone: "h \<in> cone (h::_ \<Rightarrow>\<^sub>0 _::comm_semiring_1, U)"
	using _ one_in_Polys by (rule coneI) simp

	lemma cone_closed_plus:
	assumes "a \<in> cone hU" and "b \<in> cone hU"
	shows "a + b \<in> cone hU"
	proof -
	obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	with assms have "a \<in> cone (h, U)" and "b \<in> cone (h, U)" by simp_all
	from this(1) obtain a' where "a' \<in> P[U]" and a: "a = a' * h" by (rule coneE)
	from \<open>b \<in> cone (h, U)\<close> obtain b' where "b' \<in> P[U]" and b: "b = b' * h" by (rule coneE)
	have "a + b = (a' + b') * h" by (simp only: a b algebra_simps)
	moreover from \<open>a' \<in> P[U]\<close> \<open>b' \<in> P[U]\<close> have "a' + b' \<in> P[U]" by (rule Polys_closed_plus)
	ultimately show ?thesis unfolding hU by (rule coneI)
	qed

	lemma cone_closed_uminus:
	assumes "(a::_ \<Rightarrow>\<^sub>0 _::comm_ring) \<in> cone hU"
	shows "- a \<in> cone hU"
	proof -
	obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	with assms have "a \<in> cone (h, U)" by simp
	from this(1) obtain a' where "a' \<in> P[U]" and a: "a = a' * h" by (rule coneE)
	have "- a = (- a') * h" by (simp add: a)
	moreover from \<open>a' \<in> P[U]\<close> have "- a' \<in> P[U]" by (rule Polys_closed_uminus)
	ultimately show ?thesis unfolding hU by (rule coneI)
	qed

	lemma cone_closed_minus:
	assumes "(a::_ \<Rightarrow>\<^sub>0 _::comm_ring) \<in> cone hU" and "b \<in> cone hU"
	shows "a - b \<in> cone hU"
	proof -
	from assms(2) have "- b \<in> cone hU" by (rule cone_closed_uminus)
	with assms(1) have "a + (- b) \<in> cone hU" by (rule cone_closed_plus)
	thus ?thesis by simp
	qed

	lemma cone_closed_times:
	assumes "a \<in> cone (h, U)" and "q \<in> P[U]"
	shows "q * a \<in> cone (h, U)"
	proof -
	from assms(1) obtain a' where "a' \<in> P[U]" and a: "a = a' * h" by (rule coneE)
	have "q * a = (q * a') * h" by (simp only: a ac_simps)
	moreover from assms(2) \<open>a' \<in> P[U]\<close> have "q * a' \<in> P[U]" by (rule Polys_closed_times)
	ultimately show ?thesis by (rule coneI)
	qed

	corollary cone_closed_monom_mult:
	assumes "a \<in> cone (h, U)" and "t \<in> .[U]"
	shows "punit.monom_mult c t a \<in> cone (h, U)"
	proof -
	from assms(2) have "monomial c t \<in> P[U]" by (rule Polys_closed_monomial)
	with assms(1) have "monomial c t * a \<in> cone (h, U)" by (rule cone_closed_times)
	thus ?thesis by (simp only: times_monomial_left)
	qed

	lemma coneD:
	assumes "p \<in> cone (h, U)" and "p \<noteq> 0"
	shows "lpp h adds lpp (p::_ \<Rightarrow>\<^sub>0 _::{comm_semiring_0,semiring_no_zero_divisors})"
	proof -
	from assms(1) obtain a where p: "p = a * h" by (rule coneE)
	with assms(2) have "a \<noteq> 0" and "h \<noteq> 0" by auto
	hence "lpp p = lpp a + lpp h" unfolding p by (rule lp_times)
	also have "\<dots> = lpp h + lpp a" by (rule add.commute)
	finally show ?thesis by (rule addsI)
	qed

	lemma cone_mono_1:
	assumes "h' \<in> P[U]"
	shows "cone (h' * h, U) \<subseteq> cone (h, U)"
	proof
	fix p
	assume "p \<in> cone (h' * h, U)"
	then obtain a' where "a' \<in> P[U]" and "p = a' * (h' * h)" by (rule coneE)
	from this(2) have "p = a' * h' * h" by (simp only: mult.assoc)
	moreover from \<open>a' \<in> P[U]\<close> assms have "a' * h' \<in> P[U]" by (rule Polys_closed_times)
	ultimately show "p \<in> cone (h, U)" by (rule coneI)
	qed

	lemma cone_mono_2:
	assumes "U1 \<subseteq> U2"
	shows "cone (h, U1) \<subseteq> cone (h, U2)"
	proof
	from assms have "P[U1] \<subseteq> P[U2]" by (rule Polys_mono)
	fix p
	assume "p \<in> cone (h, U1)"
	then obtain a where "a \<in> P[U1]" and "p = a * h" by (rule coneE)
	note this(2)
	moreover from \<open>a \<in> P[U1]\<close> \<open>P[U1] \<subseteq> P[U2]\<close> have "a \<in> P[U2]" ..
	ultimately show "p \<in> cone (h, U2)" by (rule coneI)
	qed

	lemma cone_subsetD:
	assumes "cone (h1, U1) \<subseteq> cone (h2::_ \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}, U2)"
	shows "h2 dvd h1" and "h1 \<noteq> 0 \<Longrightarrow> U1 \<subseteq> U2"
	proof -
	from tip_in_cone assms have "h1 \<in> cone (h2, U2)" ..
	then obtain a1' where "a1' \<in> P[U2]" and h1: "h1 = a1' * h2" by (rule coneE)
	from this(2) have "h1 = h2 * a1'" by (simp only: mult.commute)
	thus "h2 dvd h1" ..

	assume "h1 \<noteq> 0"
	with h1 have "a1' \<noteq> 0" and "h2 \<noteq> 0" by auto
	show "U1 \<subseteq> U2"
	proof
	fix x
	assume "x \<in> U1"
	hence "monomial (1::'a) (Poly_Mapping.single x 1) \<in> P[U1]" (is "?p \<in> _")
	by (intro Polys_closed_monomial PPs_closed_single)
	with refl have "?p * h1 \<in> cone (h1, U1)" by (rule coneI)
	hence "?p * h1 \<in> cone (h2, U2)" using assms ..
	then obtain a where "a \<in> P[U2]" and "?p * h1 = a * h2" by (rule coneE)
	from this(2) have "(?p * a1') * h2 = a * h2" by (simp only: h1 ac_simps)
	hence "?p * a1' = a" using \<open>h2 \<noteq> 0\<close> by (rule times_canc_right)
	with \<open>a \<in> P[U2]\<close> have "a1' * ?p \<in> P[U2]" by (simp add: mult.commute)
	hence "?p \<in> P[U2]" using \<open>a1' \<in> P[U2]\<close> \<open>a1' \<noteq> 0\<close> by (rule times_in_PolysD)
	thus "x \<in> U2" by (simp add: Polys_def PPs_def)
	qed
	qed

	lemma cone_subset_PolysD:
	assumes "cone (h::_ \<Rightarrow>\<^sub>0 'a::{comm_semiring_1,semiring_no_zero_divisors}, U) \<subseteq> P[X]"
	shows "h \<in> P[X]" and "h \<noteq> 0 \<Longrightarrow> U \<subseteq> X"
	proof -
	from tip_in_cone assms show "h \<in> P[X]" ..

	assume "h \<noteq> 0"
	show "U \<subseteq> X"
	proof
	fix x
	assume "x \<in> U"
	hence "monomial (1::'a) (Poly_Mapping.single x 1) \<in> P[U]" (is "?p \<in> _")
	by (intro Polys_closed_monomial PPs_closed_single)
	with refl have "?p * h \<in> cone (h, U)" by (rule coneI)
	hence "?p * h \<in> P[X]" using assms ..
	hence "h * ?p \<in> P[X]" by (simp only: mult.commute)
	hence "?p \<in> P[X]" using \<open>h \<in> P[X]\<close> \<open>h \<noteq> 0\<close> by (rule times_in_PolysD)
	thus "x \<in> X" by (simp add: Polys_def PPs_def)
	qed
	qed

	lemma cone_subset_PolysI:
	assumes "h \<in> P[X]" and "h \<noteq> 0 \<Longrightarrow> U \<subseteq> X"
	shows "cone (h, U) \<subseteq> P[X]"
	proof (cases "h = 0")
	case True
	thus ?thesis by (simp add: zero_in_Polys)
	next
	case False
	hence "U \<subseteq> X" by (rule assms(2))
	hence "P[U] \<subseteq> P[X]" by (rule Polys_mono)
	show ?thesis
	proof
	fix a
	assume "a \<in> cone (h, U)"
	then obtain q where "q \<in> P[U]" and a: "a = q * h" by (rule coneE)
	from this(1) \<open>P[U] \<subseteq> P[X]\<close> have "q \<in> P[X]" ..
	from this assms(1) show "a \<in> P[X]" unfolding a by (rule Polys_closed_times)
	qed
	qed

	lemma cone_image_times: "() a ` cone (h, U) = cone (a h, U)"
	by (auto simp: ac_simps image_image intro!: image_eqI coneI elim!: coneE)

	lemma cone_image_times': "() a ` cone hU = cone (apfst (() a) hU)"
	proof -
	obtain h U where "hU = (h, U)" using prod.exhaust by blast
	thus ?thesis by (simp add: cone_image_times)
	qed

	lemma homogeneous_set_coneI:
	assumes "homogeneous h"
	shows "homogeneous_set (cone (h, U))"
	proof (rule homogeneous_setI)
	fix a n
	assume "a \<in> cone (h, U)"
	then obtain q where "q \<in> P[U]" and a: "a = q * h" by (rule coneE)
	from this(1) show "hom_component a n \<in> cone (h, U)" unfolding a
	proof (induct q rule: poly_mapping_plus_induct)
	case 1
	show ?case by (simp add: zero_in_cone)
	next
	case (2 p c t)
	have "p \<in> P[U]"
	proof (intro PolysI subsetI)
	fix s
	assume "s \<in> keys p"
	moreover from 2(2) this have "s \<notin> keys (monomial c t)" by auto
	ultimately have "s \<in> keys (monomial c t + p)" by (rule in_keys_plusI2)
	also from 2(4) have "\<dots> \<subseteq> .[U]" by (rule PolysD)
	finally show "s \<in> .[U]" .
	qed
	hence : "hom_component (p h) n \<in> cone (h, U)" by (rule 2(3))
	from 2(1) have "t \<in> keys (monomial c t)" by simp
	hence "t \<in> keys (monomial c t + p)" using 2(2) by (rule in_keys_plusI1)
	also from 2(4) have "\<dots> \<subseteq> .[U]" by (rule PolysD)
	finally have "monomial c t \<in> P[U]" by (rule Polys_closed_monomial)
	with refl have "monomial c t * h \<in> cone (h, U)" (is "?h \<in> _") by (rule coneI)
	from assms have "homogeneous ?h" by (simp add: homogeneous_times)
	hence "hom_component ?h n = (?h when n = poly_deg ?h)" by (rule hom_component_of_homogeneous)
	with \<open>?h \<in> cone (h, U)\<close> have **: "hom_component ?h n \<in> cone (h, U)"
	by (simp add: when_def zero_in_cone)
	have "hom_component ((monomial c t + p) * h) n = hom_component ?h n + hom_component (p * h) n"
	by (simp only: distrib_right hom_component_plus)
	also from ** * have "\<dots> \<in> cone (h, U)" by (rule cone_closed_plus)
	finally show ?case .
	qed
	qed

	lemma subspace_cone: "phull.subspace (cone hU)"
	using zero_in_cone cone_closed_plus
	proof (rule phull.subspaceI)
	fix c a
	assume "a \<in> cone hU"
	moreover obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	ultimately have "a \<in> cone (h, U)" by simp
	thus "c \<cdot> a \<in> cone hU" unfolding hU punit.map_scale_eq_monom_mult using zero_in_PPs
	by (rule cone_closed_monom_mult)
	qed

	lemma direct_decomp_cone_insert:
	fixes h :: "_ \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}"
	assumes "x \<notin> U"
	shows "direct_decomp (cone (h, insert x U))
	[cone (h, U), cone (monomial 1 (Poly_Mapping.single x (Suc 0)) * h, insert x U)]"
	proof -
	let ?x = "Poly_Mapping.single x (Suc 0)"
	define xx where "xx = monomial (1::'a) ?x"
	show "direct_decomp (cone (h, insert x U)) [cone (h, U), cone (xx * h, insert x U)]"
	(is "direct_decomp _ ?ss")
	proof (rule direct_decompI_alt)
	fix qs
	assume "qs \<in> listset ?ss"
	then obtain a b where "a \<in> cone (h, U)" and b: "b \<in> cone (xx * h, insert x U)"
	and qs: "qs = [a, b]" by (rule listset_doubletonE)
	note this(1)
	also have "cone (h, U) \<subseteq> cone (h, insert x U)" by (rule cone_mono_2) blast
	finally have a: "a \<in> cone (h, insert x U)" .
	have "cone (xx * h, insert x U) \<subseteq> cone (h, insert x U)"
	by (rule cone_mono_1) (simp add: xx_def Polys_def PPs_closed_single)
	with b have "b \<in> cone (h, insert x U)" ..
	with a have "a + b \<in> cone (h, insert x U)" by (rule cone_closed_plus)
	thus "sum_list qs \<in> cone (h, insert x U)" by (simp add: qs)
	next
	fix a
	assume "a \<in> cone (h, insert x U)"
	then obtain q where "q \<in> P[insert x U]" and a: "a = q * h" by (rule coneE)
	define qU where "qU = except q (- .[U])"
	define qx where "qx = except q .[U]"
	have q: "q = qU + qx" by (simp only: qU_def qx_def add.commute flip: except_decomp)
	have "qU \<in> P[U]" by (rule PolysI) (simp add: qU_def keys_except)
	have x_adds: "?x adds t" if "t \<in> keys qx" for t unfolding adds_poly_mapping le_fun_def
	proof
	fix y
	show "lookup ?x y \<le> lookup t y"
	proof (cases "y = x")
	case True
	from that have "t \<in> keys q" and "t \<notin> .[U]" by (simp_all add: qx_def keys_except)
	from \<open>q \<in> P[insert x U]\<close> have "keys q \<subseteq> .[insert x U]" by (rule PolysD)
	with \<open>t \<in> keys q\<close> have "t \<in> .[insert x U]" ..
	hence "keys t \<subseteq> insert x U" by (rule PPsD)
	moreover from \<open>t \<notin> .[U]\<close> have "\<not> keys t \<subseteq> U" by (simp add: PPs_def)
	ultimately have "x \<in> keys t" by blast
	thus ?thesis by (simp add: lookup_single True in_keys_iff)
	next
	case False
	thus ?thesis by (simp add: lookup_single)
	qed
	qed
	define qx' where "qx' = Poly_Mapping.map_key ((+) ?x) qx"
	have lookup_qx': "lookup qx' = (\<lambda>t. lookup qx (?x + t))"
	by (rule ext) (simp add: qx'_def map_key.rep_eq)
	have "qx' * xx = punit.monom_mult 1 ?x qx'"
	by (simp only: xx_def mult.commute flip: times_monomial_left)
	also have "\<dots> = qx"
	by (auto simp: punit.lookup_monom_mult lookup_qx' add.commute[of ?x] adds_minus
	simp flip: not_in_keys_iff_lookup_eq_zero dest: x_adds intro!: poly_mapping_eqI)
	finally have qx: "qx = qx' * xx" by (rule sym)
	have "qx' \<in> P[insert x U]"
	proof (intro PolysI subsetI)
	fix t
	assume "t \<in> keys qx'"
	hence "t + ?x \<in> keys qx" by (simp only: lookup_qx' in_keys_iff not_False_eq_True add.commute)
	also have "\<dots> \<subseteq> keys q" by (auto simp: qx_def keys_except)
	also from \<open>q \<in> P[insert x U]\<close> have "\<dots> \<subseteq> .[insert x U]" by (rule PolysD)
	finally have "(t + ?x) - ?x \<in> .[insert x U]" by (rule PPs_closed_minus)
	thus "t \<in> .[insert x U]" by simp
	qed
	define qs where "qs = [qU * h, qx' * (xx * h)]"
	show "\<exists>!qs\<in>listset ?ss. a = sum_list qs"
	proof (intro ex1I conjI allI impI)
	from refl \<open>qU \<in> P[U]\<close> have "qU * h \<in> cone (h, U)" by (rule coneI)
	moreover from refl \<open>qx' \<in> P[insert x U]\<close> have "qx' * (xx * h) \<in> cone (xx * h, insert x U)"
	by (rule coneI)
	ultimately show "qs \<in> listset ?ss" using qs_def by (rule listset_doubletonI)
	next
	fix qs0
	assume "qs0 \<in> listset ?ss \<and> a = sum_list qs0"
	hence "qs0 \<in> listset ?ss" and a0: "a = sum_list qs0" by simp_all
	from this(1) obtain p1 p2 where "p1 \<in> cone (h, U)" and p2: "p2 \<in> cone (xx * h, insert x U)"
	and qs0: "qs0 = [p1, p2]" by (rule listset_doubletonE)
	from this(1) obtain qU0 where "qU0 \<in> P[U]" and p1: "p1 = qU0 * h" by (rule coneE)
	from p2 obtain qx0 where p2: "p2 = qx0 * (xx * h)" by (rule coneE)
	show "qs0 = qs"
	proof (cases "h = 0")
	case True
	thus ?thesis by (simp add: qs_def qs0 p1 p2)
	next
	case False
	from a0 have "(qU - qU0) * h = (qx0 - qx') * xx * h"
	by (simp add: a qs0 p1 p2 q qx algebra_simps)
	hence eq: "qU - qU0 = (qx0 - qx') * xx" using False by (rule times_canc_right)
	have "qx0 = qx'"
	proof (rule ccontr)
	assume "qx0 \<noteq> qx'"
	hence "qx0 - qx' \<noteq> 0" by simp
	moreover have "xx \<noteq> 0" by (simp add: xx_def monomial_0_iff)
	ultimately have "lpp ((qx0 - qx') * xx) = lpp (qx0 - qx') + lpp xx"
	by (rule lp_times)
	also have "lpp xx = ?x" by (simp add: xx_def punit.lt_monomial)
	finally have "?x adds lpp (qU - qU0)" by (simp add: eq)
	hence "lookup ?x x \<le> lookup (lpp (qU - qU0)) x" by (simp only: adds_poly_mapping le_fun_def)
	hence "x \<in> keys (lpp (qU - qU0))" by (simp add: in_keys_iff lookup_single)
	moreover have "lpp (qU - qU0) \<in> keys (qU - qU0)"
	proof (rule punit.lt_in_keys)
	from \<open>qx0 - qx' \<noteq> 0\<close> \<open>xx \<noteq> 0\<close> show "qU - qU0 \<noteq> 0" unfolding eq by (rule times_not_zero)
	qed
	ultimately have "x \<in> indets (qU - qU0)" by (rule in_indetsI)
	from \<open>qU \<in> P[U]\<close> \<open>qU0 \<in> P[U]\<close> have "qU - qU0 \<in> P[U]" by (rule Polys_closed_minus)
	hence "indets (qU - qU0) \<subseteq> U" by (rule PolysD)
	with \<open>x \<in> indets (qU - qU0)\<close> have "x \<in> U" ..
	with assms show False ..
	qed
	moreover from this eq have "qU0 = qU" by simp
	ultimately show ?thesis by (simp only: qs_def qs0 p1 p2)
	qed
	qed (simp_all add: qs_def a q qx, simp only: algebra_simps)
	qed
	qed

	definition valid_decomp :: "'x set \<Rightarrow> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<times> 'x set) list \<Rightarrow> bool"
	where "valid_decomp X ps \<longleftrightarrow> ((\<forall>(h, U)\<in>set ps. h \<in> P[X] \<and> h \<noteq> 0 \<and> U \<subseteq> X))"

	definition monomial_decomp :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{one,zero}) \<times> 'x set) list \<Rightarrow> bool"
	where "monomial_decomp ps \<longleftrightarrow> (\<forall>hU\<in>set ps. is_monomial (fst hU) \<and> punit.lc (fst hU) = 1)"

	definition hom_decomp :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{one,zero}) \<times> 'x set) list \<Rightarrow> bool"
	where "hom_decomp ps \<longleftrightarrow> (\<forall>hU\<in>set ps. homogeneous (fst hU))"

	definition cone_decomp :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) set \<Rightarrow>
	((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_0) \<times> 'x set) list \<Rightarrow> bool"
	where "cone_decomp T ps \<longleftrightarrow> direct_decomp T (map cone ps)"

	lemma valid_decompI:
	"(\<And>h U. (h, U) \<in> set ps \<Longrightarrow> h \<in> P[X]) \<Longrightarrow> (\<And>h U. (h, U) \<in> set ps \<Longrightarrow> h \<noteq> 0) \<Longrightarrow>
	(\<And>h U. (h, U) \<in> set ps \<Longrightarrow> U \<subseteq> X) \<Longrightarrow> valid_decomp X ps"
	unfolding valid_decomp_def by blast

	lemma valid_decompD:
	assumes "valid_decomp X ps" and "(h, U) \<in> set ps"
	shows "h \<in> P[X]" and "h \<noteq> 0" and "U \<subseteq> X"
	using assms unfolding valid_decomp_def by blast+

	lemma valid_decompD_finite:
	assumes "finite X" and "valid_decomp X ps" and "(h, U) \<in> set ps"
	shows "finite U"
	proof -
	from assms(2, 3) have "U \<subseteq> X" by (rule valid_decompD)
	thus ?thesis using assms(1) by (rule finite_subset)
	qed

	lemma valid_decomp_Nil: "valid_decomp X []"
	by (simp add: valid_decomp_def)

	lemma valid_decomp_concat:
	assumes "\<And>ps. ps \<in> set pss \<Longrightarrow> valid_decomp X ps"
	shows "valid_decomp X (concat pss)"
	proof (rule valid_decompI)
	fix h U
	assume "(h, U) \<in> set (concat pss)"
	then obtain ps where "ps \<in> set pss" and "(h, U) \<in> set ps" unfolding set_concat ..
	from this(1) have "valid_decomp X ps" by (rule assms)
	thus "h \<in> P[X]" and "h \<noteq> 0" and "U \<subseteq> X" using \<open>(h, U) \<in> set ps\<close> by (rule valid_decompD)+
	qed

	corollary valid_decomp_append:
	assumes "valid_decomp X ps" and "valid_decomp X qs"
	shows "valid_decomp X (ps @ qs)"
	proof -
	have "valid_decomp X (concat [ps, qs])" by (rule valid_decomp_concat) (auto simp: assms)
	thus ?thesis by simp
	qed

	lemma valid_decomp_map_times:
	assumes "valid_decomp X ps" and "s \<in> P[X]" and "s \<noteq> (0::_ \<Rightarrow>\<^sub>0 _::semiring_no_zero_divisors)"
	shows "valid_decomp X (map (apfst ((*) s)) ps)"
	proof (rule valid_decompI)
	fix h U
	assume "(h, U) \<in> set (map (apfst ((*) s)) ps)"
	then obtain x where "x \<in> set ps" and "(h, U) = apfst ((*) s) x" unfolding set_map ..
	moreover obtain a b where "x = (a, b)" using prod.exhaust by blast
	ultimately have h: "h = s * a" and "(a, U) \<in> set ps" by simp_all
	from assms(1) this(2) have "a \<in> P[X]" and "a \<noteq> 0" and "U \<subseteq> X" by (rule valid_decompD)+
	from assms(2) this(1) show "h \<in> P[X]" unfolding h by (rule Polys_closed_times)
	from assms(3) \<open>a \<noteq> 0\<close> show "h \<noteq> 0" unfolding h by (rule times_not_zero)
	from \<open>U \<subseteq> X\<close> show "U \<subseteq> X" .
	qed

	lemma monomial_decompI:
	"(\<And>h U. (h, U) \<in> set ps \<Longrightarrow> is_monomial h) \<Longrightarrow> (\<And>h U. (h, U) \<in> set ps \<Longrightarrow> punit.lc h = 1) \<Longrightarrow>
	monomial_decomp ps"
	by (auto simp: monomial_decomp_def)

	lemma monomial_decompD:
	assumes "monomial_decomp ps" and "(h, U) \<in> set ps"
	shows "is_monomial h" and "punit.lc h = 1"
	using assms by (auto simp: monomial_decomp_def)

	lemma monomial_decomp_append_iff:
	"monomial_decomp (ps @ qs) \<longleftrightarrow> monomial_decomp ps \<and> monomial_decomp qs"
	by (auto simp: monomial_decomp_def)

	lemma monomial_decomp_concat:
	"(\<And>ps. ps \<in> set pss \<Longrightarrow> monomial_decomp ps) \<Longrightarrow> monomial_decomp (concat pss)"
	by (induct pss) (auto simp: monomial_decomp_def)

	lemma monomial_decomp_map_times:
	assumes "monomial_decomp ps" and "is_monomial f" and "punit.lc f = (1::'a::semiring_1)"
	shows "monomial_decomp (map (apfst ((*) f)) ps)"
	proof (rule monomial_decompI)
	fix h U
	assume "(h, U) \<in> set (map (apfst ((*) f)) ps)"
	then obtain x where "x \<in> set ps" and "(h, U) = apfst ((*) f) x" unfolding set_map ..
	moreover obtain a b where "x = (a, b)" using prod.exhaust by blast
	ultimately have h: "h = f * a" and "(a, U) \<in> set ps" by simp_all
	from assms(1) this(2) have "is_monomial a" and "punit.lc a = 1" by (rule monomial_decompD)+
	from this(1) have "monomial (punit.lc a) (lpp a) = a" by (rule punit.monomial_eq_itself)
	moreover define t where "t = lpp a"
	ultimately have a: "a = monomial 1 t" by (simp only: \<open>punit.lc a = 1\<close>)
	from assms(2) have "monomial (punit.lc f) (lpp f) = f" by (rule punit.monomial_eq_itself)
	moreover define s where "s = lpp f"
	ultimately have f: "f = monomial 1 s" by (simp only: assms(3))
	show "is_monomial h" by (simp add: h a f times_monomial_monomial monomial_is_monomial)
	show "punit.lc h = 1" by (simp add: h a f times_monomial_monomial)
	qed

	lemma monomial_decomp_monomial_in_cone:
	assumes "monomial_decomp ps" and "hU \<in> set ps" and "a \<in> cone hU"
	shows "monomial (lookup a t) t \<in> cone hU"
	proof (cases "t \<in> keys a")
	case True
	obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	with assms(2) have "(h, U) \<in> set ps" by simp
	with assms(1) have "is_monomial h" by (rule monomial_decompD)
	then obtain c s where h: "h = monomial c s" by (rule is_monomial_monomial)
	from assms(3) obtain q where "q \<in> P[U]" and "a = q * h" unfolding hU by (rule coneE)
	from this(2) have "a = h * q" by (simp only: mult.commute)
	also have "\<dots> = punit.monom_mult c s q" by (simp only: h times_monomial_left)
	finally have a: "a = punit.monom_mult c s q" .
	with True have "t \<in> keys (punit.monom_mult c s q)" by simp
	hence "t \<in> (+) s ` keys q" using punit.keys_monom_mult_subset[simplified] ..
	then obtain u where "u \<in> keys q" and t: "t = s + u" ..
	note this(1)
	also from \<open>q \<in> P[U]\<close> have "keys q \<subseteq> .[U]" by (rule PolysD)
	finally have "u \<in> .[U]" .
	have "monomial (lookup a t) t = monomial (lookup q u) u * h"
	by (simp add: a t punit.lookup_monom_mult h times_monomial_monomial mult.commute)
	moreover from \<open>u \<in> .[U]\<close> have "monomial (lookup q u) u \<in> P[U]" by (rule Polys_closed_monomial)
	ultimately show ?thesis unfolding hU by (rule coneI)
	next
	case False
	thus ?thesis by (simp add: zero_in_cone in_keys_iff)
	qed

	lemma monomial_decomp_sum_list_monomial_in_cone:
	assumes "monomial_decomp ps" and "a \<in> sum_list ` listset (map cone ps)" and "t \<in> keys a"
	obtains c h U where "(h, U) \<in> set ps" and "c \<noteq> 0" and "monomial c t \<in> cone (h, U)"
	proof -
	from assms(2) obtain qs where qs_in: "qs \<in> listset (map cone ps)" and a: "a = sum_list qs" ..
	from assms(3) keys_sum_list_subset have "t \<in> Keys (set qs)" unfolding a ..
	then obtain q where "q \<in> set qs" and "t \<in> keys q" by (rule in_KeysE)
	from this(1) obtain i where "i < length qs" and q: "q = qs ! i" by (metis in_set_conv_nth)
	moreover from qs_in have "length qs = length (map cone ps)" by (rule listsetD)
	ultimately have "i < length (map cone ps)" by simp
	moreover from qs_in this have "qs ! i \<in> (map cone ps) ! i" by (rule listsetD)
	ultimately have "ps ! i \<in> set ps" and "q \<in> cone (ps ! i)" by (simp_all add: q)
	with assms(1) have *: "monomial (lookup q t) t \<in> cone (ps ! i)"
	by (rule monomial_decomp_monomial_in_cone)
	obtain h U where psi: "ps ! i = (h, U)" using prod.exhaust by blast
	show ?thesis
	proof
	from \<open>ps ! i \<in> set ps\<close> show "(h, U) \<in> set ps" by (simp only: psi)
	next
	from \<open>t \<in> keys q\<close> show "lookup q t \<noteq> 0" by (simp add: in_keys_iff)
	next
	from * show "monomial (lookup q t) t \<in> cone (h, U)" by (simp only: psi)
	qed
	qed

	lemma hom_decompI: "(\<And>h U. (h, U) \<in> set ps \<Longrightarrow> homogeneous h) \<Longrightarrow> hom_decomp ps"
	by (auto simp: hom_decomp_def)

	lemma hom_decompD: "hom_decomp ps \<Longrightarrow> (h, U) \<in> set ps \<Longrightarrow> homogeneous h"
	by (auto simp: hom_decomp_def)

	lemma hom_decomp_append_iff: "hom_decomp (ps @ qs) \<longleftrightarrow> hom_decomp ps \<and> hom_decomp qs"
	by (auto simp: hom_decomp_def)

	lemma hom_decomp_concat: "(\<And>ps. ps \<in> set pss \<Longrightarrow> hom_decomp ps) \<Longrightarrow> hom_decomp (concat pss)"
	by (induct pss) (auto simp: hom_decomp_def)

	lemma hom_decomp_map_times:
	assumes "hom_decomp ps" and "homogeneous f"
	shows "hom_decomp (map (apfst ((*) f)) ps)"
	proof (rule hom_decompI)
	fix h U
	assume "(h, U) \<in> set (map (apfst ((*) f)) ps)"
	then obtain x where "x \<in> set ps" and "(h, U) = apfst ((*) f) x" unfolding set_map ..
	moreover obtain a b where "x = (a, b)" using prod.exhaust by blast
	ultimately have h: "h = f * a" and "(a, U) \<in> set ps" by simp_all
	from assms(1) this(2) have "homogeneous a" by (rule hom_decompD)
	with assms(2) show "homogeneous h" unfolding h by (rule homogeneous_times)
	qed

	lemma monomial_decomp_imp_hom_decomp:
	assumes "monomial_decomp ps"
	shows "hom_decomp ps"
	proof (rule hom_decompI)
	fix h U
	assume "(h, U) \<in> set ps"
	with assms have "is_monomial h" by (rule monomial_decompD)
	then obtain c t where h: "h = monomial c t" by (rule is_monomial_monomial)
	show "homogeneous h" unfolding h by (fact homogeneous_monomial)
	qed

	lemma cone_decompI: "direct_decomp T (map cone ps) \<Longrightarrow> cone_decomp T ps"
	unfolding cone_decomp_def by blast

	lemma cone_decompD: "cone_decomp T ps \<Longrightarrow> direct_decomp T (map cone ps)"
	unfolding cone_decomp_def by blast

	lemma cone_decomp_cone_subset:
	assumes "cone_decomp T ps" and "hU \<in> set ps"
	shows "cone hU \<subseteq> T"
	proof
	fix p
	assume "p \<in> cone hU"
	from assms(2) obtain i where "i < length ps" and hU: "hU = ps ! i" by (metis in_set_conv_nth)
	define qs where "qs = (map 0 ps)[i := p]"
	have "sum_list qs \<in> T"
	proof (intro direct_decompD listsetI)
	from assms(1) show "direct_decomp T (map cone ps)" by (rule cone_decompD)
	next
	fix j
	assume "j < length (map cone ps)"
	with \<open>i < length ps\<close> \<open>p \<in> cone hU\<close> show "qs ! j \<in> map cone ps ! j"
	by (auto simp: qs_def nth_list_update zero_in_cone hU)
	qed (simp add: qs_def)
	also have "sum_list qs = qs ! i" by (rule sum_list_eq_nthI) (simp_all add: qs_def \<open>i < length ps\<close>)
	also from \<open>i < length ps\<close> have "\<dots> = p" by (simp add: qs_def)
	finally show "p \<in> T" .
	qed

	lemma cone_decomp_indets:
	assumes "cone_decomp T ps" and "T \<subseteq> P[X]" and "(h, U) \<in> set ps"
	shows "h \<in> P[X]" and "h \<noteq> (0::_ \<Rightarrow>\<^sub>0 _::{comm_semiring_1,semiring_no_zero_divisors}) \<Longrightarrow> U \<subseteq> X"
	proof -
	from assms(1, 3) have "cone (h, U) \<subseteq> T" by (rule cone_decomp_cone_subset)
	hence "cone (h, U) \<subseteq> P[X]" using assms(2) by (rule subset_trans)
	thus "h \<in> P[X]" and "h \<noteq> 0 \<Longrightarrow> U \<subseteq> X" by (rule cone_subset_PolysD)+
	qed

	lemma cone_decomp_closed_plus:
	assumes "cone_decomp T ps" and "a \<in> T" and "b \<in> T"
	shows "a + b \<in> T"
	proof -
	from assms(1) have dd: "direct_decomp T (map cone ps)" by (rule cone_decompD)
	then obtain qsa where qsa: "qsa \<in> listset (map cone ps)" and a: "a = sum_list qsa" using assms(2)
	by (rule direct_decompE)
	from dd assms(3) obtain qsb where qsb: "qsb \<in> listset (map cone ps)" and b: "b = sum_list qsb"
	by (rule direct_decompE)
	from qsa have "length qsa = length (map cone ps)" by (rule listsetD)
	moreover from qsb have "length qsb = length (map cone ps)" by (rule listsetD)
	ultimately have "a + b = sum_list (map2 (+) qsa qsb)" by (simp only: sum_list_map2_plus a b)
	also from dd have "sum_list (map2 (+) qsa qsb) \<in> T"
	proof (rule direct_decompD)
	from qsa qsb show "map2 (+) qsa qsb \<in> listset (map cone ps)"
	proof (rule listset_closed_map2)
	fix c p1 p2
	assume "c \<in> set (map cone ps)"
	then obtain hU where c: "c = cone hU" by auto
	assume "p1 \<in> c" and "p2 \<in> c"
	thus "p1 + p2 \<in> c" unfolding c by (rule cone_closed_plus)
	qed
	qed
	finally show ?thesis .
	qed

	lemma cone_decomp_closed_uminus:
	assumes "cone_decomp T ps" and "(a::_ \<Rightarrow>\<^sub>0 _::comm_ring) \<in> T"
	shows "- a \<in> T"
	proof -
	from assms(1) have dd: "direct_decomp T (map cone ps)" by (rule cone_decompD)
	then obtain qsa where qsa: "qsa \<in> listset (map cone ps)" and a: "a = sum_list qsa" using assms(2)
	by (rule direct_decompE)
	from qsa have "length qsa = length (map cone ps)" by (rule listsetD)
	have "- a = sum_list (map uminus qsa)" unfolding a by (induct qsa, simp_all)
	also from dd have "\<dots> \<in> T"
	proof (rule direct_decompD)
	from qsa show "map uminus qsa \<in> listset (map cone ps)"
	proof (rule listset_closed_map)
	fix c p
	assume "c \<in> set (map cone ps)"
	then obtain hU where c: "c = cone hU" by auto
	assume "p \<in> c"
	thus "- p \<in> c" unfolding c by (rule cone_closed_uminus)
	qed
	qed
	finally show ?thesis .
	qed

	corollary cone_decomp_closed_minus:
	assumes "cone_decomp T ps" and "(a::_ \<Rightarrow>\<^sub>0 _::comm_ring) \<in> T" and "b \<in> T"
	shows "a - b \<in> T"
	proof -
	from assms(1, 3) have "- b \<in> T" by (rule cone_decomp_closed_uminus)
	with assms(1, 2) have "a + (- b) \<in> T" by (rule cone_decomp_closed_plus)
	thus ?thesis by simp
	qed

	lemma cone_decomp_Nil: "cone_decomp {0} []"
	by (auto simp: cone_decomp_def intro: direct_decompI_alt)

	lemma cone_decomp_singleton: "cone_decomp (cone (t, U)) [(t, U)]"
	by (simp add: cone_decomp_def direct_decomp_singleton)

	lemma cone_decomp_append:
	assumes "direct_decomp T [S1, S2]" and "cone_decomp S1 ps" and "cone_decomp S2 qs"
	shows "cone_decomp T (ps @ qs)"
	proof (rule cone_decompI)
	from assms(2) have "direct_decomp S1 (map cone ps)" by (rule cone_decompD)
	with assms(1) have "direct_decomp T ([S2] @ map cone ps)" by (rule direct_decomp_direct_decomp)
	hence "direct_decomp T (S2 # map cone ps)" by simp
	moreover from assms(3) have "direct_decomp S2 (map cone qs)" by (rule cone_decompD)
	ultimately have "direct_decomp T (map cone ps @ map cone qs)" by (intro direct_decomp_direct_decomp)
	thus "direct_decomp T (map cone (ps @ qs))" by simp
	qed

	lemma cone_decomp_concat:
	assumes "direct_decomp T ss" and "length pss = length ss"
	and "\<And>i. i < length ss \<Longrightarrow> cone_decomp (ss ! i) (pss ! i)"
	shows "cone_decomp T (concat pss)"
	using assms(2, 1, 3)
	proof (induct pss ss arbitrary: T rule: list_induct2)
	case Nil
	from Nil(1) show ?case by (simp add: cone_decomp_def)
	next
	case (Cons ps pss s ss)
	have "0 < length (s # ss)" by simp
	hence "cone_decomp ((s # ss) ! 0) ((ps # pss) ! 0)" by (rule Cons.prems)
	hence "cone_decomp s ps" by simp
	hence *: "direct_decomp s (map cone ps)" by (rule cone_decompD)
	with Cons.prems(1) have "direct_decomp T (ss @ map cone ps)" by (rule direct_decomp_direct_decomp)
	hence 1: "direct_decomp T [sum_list ` listset ss, sum_list ` listset (map cone ps)]"
	and 2: "direct_decomp (sum_list ` listset ss) ss"
	by (auto dest: direct_decomp_appendD intro!: empty_not_in_map_cone)
	note 1
	moreover from 2 have "cone_decomp (sum_list ` listset ss) (concat pss)"
	proof (rule Cons.hyps)
	fix i
	assume "i < length ss"
	hence "Suc i < length (s # ss)" by simp
	hence "cone_decomp ((s # ss) ! Suc i) ((ps # pss) ! Suc i)" by (rule Cons.prems)
	thus "cone_decomp (ss ! i) (pss ! i)" by simp
	qed
	moreover have "cone_decomp (sum_list ` listset (map cone ps)) ps"
	proof (intro cone_decompI direct_decompI refl)
	from * show "inj_on sum_list (listset (map cone ps))"
	by (simp only: direct_decomp_def bij_betw_def)
	qed
	ultimately have "cone_decomp T (concat pss @ ps)" by (rule cone_decomp_append)
	hence "direct_decomp T (map cone (concat pss) @ map cone ps)" by (simp add: cone_decomp_def)
	hence "direct_decomp T (map cone ps @ map cone (concat pss))"
	by (auto intro: direct_decomp_perm)
	thus ?case by (simp add: cone_decomp_def)
	qed

	lemma cone_decomp_map_times:
	assumes "cone_decomp T ps"
	shows "cone_decomp (() s ` T) (map (apfst (() (s::_ \<Rightarrow>\<^sub>0 _::{comm_ring_1,ring_no_zero_divisors}))) ps)"
	proof (rule cone_decompI)
	from assms have "direct_decomp T (map cone ps)" by (rule cone_decompD)
	hence "direct_decomp (() s ` T) (map ((`) (() s)) (map cone ps))"
	by (rule direct_decomp_image_times) (rule times_canc_left)
	also have "map ((`) (() s)) (map cone ps) = map cone (map (apfst (() s)) ps)"
	by (simp add: cone_image_times')
	finally show "direct_decomp (() s ` T) (map cone (map (apfst (() s)) ps))" .
	qed

	lemma cone_decomp_perm:
	assumes "cone_decomp T ps" and "mset ps = mset qs"
	shows "cone_decomp T qs"
	using assms(1) unfolding cone_decomp_def
	proof (rule direct_decomp_perm)
	from \<open>mset ps = mset qs\<close> show \<open>mset (map cone ps) = mset (map cone qs)\<close>
	by simp
	qed

	lemma valid_cone_decomp_subset_Polys:
	assumes "valid_decomp X ps" and "cone_decomp T ps"
	shows "T \<subseteq> P[X]"
	proof
	fix p
	assume "p \<in> T"
	from assms(2) have "direct_decomp T (map cone ps)" by (rule cone_decompD)
	then obtain qs where "qs \<in> listset (map cone ps)" and p: "p = sum_list qs" using \<open>p \<in> T\<close>
	by (rule direct_decompE)
	from assms(1) this(1) show "p \<in> P[X]" unfolding p
	proof (induct ps arbitrary: qs)
	case Nil
	from Nil(2) show ?case by (simp add: zero_in_Polys)
	next
	case (Cons a ps)
	obtain h U where a: "a = (h, U)" using prod.exhaust by blast
	hence "(h, U) \<in> set (a # ps)" by simp
	with Cons.prems(1) have "h \<in> P[X]" and "U \<subseteq> X" by (rule valid_decompD)+
	hence "cone a \<subseteq> P[X]" unfolding a by (rule cone_subset_PolysI)
	from Cons.prems(1) have "valid_decomp X ps" by (simp add: valid_decomp_def)
	from Cons.prems(2) have "qs \<in> listset (cone a # map cone ps)" by simp
	then obtain q qs' where "q \<in> cone a" and qs': "qs' \<in> listset (map cone ps)" and qs: "qs = q # qs'"
	by (rule listset_ConsE)
	from this(1) \<open>cone a \<subseteq> P[X]\<close> have "q \<in> P[X]" ..
	moreover from \<open>valid_decomp X ps\<close> qs' have "sum_list qs' \<in> P[X]" by (rule Cons.hyps)
	ultimately have "q + sum_list qs' \<in> P[X]" by (rule Polys_closed_plus)
	thus ?case by (simp add: qs)
	qed
	qed

	lemma homogeneous_set_cone_decomp:
	assumes "cone_decomp T ps" and "hom_decomp ps"
	shows "homogeneous_set T"
	proof (rule homogeneous_set_direct_decomp)
	from assms(1) show "direct_decomp T (map cone ps)" by (rule cone_decompD)
	next
	fix cn
	assume "cn \<in> set (map cone ps)"
	then obtain hU where "hU \<in> set ps" and cn: "cn = cone hU" unfolding set_map ..
	moreover obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	ultimately have "(h, U) \<in> set ps" by simp
	with assms(2) have "homogeneous h" by (rule hom_decompD)
	thus "homogeneous_set cn" unfolding cn hU by (rule homogeneous_set_coneI)
	qed

	lemma subspace_cone_decomp:
	assumes "cone_decomp T ps"
	shows "phull.subspace (T::(_ \<Rightarrow>\<^sub>0 _::field) set)"
	proof (rule phull.subspace_direct_decomp)
	from assms show "direct_decomp T (map cone ps)" by (rule cone_decompD)
	next
	fix cn
	assume "cn \<in> set (map cone ps)"
	then obtain hU where "hU \<in> set ps" and cn: "cn = cone hU" unfolding set_map ..
	show "phull.subspace cn" unfolding cn by (rule subspace_cone)
	qed

	definition pos_decomp :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<Rightarrow> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list"
	("(_\<^sub>+)" [1000] 999)
	where "pos_decomp ps = filter (\<lambda>p. snd p \<noteq> {}) ps"

	definition standard_decomp :: "nat \<Rightarrow> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<times> 'x set) list \<Rightarrow> bool"
	where "standard_decomp k ps \<longleftrightarrow> (\<forall>(h, U)\<in>set (ps\<^sub>+). k \<le> poly_deg h \<and>
	(\<forall>d. k \<le> d \<longrightarrow> d \<le> poly_deg h \<longrightarrow>
	(\<exists>(h', U')\<in>set ps. poly_deg h' = d \<and> card U \<le> card U')))"

	lemma pos_decomp_Nil [simp]: "[]\<^sub>+ = []"
	by (simp add: pos_decomp_def)

	lemma pos_decomp_subset: "set (ps\<^sub>+) \<subseteq> set ps"
	by (simp add: pos_decomp_def)

	lemma pos_decomp_append: "(ps @ qs)\<^sub>+ = ps\<^sub>+ @ qs\<^sub>+"
	by (simp add: pos_decomp_def)

	lemma pos_decomp_concat: "(concat pss)\<^sub>+ = concat (map pos_decomp pss)"
	by (metis (mono_tags, lifting) filter_concat map_eq_conv pos_decomp_def)

	lemma pos_decomp_map: "(map (apfst f) ps)\<^sub>+ = map (apfst f) (ps\<^sub>+)"
	by (metis (mono_tags, lifting) pos_decomp_def filter_cong filter_map o_apply snd_apfst)

	lemma card_Diff_pos_decomp: "card {(h, U) \<in> set qs - set (qs\<^sub>+). P h} = card {h. (h, {}) \<in> set qs \<and> P h}"
	proof -
	have "{h. (h, {}) \<in> set qs \<and> P h} = fst ` {(h, U) \<in> set qs - set (qs\<^sub>+). P h}"
	by (auto simp: pos_decomp_def image_Collect)
	also have "card \<dots> = card {(h, U) \<in> set qs - set (qs\<^sub>+). P h}"
	by (rule card_image, auto simp: pos_decomp_def intro: inj_onI)
	finally show ?thesis by (rule sym)
	qed

	lemma standard_decompI:
	assumes "\<And>h U. (h, U) \<in> set (ps\<^sub>+) \<Longrightarrow> k \<le> poly_deg h"
	and "\<And>h U d. (h, U) \<in> set (ps\<^sub>+) \<Longrightarrow> k \<le> d \<Longrightarrow> d \<le> poly_deg h \<Longrightarrow>
	(\<exists>h' U'. (h', U') \<in> set ps \<and> poly_deg h' = d \<and> card U \<le> card U')"
	shows "standard_decomp k ps"
	unfolding standard_decomp_def using assms by blast

	lemma standard_decompD: "standard_decomp k ps \<Longrightarrow> (h, U) \<in> set (ps\<^sub>+) \<Longrightarrow> k \<le> poly_deg h"
	unfolding standard_decomp_def by blast

	lemma standard_decompE:
	assumes "standard_decomp k ps" and "(h, U) \<in> set (ps\<^sub>+)" and "k \<le> d" and "d \<le> poly_deg h"
	obtains h' U' where "(h', U') \<in> set ps" and "poly_deg h' = d" and "card U \<le> card U'"
	using assms unfolding standard_decomp_def by blast

	lemma standard_decomp_Nil: "ps\<^sub>+ = [] \<Longrightarrow> standard_decomp k ps"
	by (simp add: standard_decomp_def)

	lemma standard_decomp_singleton: "standard_decomp (poly_deg h) [(h, U)]"
	by (simp add: standard_decomp_def pos_decomp_def)

	lemma standard_decomp_concat:
	assumes "\<And>ps. ps \<in> set pss \<Longrightarrow> standard_decomp k ps"
	shows "standard_decomp k (concat pss)"
	proof (rule standard_decompI)
	fix h U
	assume "(h, U) \<in> set ((concat pss)\<^sub>+)"
	then obtain ps where "ps \<in> set pss" and *: "(h, U) \<in> set (ps\<^sub>+)" by (auto simp: pos_decomp_concat)
	from this(1) have "standard_decomp k ps" by (rule assms)
	thus "k \<le> poly_deg h" using * by (rule standard_decompD)

	fix d
	assume "k \<le> d" and "d \<le> poly_deg h"
	with \<open>standard_decomp k ps\<close> * obtain h' U' where "(h', U') \<in> set ps" and "poly_deg h' = d"
	and "card U \<le> card U'" by (rule standard_decompE)
	note this(2, 3)
	moreover from \<open>(h', U') \<in> set ps\<close> \<open>ps \<in> set pss\<close> have "(h', U') \<in> set (concat pss)" by auto
	ultimately show "\<exists>h' U'. (h', U') \<in> set (concat pss) \<and> poly_deg h' = d \<and> card U \<le> card U'"
	by blast
	qed

	corollary standard_decomp_append:
	assumes "standard_decomp k ps" and "standard_decomp k qs"
	shows "standard_decomp k (ps @ qs)"
	proof -
	have "standard_decomp k (concat [ps, qs])" by (rule standard_decomp_concat) (auto simp: assms)
	thus ?thesis by simp
	qed

	lemma standard_decomp_map_times:
	assumes "standard_decomp k ps" and "valid_decomp X ps" and "s \<noteq> (0::_ \<Rightarrow>\<^sub>0 'a::semiring_no_zero_divisors)"
	shows "standard_decomp (k + poly_deg s) (map (apfst ((*) s)) ps)"
	proof (rule standard_decompI)
	fix h U
	assume "(h, U) \<in> set ((map (apfst ((*) s)) ps)\<^sub>+)"
	then obtain h0 where 1: "(h0, U) \<in> set (ps\<^sub>+)" and h: "h = s * h0" by (fastforce simp: pos_decomp_map)
	from this(1) pos_decomp_subset have "(h0, U) \<in> set ps" ..
	with assms(2) have "h0 \<noteq> 0" by (rule valid_decompD)
	with assms(3) have deg_h: "poly_deg h = poly_deg s + poly_deg h0" unfolding h by (rule poly_deg_times)
	moreover from assms(1) 1 have "k \<le> poly_deg h0" by (rule standard_decompD)
	ultimately show "k + poly_deg s \<le> poly_deg h" by simp

	fix d
	assume "k + poly_deg s \<le> d" and "d \<le> poly_deg h"
	hence "k \<le> d - poly_deg s" and "d - poly_deg s \<le> poly_deg h0" by (simp_all add: deg_h)
	with assms(1) 1 obtain h' U' where 2: "(h', U') \<in> set ps" and "poly_deg h' = d - poly_deg s"
	and "card U \<le> card U'" by (rule standard_decompE)
	from assms(2) this(1) have "h' \<noteq> 0" by (rule valid_decompD)
	with assms(3) have deg_h': "poly_deg (s * h') = poly_deg s + poly_deg h'" by (rule poly_deg_times)
	from 2 have "(s * h', U') \<in> set (map (apfst ((*) s)) ps)" by force
	moreover from \<open>k + poly_deg s \<le> d\<close> \<open>poly_deg h' = d - poly_deg s\<close> have "poly_deg (s * h') = d"
	by (simp add: deg_h')
	ultimately show "\<exists>h' U'. (h', U') \<in> set (map (apfst ((*) s)) ps) \<and> poly_deg h' = d \<and> card U \<le> card U'"
	using \<open>card U \<le> card U'\<close> by fastforce
	qed

	lemma standard_decomp_nonempty_unique:
	assumes "finite X" and "valid_decomp X ps" and "standard_decomp k ps" and "ps\<^sub>+ \<noteq> []"
	shows "k = Min (poly_deg ` fst ` set (ps\<^sub>+))"
	proof -
	let ?A = "poly_deg ` fst ` set (ps\<^sub>+)"
	define m where "m = Min ?A"
	have "finite ?A" by simp
	moreover from assms(4) have "?A \<noteq> {}" by simp
	ultimately have "m \<in> ?A" unfolding m_def by (rule Min_in)
	then obtain h U where "(h, U) \<in> set (ps\<^sub>+)" and m: "m = poly_deg h" by fastforce
	have m_min: "m \<le> poly_deg h'" if "(h', U') \<in> set (ps\<^sub>+)" for h' U'
	proof -
	from that have "poly_deg (fst (h', U')) \<in> ?A" by (intro imageI)
	with \<open>finite ?A\<close> have "m \<le> poly_deg (fst (h', U'))" unfolding m_def by (rule Min_le)
	thus ?thesis by simp
	qed
	show ?thesis
	proof (rule linorder_cases)
	assume "k < m"
	hence "k \<le> poly_deg h" by (simp add: m)
	with assms(3) \<open>(h, U) \<in> set (ps\<^sub>+)\<close> le_refl obtain h' U'
	where "(h', U') \<in> set ps" and "poly_deg h' = k" and "card U \<le> card U'" by (rule standard_decompE)
	from this(2) \<open>k < m\<close> have "\<not> m \<le> poly_deg h'" by simp
	with m_min have "(h', U') \<notin> set (ps\<^sub>+)" by blast
	with \<open>(h', U') \<in> set ps\<close> have "U' = {}" by (simp add: pos_decomp_def)
	with \<open>card U \<le> card U'\<close> have "U = {} \<or> infinite U" by (simp add: card_eq_0_iff)
	thus ?thesis
	proof
	assume "U = {}"
	with \<open>(h, U) \<in> set (ps\<^sub>+)\<close> show ?thesis by (simp add: pos_decomp_def)
	next
	assume "infinite U"
	moreover from assms(1, 2) have "finite U"
	proof (rule valid_decompD_finite)
	from \<open>(h, U) \<in> set (ps\<^sub>+)\<close> show "(h, U) \<in> set ps" by (simp add: pos_decomp_def)
	qed
	ultimately show ?thesis ..
	qed
	next
	assume "m < k"
	hence "\<not> k \<le> m" by simp
	moreover from assms(3) \<open>(h, U) \<in> set (ps\<^sub>+)\<close> have "k \<le> m" unfolding m by (rule standard_decompD)
	ultimately show ?thesis ..
	qed (simp only: m_def)
	qed

	lemma standard_decomp_SucE:
	assumes "finite X" and "U \<subseteq> X" and "h \<in> P[X]" and "h \<noteq> (0::_ \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors})"
	obtains ps where "valid_decomp X ps" and "cone_decomp (cone (h, U)) ps"
	and "standard_decomp (Suc (poly_deg h)) ps"
	and "is_monomial h \<Longrightarrow> punit.lc h = 1 \<Longrightarrow> monomial_decomp ps" and "homogeneous h \<Longrightarrow> hom_decomp ps"
	proof -
	from assms(2, 1) have "finite U" by (rule finite_subset)
	thus ?thesis using assms(2) that
	proof (induct U arbitrary: thesis rule: finite_induct)
	case empty
	from assms(3, 4) have "valid_decomp X [(h, {})]" by (simp add: valid_decomp_def)
	moreover note cone_decomp_singleton
	moreover have "standard_decomp (Suc (poly_deg h)) [(h, {})]"
	by (rule standard_decomp_Nil) (simp add: pos_decomp_def)
	ultimately show ?case by (rule empty) (simp_all add: monomial_decomp_def hom_decomp_def)
	next
	case (insert x U)
	from insert.prems(1) have "x \<in> X" and "U \<subseteq> X" by simp_all
	from this(2) obtain ps where 0: "valid_decomp X ps" and 1: "cone_decomp (cone (h, U)) ps"
	and 2: "standard_decomp (Suc (poly_deg h)) ps"
	and 3: "is_monomial h \<Longrightarrow> punit.lc h = 1 \<Longrightarrow> monomial_decomp ps"
	and 4: "homogeneous h \<Longrightarrow> hom_decomp ps" by (rule insert.hyps) blast
	let ?x = "monomial (1::'a) (Poly_Mapping.single x (Suc 0))"
	have "?x \<noteq> 0" by (simp add: monomial_0_iff)
	with assms(4) have deg: "poly_deg (?x * h) = Suc (poly_deg h)"
	by (simp add: poly_deg_times poly_deg_monomial deg_pm_single)
	define qs where "qs = [(?x * h, insert x U)]"
	show ?case
	proof (rule insert.prems)
	from \<open>x \<in> X\<close> have "?x \<in> P[X]" by (intro Polys_closed_monomial PPs_closed_single)
	hence "?x * h \<in> P[X]" using assms(3) by (rule Polys_closed_times)
	moreover from \<open>?x \<noteq> 0\<close> assms(4) have "?x * h \<noteq> 0" by (rule times_not_zero)
	ultimately have "valid_decomp X qs" using insert.hyps(1) \<open>x \<in> X\<close> \<open>U \<subseteq> X\<close>
	by (simp add: qs_def valid_decomp_def)
	with 0 show "valid_decomp X (ps @ qs)" by (rule valid_decomp_append)
	next
	show "cone_decomp (cone (h, insert x U)) (ps @ qs)"
	proof (rule cone_decomp_append)
	show "direct_decomp (cone (h, insert x U)) [cone (h, U), cone (?x * h, insert x U)]"
	using insert.hyps(2) by (rule direct_decomp_cone_insert)
	next
	show "cone_decomp (cone (?x * h, insert x U)) qs"
	by (simp add: qs_def cone_decomp_singleton)
	qed (fact 1)
	next
	from standard_decomp_singleton[of "?x * h" "insert x U"]
	have "standard_decomp (Suc (poly_deg h)) qs" by (simp add: deg qs_def)
	with 2 show "standard_decomp (Suc (poly_deg h)) (ps @ qs)" by (rule standard_decomp_append)
	next
	assume "is_monomial h" and "punit.lc h = 1"
	hence "monomial_decomp ps" by (rule 3)
	moreover have "monomial_decomp qs"
	proof -
	have "is_monomial (?x * h)"
	by (metis \<open>is_monomial h\<close> is_monomial_monomial monomial_is_monomial mult.commute
	mult.right_neutral mult_single)
	thus ?thesis by (simp add: monomial_decomp_def qs_def lc_times \<open>punit.lc h = 1\<close>)
	qed
	ultimately show "monomial_decomp (ps @ qs)" by (simp only: monomial_decomp_append_iff)
	next
	assume "homogeneous h"
	hence "hom_decomp ps" by (rule 4)
	moreover from \<open>homogeneous h\<close> have "hom_decomp qs"
	by (simp add: hom_decomp_def qs_def homogeneous_times)
	ultimately show "hom_decomp (ps @ qs)" by (simp only: hom_decomp_append_iff)
	qed
	qed
	qed

	lemma standard_decomp_geE:
	assumes "finite X" and "valid_decomp X ps"
	and "cone_decomp (T::(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}) set) ps"
	and "standard_decomp k ps" and "k \<le> d"
	obtains qs where "valid_decomp X qs" and "cone_decomp T qs" and "standard_decomp d qs"
	and "monomial_decomp ps \<Longrightarrow> monomial_decomp qs" and "hom_decomp ps \<Longrightarrow> hom_decomp qs"
	proof -
	have "\<exists>qs. valid_decomp X qs \<and> cone_decomp T qs \<and> standard_decomp (k + i) qs \<and>
	(monomial_decomp ps \<longrightarrow> monomial_decomp qs) \<and> (hom_decomp ps \<longrightarrow> hom_decomp qs)" for i
	proof (induct i)
	case 0
	from assms(2, 3, 4) show ?case unfolding add_0_right by blast
	next
	case (Suc i)
	then obtain qs where 0: "valid_decomp X qs" and 1: "cone_decomp T qs"
	and 2: "standard_decomp (k + i) qs" and 3: "monomial_decomp ps \<Longrightarrow> monomial_decomp qs"
	and 4: "hom_decomp ps \<Longrightarrow> hom_decomp qs" by blast
	let ?P = "\<lambda>hU. poly_deg (fst hU) \<noteq> k + i"
	define rs where "rs = filter (- ?P) qs"
	define ss where "ss = filter ?P qs"

	have "set rs \<subseteq> set qs" by (auto simp: rs_def)
	have "set ss \<subseteq> set qs" by (auto simp: ss_def)

	define f where "f = (\<lambda>hU. SOME ps'. valid_decomp X ps' \<and> cone_decomp (cone hU) ps' \<and>
	standard_decomp (Suc (poly_deg ((fst hU)::('x \<Rightarrow>\<^sub>0 _) \<Rightarrow>\<^sub>0 'a))) ps' \<and>
	(monomial_decomp ps \<longrightarrow> monomial_decomp ps') \<and>
	(hom_decomp ps \<longrightarrow> hom_decomp ps'))"
	have "valid_decomp X (f hU) \<and> cone_decomp (cone hU) (f hU) \<and> standard_decomp (Suc (k + i)) (f hU) \<and>
	(monomial_decomp ps \<longrightarrow> monomial_decomp (f hU)) \<and> (hom_decomp ps \<longrightarrow> hom_decomp (f hU))"
	if "hU \<in> set rs" for hU
	proof -
	obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	with that have eq: "poly_deg (fst hU) = k + i" by (simp add: rs_def)
	from that \<open>set rs \<subseteq> set qs\<close> have "(h, U) \<in> set qs" unfolding hU ..
	with 0 have "U \<subseteq> X" and "h \<in> P[X]" and "h \<noteq> 0" by (rule valid_decompD)+
	with assms(1) obtain ps' where "valid_decomp X ps'" and "cone_decomp (cone (h, U)) ps'"
	and "standard_decomp (Suc (poly_deg h)) ps'"
	and md: "is_monomial h \<Longrightarrow> punit.lc h = 1 \<Longrightarrow> monomial_decomp ps'"
	and hd: "homogeneous h \<Longrightarrow> hom_decomp ps'" by (rule standard_decomp_SucE) blast
	note this(1-3)
	moreover have "monomial_decomp ps'" if "monomial_decomp ps"
	proof -
	from that have "monomial_decomp qs" by (rule 3)
	hence "is_monomial h" and "punit.lc h = 1" using \<open>(h, U) \<in> set qs\<close> by (rule monomial_decompD)+
	thus ?thesis by (rule md)
	qed
	moreover have "hom_decomp ps'" if "hom_decomp ps"
	proof -
	from that have "hom_decomp qs" by (rule 4)
	hence "homogeneous h" using \<open>(h, U) \<in> set qs\<close> by (rule hom_decompD)
	thus ?thesis by (rule hd)
	qed
	ultimately have "valid_decomp X ps' \<and> cone_decomp (cone hU) ps' \<and>
	standard_decomp (Suc (poly_deg (fst hU))) ps' \<and> (monomial_decomp ps \<longrightarrow> monomial_decomp ps') \<and>
	(hom_decomp ps \<longrightarrow> hom_decomp ps')" by (simp add: hU)
	thus ?thesis unfolding f_def eq by (rule someI)
	qed
	hence f1: "\<And>ps. ps \<in> set (map f rs) \<Longrightarrow> valid_decomp X ps"
	and f2: "\<And>hU. hU \<in> set rs \<Longrightarrow> cone_decomp (cone hU) (f hU)"
	and f3: "\<And>ps. ps \<in> set (map f rs) \<Longrightarrow> standard_decomp (Suc (k + i)) ps"
	and f4: "\<And>ps'. monomial_decomp ps \<Longrightarrow> ps' \<in> set (map f rs) \<Longrightarrow> monomial_decomp ps'"
	and f5: "\<And>ps'. hom_decomp ps \<Longrightarrow> ps' \<in> set (map f rs) \<Longrightarrow> hom_decomp ps'" by auto

	define rs' where "rs' = concat (map f rs)"
	show ?case unfolding add_Suc_right
	proof (intro exI conjI impI)
	have "valid_decomp X ss"
	proof (rule valid_decompI)
	fix h U
	assume "(h, U) \<in> set ss"
	hence "(h, U) \<in> set qs" using \<open>set ss \<subseteq> set qs\<close> ..
	with 0 show "h \<in> P[X]" and "h \<noteq> 0" and "U \<subseteq> X" by (rule valid_decompD)+
	qed
	moreover have "valid_decomp X rs'"
	unfolding rs'_def using f1 by (rule valid_decomp_concat)
	ultimately show "valid_decomp X (ss @ rs')" by (rule valid_decomp_append)
	next
	from 1 have "direct_decomp T (map cone qs)" by (rule cone_decompD)
	hence "direct_decomp T ((map cone ss) @ (map cone rs))" unfolding ss_def rs_def
	by (rule direct_decomp_split_map)
	hence ss: "cone_decomp (sum_list ` listset (map cone ss)) ss"
	and "cone_decomp (sum_list ` listset (map cone rs)) rs"
	and T: "direct_decomp T [sum_list ` listset (map cone ss), sum_list ` listset (map cone rs)]"
	by (auto simp: cone_decomp_def dest: direct_decomp_appendD intro!: empty_not_in_map_cone)
	from this(2) have "direct_decomp (sum_list ` listset (map cone rs)) (map cone rs)"
	by (rule cone_decompD)
	hence "cone_decomp (sum_list ` listset (map cone rs)) rs'" unfolding rs'_def
	proof (rule cone_decomp_concat)
	fix i
	assume *: "i < length (map cone rs)"
	hence "rs ! i \<in> set rs" by simp
	hence "cone_decomp (cone (rs ! i)) (f (rs ! i))" by (rule f2)
	with * show "cone_decomp (map cone rs ! i) (map f rs ! i)" by simp
	qed simp
	with T ss show "cone_decomp T (ss @ rs')" by (rule cone_decomp_append)
	next
	have "standard_decomp (Suc (k + i)) ss"
	proof (rule standard_decompI)
	fix h U
	assume "(h, U) \<in> set (ss\<^sub>+)"
	hence "(h, U) \<in> set (qs\<^sub>+)" and "poly_deg h \<noteq> k + i" by (simp_all add: pos_decomp_def ss_def)
	from 2 this(1) have "k + i \<le> poly_deg h" by (rule standard_decompD)
	with \<open>poly_deg h \<noteq> k + i\<close> show "Suc (k + i) \<le> poly_deg h" by simp

	fix d'
	assume "Suc (k + i) \<le> d'" and "d' \<le> poly_deg h"
	from this(1) have "k + i \<le> d'" and "d' \<noteq> k + i" by simp_all
	from 2 \<open>(h, U) \<in> set (qs\<^sub>+)\<close> this(1) obtain h' U'
	where "(h', U') \<in> set qs" and "poly_deg h' = d'" and "card U \<le> card U'"
	using \<open>d' \<le> poly_deg h\<close> by (rule standard_decompE)
	moreover from \<open>d' \<noteq> k + i\<close> this(1, 2) have "(h', U') \<in> set ss" by (simp add: ss_def)
	ultimately show "\<exists>h' U'. (h', U') \<in> set ss \<and> poly_deg h' = d' \<and> card U \<le> card U'" by blast
	qed
	moreover have "standard_decomp (Suc (k + i)) rs'"
	unfolding rs'_def using f3 by (rule standard_decomp_concat)
	ultimately show "standard_decomp (Suc (k + i)) (ss @ rs')" by (rule standard_decomp_append)
	next
	assume *: "monomial_decomp ps"
	hence "monomial_decomp qs" by (rule 3)
	hence "monomial_decomp ss" by (simp add: monomial_decomp_def ss_def)
	moreover have "monomial_decomp rs'"
	unfolding rs'_def using f4[OF *] by (rule monomial_decomp_concat)
	ultimately show "monomial_decomp (ss @ rs')" by (simp only: monomial_decomp_append_iff)
	next
	assume *: "hom_decomp ps"
	hence "hom_decomp qs" by (rule 4)
	hence "hom_decomp ss" by (simp add: hom_decomp_def ss_def)
	moreover have "hom_decomp rs'" unfolding rs'_def using f5[OF *] by (rule hom_decomp_concat)
	ultimately show "hom_decomp (ss @ rs')" by (simp only: hom_decomp_append_iff)
	qed
	qed
	then obtain qs where 1: "valid_decomp X qs" and 2: "cone_decomp T qs"
	and "standard_decomp (k + (d - k)) qs" and 4: "monomial_decomp ps \<Longrightarrow> monomial_decomp qs"
	and 5: "hom_decomp ps \<Longrightarrow> hom_decomp qs" by blast
	from this(3) assms(5) have "standard_decomp d qs" by simp
	with 1 2 show ?thesis using 4 5 ..
	qed

	subsection \<open>Splitting w.r.t. Ideals\<close>

	context
	fixes X :: "'x set"
	begin

	definition splits_wrt :: "(((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<times> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list) \<Rightarrow>
	(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1) set \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) set \<Rightarrow> bool"
	where "splits_wrt pqs T F \<longleftrightarrow> cone_decomp T (fst pqs @ snd pqs) \<and>
	(\<forall>hU\<in>set (fst pqs). cone hU \<subseteq> ideal F \<inter> P[X]) \<and>
	(\<forall>(h, U)\<in>set (snd pqs). cone (h, U) \<subseteq> P[X] \<and> cone (h, U) \<inter> ideal F = {0})"

	lemma splits_wrtI:
	assumes "cone_decomp T (ps @ qs)"
	and "\<And>h U. (h, U) \<in> set ps \<Longrightarrow> cone (h, U) \<subseteq> P[X]" and "\<And>h U. (h, U) \<in> set ps \<Longrightarrow> h \<in> ideal F"
	and "\<And>h U. (h, U) \<in> set qs \<Longrightarrow> cone (h, U) \<subseteq> P[X]"
	and "\<And>h U a. (h, U) \<in> set qs \<Longrightarrow> a \<in> cone (h, U) \<Longrightarrow> a \<in> ideal F \<Longrightarrow> a = 0"
	shows "splits_wrt (ps, qs) T F"
	unfolding splits_wrt_def fst_conv snd_conv
	proof (intro conjI ballI)
	fix hU
	assume "hU \<in> set ps"
	moreover obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	ultimately have "(h, U) \<in> set ps" by simp
	hence "cone (h, U) \<subseteq> P[X]" and "h \<in> ideal F" by (rule assms)+
	from _ this(1) show "cone hU \<subseteq> ideal F \<inter> P[X]" unfolding hU
	proof (rule Int_greatest)
	show "cone (h, U) \<subseteq> ideal F"
	proof
	fix a
	assume "a \<in> cone (h, U)"
	then obtain a' where "a' \<in> P[U]" and a: "a = a' * h" by (rule coneE)
	from \<open>h \<in> ideal F\<close> show "a \<in> ideal F" unfolding a by (rule ideal.span_scale)
	qed
	qed
	next
	fix hU
	assume "hU \<in> set qs"
	moreover obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	ultimately have "(h, U) \<in> set qs" by simp
	hence "cone (h, U) \<subseteq> P[X]" and "\<And>a. a \<in> cone (h, U) \<Longrightarrow> a \<in> ideal F \<Longrightarrow> a = 0" by (rule assms)+
	moreover have "0 \<in> cone (h, U) \<inter> ideal F"
	by (simp add: zero_in_cone ideal.span_zero)
	ultimately show "case hU of (h, U) \<Rightarrow> cone (h, U) \<subseteq> P[X] \<and> cone (h, U) \<inter> ideal F = {0}"
	by (fastforce simp: hU)
	qed (fact assms)+

	lemma splits_wrtI_valid_decomp:
	assumes "valid_decomp X ps" and "valid_decomp X qs" and "cone_decomp T (ps @ qs)"
	and "\<And>h U. (h, U) \<in> set ps \<Longrightarrow> h \<in> ideal F"
	and "\<And>h U a. (h, U) \<in> set qs \<Longrightarrow> a \<in> cone (h, U) \<Longrightarrow> a \<in> ideal F \<Longrightarrow> a = 0"
	shows "splits_wrt (ps, qs) T F"
	using assms(3) _ _ _ assms(5)
	proof (rule splits_wrtI)
	fix h U
	assume "(h, U) \<in> set ps"
	thus "h \<in> ideal F" by (rule assms(4))
	from assms(1) \<open>(h, U) \<in> set ps\<close> have "h \<in> P[X]" and "U \<subseteq> X" by (rule valid_decompD)+
	thus "cone (h, U) \<subseteq> P[X]" by (rule cone_subset_PolysI)
	next
	fix h U
	assume "(h, U) \<in> set qs"
	with assms(2) have "h \<in> P[X]" by (rule valid_decompD)
	moreover from assms(2) \<open>(h, U) \<in> set qs\<close> have "U \<subseteq> X" by (rule valid_decompD)
	ultimately show "cone (h, U) \<subseteq> P[X]" by (rule cone_subset_PolysI)
	qed

	lemma splits_wrtD:
	assumes "splits_wrt (ps, qs) T F"
	shows "cone_decomp T (ps @ qs)" and "hU \<in> set ps \<Longrightarrow> cone hU \<subseteq> ideal F \<inter> P[X]"
	and "hU \<in> set qs \<Longrightarrow> cone hU \<subseteq> P[X]" and "hU \<in> set qs \<Longrightarrow> cone hU \<inter> ideal F = {0}"
	using assms by (fastforce simp: splits_wrt_def)+

	lemma splits_wrt_image_sum_list_fst_subset:
	assumes "splits_wrt (ps, qs) T F"
	shows "sum_list ` listset (map cone ps) \<subseteq> ideal F \<inter> P[X]"
	proof
	fix x
	assume x_in: "x \<in> sum_list ` listset (map cone ps)"
	have "listset (map cone ps) \<subseteq> listset (map (\<lambda>_. ideal F \<inter> P[X]) ps)"
	proof (rule listset_mono)
	fix i
	assume i: "i < length (map (\<lambda>_. ideal F \<inter> P[X]) ps)"
	hence "ps ! i \<in> set ps" by simp
	with assms(1) have "cone (ps ! i) \<subseteq> ideal F \<inter> P[X]" by (rule splits_wrtD)
	with i show "map cone ps ! i \<subseteq> map (\<lambda>_. ideal F \<inter> P[X]) ps ! i" by simp
	qed simp
	hence "sum_list ` listset (map cone ps) \<subseteq> sum_list ` listset (map (\<lambda>_. ideal F \<inter> P[X]) ps)"
	by (rule image_mono)
	with x_in have "x \<in> sum_list ` listset (map (\<lambda>_. ideal F \<inter> P[X]) ps)" ..
	then obtain xs where xs: "xs \<in> listset (map (\<lambda>_. ideal F \<inter> P[X]) ps)" and x: "x = sum_list xs" ..
	have 1: "y \<in> ideal F \<inter> P[X]" if "y \<in> set xs" for y
	proof -
	from that obtain i where "i < length xs" and y: "y = xs ! i" by (metis in_set_conv_nth)
	moreover from xs have "length xs = length (map (\<lambda>_. ideal F \<inter> P[X]) ps)"
	by (rule listsetD)
	ultimately have "i < length (map (\<lambda>_. ideal F \<inter> P[X]) ps)" by simp
	moreover from xs this have "xs ! i \<in> (map (\<lambda>_. ideal F \<inter> P[X]) ps) ! i" by (rule listsetD)
	ultimately show "y \<in> ideal F \<inter> P[X]" by (simp add: y)
	qed
	show "x \<in> ideal F \<inter> P[X]" unfolding x
	proof
	show "sum_list xs \<in> ideal F"
	proof (rule ideal.span_closed_sum_list[simplified])
	fix y
	assume "y \<in> set xs"
	hence "y \<in> ideal F \<inter> P[X]" by (rule 1)
	thus "y \<in> ideal F" by simp
	qed
	next
	show "sum_list xs \<in> P[X]"
	proof (rule Polys_closed_sum_list)
	fix y
	assume "y \<in> set xs"
	hence "y \<in> ideal F \<inter> P[X]" by (rule 1)
	thus "y \<in> P[X]" by simp
	qed
	qed
	qed

	lemma splits_wrt_image_sum_list_snd_subset:
	assumes "splits_wrt (ps, qs) T F"
	shows "sum_list ` listset (map cone qs) \<subseteq> P[X]"
	proof
	fix x
	assume x_in: "x \<in> sum_list ` listset (map cone qs)"
	have "listset (map cone qs) \<subseteq> listset (map (\<lambda>_. P[X]) qs)"
	proof (rule listset_mono)
	fix i
	assume i: "i < length (map (\<lambda>_. P[X]) qs)"
	hence "qs ! i \<in> set qs" by simp
	with assms(1) have "cone (qs ! i) \<subseteq> P[X]" by (rule splits_wrtD)
	with i show "map cone qs ! i \<subseteq> map (\<lambda>_. P[X]) qs ! i" by simp
	qed simp
	hence "sum_list ` listset (map cone qs) \<subseteq> sum_list ` listset (map (\<lambda>_. P[X]) qs)"
	by (rule image_mono)
	with x_in have "x \<in> sum_list ` listset (map (\<lambda>_. P[X]) qs)" ..
	then obtain xs where xs: "xs \<in> listset (map (\<lambda>_. P[X]) qs)" and x: "x = sum_list xs" ..
	show "x \<in> P[X]" unfolding x
	proof (rule Polys_closed_sum_list)
	fix y
	assume "y \<in> set xs"
	then obtain i where "i < length xs" and y: "y = xs ! i" by (metis in_set_conv_nth)
	moreover from xs have "length xs = length (map (\<lambda>_. P[X]::(_ \<Rightarrow>\<^sub>0 'a) set) qs)"
	by (rule listsetD)
	ultimately have "i < length (map (\<lambda>_. P[X]) qs)" by simp
	moreover from xs this have "xs ! i \<in> (map (\<lambda>_. P[X]) qs) ! i" by (rule listsetD)
	ultimately show "y \<in> P[X]" by (simp add: y)
	qed
	qed

	lemma splits_wrt_cone_decomp_1:
	assumes "splits_wrt (ps, qs) T F" and "monomial_decomp qs" and "is_monomial_set (F::(_ \<Rightarrow>\<^sub>0 'a::field) set)"
	\<comment>\<open>The last two assumptions are missing in the paper.\<close>
	shows "cone_decomp (T \<inter> ideal F) ps"
	proof -
	from assms(1) have *: "cone_decomp T (ps @ qs)" by (rule splits_wrtD)
	hence "direct_decomp T (map cone ps @ map cone qs)" by (simp add: cone_decomp_def)
	hence 1: "direct_decomp (sum_list ` listset (map cone ps)) (map cone ps)"
	and 2: "direct_decomp T [sum_list ` listset (map cone ps), sum_list ` listset (map cone qs)]"
	by (auto dest: direct_decomp_appendD intro!: empty_not_in_map_cone)
	let ?ss = "[sum_list ` listset (map cone ps), sum_list ` listset (map cone qs)]"
	show ?thesis
	proof (intro cone_decompI direct_decompI)
	from 1 show "inj_on sum_list (listset (map cone ps))" by (simp only: direct_decomp_def bij_betw_def)
	next
	from assms(1) have "sum_list ` listset (map cone ps) \<subseteq> ideal F \<inter> P[X]"
	by (rule splits_wrt_image_sum_list_fst_subset)
	hence sub: "sum_list ` listset (map cone ps) \<subseteq> ideal F" by simp
	show "sum_list ` listset (map cone ps) = T \<inter> ideal F"
	proof (rule set_eqI)
	fix x
	show "x \<in> sum_list ` listset (map cone ps) \<longleftrightarrow> x \<in> T \<inter> ideal F"
	proof
	assume x_in: "x \<in> sum_list ` listset (map cone ps)"
	show "x \<in> T \<inter> ideal F"
	proof (intro IntI)
	have "map (\<lambda>_. 0) qs \<in> listset (map cone qs)" (is "?ys \<in> _")
	by (induct qs) (auto intro: listset_ConsI zero_in_cone simp del: listset.simps(2))
	hence "sum_list ?ys \<in> sum_list ` listset (map cone qs)" by (rule imageI)
	hence "0 \<in> sum_list ` listset (map cone qs)" by simp
	with x_in have "[x, 0] \<in> listset ?ss" using refl by (rule listset_doubletonI)
	with 2 have "sum_list [x, 0] \<in> T" by (rule direct_decompD)
	thus "x \<in> T" by simp
	next
	from x_in sub show "x \<in> ideal F" ..
	qed
	next
	assume "x \<in> T \<inter> ideal F"
	hence "x \<in> T" and "x \<in> ideal F" by simp_all
	from 2 this(1) obtain xs where "xs \<in> listset ?ss" and x: "x = sum_list xs"
	by (rule direct_decompE)
	from this(1) obtain p q where p: "p \<in> sum_list ` listset (map cone ps)"
	and q: "q \<in> sum_list ` listset (map cone qs)" and xs: "xs = [p, q]"
	by (rule listset_doubletonE)
	from \<open>x \<in> ideal F\<close> have "p + q \<in> ideal F" by (simp add: x xs)
	moreover from p sub have "p \<in> ideal F" ..
	ultimately have "p + q - p \<in> ideal F" by (rule ideal.span_diff)
	hence "q \<in> ideal F" by simp
	have "q = 0"
	proof (rule ccontr)
	assume "q \<noteq> 0"
	hence "keys q \<noteq> {}" by simp
	then obtain t where "t \<in> keys q" by blast
	with assms(2) q obtain c h U where "(h, U) \<in> set qs" and "c \<noteq> 0"
	and "monomial c t \<in> cone (h, U)" by (rule monomial_decomp_sum_list_monomial_in_cone)
	moreover from assms(3) \<open>q \<in> ideal F\<close> \<open>t \<in> keys q\<close> have "monomial c t \<in> ideal F"
	by (rule punit.monomial_pmdl_field[simplified])
	ultimately have "monomial c t \<in> cone (h, U) \<inter> ideal F" by simp
	also from assms(1) \<open>(h, U) \<in> set qs\<close> have "\<dots> = {0}" by (rule splits_wrtD)
	finally have "c = 0" by (simp add: monomial_0_iff)
	with \<open>c \<noteq> 0\<close> show False ..
	qed
	with p show "x \<in> sum_list ` listset (map cone ps)" by (simp add: x xs)
	qed
	qed
	qed
	qed

	text \<open>Together, Theorems \<open>splits_wrt_image_sum_list_fst_subset\<close> and \<open>splits_wrt_cone_decomp_1\<close>
	imply that @{term ps} is also a cone decomposition of @{term "T \<inter> ideal F \<inter> P[X]"}.\<close>

	lemma splits_wrt_cone_decomp_2:
	assumes "finite X" and "splits_wrt (ps, qs) T F" and "monomial_decomp qs" and "is_monomial_set F"
	and "F \<subseteq> P[X]"
	shows "cone_decomp (T \<inter> normal_form F ` P[X]) qs"
	proof -
	from assms(2) have *: "cone_decomp T (ps @ qs)" by (rule splits_wrtD)
	hence "direct_decomp T (map cone ps @ map cone qs)" by (simp add: cone_decomp_def)
	hence 1: "direct_decomp (sum_list ` listset (map cone qs)) (map cone qs)"
	and 2: "direct_decomp T [sum_list ` listset (map cone ps), sum_list ` listset (map cone qs)]"
	by (auto dest: direct_decomp_appendD intro!: empty_not_in_map_cone)
	let ?ss = "[sum_list ` listset (map cone ps), sum_list ` listset (map cone qs)]"
	let ?G = "punit.reduced_GB F"
	from assms(1, 5) have "?G \<subseteq> P[X]" and G_is_GB: "punit.is_Groebner_basis ?G"
	and ideal_G: "ideal ?G = ideal F"
	by (rule reduced_GB_Polys, rule reduced_GB_is_GB_Polys, rule reduced_GB_ideal_Polys)
	show ?thesis
	proof (intro cone_decompI direct_decompI)
	from 1 show "inj_on sum_list (listset (map cone qs))" by (simp only: direct_decomp_def bij_betw_def)
	next
	from assms(2) have "sum_list ` listset (map cone ps) \<subseteq> ideal F \<inter> P[X]"
	by (rule splits_wrt_image_sum_list_fst_subset)
	hence sub: "sum_list ` listset (map cone ps) \<subseteq> ideal F" by simp
	show "sum_list ` listset (map cone qs) = T \<inter> normal_form F ` P[X]"
	proof (rule set_eqI)
	fix x
	show "x \<in> sum_list ` listset (map cone qs) \<longleftrightarrow> x \<in> T \<inter> normal_form F ` P[X]"
	proof
	assume x_in: "x \<in> sum_list ` listset (map cone qs)"
	show "x \<in> T \<inter> normal_form F ` P[X]"
	proof (intro IntI)
	have "map (\<lambda>_. 0) ps \<in> listset (map cone ps)" (is "?ys \<in> _")
	by (induct ps) (auto intro: listset_ConsI zero_in_cone simp del: listset.simps(2))
	hence "sum_list ?ys \<in> sum_list ` listset (map cone ps)" by (rule imageI)
	hence "0 \<in> sum_list ` listset (map cone ps)" by simp
	from this x_in have "[0, x] \<in> listset ?ss" using refl by (rule listset_doubletonI)
	with 2 have "sum_list [0, x] \<in> T" by (rule direct_decompD)
	thus "x \<in> T" by simp
	next
	from assms(2) have "sum_list ` listset (map cone qs) \<subseteq> P[X]"
	by (rule splits_wrt_image_sum_list_snd_subset)
	with x_in have "x \<in> P[X]" ..
	moreover have "\<not> punit.is_red ?G x"
	proof
	assume "punit.is_red ?G x"
	then obtain g t where "g \<in> ?G" and "t \<in> keys x" and "g \<noteq> 0" and adds: "lpp g adds t"
	by (rule punit.is_red_addsE[simplified])
	from assms(3) x_in this(2) obtain c h U where "(h, U) \<in> set qs" and "c \<noteq> 0"
	and "monomial c t \<in> cone (h, U)" by (rule monomial_decomp_sum_list_monomial_in_cone)
	note this(3)
	moreover have "monomial c t \<in> ideal ?G"
	proof (rule punit.is_red_monomial_monomial_set_in_pmdl[simplified])
	from \<open>c \<noteq> 0\<close> show "is_monomial (monomial c t)" by (rule monomial_is_monomial)
	next
	from assms(1, 5, 4) show "is_monomial_set ?G" by (rule reduced_GB_is_monomial_set_Polys)
	next
	from \<open>c \<noteq> 0\<close> have "t \<in> keys (monomial c t)" by simp
	with \<open>g \<in> ?G\<close> \<open>g \<noteq> 0\<close> show "punit.is_red ?G (monomial c t)" using adds
	by (rule punit.is_red_addsI[simplified])
	qed
	ultimately have "monomial c t \<in> cone (h, U) \<inter> ideal F" by (simp add: ideal_G)
	also from assms(2) \<open>(h, U) \<in> set qs\<close> have "\<dots> = {0}" by (rule splits_wrtD)
	finally have "c = 0" by (simp add: monomial_0_iff)
	with \<open>c \<noteq> 0\<close> show False ..
	qed
	ultimately show "x \<in> normal_form F ` P[X]"
	using assms(1, 5) by (simp add: image_normal_form_iff)
	qed
	next
	assume "x \<in> T \<inter> normal_form F ` P[X]"
	hence "x \<in> T" and "x \<in> normal_form F ` P[X]" by simp_all
	from this(2) assms(1, 5) have "x \<in> P[X]" and irred: "\<not> punit.is_red ?G x"
	by (simp_all add: image_normal_form_iff)
	from 2 \<open>x \<in> T\<close> obtain xs where "xs \<in> listset ?ss" and x: "x = sum_list xs"
	by (rule direct_decompE)
	from this(1) obtain p q where p: "p \<in> sum_list ` listset (map cone ps)"
	and q: "q \<in> sum_list ` listset (map cone qs)" and xs: "xs = [p, q]"
	by (rule listset_doubletonE)
	have "x = p + q" by (simp add: x xs)
	from p sub have "p \<in> ideal F" ..
	have "p = 0"
	proof (rule ccontr)
	assume "p \<noteq> 0"
	hence "keys p \<noteq> {}" by simp
	then obtain t where "t \<in> keys p" by blast
	from assms(4) \<open>p \<in> ideal F\<close> \<open>t \<in> keys p\<close> have 3: "monomial c t \<in> ideal F" for c
	by (rule punit.monomial_pmdl_field[simplified])
	have "t \<notin> keys q"
	proof
	assume "t \<in> keys q"
	with assms(3) q obtain c h U where "(h, U) \<in> set qs" and "c \<noteq> 0"
	and "monomial c t \<in> cone (h, U)" by (rule monomial_decomp_sum_list_monomial_in_cone)
	from this(3) 3 have "monomial c t \<in> cone (h, U) \<inter> ideal F" by simp
	also from assms(2) \<open>(h, U) \<in> set qs\<close> have "\<dots> = {0}" by (rule splits_wrtD)
	finally have "c = 0" by (simp add: monomial_0_iff)
	with \<open>c \<noteq> 0\<close> show False ..
	qed
	with \<open>t \<in> keys p\<close> have "t \<in> keys x" unfolding \<open>x = p + q\<close> by (rule in_keys_plusI1)
	have "punit.is_red ?G x"
	proof -
	note G_is_GB
	moreover from 3 have "monomial 1 t \<in> ideal ?G" by (simp only: ideal_G)
	moreover have "monomial (1::'a) t \<noteq> 0" by (simp add: monomial_0_iff)
	ultimately obtain g where "g \<in> ?G" and "g \<noteq> 0"
	and "lpp g adds lpp (monomial (1::'a) t)" by (rule punit.GB_adds_lt[simplified])
	from this(3) have "lpp g adds t" by (simp add: punit.lt_monomial)
	with \<open>g \<in> ?G\<close> \<open>g \<noteq> 0\<close> \<open>t \<in> keys x\<close> show ?thesis by (rule punit.is_red_addsI[simplified])
	qed
	with irred show False ..
	qed
	with q show "x \<in> sum_list ` listset (map cone qs)" by (simp add: x xs)
	qed
	qed
	qed
	qed

	lemma quot_monomial_ideal_monomial:
	"ideal (monomial 1 ` S) \<div> monomial 1 (Poly_Mapping.single (x::'x) (1::nat)) =
	ideal (monomial (1::'a::comm_ring_1) ` (\<lambda>s. s - Poly_Mapping.single x 1) ` S)"
	proof (rule set_eqI)
	let ?x = "Poly_Mapping.single x (1::nat)"
	fix a
	have "a \<in> ideal (monomial 1 ` S) \<div> monomial 1 ?x \<longleftrightarrow> punit.monom_mult 1 ?x a \<in> ideal (monomial (1::'a) ` S)"
	by (simp only: quot_set_iff times_monomial_left)
	also have "\<dots> \<longleftrightarrow> a \<in> ideal (monomial 1 ` (\<lambda>s. s - ?x) ` S)"
	proof (induct a rule: poly_mapping_plus_induct)
	case 1
	show ?case by (simp add: ideal.span_zero)
	next
	case (2 a c t)
	let ?S = "monomial (1::'a) ` (\<lambda>s. s - ?x) ` S"
	show ?case
	proof
	assume 0: "punit.monom_mult 1 ?x (monomial c t + a) \<in> ideal (monomial 1 ` S)"
	have "is_monomial_set (monomial (1::'a) ` S)"
	by (auto intro!: is_monomial_setI monomial_is_monomial)
	moreover from 0 have 1: "monomial c (?x + t) + punit.monom_mult 1 ?x a \<in> ideal (monomial 1 ` S)"
	by (simp add: punit.monom_mult_monomial punit.monom_mult_dist_right)
	moreover have "?x + t \<in> keys (monomial c (?x + t) + punit.monom_mult 1 ?x a)"
	proof (intro in_keys_plusI1 notI)
	from 2(1) show "?x + t \<in> keys (monomial c (?x + t))" by simp
	next
	assume "?x + t \<in> keys (punit.monom_mult 1 ?x a)"
	also have "\<dots> \<subseteq> (+) ?x ` keys a" by (rule punit.keys_monom_mult_subset[simplified])
	finally obtain s where "s \<in> keys a" and "?x + t = ?x + s" ..
	from this(2) have "t = s" by simp
	with \<open>s \<in> keys a\<close> 2(2) show False by simp
	qed
	ultimately obtain f where "f \<in> monomial (1::'a) ` S" and adds: "lpp f adds ?x + t"
	by (rule punit.keys_monomial_pmdl[simplified])
	from this(1) obtain s where "s \<in> S" and f: "f = monomial 1 s" ..
	from adds have "s adds ?x + t" by (simp add: f punit.lt_monomial)
	hence "s - ?x adds t"
	by (metis (no_types, lifting) add_minus_2 adds_minus adds_triv_right plus_minus_assoc_pm_nat_1)
	then obtain s' where t: "t = (s - ?x) + s'" by (rule addsE)
	from \<open>s \<in> S\<close> have "monomial 1 (s - ?x) \<in> ?S" by (intro imageI)
	also have "\<dots> \<subseteq> ideal ?S" by (rule ideal.span_superset)
	finally have "monomial c s' * monomial 1 (s - ?x) \<in> ideal ?S"
	by (rule ideal.span_scale)
	hence "monomial c t \<in> ideal ?S" by (simp add: times_monomial_monomial t add.commute)
	moreover have "a \<in> ideal ?S"
	proof -
	from \<open>f \<in> monomial 1 ` S\<close> have "f \<in> ideal (monomial 1 ` S)" by (rule ideal.span_base)
	hence "punit.monom_mult c (?x + t - s) f \<in> ideal (monomial 1 ` S)"
	by (rule punit.pmdl_closed_monom_mult[simplified])
	with \<open>s adds ?x + t\<close> have "monomial c (?x + t) \<in> ideal (monomial 1 ` S)"
	by (simp add: f punit.monom_mult_monomial adds_minus)
	with 1 have "monomial c (?x + t) + punit.monom_mult 1 ?x a - monomial c (?x + t) \<in> ideal (monomial 1 ` S)"
	by (rule ideal.span_diff)
	thus ?thesis by (simp add: 2(3) del: One_nat_def)
	qed
	ultimately show "monomial c t + a \<in> ideal ?S"
	by (rule ideal.span_add)
	next
	have "is_monomial_set ?S" by (auto intro!: is_monomial_setI monomial_is_monomial)
	moreover assume 1: "monomial c t + a \<in> ideal ?S"
	moreover from _ 2(2) have "t \<in> keys (monomial c t + a)"
	proof (rule in_keys_plusI1)
	from 2(1) show "t \<in> keys (monomial c t)" by simp
	qed
	ultimately obtain f where "f \<in> ?S" and adds: "lpp f adds t"
	by (rule punit.keys_monomial_pmdl[simplified])
	from this(1) obtain s where "s \<in> S" and f: "f = monomial 1 (s - ?x)" by blast
	from adds have "s - ?x adds t" by (simp add: f punit.lt_monomial)
	hence "s adds ?x + t"
	by (auto simp: adds_poly_mapping le_fun_def lookup_add lookup_minus lookup_single when_def
	split: if_splits)
	then obtain s' where t: "?x + t = s + s'" by (rule addsE)
	from \<open>s \<in> S\<close> have "monomial 1 s \<in> monomial 1 ` S" by (rule imageI)
	also have "\<dots> \<subseteq> ideal (monomial 1 ` S)" by (rule ideal.span_superset)
	finally have "monomial c s' * monomial 1 s \<in> ideal (monomial 1 ` S)"
	by (rule ideal.span_scale)
	hence "monomial c (?x + t) \<in> ideal (monomial 1 ` S)"
	by (simp only: t) (simp add: times_monomial_monomial add.commute)
	moreover have "punit.monom_mult 1 ?x a \<in> ideal (monomial 1 ` S)"
	proof -
	from \<open>f \<in> ?S\<close> have "f \<in> ideal ?S" by (rule ideal.span_base)
	hence "punit.monom_mult c (t - (s - ?x)) f \<in> ideal ?S"
	by (rule punit.pmdl_closed_monom_mult[simplified])
	with \<open>s - ?x adds t\<close> have "monomial c t \<in> ideal ?S"
	by (simp add: f punit.monom_mult_monomial adds_minus)
	with 1 have "monomial c t + a - monomial c t \<in> ideal ?S"
	by (rule ideal.span_diff)
	thus ?thesis by (simp add: 2(3) del: One_nat_def)
	qed
	ultimately have "monomial c (?x + t) + punit.monom_mult 1 ?x a \<in> ideal (monomial 1 ` S)"
	by (rule ideal.span_add)
	thus "punit.monom_mult 1 ?x (monomial c t + a) \<in> ideal (monomial 1 ` S)"
	by (simp add: punit.monom_mult_monomial punit.monom_mult_dist_right)
	qed
	qed
	finally show "a \<in> ideal (monomial 1 ` S) \<div> monomial 1 ?x \<longleftrightarrow> a \<in> ideal (monomial 1 ` (\<lambda>s. s - ?x) ` S)" .
	qed

	lemma lem_4_2_1:
	assumes "ideal F \<div> monomial 1 t = ideal (monomial (1::'a::comm_ring_1) ` S)"
	shows "cone (monomial 1 t, U) \<subseteq> ideal F \<longleftrightarrow> 0 \<in> S"
	proof
	have "monomial 1 t \<in> cone (monomial (1::'a) t, U)" by (rule tip_in_cone)
	also assume "cone (monomial 1 t, U) \<subseteq> ideal F"
	finally have : "monomial 1 t 1 \<in> ideal F" by simp
	have "is_monomial_set (monomial (1::'a) ` S)"
	by (auto intro!: is_monomial_setI monomial_is_monomial)
	moreover from * have "1 \<in> ideal (monomial (1::'a) ` S)" by (simp only: quot_set_iff flip: assms)
	moreover have "0 \<in> keys (1::_ \<Rightarrow>\<^sub>0 'a)" by simp
	ultimately obtain g where "g \<in> monomial (1::'a) ` S" and adds: "lpp g adds 0"
	by (rule punit.keys_monomial_pmdl[simplified])
	from this(1) obtain s where "s \<in> S" and g: "g = monomial 1 s" ..
	from adds have "s adds 0" by (simp add: g punit.lt_monomial flip: single_one)
	with \<open>s \<in> S\<close> show "0 \<in> S" by (simp only: adds_zero)
	next
	assume "0 \<in> S"
	hence "monomial 1 0 \<in> monomial (1::'a) ` S" by (rule imageI)
	hence "1 \<in> ideal (monomial (1::'a) ` S)" unfolding single_one by (rule ideal.span_base)
	hence eq: "ideal F \<div> monomial 1 t = UNIV" (is "_ \<div> ?t = _")
	by (simp only: assms ideal_eq_UNIV_iff_contains_one)
	show "cone (monomial 1 t, U) \<subseteq> ideal F"
	proof
	fix a
	assume "a \<in> cone (?t, U)"
	then obtain q where a: "a = q * ?t" by (rule coneE)
	have "q \<in> ideal F \<div> ?t" by (simp add: eq)
	thus "a \<in> ideal F" by (simp only: a quot_set_iff mult.commute)
	qed
	qed

	lemma lem_4_2_2:
	assumes "ideal F \<div> monomial 1 t = ideal (monomial (1::'a::comm_ring_1) ` S)"
	shows "cone (monomial 1 t, U) \<inter> ideal F = {0} \<longleftrightarrow> S \<inter> .[U] = {}"
	proof
	let ?t = "monomial (1::'a) t"
	assume eq: "cone (?t, U) \<inter> ideal F = {0}"
	{
	fix s
	assume "s \<in> S"
	hence "monomial 1 s \<in> monomial (1::'a) ` S" (is "?s \<in> _") by (rule imageI)
	hence "?s \<in> ideal (monomial 1 ` S)" by (rule ideal.span_base)
	also have "\<dots> = ideal F \<div> ?t" by (simp only: assms)
	finally have : "?s ?t \<in> ideal F" by (simp only: quot_set_iff mult.commute)
	assume "s \<in> .[U]"
	hence "?s \<in> P[U]" by (rule Polys_closed_monomial)
	with refl have "?s * ?t \<in> cone (?t, U)" by (rule coneI)
	with * have "?s * ?t \<in> cone (?t, U) \<inter> ideal F" by simp
	hence False by (simp add: eq times_monomial_monomial monomial_0_iff)
	}
	thus "S \<inter> .[U] = {}" by blast
	next
	let ?t = "monomial (1::'a) t"
	assume eq: "S \<inter> .[U] = {}"
	{
	fix a
	assume "a \<in> cone (?t, U)"
	then obtain q where "q \<in> P[U]" and a: "a = q * ?t" by (rule coneE)
	assume "a \<in> ideal F"
	have "a = 0"
	proof (rule ccontr)
	assume "a \<noteq> 0"
	hence "q \<noteq> 0" by (auto simp: a)
	from \<open>a \<in> ideal F\<close> have *: "q \<in> ideal F \<div> ?t" by (simp only: quot_set_iff a mult.commute)
	have "is_monomial_set (monomial (1::'a) ` S)"
	by (auto intro!: is_monomial_setI monomial_is_monomial)
	moreover from * have q_in: "q \<in> ideal (monomial 1 ` S)" by (simp only: assms)
	moreover from \<open>q \<noteq> 0\<close> have "lpp q \<in> keys q" by (rule punit.lt_in_keys)
	ultimately obtain g where "g \<in> monomial (1::'a) ` S" and adds: "lpp g adds lpp q"
	by (rule punit.keys_monomial_pmdl[simplified])
	from this(1) obtain s where "s \<in> S" and g: "g = monomial 1 s" ..
	from \<open>q \<noteq> 0\<close> have "lpp q \<in> keys q" by (rule punit.lt_in_keys)
	also from \<open>q \<in> P[U]\<close> have "\<dots> \<subseteq> .[U]" by (rule PolysD)
	finally have "lpp q \<in> .[U]" .
	moreover from adds have "s adds lpp q" by (simp add: g punit.lt_monomial)
	ultimately have "s \<in> .[U]" by (rule PPs_closed_adds)
	with eq \<open>s \<in> S\<close> show False by blast
	qed
	}
	thus "cone (?t, U) \<inter> ideal F = {0}" using zero_in_cone ideal.span_zero by blast
	qed

	subsection \<open>Function \<open>split\<close>\<close>

	definition max_subset :: "'a set \<Rightarrow> ('a set \<Rightarrow> bool) \<Rightarrow> 'a set"
	where "max_subset A P = (ARG_MAX card B. B \<subseteq> A \<and> P B)"

	lemma max_subset:
	assumes "finite A" and "B \<subseteq> A" and "P B"
	shows "max_subset A P \<subseteq> A" (is ?thesis1)
	and "P (max_subset A P)" (is ?thesis2)
	and "card B \<le> card (max_subset A P)" (is ?thesis3)
	proof -
	from assms(2, 3) have "B \<subseteq> A \<and> P B" by simp
	moreover have "\<forall>C. C \<subseteq> A \<and> P C \<longrightarrow> card C < Suc (card A)"
	proof (intro allI impI, elim conjE)
	fix C
	assume "C \<subseteq> A"
	with assms(1) have "card C \<le> card A" by (rule card_mono)
	thus "card C < Suc (card A)" by simp
	qed
	ultimately have "?thesis1 \<and> ?thesis2" and ?thesis3 unfolding max_subset_def
	by (rule arg_max_natI, rule arg_max_nat_le)
	thus ?thesis1 and ?thesis2 and ?thesis3 by simp_all
	qed

	function (domintros) split :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'x set \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) set \<Rightarrow>
	((((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> ('x set)) list) \<times>
	(((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{zero,one}) \<times> ('x set)) list))"
	where
	"split t U S =
	(if 0 \<in> S then
	([(monomial 1 t, U)], [])
	else if S \<inter> .[U] = {} then
	([], [(monomial 1 t, U)])
	else
	let x = SOME x'. x' \<in> U - (max_subset U (\<lambda>V. S \<inter> .[V] = {}));
	(ps0, qs0) = split t (U - {x}) S;
	(ps1, qs1) = split (Poly_Mapping.single x 1 + t) U ((\<lambda>f. f - Poly_Mapping.single x 1) ` S) in
	(ps0 @ ps1, qs0 @ qs1))"
	by auto

	text \<open>Function @{const split} is not executable, because this is not necessary.
	With some effort, it could be made executable, though.\<close>

	lemma split_domI':
	assumes "finite X" and "fst (snd args) \<subseteq> X" and "finite (snd (snd args))"
	shows "split_dom TYPE('a::{zero,one}) args"
	proof -
	let ?m = "\<lambda>args'. card (fst (snd args')) + sum deg_pm (snd (snd args'))"
	from wf_measure[of ?m] assms(2, 3) show ?thesis
	proof (induct args)
	case (less args)
	obtain t U F where args: "args = (t, U, F)" using prod.exhaust by metis
	from less.prems have "U \<subseteq> X" and "finite F" by (simp_all only: args fst_conv snd_conv)
	from this(1) assms(1) have "finite U" by (rule finite_subset)
	have IH: "split_dom TYPE('a) (t', U', F')"
	if "U' \<subseteq> X" and "finite F'" and "card U' + sum deg_pm F' < card U + sum deg_pm F"
	for t' U' F'
	using less.hyps that by (simp add: args)

	define S where "S = max_subset U (\<lambda>V. F \<inter> .[V] = {})"
	define x where "x = (SOME x'. x' \<in> U \<and> x' \<notin> S)"
	show ?case unfolding args
	proof (rule split.domintros, simp_all only: x_def[symmetric] S_def[symmetric])
	fix f
	assume "0 \<notin> F" and "f \<in> F" and "f \<in> .[U]"
	from this(1) have "F \<inter> .[{}] = {}" by simp
	with \<open>finite U\<close> empty_subsetI have "S \<subseteq> U" and "F \<inter> .[S] = {}"
	unfolding S_def by (rule max_subset)+
	have "x \<in> U \<and> x \<notin> S" unfolding x_def
	proof (rule someI_ex)
	from \<open>f \<in> F\<close> \<open>f \<in> .[U]\<close> \<open>F \<inter> .[S] = {}\<close> have "S \<noteq> U" by blast
	with \<open>S \<subseteq> U\<close> show "\<exists>y. y \<in> U \<and> y \<notin> S" by blast
	qed
	hence "x \<in> U" and "x \<notin> S" by simp_all
	{
	assume "\<not> split_dom TYPE('a) (t, U - {x}, F)"
	moreover from _ \<open>finite F\<close> have "split_dom TYPE('a) (t, U - {x}, F)"
	proof (rule IH)
	from \<open>U \<subseteq> X\<close> show "U - {x} \<subseteq> X" by blast
	next
	from \<open>finite U\<close> \<open>x \<in> U\<close> have "card (U - {x}) < card U" by (rule card_Diff1_less)
	thus "card (U - {x}) + sum deg_pm F < card U + sum deg_pm F" by simp
	qed
	ultimately show False ..
	}
	{
	let ?args = "(Poly_Mapping.single x (Suc 0) + t, U, (\<lambda>f. f - Poly_Mapping.single x (Suc 0)) ` F)"
	assume "\<not> split_dom TYPE('a) ?args"
	moreover from \<open>U \<subseteq> X\<close> have "split_dom TYPE('a) ?args"
	proof (rule IH)
	from \<open>finite F\<close> show "finite ((\<lambda>f. f - Poly_Mapping.single x (Suc 0)) ` F)"
	by (rule finite_imageI)
	next
	have "sum deg_pm ((\<lambda>f. f - Poly_Mapping.single x (Suc 0)) ` F) \<le>
	sum (deg_pm \<circ> (\<lambda>f. f - Poly_Mapping.single x (Suc 0))) F"
	using \<open>finite F\<close> by (rule sum_image_le) simp
	also from \<open>finite F\<close> have "\<dots> < sum deg_pm F"
	proof (rule sum_strict_mono_ex1)
	show "\<forall>f\<in>F. (deg_pm \<circ> (\<lambda>f. f - Poly_Mapping.single x (Suc 0))) f \<le> deg_pm f"
	by (simp add: deg_pm_minus_le)
	next
	show "\<exists>f\<in>F. (deg_pm \<circ> (\<lambda>f. f - Poly_Mapping.single x (Suc 0))) f < deg_pm f"
	proof (rule ccontr)
	assume *: "\<not> (\<exists>f\<in>F. (deg_pm \<circ> (\<lambda>f. f - Poly_Mapping.single x (Suc 0))) f < deg_pm f)"
	note \<open>finite U\<close>
	moreover from \<open>x \<in> U\<close> \<open>S \<subseteq> U\<close> have "insert x S \<subseteq> U" by (rule insert_subsetI)
	moreover have "F \<inter> .[insert x S] = {}"
	proof -
	{
	fix s
	assume "s \<in> F"
	with * have "\<not> deg_pm (s - Poly_Mapping.single x (Suc 0)) < deg_pm s" by simp
	with deg_pm_minus_le[of s "Poly_Mapping.single x (Suc 0)"]
	have "deg_pm (s - Poly_Mapping.single x (Suc 0)) = deg_pm s" by simp
	hence "keys s \<inter> keys (Poly_Mapping.single x (Suc 0)) = {}"
	by (simp only: deg_pm_minus_id_iff)
	hence "x \<notin> keys s" by simp
	moreover assume "s \<in> .[insert x S]"
	ultimately have "s \<in> .[S]" by (fastforce simp: PPs_def)
	with \<open>s \<in> F\<close> \<open>F \<inter> .[S] = {}\<close> have False by blast
	}
	thus ?thesis by blast
	qed
	ultimately have "card (insert x S) \<le> card S" unfolding S_def by (rule max_subset)
	moreover from \<open>S \<subseteq> U\<close> \<open>finite U\<close> have "finite S" by (rule finite_subset)
	ultimately show False using \<open>x \<notin> S\<close> by simp
	qed
	qed
	finally show "card U + sum deg_pm ((\<lambda>f. f - monomial (Suc 0) x) ` F) < card U + sum deg_pm F"
	by simp
	qed
	ultimately show False ..
	}
	qed
	qed
	qed

	corollary split_domI: "finite X \<Longrightarrow> U \<subseteq> X \<Longrightarrow> finite S \<Longrightarrow> split_dom TYPE('a::{zero,one}) (t, U, S)"
	using split_domI'[of "(t, U, S)"] by simp

	lemma split_empty:
	assumes "finite X" and "U \<subseteq> X"
	shows "split t U {} = ([], [(monomial (1::'a::{zero,one}) t, U)])"
	proof -
	have "finite {}" ..
	with assms have "split_dom TYPE('a) (t, U, {})" by (rule split_domI)
	thus ?thesis by (simp add: split.psimps)
	qed

	lemma split_induct [consumes 3, case_names base1 base2 step]:
	fixes P :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> _"
	assumes "finite X" and "U \<subseteq> X" and "finite S"
	assumes "\<And>t U S. U \<subseteq> X \<Longrightarrow> finite S \<Longrightarrow> 0 \<in> S \<Longrightarrow> P t U S ([(monomial (1::'a::{zero,one}) t, U)], [])"
	assumes "\<And>t U S. U \<subseteq> X \<Longrightarrow> finite S \<Longrightarrow> 0 \<notin> S \<Longrightarrow> S \<inter> .[U] = {} \<Longrightarrow> P t U S ([], [(monomial 1 t, U)])"
	assumes "\<And>t U S V x ps0 ps1 qs0 qs1. U \<subseteq> X \<Longrightarrow> finite S \<Longrightarrow> 0 \<notin> S \<Longrightarrow> S \<inter> .[U] \<noteq> {} \<Longrightarrow> V \<subseteq> U \<Longrightarrow>
	S \<inter> .[V] = {} \<Longrightarrow> (\<And>V'. V' \<subseteq> U \<Longrightarrow> S \<inter> .[V'] = {} \<Longrightarrow> card V' \<le> card V) \<Longrightarrow>
	x \<in> U \<Longrightarrow> x \<notin> V \<Longrightarrow> V = max_subset U (\<lambda>V'. S \<inter> .[V'] = {}) \<Longrightarrow> x = (SOME x'. x' \<in> U - V) \<Longrightarrow>
	(ps0, qs0) = split t (U - {x}) S \<Longrightarrow>
	(ps1, qs1) = split (Poly_Mapping.single x 1 + t) U ((\<lambda>f. f - Poly_Mapping.single x 1) ` S) \<Longrightarrow>
	split t U S = (ps0 @ ps1, qs0 @ qs1) \<Longrightarrow>
	P t (U - {x}) S (ps0, qs0) \<Longrightarrow>
	P (Poly_Mapping.single x 1 + t) U ((\<lambda>f. f - Poly_Mapping.single x 1) ` S) (ps1, qs1) \<Longrightarrow>
	P t U S (ps0 @ ps1, qs0 @ qs1)"
	shows "P t U S (split t U S)"
	proof -
	from assms(1-3) have "split_dom TYPE('a) (t, U, S)" by (rule split_domI)
	thus ?thesis using assms(2,3)
	proof (induct t U S rule: split.pinduct)
	case step: (1 t U F)
	from step(4) assms(1) have "finite U" by (rule finite_subset)
	define S where "S = max_subset U (\<lambda>V. F \<inter> .[V] = {})"
	define x where "x = (SOME x'. x' \<in> U \<and> x' \<notin> S)"
	show ?case
	proof (simp add: split.psimps[OF step(1)] S_def[symmetric] x_def[symmetric] split: prod.split, intro allI conjI impI)
	assume "0 \<in> F"
	with step(4, 5) show "P t U F ([(monomial 1 t, U)], [])" by (rule assms(4))
	thus "P t U F ([(monomial 1 t, U)], [])" .
	next
	assume "0 \<notin> F" and "F \<inter> .[U] = {}"
	with step(4, 5) show "P t U F ([], [(monomial 1 t, U)])" by (rule assms(5))
	next
	fix ps0 qs0 ps1 qs1 :: "((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list"
	assume "split (Poly_Mapping.single x (Suc 0) + t) U ((\<lambda>f. f - Poly_Mapping.single x (Suc 0)) ` F) = (ps1, qs1)"
	hence PQ1[symmetric]: "split (Poly_Mapping.single x 1 + t) U ((\<lambda>f. f - Poly_Mapping.single x 1) ` F) = (ps1, qs1)"
	by simp
	assume PQ0[symmetric]: "split t (U - {x}) F = (ps0, qs0)"
	assume "F \<inter> .[U] \<noteq> {}" and "0 \<notin> F"
	from this(2) have "F \<inter> .[{}] = {}" by simp
	with \<open>finite U\<close> empty_subsetI have "S \<subseteq> U" and "F \<inter> .[S] = {}"
	unfolding S_def by (rule max_subset)+
	have S_max: "card S' \<le> card S" if "S' \<subseteq> U" and "F \<inter> .[S'] = {}" for S'
	using \<open>finite U\<close> that unfolding S_def by (rule max_subset)
	have "x \<in> U \<and> x \<notin> S" unfolding x_def
	proof (rule someI_ex)
	from \<open>F \<inter> .[U] \<noteq> {}\<close> \<open>F \<inter> .[S] = {}\<close> have "S \<noteq> U" by blast
	with \<open>S \<subseteq> U\<close> show "\<exists>y. y \<in> U \<and> y \<notin> S" by blast
	qed
	hence "x \<in> U" and "x \<notin> S" by simp_all
	from step(4, 5) \<open>0 \<notin> F\<close> \<open>F \<inter> .[U] \<noteq> {}\<close> \<open>S \<subseteq> U\<close> \<open>F \<inter> .[S] = {}\<close> S_max \<open>x \<in> U\<close> \<open>x \<notin> S\<close> S_def _ PQ0 PQ1
	show "P t U F (ps0 @ ps1, qs0 @ qs1)"
	proof (rule assms(6))
	show "P t (U - {x}) F (ps0, qs0)"
	unfolding PQ0 using \<open>0 \<notin> F\<close> \<open>F \<inter> .[U] \<noteq> {}\<close> _ _ step(5)
	proof (rule step(2))
	from \<open>U \<subseteq> X\<close> show "U - {x} \<subseteq> X" by fastforce
	qed (simp add: x_def S_def)
	next
	show "P (Poly_Mapping.single x 1 + t) U ((\<lambda>f. f - Poly_Mapping.single x 1) ` F) (ps1, qs1)"
	unfolding PQ1 using \<open>0 \<notin> F\<close> \<open>F \<inter> .[U] \<noteq> {}\<close> _ refl PQ0 \<open>U \<subseteq> X\<close>
	proof (rule step(3))
	from \<open>finite F\<close> show "finite ((\<lambda>f. f - Poly_Mapping.single x 1) ` F)" by (rule finite_imageI)
	qed (simp add: x_def S_def)
	next
	show "split t U F = (ps0 @ ps1, qs0 @ qs1)" using \<open>0 \<notin> F\<close> \<open>F \<inter> .[U] \<noteq> {}\<close>
	by (simp add: split.psimps[OF step(1)] Let_def flip: S_def x_def PQ0 PQ1 del: One_nat_def)
	qed (assumption+, simp add: x_def S_def)
	qed
	qed
	qed

	lemma valid_decomp_split:
	assumes "finite X" and "U \<subseteq> X" and "finite S" and "t \<in> .[X]"
	shows "valid_decomp X (fst ((split t U S)::(_ \<times> (((_ \<Rightarrow>\<^sub>0 'a::zero_neq_one) \<times> _) list))))"
	and "valid_decomp X (snd ((split t U S)::(_ \<times> (((_ \<Rightarrow>\<^sub>0 'a::zero_neq_one) \<times> _) list))))"
	(is "valid_decomp _ (snd ?s)")
	proof -
	from assms have "valid_decomp X (fst ?s) \<and> valid_decomp X (snd ?s)"
	proof (induct t U S rule: split_induct)
	case (base1 t U S)
	from base1(1, 4) show ?case by (simp add: valid_decomp_def monomial_0_iff Polys_closed_monomial)
	next
	case (base2 t U S)
	from base2(1, 5) show ?case by (simp add: valid_decomp_def monomial_0_iff Polys_closed_monomial)
	next
	case (step t U S V x ps0 ps1 qs0 qs1)
	from step.hyps(8, 1) have "x \<in> X" ..
	hence "Poly_Mapping.single x 1 \<in> .[X]" by (rule PPs_closed_single)
	hence "Poly_Mapping.single x 1 + t \<in> .[X]" using step.prems by (rule PPs_closed_plus)
	with step.hyps(15, 16) step.prems show ?case by (simp add: valid_decomp_append)
	qed
	thus "valid_decomp X (fst ?s)" and "valid_decomp X (snd ?s)" by simp_all
	qed

	lemma monomial_decomp_split:
	assumes "finite X" and "U \<subseteq> X" and "finite S"
	shows "monomial_decomp (fst ((split t U S)::(_ \<times> (((_ \<Rightarrow>\<^sub>0 'a::zero_neq_one) \<times> _) list))))"
	and "monomial_decomp (snd ((split t U S)::(_ \<times> (((_ \<Rightarrow>\<^sub>0 'a::zero_neq_one) \<times> _) list))))"
	(is "monomial_decomp (snd ?s)")
	proof -
	from assms have "monomial_decomp (fst ?s) \<and> monomial_decomp (snd ?s)"
	proof (induct t U S rule: split_induct)
	case (base1 t U S)
	from base1(1) show ?case by (simp add: monomial_decomp_def monomial_is_monomial)
	next
	case (base2 t U S)
	from base2(1) show ?case by (simp add: monomial_decomp_def monomial_is_monomial)
	next
	case (step t U S V x ps0 ps1 qs0 qs1)
	from step.hyps(15, 16) show ?case by (auto simp: monomial_decomp_def)
	qed
	thus "monomial_decomp (fst ?s)" and "monomial_decomp (snd ?s)" by simp_all
	qed

	lemma split_splits_wrt:
	assumes "finite X" and "U \<subseteq> X" and "finite S" and "t \<in> .[X]"
	and "ideal F \<div> monomial 1 t = ideal (monomial 1 ` S)"
	shows "splits_wrt (split t U S) (cone (monomial (1::'a::{comm_ring_1,ring_no_zero_divisors}) t, U)) F"
	using assms
	proof (induct t U S rule: split_induct)
	case (base1 t U S)
	from base1(3) have "cone (monomial 1 t, U) \<subseteq> ideal F" by (simp only: lem_4_2_1 base1(5))
	show ?case
	proof (rule splits_wrtI)
	fix h0 U0
	assume "(h0, U0) \<in> set [(monomial (1::'a) t, U)]"
	hence h0: "h0 = monomial 1 t" and "U0 = U" by simp_all
	note this(1)
	also have "monomial 1 t \<in> cone (monomial (1::'a) t, U)" by (fact tip_in_cone)
	also have "\<dots> \<subseteq> ideal F" by fact
	finally show "h0 \<in> ideal F" .

	from base1(4) have "h0 \<in> P[X]" unfolding h0 by (rule Polys_closed_monomial)
	moreover from base1(1) have "U0 \<subseteq> X" by (simp only: \<open>U0 = U\<close>)
	ultimately show "cone (h0, U0) \<subseteq> P[X]" by (rule cone_subset_PolysI)
	qed (simp_all add: cone_decomp_singleton \<open>U \<subseteq> X\<close>)
	next
	case (base2 t U S)
	from base2(4) have "cone (monomial 1 t, U) \<inter> ideal F = {0}" by (simp only: lem_4_2_2 base2(6))
	show ?case
	proof (rule splits_wrtI)
	fix h0 U0
	assume "(h0, U0) \<in> set [(monomial (1::'a) t, U)]"
	hence h0: "h0 = monomial 1 t" and "U0 = U" by simp_all
	note this(1)
	also from base2(5) have "monomial 1 t \<in> P[X]" by (rule Polys_closed_monomial)
	finally have "h0 \<in> P[X]" .
	moreover from base2(1) have "U0 \<subseteq> X" by (simp only: \<open>U0 = U\<close>)
	ultimately show "cone (h0, U0) \<subseteq> P[X]" by (rule cone_subset_PolysI)
	next
	fix h0 U0 a
	assume "(h0, U0) \<in> set [(monomial (1::'a) t, U)]" and "a \<in> cone (h0, U0)"
	hence "a \<in> cone (monomial 1 t, U)" by simp
	moreover assume "a \<in> ideal F"
	ultimately have "a \<in> cone (monomial 1 t, U) \<inter> ideal F" by (rule IntI)
	also have "\<dots> = {0}" by fact
	finally show "a = 0" by simp
	qed (simp_all add: cone_decomp_singleton \<open>U \<subseteq> X\<close>)
	next
	case (step t U S V x ps0 ps1 qs0 qs1)
	let ?x = "Poly_Mapping.single x 1"
	from step.prems have 0: "splits_wrt (ps0, qs0) (cone (monomial 1 t, U - {x})) F" by (rule step.hyps)
	have 1: "splits_wrt (ps1, qs1) (cone (monomial 1 (?x + t), U)) F"
	proof (rule step.hyps)
	from step.hyps(8, 1) have "x \<in> X" ..
	hence "?x \<in> .[X]" by (rule PPs_closed_single)
	thus "?x + t \<in> .[X]" using step.prems(1) by (rule PPs_closed_plus)
	next
	have "ideal F \<div> monomial 1 (?x + t) = ideal F \<div> monomial 1 t \<div> monomial 1 ?x"
	by (simp add: times_monomial_monomial add.commute)
	also have "\<dots> = ideal (monomial 1 ` S) \<div> monomial 1 ?x" by (simp only: step.prems)
	finally show "ideal F \<div> monomial 1 (?x + t) = ideal (monomial 1 ` (\<lambda>s. s - ?x) ` S)"
	by (simp only: quot_monomial_ideal_monomial)
	qed

	show ?case
	proof (rule splits_wrtI)
	from step.hyps(8) have U: "insert x U = U" by blast
	have "direct_decomp (cone (monomial (1::'a) t, insert x (U - {x})))
	[cone (monomial 1 t, U - {x}),
	cone (monomial 1 (monomial (Suc 0) x) * monomial 1 t, insert x (U - {x}))]"
	by (rule direct_decomp_cone_insert) simp
	hence "direct_decomp (cone (monomial (1::'a) t, U))
	[cone (monomial 1 t, U - {x}), cone (monomial 1 (?x + t), U)]"
	by (simp add: U times_monomial_monomial)
	moreover from 0 have "cone_decomp (cone (monomial 1 t, U - {x})) (ps0 @ qs0)"
	by (rule splits_wrtD)
	moreover from 1 have "cone_decomp (cone (monomial 1 (?x + t), U)) (ps1 @ qs1)"
	by (rule splits_wrtD)
	ultimately have "cone_decomp (cone (monomial 1 t, U)) ((ps0 @ qs0) @ (ps1 @ qs1))"
	by (rule cone_decomp_append)
	thus "cone_decomp (cone (monomial 1 t, U)) ((ps0 @ ps1) @ qs0 @ qs1)"
	by (rule cone_decomp_perm) simp
	next
	fix h0 U0
	assume "(h0, U0) \<in> set (ps0 @ ps1)"
	hence "(h0, U0) \<in> set ps0 \<union> set ps1" by simp
	hence "cone (h0, U0) \<subseteq> ideal F \<inter> P[X]"
	proof
	assume "(h0, U0) \<in> set ps0"
	with 0 show ?thesis by (rule splits_wrtD)
	next
	assume "(h0, U0) \<in> set ps1"
	with 1 show ?thesis by (rule splits_wrtD)
	qed
	hence *: "cone (h0, U0) \<subseteq> ideal F" and "cone (h0, U0) \<subseteq> P[X]" by simp_all
	from this(2) show "cone (h0, U0) \<subseteq> P[X]" .

	from tip_in_cone * show "h0 \<in> ideal F" ..
	next
	fix h0 U0
	assume "(h0, U0) \<in> set (qs0 @ qs1)"
	hence "(h0, U0) \<in> set qs0 \<union> set qs1" by simp
	thus "cone (h0, U0) \<subseteq> P[X]"
	proof
	assume "(h0, U0) \<in> set qs0"
	with 0 show ?thesis by (rule splits_wrtD)
	next
	assume "(h0, U0) \<in> set qs1"
	with 1 show ?thesis by (rule splits_wrtD)
	qed

	from \<open>(h0, U0) \<in> set qs0 \<union> set qs1\<close> have "cone (h0, U0) \<inter> ideal F = {0}"
	proof
	assume "(h0, U0) \<in> set qs0"
	with 0 show ?thesis by (rule splits_wrtD)
	next
	assume "(h0, U0) \<in> set qs1"
	with 1 show ?thesis by (rule splits_wrtD)
	qed
	thus "\<And>a. a \<in> cone (h0, U0) \<Longrightarrow> a \<in> ideal F \<Longrightarrow> a = 0" by blast
	qed
	qed

	lemma lem_4_5:
	assumes "finite X" and "U \<subseteq> X" and "t \<in> .[X]" and "F \<subseteq> P[X]"
	and "ideal F \<div> monomial 1 t = ideal (monomial (1::'a) ` S)"
	and "cone (monomial (1::'a::field) t', V) \<subseteq> cone (monomial 1 t, U) \<inter> normal_form F ` P[X]"
	shows "V \<subseteq> U" and "S \<inter> .[V] = {}"
	proof -
	let ?t = "monomial (1::'a) t"
	let ?t' = "monomial (1::'a) t'"
	from assms(6) have 1: "cone (?t', V) \<subseteq> cone (?t, U)" and 2: "cone (?t', V) \<subseteq> normal_form F ` P[X]"
	by blast+
	from this(1) show "V \<subseteq> U" by (rule cone_subsetD) (simp add: monomial_0_iff)

	show "S \<inter> .[V] = {}"
	proof
	let ?t = "monomial (1::'a) t"
	let ?t' = "monomial (1::'a) t'"
	show "S \<inter> .[V] \<subseteq> {}"
	proof
	fix s
	assume "s \<in> S \<inter> .[V]"
	hence "s \<in> S" and "s \<in> .[V]" by simp_all
	from this(2) have "monomial (1::'a) s \<in> P[V]" (is "?s \<in> _") by (rule Polys_closed_monomial)
	with refl have "?s * ?t \<in> cone (?t, V)" by (rule coneI)
	from tip_in_cone 1 have "?t' \<in> cone (?t, U)" ..
	then obtain s' where "s' \<in> P[U]" and t': "?t' = s' * ?t" by (rule coneE)
	note this(1)
	also from assms(2) have "P[U] \<subseteq> P[X]" by (rule Polys_mono)
	finally have "s' \<in> P[X]" .
	have "s' * ?s * ?t = ?s * ?t'" by (simp add: t')
	also from refl \<open>?s \<in> P[V]\<close> have "\<dots> \<in> cone (?t', V)" by (rule coneI)
	finally have "s' * ?s * ?t \<in> cone (?t', V)" .
	hence 1: "s' * ?s * ?t \<in> normal_form F ` P[X]" using 2 ..
	from \<open>s \<in> S\<close> have "?s \<in> monomial 1 ` S" by (rule imageI)
	hence "?s \<in> ideal (monomial 1 ` S)" by (rule ideal.span_base)
	hence "s' * ?s \<in> ideal (monomial 1 ` S)" by (rule ideal.span_scale)
	hence "s' * ?s \<in> ideal F \<div> ?t" by (simp only: assms(5))
	hence "s' * ?s * ?t \<in> ideal F" by (simp only: quot_set_iff mult.commute)
	hence "s' * ?s * ?t \<in> ideal F \<inter> normal_form F ` P[X]" using 1 by (rule IntI)
	also from assms(1, 4) have "\<dots> \<subseteq> {0}"
	by (auto simp: normal_form_normal_form simp flip: normal_form_zero_iff)
	finally have "?s * ?t' = 0" by (simp add: t' ac_simps)
	thus "s \<in> {}" by (simp add: times_monomial_monomial monomial_0_iff)
	qed
	qed (fact empty_subsetI)
	qed

	lemma lem_4_6:
	assumes "finite X" and "U \<subseteq> X" and "finite S" and "t \<in> .[X]" and "F \<subseteq> P[X]"
	and "ideal F \<div> monomial 1 t = ideal (monomial 1 ` S)"
	assumes "cone (monomial 1 t', V) \<subseteq> cone (monomial 1 t, U) \<inter> normal_form F ` P[X]"
	obtains V' where "(monomial 1 t, V') \<in> set (snd (split t U S))" and "card V \<le> card V'"
	proof -
	let ?t = "monomial (1::'a) t"
	let ?t' = "monomial (1::'a) t'"
	from assms(7) have "cone (?t', V) \<subseteq> cone (?t, U)" and "cone (?t', V) \<subseteq> normal_form F ` P[X]"
	by blast+
	from assms(1, 2, 4, 5, 6, 7) have "V \<subseteq> U" and "S \<inter> .[V] = {}" by (rule lem_4_5)+
	with assms(1, 2, 3) show ?thesis using that
	proof (induct t U S arbitrary: V thesis rule: split_induct)
	case (base1 t U S)
	from base1.hyps(3) have "0 \<in> S \<inter> .[V]" using zero_in_PPs by (rule IntI)
	thus ?case by (simp add: base1.prems(2))
	next
	case (base2 t U S)
	show ?case
	proof (rule base2.prems)
	from base2.hyps(1) assms(1) have "finite U" by (rule finite_subset)
	thus "card V \<le> card U" using base2.prems(1) by (rule card_mono)
	qed simp
	next
	case (step t U S V0 x ps0 ps1 qs0 qs1)
	from step.prems(1, 2) have 0: "card V \<le> card V0" by (rule step.hyps)
	from step.hyps(5, 9) have "V0 \<subseteq> U - {x}" by blast
	then obtain V' where 1: "(monomial 1 t, V') \<in> set (snd (ps0, qs0))" and 2: "card V0 \<le> card V'"
	using step.hyps(6) by (rule step.hyps)
	show ?case
	proof (rule step.prems)
	from 1 show "(monomial 1 t, V') \<in> set (snd (ps0 @ ps1, qs0 @ qs1))" by simp
	next
	from 0 2 show "card V \<le> card V'" by (rule le_trans)
	qed
	qed
	qed

	lemma lem_4_7:
	assumes "finite X" and "S \<subseteq> .[X]" and "g \<in> punit.reduced_GB (monomial (1::'a) ` S)"
	and "cone_decomp (P[X] \<inter> ideal (monomial (1::'a::field) ` S)) ps"
	and "monomial_decomp ps"
	obtains U where "(g, U) \<in> set ps"
	proof -
	let ?S = "monomial (1::'a) ` S"
	let ?G = "punit.reduced_GB ?S"
	note assms(1)
	moreover from assms(2) have "?S \<subseteq> P[X]" by (auto intro: Polys_closed_monomial)
	moreover have "is_monomial_set ?S"
	by (auto intro!: is_monomial_setI monomial_is_monomial)
	ultimately have "is_monomial_set ?G" by (rule reduced_GB_is_monomial_set_Polys)
	hence "is_monomial g" using assms(3) by (rule is_monomial_setD)
	hence "g \<noteq> 0" by (rule monomial_not_0)
	moreover from assms(1) \<open>?S \<subseteq> P[X]\<close> have "punit.is_monic_set ?G"
	by (rule reduced_GB_is_monic_set_Polys)
	ultimately have "punit.lc g = 1" using assms(3) by (simp add: punit.is_monic_set_def)
	moreover define t where "t = lpp g"
	moreover from \<open>is_monomial g\<close> have "monomial (punit.lc g) (lpp g) = g"
	by (rule punit.monomial_eq_itself)
	ultimately have g: "g = monomial 1 t" by simp
	hence "t \<in> keys g" by simp
	from assms(3) have "g \<in> ideal ?G" by (rule ideal.span_base)
	also from assms(1) \<open>?S \<subseteq> P[X]\<close> have ideal_G: "\<dots> = ideal ?S" by (rule reduced_GB_ideal_Polys)
	finally have "g \<in> ideal ?S" .
	moreover from assms(3) have "g \<in> P[X]" by rule (intro reduced_GB_Polys assms(1) \<open>?S \<subseteq> P[X]\<close>)
	ultimately have "g \<in> P[X] \<inter> ideal ?S" by simp
	with assms(4) have "g \<in> sum_list ` listset (map cone ps)"
	by (simp only: cone_decomp_def direct_decompD)
	with assms(5) obtain d h U where *: "(h, U) \<in> set ps" and "d \<noteq> 0" and "monomial d t \<in> cone (h, U)"
	using \<open>t \<in> keys g\<close> by (rule monomial_decomp_sum_list_monomial_in_cone)
	from this(3) zero_in_PPs have "punit.monom_mult (1 / d) 0 (monomial d t) \<in> cone (h, U)"
	by (rule cone_closed_monom_mult)
	with \<open>d \<noteq> 0\<close> have "g \<in> cone (h, U)" by (simp add: g punit.monom_mult_monomial)
	then obtain q where "q \<in> P[U]" and g': "g = q * h" by (rule coneE)
	from \<open>g \<noteq> 0\<close> have "q \<noteq> 0" and "h \<noteq> 0" by (auto simp: g')
	hence lt_g': "lpp g = lpp q + lpp h" unfolding g' by (rule lp_times)
	hence adds1: "lpp h adds t" by (simp add: t_def)
	from assms(5) * have "is_monomial h" and "punit.lc h = 1" by (rule monomial_decompD)+
	moreover from this(1) have "monomial (punit.lc h) (lpp h) = h"
	by (rule punit.monomial_eq_itself)
	moreover define s where "s = lpp h"
	ultimately have h: "h = monomial 1 s" by simp
	have "punit.lc q = punit.lc g" by (simp add: g' lc_times \<open>punit.lc h = 1\<close>)
	hence "punit.lc q = 1" by (simp only: \<open>punit.lc g = 1\<close>)
	note tip_in_cone
	also from assms(4) * have "cone (h, U) \<subseteq> P[X] \<inter> ideal ?S" by (rule cone_decomp_cone_subset)
	also have "\<dots> \<subseteq> ideal ?G" by (simp add: ideal_G)
	finally have "h \<in> ideal ?G" .
	from assms(1) \<open>?S \<subseteq> P[X]\<close> have "punit.is_Groebner_basis ?G" by (rule reduced_GB_is_GB_Polys)
	then obtain g' where "g' \<in> ?G" and "g' \<noteq> 0" and adds2: "lpp g' adds lpp h"
	using \<open>h \<in> ideal ?G\<close> \<open>h \<noteq> 0\<close> by (rule punit.GB_adds_lt[simplified])
	from this(3) adds1 have "lpp g' adds t" by (rule adds_trans)
	with _ \<open>g' \<noteq> 0\<close> \<open>t \<in> keys g\<close> have "punit.is_red {g'} g"
	by (rule punit.is_red_addsI[simplified]) simp
	have "g' = g"
	proof (rule ccontr)
	assume "g' \<noteq> g"
	with \<open>g' \<in> ?G\<close> have "{g'} \<subseteq> ?G - {g}" by simp
	with \<open>punit.is_red {g'} g\<close> have red: "punit.is_red (?G - {g}) g" by (rule punit.is_red_subset)
	from assms(1) \<open>?S \<subseteq> P[X]\<close> have "punit.is_auto_reduced ?G" by (rule reduced_GB_is_auto_reduced_Polys)
	hence "\<not> punit.is_red (?G - {g}) g" using assms(3) by (rule punit.is_auto_reducedD)
	thus False using red ..
	qed
	with adds2 have "t adds lpp h" by (simp only: t_def)
	with adds1 have "lpp h = t" by (rule adds_antisym)
	hence "lpp q = 0" using lt_g' by (simp add: t_def)
	hence "monomial (punit.lc q) 0 = q" by (rule punit.lt_eq_min_term_monomial[simplified])
	hence "g = h" by (simp add: \<open>punit.lc q = 1\<close> g')
	with * have "(g, U) \<in> set ps" by simp
	thus ?thesis ..
	qed

	lemma snd_splitI:
	assumes "finite X" and "U \<subseteq> X" and "finite S" and "0 \<notin> S"
	obtains V where "V \<subseteq> U" and "(monomial 1 t, V) \<in> set (snd (split t U S))"
	using assms
	proof (induct t U S arbitrary: thesis rule: split_induct)
	case (base1 t U S)
	from base1.prems(2) base1.hyps(3) show ?case ..
	next
	case (base2 t U S)
	from subset_refl show ?case by (rule base2.prems) simp
	next
	case (step t U S V0 x ps0 ps1 qs0 qs1)
	from step.hyps(3) obtain V where 1: "V \<subseteq> U - {x}" and 2: "(monomial 1 t, V) \<in> set (snd (ps0, qs0))"
	using step.hyps(15) by blast
	show ?case
	proof (rule step.prems)
	from 1 show "V \<subseteq> U" by blast
	next
	from 2 show "(monomial 1 t, V) \<in> set (snd (ps0 @ ps1, qs0 @ qs1))" by fastforce
	qed
	qed

	lemma fst_splitE:
	assumes "finite X" and "U \<subseteq> X" and "finite S" and "0 \<notin> S"
	and "(monomial (1::'a) s, V) \<in> set (fst (split t U S))"
	obtains t' x where "t' \<in> .[X]" and "x \<in> X" and "V \<subseteq> U" and "0 \<notin> (\<lambda>s. s - t') ` S"
	and "s = t' + t + Poly_Mapping.single x 1"
	and "(monomial (1::'a::zero_neq_one) s, V) \<in> set (fst (split (t' + t) V ((\<lambda>s. s - t') ` S)))"
	and "set (snd (split (t' + t) V ((\<lambda>s. s - t') ` S))) \<subseteq> (set (snd (split t U S)) :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) set)"
	using assms
	proof (induct t U S arbitrary: thesis rule: split_induct)
	case (base1 t U S)
	from base1.prems(2) base1.hyps(3) show ?case ..
	next
	case (base2 t U S)
	from base2.prems(3) show ?case by simp
	next
	case (step t U S V0 x ps0 ps1 qs0 qs1)
	from step.prems(3) have "(monomial 1 s, V) \<in> set ps0 \<union> set ps1" by simp
	thus ?case
	proof
	assume "(monomial 1 s, V) \<in> set ps0"
	hence "(monomial (1::'a) s, V) \<in> set (fst (ps0, qs0))" by (simp only: fst_conv)
	with step.hyps(3) obtain t' x' where "t' \<in> .[X]" and "x' \<in> X" and "V \<subseteq> U - {x}"
	and "0 \<notin> (\<lambda>s. s - t') ` S" and "s = t' + t + Poly_Mapping.single x' 1"
	and "(monomial (1::'a) s, V) \<in> set (fst (split (t' + t) V ((\<lambda>s. s - t') ` S)))"
	and "set (snd (split (t' + t) V ((\<lambda>s. s - t') ` S))) \<subseteq> set (snd (ps0, qs0))"
	using step.hyps(15) by blast
	note this(7)
	also have "set (snd (ps0, qs0)) \<subseteq> set (snd (ps0 @ ps1, qs0 @ qs1))" by simp
	finally have "set (snd (split (t' + t) V ((\<lambda>s. s - t') ` S))) \<subseteq> set (snd (ps0 @ ps1, qs0 @ qs1))" .
	from \<open>V \<subseteq> U - {x}\<close> have "V \<subseteq> U" by blast
	show ?thesis by (rule step.prems) fact+
	next
	assume "(monomial 1 s, V) \<in> set ps1"
	show ?thesis
	proof (cases "0 \<in> (\<lambda>f. f - Poly_Mapping.single x 1) ` S")
	case True
	from step.hyps(2) have fin: "finite ((\<lambda>f. f - Poly_Mapping.single x 1) ` S)"
	by (rule finite_imageI)
	have "split (Poly_Mapping.single x 1 + t) U ((\<lambda>f. f - Poly_Mapping.single x 1) ` S) =
	([(monomial (1::'a) (Poly_Mapping.single x 1 + t), U)], [])"
	by (simp only: split.psimps[OF split_domI, OF assms(1) step.hyps(1) fin] True if_True)
	hence "ps1 = [(monomial 1 (Poly_Mapping.single x 1 + t), U)]"
	by (simp only: step.hyps(13)[symmetric] prod.inject)
	with \<open>(monomial 1 s, V) \<in> set ps1\<close> have s: "s = Poly_Mapping.single x 1 + t" and "V = U"
	by (auto dest!: monomial_inj)
	show ?thesis
	proof (rule step.prems)
	show "0 \<in> .[X]" by (fact zero_in_PPs)
	next
	from step.hyps(8, 1) show "x \<in> X" ..
	next
	show "V \<subseteq> U" by (simp add: \<open>V = U\<close>)
	next
	from step.hyps(3) show "0 \<notin> (\<lambda>s. s - 0) ` S" by simp
	next
	show "s = 0 + t + Poly_Mapping.single x 1" by (simp add: s add.commute)
	next
	show "(monomial (1::'a) s, V) \<in> set (fst (split (0 + t) V ((\<lambda>s. s - 0) ` S)))"
	using \<open>(monomial 1 s, V) \<in> set ps1\<close> by (simp add: step.hyps(14) \<open>V = U\<close>)
	next
	show "set (snd (split (0 + t) V ((\<lambda>s. s - 0) ` S))) \<subseteq> set (snd (ps0 @ ps1, qs0 @ qs1))"
	by (simp add: step.hyps(14) \<open>V = U\<close>)
	qed
	next
	case False
	moreover from \<open>(monomial 1 s, V) \<in> set ps1\<close> have "(monomial 1 s, V) \<in> set (fst (ps1, qs1))"
	by (simp only: fst_conv)
	ultimately obtain t' x' where "t' \<in> .[X]" and "x' \<in> X" and "V \<subseteq> U"
	and 1: "0 \<notin> (\<lambda>s. s - t') ` (\<lambda>f. f - Poly_Mapping.single x 1) ` S"
	and s: "s = t' + (Poly_Mapping.single x 1 + t) + Poly_Mapping.single x' 1"
	and 2: "(monomial (1::'a) s, V) \<in> set (fst (split (t' + (Poly_Mapping.single x 1 + t)) V
	((\<lambda>s. s - t') ` (\<lambda>f. f - Poly_Mapping.single x 1) ` S)))"
	and 3: "set (snd (split (t' + (Poly_Mapping.single x 1 + t)) V ((\<lambda>s. s - t') ` (\<lambda>f. f - monomial 1 x) ` S))) \<subseteq>
	set (snd (ps1, qs1))"
	using step.hyps(16) by blast
	have eq: "(\<lambda>s. s - t') ` (\<lambda>f. f - Poly_Mapping.single x 1) ` S =
	(\<lambda>s. s - (t' + Poly_Mapping.single x 1)) ` S"
	by (simp add: image_image add.commute diff_diff_eq)
	show ?thesis
	proof (rule step.prems)
	from step.hyps(8, 1) have "x \<in> X" ..
	hence "Poly_Mapping.single x 1 \<in> .[X]" by (rule PPs_closed_single)
	with \<open>t' \<in> .[X]\<close> show "t' + Poly_Mapping.single x 1 \<in> .[X]" by (rule PPs_closed_plus)
	next
	from 1 show "0 \<notin> (\<lambda>s. s - (t' + Poly_Mapping.single x 1)) ` S"
	by (simp only: eq not_False_eq_True)
	next
	show "s = t' + Poly_Mapping.single x 1 + t + Poly_Mapping.single x' 1" by (simp only: s ac_simps)
	next
	show "(monomial (1::'a) s, V) \<in> set (fst (split (t' + Poly_Mapping.single x 1 + t) V
	((\<lambda>s. s - (t' + Poly_Mapping.single x 1)) ` S)))"
	using 2 by (simp only: eq add.assoc)
	next
	have "set (snd (split (t' + Poly_Mapping.single x 1 + t) V ((\<lambda>s. s - (t' + Poly_Mapping.single x 1)) ` S))) \<subseteq>
	set (snd (ps1, qs1))" (is "?x \<subseteq> _") using 3 by (simp only: eq add.assoc)
	also have "\<dots> \<subseteq> set (snd (ps0 @ ps1, qs0 @ qs1))" by simp
	finally show "?x \<subseteq> set (snd (ps0 @ ps1, qs0 @ qs1))" .
	qed fact+
	qed
	qed
	qed

	lemma lem_4_8:
	assumes "finite X" and "finite S" and "S \<subseteq> .[X]" and "0 \<notin> S"
	and "g \<in> punit.reduced_GB (monomial (1::'a) ` S)"
	obtains t U where "U \<subseteq> X" and "(monomial (1::'a::field) t, U) \<in> set (snd (split 0 X S))"
	and "poly_deg g = Suc (deg_pm t)"
	proof -
	let ?S = "monomial (1::'a) ` S"
	let ?G = "punit.reduced_GB ?S"
	have md1: "monomial_decomp (fst ((split 0 X S)::(_ \<times> (((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list))))"
	and md2: "monomial_decomp (snd ((split 0 X S)::(_ \<times> (((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list))))"
	using assms(1) subset_refl assms(2) by (rule monomial_decomp_split)+
	from assms(3) have 0: "?S \<subseteq> P[X]" by (auto intro: Polys_closed_monomial)
	with assms(1) have "punit.is_auto_reduced ?G" and "punit.is_monic_set ?G"
	and ideal_G: "ideal ?G = ideal ?S" and "0 \<notin> ?G"
	by (rule reduced_GB_is_auto_reduced_Polys, rule reduced_GB_is_monic_set_Polys,
	rule reduced_GB_ideal_Polys, rule reduced_GB_nonzero_Polys)
	from this(2, 4) assms(5) have "punit.lc g = 1" by (auto simp: punit.is_monic_set_def)
	have "is_monomial_set ?S" by (auto intro!: is_monomial_setI monomial_is_monomial)
	with assms(1) 0 have "is_monomial_set ?G" by (rule reduced_GB_is_monomial_set_Polys)
	hence "is_monomial g" using assms(5) by (rule is_monomial_setD)
	moreover define s where "s = lpp g"
	ultimately have g: "g = monomial 1 s" using \<open>punit.lc g = 1\<close> by (metis punit.monomial_eq_itself)
	note assms(1) subset_refl assms(2) zero_in_PPs
	moreover have "ideal ?G \<div> monomial 1 0 = ideal ?S" by (simp add: ideal_G)
	ultimately have "splits_wrt (split 0 X S) (cone (monomial (1::'a) 0, X)) ?G" by (rule split_splits_wrt)
	hence "splits_wrt (fst (split 0 X S), snd (split 0 X S)) P[X] ?G" by simp
	hence "cone_decomp (P[X] \<inter> ideal ?G) (fst (split 0 X S))"
	using md2 \<open>is_monomial_set ?G\<close> by (rule splits_wrt_cone_decomp_1)
	hence "cone_decomp (P[X] \<inter> ideal ?S) (fst (split 0 X S))" by (simp only: ideal_G)
	with assms(1, 3, 5) obtain U where "(g, U) \<in> set (fst (split 0 X S))" using md1 by (rule lem_4_7)
	with assms(1) subset_refl assms(2, 4) obtain t' x where "t' \<in> .[X]" and "x \<in> X" and "U \<subseteq> X"
	and "0 \<notin> (\<lambda>s. s - t') ` S" and s: "s = t' + 0 + Poly_Mapping.single x 1"
	and "(g, U) \<in> set (fst (split (t' + 0) U ((\<lambda>s. s - t') ` S)))"
	and "set (snd (split (t' + 0) U ((\<lambda>s. s - t') ` S))) \<subseteq> (set (snd (split 0 X S)) :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) set)"
	unfolding g by (rule fst_splitE)
	let ?S = "(\<lambda>s. s - t') ` S"
	from assms(2) have "finite ?S" by (rule finite_imageI)
	with assms(1) \<open>U \<subseteq> X\<close> obtain V where "V \<subseteq> U"
	and "(monomial (1::'a) (t' + 0), V) \<in> set (snd (split (t' + 0) U ?S))"
	using \<open>0 \<notin> ?S\<close> by (rule snd_splitI)
	note this(2)
	also have "\<dots> \<subseteq> set (snd (split 0 X S))" by fact
	finally have "(monomial (1::'a) t', V) \<in> set (snd (split 0 X S))" by simp
	have "poly_deg g = Suc (deg_pm t')" by (simp add: g s deg_pm_plus deg_pm_single poly_deg_monomial)
	from \<open>V \<subseteq> U\<close> \<open>U \<subseteq> X\<close> have "V \<subseteq> X" by (rule subset_trans)
	show ?thesis by rule fact+
	qed

	corollary cor_4_9:
	assumes "finite X" and "finite S" and "S \<subseteq> .[X]"
	and "g \<in> punit.reduced_GB (monomial (1::'a::field) ` S)"
	shows "poly_deg g \<le> Suc (Max (poly_deg ` fst ` (set (snd (split 0 X S)) :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) set)))"
	(is "_ \<le> Suc (Max (poly_deg ` fst ` ?S))")
	proof (cases "0 \<in> S")
	case True
	hence "1 \<in> monomial (1::'a) ` S" by (rule rev_image_eqI) (simp only: single_one)
	hence "1 \<in> ideal (monomial (1::'a) ` S)" by (rule ideal.span_base)
	hence "ideal (monomial (1::'a) ` S) = UNIV" by (simp only: ideal_eq_UNIV_iff_contains_one)
	moreover from assms(3) have "monomial (1::'a) ` S \<subseteq> P[X]" by (auto intro: Polys_closed_monomial)
	ultimately have "punit.reduced_GB (monomial (1::'a) ` S) = {1}"
	using assms(1) by (simp only: ideal_eq_UNIV_iff_reduced_GB_eq_one_Polys)
	with assms(4) show ?thesis by simp
	next
	case False
	from finite_set have fin: "finite (poly_deg ` fst ` ?S)" by (intro finite_imageI)
	obtain t U where "(monomial 1 t, U) \<in> ?S" and g: "poly_deg g = Suc (deg_pm t)"
	using assms(1-3) False assms(4) by (rule lem_4_8)
	from this(1) have "poly_deg (fst (monomial (1::'a) t, U)) \<in> poly_deg ` fst ` ?S"
	by (intro imageI)
	hence "deg_pm t \<in> poly_deg ` fst ` ?S" by (simp add: poly_deg_monomial)
	with fin have "deg_pm t \<le> Max (poly_deg ` fst ` ?S)" by (rule Max_ge)
	thus "poly_deg g \<le> Suc (Max (poly_deg ` fst ` ?S))" by (simp add: g)
	qed

	lemma standard_decomp_snd_split:
	assumes "finite X" and "U \<subseteq> X" and "finite S" and "S \<subseteq> .[X]" and "t \<in> .[X]"
	shows "standard_decomp (deg_pm t) (snd (split t U S) :: ((_ \<Rightarrow>\<^sub>0 'a::field) \<times> _) list)"
	using assms
	proof (induct t U S rule: split_induct)
	case (base1 t U S)
	show ?case by (simp add: standard_decomp_Nil)
	next
	case (base2 t U S)
	have "deg_pm t = poly_deg (monomial (1::'a) t)" by (simp add: poly_deg_monomial)
	thus ?case by (simp add: standard_decomp_singleton)
	next
	case (step t U S V x ps0 ps1 qs0 qs1)
	from step.hyps(15) step.prems have qs0: "standard_decomp (deg_pm t) qs0" by (simp only: snd_conv)
	have "(\<lambda>s. s - Poly_Mapping.single x 1) ` S \<subseteq> .[X]"
	proof
	fix u
	assume "u \<in> (\<lambda>s. s - Poly_Mapping.single x 1) ` S"
	then obtain s where "s \<in> S" and u: "u = s - Poly_Mapping.single x 1" ..
	from this(1) step.prems(1) have "s \<in> .[X]" ..
	thus "u \<in> .[X]" unfolding u by (rule PPs_closed_minus)
	qed
	moreover from _ step.prems(2) have "Poly_Mapping.single x 1 + t \<in> .[X]"
	proof (rule PPs_closed_plus)
	from step.hyps(8, 1) have "x \<in> X" ..
	thus "Poly_Mapping.single x 1 \<in> .[X]" by (rule PPs_closed_single)
	qed
	ultimately have qs1: "standard_decomp (Suc (deg_pm t)) qs1" using step.hyps(16)
	by (simp add: deg_pm_plus deg_pm_single)
	show ?case unfolding snd_conv
	proof (rule standard_decompI)
	fix h U0
	assume "(h, U0) \<in> set ((qs0 @ qs1)\<^sub>+)"
	hence *: "(h, U0) \<in> set (qs0\<^sub>+) \<union> set (qs1\<^sub>+)" by (simp add: pos_decomp_append)
	thus "deg_pm t \<le> poly_deg h"
	proof
	assume "(h, U0) \<in> set (qs0\<^sub>+)"
	with qs0 show ?thesis by (rule standard_decompD)
	next
	assume "(h, U0) \<in> set (qs1\<^sub>+)"
	with qs1 have "Suc (deg_pm t) \<le> poly_deg h" by (rule standard_decompD)
	thus ?thesis by simp
	qed

	fix d
	assume d1: "deg_pm t \<le> d" and d2: "d \<le> poly_deg h"
	from * show "\<exists>t' U'. (t', U') \<in> set (qs0 @ qs1) \<and> poly_deg t' = d \<and> card U0 \<le> card U'"
	proof
	assume "(h, U0) \<in> set (qs0\<^sub>+)"
	with qs0 obtain h' U' where "(h', U') \<in> set qs0" and "poly_deg h' = d" and "card U0 \<le> card U'"
	using d1 d2 by (rule standard_decompE)
	moreover from this(1) have "(h', U') \<in> set (qs0 @ qs1)" by simp
	ultimately show ?thesis by blast
	next
	assume "(h, U0) \<in> set (qs1\<^sub>+)"
	hence "(h, U0) \<in> set qs1" by (simp add: pos_decomp_def)
	from assms(1) step.hyps(1, 2) have "monomial_decomp (snd (split t U S) :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list)"
	by (rule monomial_decomp_split)
	hence md: "monomial_decomp (qs0 @ qs1)" by (simp add: step.hyps(14))
	moreover from \<open>(h, U0) \<in> set qs1\<close> have "(h, U0) \<in> set (qs0 @ qs1)" by simp
	ultimately have "is_monomial h" and "punit.lc h = 1" by (rule monomial_decompD)+
	moreover from this(1) have "monomial (punit.lc h) (lpp h) = h" by (rule punit.monomial_eq_itself)
	moreover define s where "s = lpp h"
	ultimately have h: "h = monomial 1 s" by simp
	from d1 have "deg_pm t = d \<or> Suc (deg_pm t) \<le> d" by auto
	thus ?thesis
	proof
	assume "deg_pm t = d"
	define F where "F = (*) (monomial 1 t) ` monomial (1::'a) ` S"
	have "F \<subseteq> P[X]"
	proof
	fix f
	assume "f \<in> F"
	then obtain u where "u \<in> S" and f: "f = monomial 1 (t + u)"
	by (auto simp: F_def times_monomial_monomial)
	from this(1) step.prems(1) have "u \<in> .[X]" ..
	with step.prems(2) have "t + u \<in> .[X]" by (rule PPs_closed_plus)
	thus "f \<in> P[X]" unfolding f by (rule Polys_closed_monomial)
	qed
	have "ideal F = (*) (monomial 1 t) ` ideal (monomial 1 ` S)"
	by (simp only: ideal.span_image_scale_eq_image_scale F_def)
	moreover have "inj ((*) (monomial (1::'a) t))"
	by (auto intro!: injI simp: times_monomial_left monomial_0_iff dest!: punit.monom_mult_inj_3)
	ultimately have eq: "ideal F \<div> monomial 1 t = ideal (monomial 1 ` S)"
	by (simp only: quot_set_image_times)
	with assms(1) step.hyps(1, 2) step.prems(2)
	have "splits_wrt (split t U S) (cone (monomial (1::'a) t, U)) F" by (rule split_splits_wrt)
	hence "splits_wrt (ps0 @ ps1, qs0 @ qs1) (cone (monomial 1 t, U)) F" by (simp only: step.hyps(14))
	with assms(1) have "cone_decomp (cone (monomial (1::'a) t, U) \<inter> normal_form F ` P[X]) (qs0 @ qs1)"
	using md _ \<open>F \<subseteq> P[X]\<close>
	by (rule splits_wrt_cone_decomp_2)
	(auto intro!: is_monomial_setI monomial_is_monomial simp: F_def times_monomial_monomial)
	hence "cone (monomial 1 s, U0) \<subseteq> cone (monomial (1::'a) t, U) \<inter> normal_form F ` P[X]"
	using \<open>(h, U0) \<in> set (qs0 @ qs1)\<close> unfolding h by (rule cone_decomp_cone_subset)
	with assms(1) step.hyps(1, 2) step.prems(2) \<open>F \<subseteq> P[X]\<close> eq
	obtain U' where "(monomial (1::'a) t, U') \<in> set (snd (split t U S))" and "card U0 \<le> card U'"
	by (rule lem_4_6)
	from this(1) have "(monomial 1 t, U') \<in> set (qs0 @ qs1)" by (simp add: step.hyps(14))
	show ?thesis
	proof (intro exI conjI)
	show "poly_deg (monomial (1::'a) t) = d" by (simp add: poly_deg_monomial \<open>deg_pm t = d\<close>)
	qed fact+
	next
	assume "Suc (deg_pm t) \<le> d"
	with qs1 \<open>(h, U0) \<in> set (qs1\<^sub>+)\<close> obtain h' U' where "(h', U') \<in> set qs1" and "poly_deg h' = d"
	and "card U0 \<le> card U'" using d2 by (rule standard_decompE)
	moreover from this(1) have "(h', U') \<in> set (qs0 @ qs1)" by simp
	ultimately show ?thesis by blast
	qed
	qed
	qed
	qed

	theorem standard_cone_decomp_snd_split:
	fixes F
	defines "G \<equiv> punit.reduced_GB F"
	defines "ss \<equiv> (split 0 X (lpp ` G)) :: ((_ \<Rightarrow>\<^sub>0 'a::field) \<times> _) list \<times> _"
	defines "d \<equiv> Suc (Max (poly_deg ` fst ` set (snd ss)))"
	assumes "finite X" and "F \<subseteq> P[X]"
	shows "standard_decomp 0 (snd ss)" (is ?thesis1)
	and "cone_decomp (normal_form F ` P[X]) (snd ss)" (is ?thesis2)
	and "(\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> g \<in> G \<Longrightarrow> poly_deg g \<le> d"
	proof -
	have "ideal G = ideal F" and "punit.is_Groebner_basis G" and "finite G" and "0 \<notin> G"
	and "G \<subseteq> P[X]" and "punit.is_reduced_GB G" using assms(4, 5) unfolding G_def
	by (rule reduced_GB_ideal_Polys, rule reduced_GB_is_GB_Polys, rule finite_reduced_GB_Polys,
	rule reduced_GB_nonzero_Polys, rule reduced_GB_Polys, rule reduced_GB_is_reduced_GB_Polys)
	define S where "S = lpp ` G"
	note assms(4) subset_refl
	moreover from \<open>finite G\<close> have "finite S" unfolding S_def by (rule finite_imageI)
	moreover from \<open>G \<subseteq> P[X]\<close> have "S \<subseteq> .[X]" unfolding S_def by (rule PPs_closed_image_lpp)
	ultimately have "standard_decomp (deg_pm (0::'x \<Rightarrow>\<^sub>0 nat)) (snd ss)"
	using zero_in_PPs unfolding ss_def S_def by (rule standard_decomp_snd_split)
	thus ?thesis1 by simp

	let ?S = "monomial (1::'a) ` S"
	from \<open>S \<subseteq> .[X]\<close> have "?S \<subseteq> P[X]" by (auto intro: Polys_closed_monomial)
	have "splits_wrt ss (cone (monomial 1 0, X)) ?S"
	using assms(4) subset_refl \<open>finite S\<close> zero_in_PPs unfolding ss_def S_def
	by (rule split_splits_wrt) simp
	hence "splits_wrt (fst ss, snd ss) P[X] ?S" by simp
	with assms(4) have "cone_decomp (P[X] \<inter> normal_form ?S ` P[X]) (snd ss)" using _ _ \<open>?S \<subseteq> P[X]\<close>
	proof (rule splits_wrt_cone_decomp_2)
	from assms(4) subset_refl \<open>finite S\<close> show "monomial_decomp (snd ss)"
	unfolding ss_def S_def by (rule monomial_decomp_split)
	qed (auto intro!: is_monomial_setI monomial_is_monomial)
	moreover have "normal_form ?S ` P[X] = normal_form F ` P[X]"
	by (rule set_eqI)
	(simp add: image_normal_form_iff[OF assms(4)] assms(5) \<open>?S \<subseteq> P[X]\<close>,
	simp add: S_def is_red_reduced_GB_monomial_lt_GB_Polys[OF assms(4)] \<open>G \<subseteq> P[X]\<close> \<open>0 \<notin> G\<close> flip: G_def)
	moreover from assms(4, 5) have "normal_form F ` P[X] \<subseteq> P[X]"
	by (auto intro: Polys_closed_normal_form)
	ultimately show ?thesis2 by (simp only: Int_absorb1)

	assume "\<And>f. f \<in> F \<Longrightarrow> homogeneous f"
	moreover note \<open>punit.is_reduced_GB G\<close> \<open>ideal G = ideal F\<close>
	moreover assume "g \<in> G"
	ultimately have "homogeneous g" by (rule is_reduced_GB_homogeneous)
	moreover have "lpp g \<in> keys g"
	proof (rule punit.lt_in_keys)
	from \<open>g \<in> G\<close> \<open>0 \<notin> G\<close> show "g \<noteq> 0" by blast
	qed
	ultimately have deg_lt: "deg_pm (lpp g) = poly_deg g" by (rule homogeneousD_poly_deg)
	from \<open>g \<in> G\<close> have "monomial 1 (lpp g) \<in> ?S" unfolding S_def by (intro imageI)
	also have "\<dots> = punit.reduced_GB ?S" unfolding S_def G_def using assms(4, 5)
	by (rule reduced_GB_monomial_lt_reduced_GB_Polys[symmetric])
	finally have "monomial 1 (lpp g) \<in> punit.reduced_GB ?S" .
	with assms(4) \<open>finite S\<close> \<open>S \<subseteq> .[X]\<close> have "poly_deg (monomial (1::'a) (lpp g)) \<le> d"
	unfolding d_def ss_def S_def[symmetric] by (rule cor_4_9)
	thus "poly_deg g \<le> d" by (simp add: poly_deg_monomial deg_lt)
	qed

	subsection \<open>Splitting Ideals\<close>

	qualified definition ideal_decomp_aux :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) set \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow>
	((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field) set \<times> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list)"
	where "ideal_decomp_aux F f =
	(let J = ideal F; L = (J \<div> f) \<inter> P[X]; L' = lpp ` punit.reduced_GB L in
	(() f ` normal_form L ` P[X], map (apfst (() f)) (snd (split 0 X L'))))"

	context
	assumes fin_X: "finite X"
	begin

	lemma ideal_decomp_aux:
	assumes "finite F" and "F \<subseteq> P[X]" and "f \<in> P[X]"
	shows "fst (ideal_decomp_aux F f) \<subseteq> ideal {f}" (is ?thesis1)
	and "ideal F \<inter> fst (ideal_decomp_aux F f) = {0}" (is ?thesis2)
	and "direct_decomp (ideal (insert f F) \<inter> P[X]) [fst (ideal_decomp_aux F f), ideal F \<inter> P[X]]" (is ?thesis3)
	and "cone_decomp (fst (ideal_decomp_aux F f)) (snd (ideal_decomp_aux F f))" (is ?thesis4)
	and "f \<noteq> 0 \<Longrightarrow> valid_decomp X (snd (ideal_decomp_aux F f))" (is "_ \<Longrightarrow> ?thesis5")
	and "f \<noteq> 0 \<Longrightarrow> standard_decomp (poly_deg f) (snd (ideal_decomp_aux F f))" (is "_ \<Longrightarrow> ?thesis6")
	and "homogeneous f \<Longrightarrow> hom_decomp (snd (ideal_decomp_aux F f))" (is "_ \<Longrightarrow> ?thesis7")
	proof -
	define J where "J = ideal F"
	define L where "L = (J \<div> f) \<inter> P[X]"
	define S where "S = (*) f ` normal_form L ` P[X]"
	define L' where "L' = lpp ` punit.reduced_GB L"

	have eq: "ideal_decomp_aux F f = (S, map (apfst ((*) f)) (snd (split 0 X L')))"
	by (simp add: J_def ideal_decomp_aux_def Let_def L_def L'_def S_def)

	have L_sub: "L \<subseteq> P[X]" by (simp add: L_def)

	show ?thesis1 unfolding eq fst_conv
	proof
	fix s
	assume "s \<in> S"
	then obtain q where "s = normal_form L q * f" unfolding S_def by (elim imageE) auto
	also have "\<dots> \<in> ideal {f}" by (intro ideal.span_scale ideal.span_base singletonI)
	finally show "s \<in> ideal {f}" .
	qed

	show ?thesis2
	proof (rule set_eqI)
	fix h
	show "h \<in> ideal F \<inter> fst (ideal_decomp_aux F f) \<longleftrightarrow> h \<in> {0}"
	proof
	assume "h \<in> ideal F \<inter> fst (ideal_decomp_aux F f)"
	hence "h \<in> J" and "h \<in> S" by (simp_all add: J_def S_def eq)
	from this(2) obtain q where "q \<in> P[X]" and h: "h = f * normal_form L q" by (auto simp: S_def)
	from fin_X L_sub this(1) have "normal_form L q \<in> P[X]" by (rule Polys_closed_normal_form)
	moreover from \<open>h \<in> J\<close> have "f * normal_form L q \<in> J" by (simp add: h)
	ultimately have "normal_form L q \<in> L" by (simp add: L_def quot_set_iff)
	hence "normal_form L q \<in> ideal L" by (rule ideal.span_base)
	with normal_form_diff_in_ideal[OF fin_X L_sub] have "(q - normal_form L q) + normal_form L q \<in> ideal L"
	by (rule ideal.span_add)
	hence "normal_form L q = 0" using fin_X L_sub by (simp add: normal_form_zero_iff)
	thus "h \<in> {0}" by (simp add: h)
	next
	assume "h \<in> {0}"
	moreover have "0 \<in> (*) f ` normal_form L ` P[X]"
	proof (intro image_eqI)
	from fin_X L_sub show "0 = normal_form L 0" by (simp only: normal_form_zero)
	qed (simp_all add: zero_in_Polys)
	ultimately show "h \<in> ideal F \<inter> fst (ideal_decomp_aux F f)" by (simp add: ideal.span_zero eq S_def)
	qed
	qed

	have "direct_decomp (ideal (insert f F) \<inter> P[X]) [ideal F \<inter> P[X], fst (ideal_decomp_aux F f)]"
	unfolding eq fst_conv S_def L_def J_def using fin_X assms(2, 3) by (rule direct_decomp_ideal_insert)
	thus ?thesis3 by (rule direct_decomp_perm) simp

	have std: "standard_decomp 0 (snd (split 0 X L') :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list)"
	and "cone_decomp (normal_form L ` P[X]) (snd (split 0 X L'))"
	unfolding L'_def using fin_X \<open>L \<subseteq> P[X]\<close> by (rule standard_cone_decomp_snd_split)+
	from this(2) show ?thesis4 unfolding eq fst_conv snd_conv S_def by (rule cone_decomp_map_times)

	from fin_X \<open>L \<subseteq> P[X]\<close> have "finite (punit.reduced_GB L)" by (rule finite_reduced_GB_Polys)
	hence "finite L'" unfolding L'_def by (rule finite_imageI)
	{
	have "monomial_decomp (snd (split 0 X L') :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list)"
	using fin_X subset_refl \<open>finite L'\<close> by (rule monomial_decomp_split)
	hence "hom_decomp (snd (split 0 X L') :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list)"
	by (rule monomial_decomp_imp_hom_decomp)
	moreover assume "homogeneous f"
	ultimately show ?thesis7 unfolding eq snd_conv by (rule hom_decomp_map_times)
	}

	have vd: "valid_decomp X (snd (split 0 X L') :: ((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list)"
	using fin_X subset_refl \<open>finite L'\<close> zero_in_PPs by (rule valid_decomp_split)
	moreover note assms(3)
	moreover assume "f \<noteq> 0"
	ultimately show ?thesis5 unfolding eq snd_conv by (rule valid_decomp_map_times)

	from std vd \<open>f \<noteq> 0\<close> have "standard_decomp (0 + poly_deg f) (map (apfst ((*) f)) (snd (split 0 X L')))"
	by (rule standard_decomp_map_times)
	thus ?thesis6 by (simp add: eq)
	qed

	lemma ideal_decompE:
	fixes f0 :: "_ \<Rightarrow>\<^sub>0 'a::field"
	assumes "finite F" and "F \<subseteq> P[X]" and "f0 \<in> P[X]" and "\<And>f. f \<in> F \<Longrightarrow> poly_deg f \<le> poly_deg f0"
	obtains T ps where "valid_decomp X ps" and "standard_decomp (poly_deg f0) ps" and "cone_decomp T ps"
	and "(\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> hom_decomp ps"
	and "direct_decomp (ideal (insert f0 F) \<inter> P[X]) [ideal {f0} \<inter> P[X], T]"
	using assms(1, 2, 4)
	proof (induct F arbitrary: thesis)
	case empty
	show ?case
	proof (rule empty.prems)
	show "valid_decomp X []" by (rule valid_decompI) simp_all
	next
	show "standard_decomp (poly_deg f0) []" by (rule standard_decompI) simp_all
	next
	show "cone_decomp {0} []" by (rule cone_decompI) (simp add: direct_decomp_def bij_betw_def)
	next
	have "direct_decomp (ideal {f0} \<inter> P[X]) [ideal {f0} \<inter> P[X]]"
	by (fact direct_decomp_singleton)
	hence "direct_decomp (ideal {f0} \<inter> P[X]) [{0}, ideal {f0} \<inter> P[X]]" by (rule direct_decomp_Cons_zeroI)
	thus "direct_decomp (ideal {f0} \<inter> P[X]) [ideal {f0} \<inter> P[X], {0}]"
	by (rule direct_decomp_perm) simp
	qed (simp add: hom_decomp_def)
	next
	case (insert f F)
	from insert.prems(2) have "F \<subseteq> P[X]" by simp
	moreover have "poly_deg f' \<le> poly_deg f0" if "f' \<in> F" for f'
	proof -
	from that have "f' \<in> insert f F" by simp
	thus ?thesis by (rule insert.prems)
	qed
	ultimately obtain T ps where valid_ps: "valid_decomp X ps" and std_ps: "standard_decomp (poly_deg f0) ps"
	and cn_ps: "cone_decomp T ps" and dd: "direct_decomp (ideal (insert f0 F) \<inter> P[X]) [ideal {f0} \<inter> P[X], T]"
	and hom_ps: "(\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> hom_decomp ps"
	using insert.hyps(3) by metis
	show ?case
	proof (cases "f = 0")
	case True
	show ?thesis
	proof (rule insert.prems)
	from dd show "direct_decomp (ideal (insert f0 (insert f F)) \<inter> P[X]) [ideal {f0} \<inter> P[X], T]"
	by (simp only: insert_commute[of f0] True ideal.span_insert_zero)
	next
	assume "\<And>f'. f' \<in> insert f F \<Longrightarrow> homogeneous f'"
	hence "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" by blast
	thus "hom_decomp ps" by (rule hom_ps)
	qed fact+
	next
	case False
	let ?D = "ideal_decomp_aux (insert f0 F) f"
	from insert.hyps(1) have f0F_fin: "finite (insert f0 F)" by simp
	moreover from \<open>F \<subseteq> P[X]\<close> assms(3) have f0F_sub: "insert f0 F \<subseteq> P[X]" by simp
	moreover from insert.prems(2) have "f \<in> P[X]" by simp
	ultimately have eq: "ideal (insert f0 F) \<inter> fst ?D = {0}" and "valid_decomp X (snd ?D)"
	and cn_D: "cone_decomp (fst ?D) (snd ?D)"
	and "standard_decomp (poly_deg f) (snd ?D)"
	and dd': "direct_decomp (ideal (insert f (insert f0 F)) \<inter> P[X])
	[fst ?D, ideal (insert f0 F) \<inter> P[X]]"
	and hom_D: "homogeneous f \<Longrightarrow> hom_decomp (snd ?D)"
	by (rule ideal_decomp_aux, auto intro: ideal_decomp_aux simp: False)
	note fin_X this(2-4)
	moreover have "poly_deg f \<le> poly_deg f0" by (rule insert.prems) simp
	ultimately obtain qs where valid_qs: "valid_decomp X qs" and cn_qs: "cone_decomp (fst ?D) qs"
	and std_qs: "standard_decomp (poly_deg f0) qs"
	and hom_qs: "hom_decomp (snd ?D) \<Longrightarrow> hom_decomp qs" by (rule standard_decomp_geE) blast
	let ?T = "sum_list ` listset [T, fst ?D]"
	let ?ps = "ps @ qs"
	show ?thesis
	proof (rule insert.prems)
	from valid_ps valid_qs show "valid_decomp X ?ps" by (rule valid_decomp_append)
	next
	from std_ps std_qs show "standard_decomp (poly_deg f0) ?ps" by (rule standard_decomp_append)
	next
	from dd have "direct_decomp (ideal (insert f0 F) \<inter> P[X]) [T, ideal {f0} \<inter> P[X]]"
	by (rule direct_decomp_perm) simp
	hence "T \<subseteq> ideal (insert f0 F) \<inter> P[X]"
	by (rule direct_decomp_Cons_subsetI) (simp add: ideal.span_zero zero_in_Polys)
	hence "T \<inter> fst ?D \<subseteq> ideal (insert f0 F) \<inter> fst ?D" by blast
	hence "T \<inter> fst ?D \<subseteq> {0}" by (simp only: eq)
	from refl have "direct_decomp ?T [T, fst ?D]"
	proof (intro direct_decompI inj_onI)
	fix xs ys
	assume "xs \<in> listset [T, fst ?D]"
	then obtain x1 x2 where "x1 \<in> T" and "x2 \<in> fst ?D" and xs: "xs = [x1, x2]"
	by (rule listset_doubletonE)
	assume "ys \<in> listset [T, fst ?D]"
	then obtain y1 y2 where "y1 \<in> T" and "y2 \<in> fst ?D" and ys: "ys = [y1, y2]"
	by (rule listset_doubletonE)
	assume "sum_list xs = sum_list ys"
	hence "x1 - y1 = y2 - x2" by (simp add: xs ys) (metis add_diff_cancel_left add_diff_cancel_right)
	moreover from cn_ps \<open>x1 \<in> T\<close> \<open>y1 \<in> T\<close> have "x1 - y1 \<in> T" by (rule cone_decomp_closed_minus)
	moreover from cn_D \<open>y2 \<in> fst ?D\<close> \<open>x2 \<in> fst ?D\<close> have "y2 - x2 \<in> fst ?D"
	by (rule cone_decomp_closed_minus)
	ultimately have "y2 - x2 \<in> T \<inter> fst ?D" by simp
	also have "\<dots> \<subseteq> {0}" by fact
	finally have "x2 = y2" by simp
	with \<open>x1 - y1 = y2 - x2\<close> show "xs = ys" by (simp add: xs ys)
	qed
	thus "cone_decomp ?T ?ps" using cn_ps cn_qs by (rule cone_decomp_append)
	next
	assume "\<And>f'. f' \<in> insert f F \<Longrightarrow> homogeneous f'"
	hence "homogeneous f" and "\<And>f'. f' \<in> F \<Longrightarrow> homogeneous f'" by blast+
	from this(2) have "hom_decomp ps" by (rule hom_ps)
	moreover from \<open>homogeneous f\<close> have "hom_decomp qs" by (intro hom_qs hom_D)
	ultimately show "hom_decomp (ps @ qs)" by (simp only: hom_decomp_append_iff)
	next
	from dd' have "direct_decomp (ideal (insert f0 (insert f F)) \<inter> P[X])
	[ideal (insert f0 F) \<inter> P[X], fst ?D]"
	by (simp add: insert_commute direct_decomp_perm)
	hence "direct_decomp (ideal (insert f0 (insert f F)) \<inter> P[X])
	([fst ?D] @ [ideal {f0} \<inter> P[X], T])" using dd by (rule direct_decomp_direct_decomp)
	hence "direct_decomp (ideal (insert f0 (insert f F)) \<inter> P[X]) ([ideal {f0} \<inter> P[X]] @ [T, fst ?D])"
	by (rule direct_decomp_perm) auto
	hence "direct_decomp (ideal (insert f0 (insert f F)) \<inter> P[X]) [sum_list ` listset [ideal {f0} \<inter> P[X]], ?T]"
	by (rule direct_decomp_appendD)
	thus "direct_decomp (ideal (insert f0 (insert f F)) \<inter> P[X]) [ideal {f0} \<inter> P[X], ?T]"
	by (simp add: image_image)
	qed
	qed
	qed

	subsection \<open>Exact Cone Decompositions\<close>

	definition exact_decomp :: "nat \<Rightarrow> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<times> 'x set) list \<Rightarrow> bool"
	where "exact_decomp m ps \<longleftrightarrow> (\<forall>(h, U)\<in>set ps. h \<in> P[X] \<and> U \<subseteq> X) \<and>
	(\<forall>(h, U)\<in>set ps. \<forall>(h', U')\<in>set ps. poly_deg h = poly_deg h' \<longrightarrow>
	m < card U \<longrightarrow> m < card U' \<longrightarrow> (h, U) = (h', U'))"

	lemma exact_decompI:
	"(\<And>h U. (h, U) \<in> set ps \<Longrightarrow> h \<in> P[X]) \<Longrightarrow> (\<And>h U. (h, U) \<in> set ps \<Longrightarrow> U \<subseteq> X) \<Longrightarrow>
	(\<And>h h' U U'. (h, U) \<in> set ps \<Longrightarrow> (h', U') \<in> set ps \<Longrightarrow> poly_deg h = poly_deg h' \<Longrightarrow>
	m < card U \<Longrightarrow> m < card U' \<Longrightarrow> (h, U) = (h', U')) \<Longrightarrow>
	exact_decomp m ps"
	unfolding exact_decomp_def by fastforce

	lemma exact_decompD:
	assumes "exact_decomp m ps" and "(h, U) \<in> set ps"
	shows "h \<in> P[X]" and "U \<subseteq> X"
	and "(h', U') \<in> set ps \<Longrightarrow> poly_deg h = poly_deg h' \<Longrightarrow> m < card U \<Longrightarrow> m < card U' \<Longrightarrow>
	(h, U) = (h', U')"
	using assms unfolding exact_decomp_def by fastforce+

	lemma exact_decompI_zero:
	assumes "\<And>h U. (h, U) \<in> set ps \<Longrightarrow> h \<in> P[X]" and "\<And>h U. (h, U) \<in> set ps \<Longrightarrow> U \<subseteq> X"
	and "\<And>h h' U U'. (h, U) \<in> set (ps\<^sub>+) \<Longrightarrow> (h', U') \<in> set (ps\<^sub>+) \<Longrightarrow> poly_deg h = poly_deg h' \<Longrightarrow>
	(h, U) = (h', U')"
	shows "exact_decomp 0 ps"
	using assms(1, 2)
	proof (rule exact_decompI)
	fix h h' and U U' :: "'x set"
	assume "0 < card U"
	hence "U \<noteq> {}" by auto
	moreover assume "(h, U) \<in> set ps"
	ultimately have "(h, U) \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	assume "0 < card U'"
	hence "U' \<noteq> {}" by auto
	moreover assume "(h', U') \<in> set ps"
	ultimately have "(h', U') \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	assume "poly_deg h = poly_deg h'"
	with \<open>(h, U) \<in> set (ps\<^sub>+)\<close> \<open>(h', U') \<in> set (ps\<^sub>+)\<close> show "(h, U) = (h', U')" by (rule assms(3))
	qed

	lemma exact_decompD_zero:
	assumes "exact_decomp 0 ps" and "(h, U) \<in> set (ps\<^sub>+)" and "(h', U') \<in> set (ps\<^sub>+)"
	and "poly_deg h = poly_deg h'"
	shows "(h, U) = (h', U')"
	proof -
	from assms(2) have "(h, U) \<in> set ps" and "U \<noteq> {}" by (simp_all add: pos_decomp_def)
	from assms(1) this(1) have "U \<subseteq> X" by (rule exact_decompD)
	hence "finite U" using fin_X by (rule finite_subset)
	with \<open>U \<noteq> {}\<close> have "0 < card U" by (simp add: card_gt_0_iff)
	from assms(3) have "(h', U') \<in> set ps" and "U' \<noteq> {}" by (simp_all add: pos_decomp_def)
	from assms(1) this(1) have "U' \<subseteq> X" by (rule exact_decompD)
	hence "finite U'" using fin_X by (rule finite_subset)
	with \<open>U' \<noteq> {}\<close> have "0 < card U'" by (simp add: card_gt_0_iff)
	show ?thesis by (rule exact_decompD) fact+
	qed

	lemma exact_decomp_imp_valid_decomp:
	assumes "exact_decomp m ps" and "\<And>h U. (h, U) \<in> set ps \<Longrightarrow> h \<noteq> 0"
	shows "valid_decomp X ps"
	proof (rule valid_decompI)
	fix h U
	assume *: "(h, U) \<in> set ps"
	with assms(1) show "h \<in> P[X]" and "U \<subseteq> X" by (rule exact_decompD)+
	from * show "h \<noteq> 0" by (rule assms(2))
	qed

	lemma exact_decomp_card_X:
	assumes "valid_decomp X ps" and "card X \<le> m"
	shows "exact_decomp m ps"
	proof (rule exact_decompI)
	fix h U
	assume "(h, U) \<in> set ps"
	with assms(1) show "h \<in> P[X]" and "U \<subseteq> X" by (rule valid_decompD)+
	next
	fix h1 h2 U1 U2
	assume "(h1, U1) \<in> set ps"
	with assms(1) have "U1 \<subseteq> X" by (rule valid_decompD)
	with fin_X have "card U1 \<le> card X" by (rule card_mono)
	also have "\<dots> \<le> m" by (fact assms(2))
	also assume "m < card U1"
	finally show "(h1, U1) = (h2, U2)" by simp
	qed

	definition \<a> :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<times> 'x set) list \<Rightarrow> nat"
	where "\<a> ps = (LEAST k. standard_decomp k ps)"

	definition \<b> :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<times> 'x set) list \<Rightarrow> nat \<Rightarrow> nat"
	where "\<b> ps i = (LEAST d. \<a> ps \<le> d \<and> (\<forall>(h, U)\<in>set ps. i \<le> card U \<longrightarrow> poly_deg h < d))"

	lemma \<a>: "standard_decomp k ps \<Longrightarrow> standard_decomp (\<a> ps) ps"
	unfolding \<a>_def by (rule LeastI)

	lemma \<a>_Nil:
	assumes "ps\<^sub>+ = []"
	shows "\<a> ps = 0"
	proof -
	from assms have "standard_decomp 0 ps" by (rule standard_decomp_Nil)
	thus ?thesis unfolding \<a>_def by (rule Least_eq_0)
	qed

	lemma \<a>_nonempty:
	assumes "valid_decomp X ps" and "standard_decomp k ps" and "ps\<^sub>+ \<noteq> []"
	shows "\<a> ps = Min (poly_deg ` fst ` set (ps\<^sub>+))"
	using fin_X assms(1) _ assms(3)
	proof (rule standard_decomp_nonempty_unique)
	from assms(2) show "standard_decomp (\<a> ps) ps" by (rule \<a>)
	qed

	lemma \<a>_nonempty_unique:
	assumes "valid_decomp X ps" and "standard_decomp k ps" and "ps\<^sub>+ \<noteq> []"
	shows "\<a> ps = k"
	proof -
	from assms have "\<a> ps = Min (poly_deg ` fst ` set (ps\<^sub>+))" by (rule \<a>_nonempty)
	moreover from fin_X assms have "k = Min (poly_deg ` fst ` set (ps\<^sub>+))"
	by (rule standard_decomp_nonempty_unique)
	ultimately show ?thesis by simp
	qed

	lemma \<b>:
	shows "\<a> ps \<le> \<b> ps i" and "(h, U) \<in> set ps \<Longrightarrow> i \<le> card U \<Longrightarrow> poly_deg h < \<b> ps i"
	proof -
	let ?A = "poly_deg ` fst ` set ps"
	define A where "A = insert (\<a> ps) ?A"
	define m where "m = Suc (Max A)"
	from finite_set have "finite ?A" by (intro finite_imageI)
	hence "finite A" by (simp add: A_def)
	have "\<a> ps \<le> \<b> ps i \<and> (\<forall>(h', U')\<in>set ps. i \<le> card U' \<longrightarrow> poly_deg h' < \<b> ps i)" unfolding \<b>_def
	proof (rule LeastI)
	have "\<a> ps \<in> A" by (simp add: A_def)
	with \<open>finite A\<close> have "\<a> ps \<le> Max A" by (rule Max_ge)
	hence "\<a> ps \<le> m" by (simp add: m_def)
	moreover {
	fix h U
	assume "(h, U) \<in> set ps"
	hence "poly_deg (fst (h, U)) \<in> ?A" by (intro imageI)
	hence "poly_deg h \<in> A" by (simp add: A_def)
	with \<open>finite A\<close> have "poly_deg h \<le> Max A" by (rule Max_ge)
	hence "poly_deg h < m" by (simp add: m_def)
	}
	ultimately show "\<a> ps \<le> m \<and> (\<forall>(h, U)\<in>set ps. i \<le> card U \<longrightarrow> poly_deg h < m)" by blast
	qed
	thus "\<a> ps \<le> \<b> ps i" and "(h, U) \<in> set ps \<Longrightarrow> i \<le> card U \<Longrightarrow> poly_deg h < \<b> ps i" by blast+
	qed

	lemma \<b>_le:
	"\<a> ps \<le> d \<Longrightarrow> (\<And>h' U'. (h', U') \<in> set ps \<Longrightarrow> i \<le> card U' \<Longrightarrow> poly_deg h' < d) \<Longrightarrow> \<b> ps i \<le> d"
	unfolding \<b>_def by (intro Least_le) blast

	lemma \<b>_decreasing:
	assumes "i \<le> j"
	shows "\<b> ps j \<le> \<b> ps i"
	proof (rule \<b>_le)
	fix h U
	assume "(h, U) \<in> set ps"
	assume "j \<le> card U"
	with assms(1) have "i \<le> card U" by (rule le_trans)
	with \<open>(h, U) \<in> set ps\<close> show "poly_deg h < \<b> ps i" by (rule \<b>)
	qed (fact \<b>)

	lemma \<b>_Nil:
	assumes "ps\<^sub>+ = []" and "Suc 0 \<le> i"
	shows "\<b> ps i = 0"
	unfolding \<b>_def
	proof (rule Least_eq_0)
	from assms(1) have "\<a> ps = 0" by (rule \<a>_Nil)
	moreover {
	fix h and U::"'x set"
	note assms(2)
	also assume "i \<le> card U"
	finally have "U \<noteq> {}" by auto
	moreover assume "(h, U) \<in> set ps"
	ultimately have "(h, U) \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	hence False by (simp add: assms)
	}
	ultimately show "\<a> ps \<le> 0 \<and> (\<forall>(h, U)\<in>set ps. i \<le> card U \<longrightarrow> poly_deg h < 0)" by blast
	qed

	lemma \<b>_zero:
	assumes "ps \<noteq> []"
	shows "Suc (Max (poly_deg ` fst ` set ps)) \<le> \<b> ps 0"
	proof -
	from finite_set have "finite (poly_deg ` fst ` set ps)" by (intro finite_imageI)
	moreover from assms have "poly_deg ` fst ` set ps \<noteq> {}" by simp
	moreover have "\<forall>a\<in>poly_deg ` fst ` set ps. a < \<b> ps 0"
	proof
	fix d
	assume "d \<in> poly_deg ` fst ` set ps"
	then obtain p where "p \<in> set ps" and "d = poly_deg (fst p)" by blast
	moreover obtain h U where "p = (h, U)" using prod.exhaust by blast
	ultimately have "(h, U) \<in> set ps" and d: "d = poly_deg h" by simp_all
	from this(1) le0 show "d < \<b> ps 0" unfolding d by (rule \<b>)
	qed
	ultimately have "Max (poly_deg ` fst ` set ps) < \<b> ps 0" by simp
	thus ?thesis by simp
	qed

	corollary \<b>_zero_gr:
	assumes "(h, U) \<in> set ps"
	shows "poly_deg h < \<b> ps 0"
	proof -
	have "poly_deg h \<le> Max (poly_deg ` fst ` set ps)"
	proof (rule Max_ge)
	from finite_set show "finite (poly_deg ` fst ` set ps)" by (intro finite_imageI)
	next
	from assms have "poly_deg (fst (h, U)) \<in> poly_deg ` fst ` set ps" by (intro imageI)
	thus "poly_deg h \<in> poly_deg ` fst ` set ps" by simp
	qed
	also have "\<dots> < Suc \<dots>" by simp
	also have "\<dots> \<le> \<b> ps 0"
	proof (rule \<b>_zero)
	from assms show "ps \<noteq> []" by auto
	qed
	finally show ?thesis .
	qed

	lemma \<b>_one:
	assumes "valid_decomp X ps" and "standard_decomp k ps"
	shows "\<b> ps (Suc 0) = (if ps\<^sub>+ = [] then 0 else Suc (Max (poly_deg ` fst ` set (ps\<^sub>+))))"
	proof (cases "ps\<^sub>+ = []")
	case True
	hence "\<b> ps (Suc 0) = 0" using le_refl by (rule \<b>_Nil)
	with True show ?thesis by simp
	next
	case False
	with assms have aP: "\<a> ps = Min (poly_deg ` fst ` set (ps\<^sub>+))" (is "_ = Min ?A") by (rule \<a>_nonempty)
	from pos_decomp_subset finite_set have "finite (set (ps\<^sub>+))" by (rule finite_subset)
	hence "finite ?A" by (intro finite_imageI)
	from False have "?A \<noteq> {}" by simp
	have "\<b> ps (Suc 0) = Suc (Max ?A)" unfolding \<b>_def
	proof (rule Least_equality)
	from \<open>finite ?A\<close> \<open>?A \<noteq> {}\<close> have "\<a> ps \<in> ?A" unfolding aP by (rule Min_in)
	with \<open>finite ?A\<close> have "\<a> ps \<le> Max ?A" by (rule Max_ge)
	hence "\<a> ps \<le> Suc (Max ?A)" by simp
	moreover {
	fix h U
	assume "(h, U) \<in> set ps"
	with fin_X assms(1) have "finite U" by (rule valid_decompD_finite)
	moreover assume "Suc 0 \<le> card U"
	ultimately have "U \<noteq> {}" by auto
	with \<open>(h, U) \<in> set ps\<close> have "(h, U) \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	hence "poly_deg (fst (h, U)) \<in> ?A" by (intro imageI)
	hence "poly_deg h \<in> ?A" by (simp only: fst_conv)
	with \<open>finite ?A\<close> have "poly_deg h \<le> Max ?A" by (rule Max_ge)
	hence "poly_deg h < Suc (Max ?A)" by simp
	}
	ultimately show "\<a> ps \<le> Suc (Max ?A) \<and> (\<forall>(h, U)\<in>set ps. Suc 0 \<le> card U \<longrightarrow> poly_deg h < Suc (Max ?A))"
	by blast
	next
	fix d
	assume "\<a> ps \<le> d \<and> (\<forall>(h, U)\<in>set ps. Suc 0 \<le> card U \<longrightarrow> poly_deg h < d)"
	hence rl: "poly_deg h < d" if "(h, U) \<in> set ps" and "0 < card U" for h U using that by auto
	have "Max ?A < d" unfolding Max_less_iff[OF \<open>finite ?A\<close> \<open>?A \<noteq> {}\<close>]
	proof
	fix d0
	assume "d0 \<in> poly_deg ` fst ` set (ps\<^sub>+)"
	then obtain h U where "(h, U) \<in> set (ps\<^sub>+)" and d0: "d0 = poly_deg h" by auto
	from this(1) have "(h, U) \<in> set ps" and "U \<noteq> {}" by (simp_all add: pos_decomp_def)
	from fin_X assms(1) this(1) have "finite U" by (rule valid_decompD_finite)
	with \<open>U \<noteq> {}\<close> have "0 < card U" by (simp add: card_gt_0_iff)
	with \<open>(h, U) \<in> set ps\<close> show "d0 < d" unfolding d0 by (rule rl)
	qed
	thus "Suc (Max ?A) \<le> d" by simp
	qed
	with False show ?thesis by simp
	qed

	corollary \<b>_one_gr:
	assumes "valid_decomp X ps" and "standard_decomp k ps" and "(h, U) \<in> set (ps\<^sub>+)"
	shows "poly_deg h < \<b> ps (Suc 0)"
	proof -
	from assms(3) have "ps\<^sub>+ \<noteq> []" by auto
	with assms(1, 2) have eq: "\<b> ps (Suc 0) = Suc (Max (poly_deg ` fst ` set (ps\<^sub>+)))"
	by (simp add: \<b>_one)
	have "poly_deg h \<le> Max (poly_deg ` fst ` set (ps\<^sub>+))"
	proof (rule Max_ge)
	from finite_set show "finite (poly_deg ` fst ` set (ps\<^sub>+))" by (intro finite_imageI)
	next
	from assms(3) have "poly_deg (fst (h, U)) \<in> poly_deg ` fst ` set (ps\<^sub>+)" by (intro imageI)
	thus "poly_deg h \<in> poly_deg ` fst ` set (ps\<^sub>+)" by simp
	qed
	also have "\<dots> < \<b> ps (Suc 0)" by (simp add: eq)
	finally show ?thesis .
	qed

	lemma \<b>_card_X:
	assumes "exact_decomp m ps" and "Suc (card X) \<le> i"
	shows "\<b> ps i = \<a> ps"
	unfolding \<b>_def
	proof (rule Least_equality)
	{
	fix h U
	assume "(h, U) \<in> set ps"
	with assms(1) have "U \<subseteq> X" by (rule exact_decompD)
	note assms(2)
	also assume "i \<le> card U"
	finally have "card X < card U" by simp
	with fin_X have "\<not> U \<subseteq> X" by (auto dest: card_mono leD)
	hence False using \<open>U \<subseteq> X\<close> ..
	}
	thus "\<a> ps \<le> \<a> ps \<and> (\<forall>(h, U)\<in>set ps. i \<le> card U \<longrightarrow> poly_deg h < \<a> ps)" by blast
	qed simp

	lemma lem_6_1_1:
	assumes "standard_decomp k ps" and "exact_decomp m ps" and "Suc 0 \<le> i"
	and "i \<le> card X" and "\<b> ps (Suc i) \<le> d" and "d < \<b> ps i"
	obtains h U where "(h, U) \<in> set (ps\<^sub>+)" and "poly_deg h = d" and "card U = i"
	proof -
	have "ps\<^sub>+ \<noteq> []"
	proof
	assume "ps\<^sub>+ = []"
	hence "\<b> ps i = 0" using assms(3) by (rule \<b>_Nil)
	with assms(6) show False by simp
	qed
	have eq1: "\<b> ps (Suc (card X)) = \<a> ps" using assms(2) le_refl by (rule \<b>_card_X)
	from assms(1) have std: "standard_decomp (\<b> ps (Suc (card X))) ps" unfolding eq1 by (rule \<a>)
	from assms(4) have "Suc i \<le> Suc (card X)" ..
	hence "\<b> ps (Suc (card X)) \<le> \<b> ps (Suc i)" by (rule \<b>_decreasing)
	hence "\<a> ps \<le> \<b> ps (Suc i)" by (simp only: eq1)
	have "\<exists>h U. (h, U) \<in> set ps \<and> i \<le> card U \<and> \<b> ps i \<le> Suc (poly_deg h)"
	proof (rule ccontr)
	assume *: "\<nexists>h U. (h, U) \<in> set ps \<and> i \<le> card U \<and> \<b> ps i \<le> Suc (poly_deg h)"
	note \<open>\<a> ps \<le> \<b> ps (Suc i)\<close>
	also from assms(5, 6) have "\<b> ps (Suc i) < \<b> ps i" by (rule le_less_trans)
	finally have "\<a> ps < \<b> ps i" .
	hence "\<a> ps \<le> \<b> ps i - 1" by simp
	hence "\<b> ps i \<le> \<b> ps i - 1"
	proof (rule \<b>_le)
	fix h U
	assume "(h, U) \<in> set ps" and "i \<le> card U"
	show "poly_deg h < \<b> ps i - 1"
	proof (rule ccontr)
	assume "\<not> poly_deg h < \<b> ps i - 1"
	hence "\<b> ps i \<le> Suc (poly_deg h)" by simp
	with * \<open>(h, U) \<in> set ps\<close> \<open>i \<le> card U\<close> show False by auto
	qed
	qed
	thus False using \<open>\<a> ps < \<b> ps i\<close> by linarith
	qed
	then obtain h U where "(h, U) \<in> set ps" and "i \<le> card U" and "\<b> ps i \<le> Suc (poly_deg h)" by blast
	from assms(3) this(2) have "U \<noteq> {}" by auto
	with \<open>(h, U) \<in> set ps\<close> have "(h, U) \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	note std this
	moreover have "\<b> ps (Suc (card X)) \<le> d" unfolding eq1 using \<open>\<a> ps \<le> \<b> ps (Suc i)\<close> assms(5)
	by (rule le_trans)
	moreover have "d \<le> poly_deg h"
	proof -
	from assms(6) \<open>\<b> ps i \<le> Suc (poly_deg h)\<close> have "d < Suc (poly_deg h)" by (rule less_le_trans)
	thus ?thesis by simp
	qed
	ultimately obtain h' U' where "(h', U') \<in> set ps" and d: "poly_deg h' = d" and "card U \<le> card U'"
	by (rule standard_decompE)
	from \<open>i \<le> card U\<close> this(3) have "i \<le> card U'" by (rule le_trans)
	with assms(3) have "U' \<noteq> {}" by auto
	with \<open>(h', U') \<in> set ps\<close> have "(h', U') \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	moreover note \<open>poly_deg h' = d\<close>
	moreover have "card U' = i"
	proof (rule ccontr)
	assume "card U' \<noteq> i"
	with \<open>i \<le> card U'\<close> have "Suc i \<le> card U'" by simp
	with \<open>(h', U') \<in> set ps\<close> have "poly_deg h' < \<b> ps (Suc i)" by (rule \<b>)
	with assms(5) show False by (simp add: d)
	qed
	ultimately show ?thesis ..
	qed

	corollary lem_6_1_2:
	assumes "standard_decomp k ps" and "exact_decomp 0 ps" and "Suc 0 \<le> i"
	and "i \<le> card X" and "\<b> ps (Suc i) \<le> d" and "d < \<b> ps i"
	obtains h U where "{(h', U') \<in> set (ps\<^sub>+). poly_deg h' = d} = {(h, U)}" and "card U = i"
	proof -
	from assms obtain h U where "(h, U) \<in> set (ps\<^sub>+)" and "poly_deg h = d" and "card U = i"
	by (rule lem_6_1_1)
	hence "{(h, U)} \<subseteq> {(h', U') \<in> set (ps\<^sub>+). poly_deg h' = d}" (is "_ \<subseteq> ?A") by simp
	moreover have "?A \<subseteq> {(h, U)}"
	proof
	fix x
	assume "x \<in> ?A"
	then obtain h' U' where "(h', U') \<in> set (ps\<^sub>+)" and "poly_deg h' = d" and x: "x = (h', U')"
	by blast
	note assms(2) \<open>(h, U) \<in> set (ps\<^sub>+)\<close> this(1)
	moreover have "poly_deg h = poly_deg h'" by (simp only: \<open>poly_deg h = d\<close> \<open>poly_deg h' = d\<close>)
	ultimately have "(h, U) = (h', U')" by (rule exact_decompD_zero)
	thus "x \<in> {(h, U)}" by (simp add: x)
	qed
	ultimately have "{(h, U)} = ?A" ..
	hence "?A = {(h, U)}" by (rule sym)
	thus ?thesis using \<open>card U = i\<close> ..
	qed

	corollary lem_6_1_2':
	assumes "standard_decomp k ps" and "exact_decomp 0 ps" and "Suc 0 \<le> i"
	and "i \<le> card X" and "\<b> ps (Suc i) \<le> d" and "d < \<b> ps i"
	shows "card {(h', U') \<in> set (ps\<^sub>+). poly_deg h' = d} = 1" (is "card ?A = _")
	and "{(h', U') \<in> set (ps\<^sub>+). poly_deg h' = d \<and> card U' = i} = {(h', U') \<in> set (ps\<^sub>+). poly_deg h' = d}"
	(is "?B = _")
	and "card {(h', U') \<in> set (ps\<^sub>+). poly_deg h' = d \<and> card U' = i} = 1"
	proof -
	from assms obtain h U where "?A = {(h, U)}" and "card U = i" by (rule lem_6_1_2)
	from this(1) show "card ?A = 1" by simp
	moreover show "?B = ?A"
	proof
	have "(h, U) \<in> ?A" by (simp add: \<open>?A = {(h, U)}\<close>)
	have "?A = {(h, U)}" by fact
	also from \<open>(h, U) \<in> ?A\<close> \<open>card U = i\<close> have "\<dots> \<subseteq> ?B" by simp
	finally show "?A \<subseteq> ?B" .
	qed blast
	ultimately show "card ?B = 1" by simp
	qed

	corollary lem_6_1_3:
	assumes "standard_decomp k ps" and "exact_decomp 0 ps" and "Suc 0 \<le> i"
	and "i \<le> card X" and "(h, U) \<in> set (ps\<^sub>+)" and "card U = i"
	shows "\<b> ps (Suc i) \<le> poly_deg h"
	proof (rule ccontr)
	define j where "j = (LEAST j'. \<b> ps j' \<le> poly_deg h)"
	assume "\<not> \<b> ps (Suc i) \<le> poly_deg h"
	hence "poly_deg h < \<b> ps (Suc i)" by simp
	from assms(2) le_refl have "\<b> ps (Suc (card X)) = \<a> ps" by (rule \<b>_card_X)
	also from _ assms(5) have "\<dots> \<le> poly_deg h"
	proof (rule standard_decompD)
	from assms(1) show "standard_decomp (\<a> ps) ps" by (rule \<a>)
	qed
	finally have "\<b> ps (Suc (card X)) \<le> poly_deg h" .
	hence 1: "\<b> ps j \<le> poly_deg h" unfolding j_def by (rule LeastI)
	have "Suc i < j"
	proof (rule ccontr)
	assume "\<not> Suc i < j"
	hence "j \<le> Suc i" by simp
	hence "\<b> ps (Suc i) \<le> \<b> ps j" by (rule \<b>_decreasing)
	also have "\<dots> \<le> poly_deg h" by fact
	finally show False using \<open>poly_deg h < \<b> ps (Suc i)\<close> by simp
	qed
	hence eq: "Suc (j - 1) = j" by simp
	note assms(1, 2)
	moreover from assms(3) have "Suc 0 \<le> j - 1"
	proof (rule le_trans)
	from \<open>Suc i < j\<close> show "i \<le> j - 1" by simp
	qed
	moreover have "j - 1 \<le> card X"
	proof -
	have "j \<le> Suc (card X)" unfolding j_def by (rule Least_le) fact
	thus ?thesis by simp
	qed
	moreover from 1 have "\<b> ps (Suc (j - 1)) \<le> poly_deg h" by (simp only: eq)
	moreover have "poly_deg h < \<b> ps (j - 1)"
	proof (rule ccontr)
	assume "\<not> poly_deg h < \<b> ps (j - 1)"
	hence "\<b> ps (j - 1) \<le> poly_deg h" by simp
	hence "j \<le> j - 1" unfolding j_def by (rule Least_le)
	also have "\<dots> < Suc (j - 1)" by simp
	finally show False by (simp only: eq)
	qed
	ultimately obtain h0 U0
	where eq1: "{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = poly_deg h} = {(h0, U0)}"
	and "card U0 = j - 1" by (rule lem_6_1_2)
	from assms(5) have "(h, U) \<in> {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = poly_deg h}" by simp
	hence "(h, U) \<in> {(h0, U0)}" by (simp only: eq1)
	hence "U = U0" by simp
	hence "card U = j - 1" by (simp only: \<open>card U0 = j - 1\<close>)
	hence "i = j - 1" by (simp only: assms(6))
	hence "Suc i = j" by (simp only: eq)
	with \<open>Suc i < j\<close> show False by simp
	qed

	qualified fun shift_list :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}) \<times> 'x set) \<Rightarrow>
	'x \<Rightarrow> _ list \<Rightarrow> _ list" where
	"shift_list (h, U) x ps =
	((punit.monom_mult 1 (Poly_Mapping.single x 1) h, U) # (h, U - {x}) # removeAll (h, U) ps)"

	declare shift_list.simps[simp del]

	lemma monomial_decomp_shift_list:
	assumes "monomial_decomp ps" and "hU \<in> set ps"
	shows "monomial_decomp (shift_list hU x ps)"
	proof -
	let ?x = "Poly_Mapping.single x (1::nat)"
	obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	with assms(2) have "(h, U) \<in> set ps" by simp
	with assms(1) have 1: "is_monomial h" and 2: "lcf h = 1" by (rule monomial_decompD)+
	from this(1) have "monomial (lcf h) (lpp h) = h" by (rule punit.monomial_eq_itself)
	moreover define t where "t = lpp h"
	ultimately have "h = monomial 1 t" by (simp only: 2)
	hence "is_monomial (punit.monom_mult 1 ?x h)" and "lcf (punit.monom_mult 1 ?x h) = 1"
	by (simp_all add: punit.monom_mult_monomial monomial_is_monomial)
	with assms(1) 1 2 show ?thesis by (simp add: shift_list.simps monomial_decomp_def hU)
	qed

	lemma hom_decomp_shift_list:
	assumes "hom_decomp ps" and "hU \<in> set ps"
	shows "hom_decomp (shift_list hU x ps)"
	proof -
	let ?x = "Poly_Mapping.single x (1::nat)"
	obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	with assms(2) have "(h, U) \<in> set ps" by simp
	with assms(1) have 1: "homogeneous h" by (rule hom_decompD)
	hence "homogeneous (punit.monom_mult 1 ?x h)" by (simp only: homogeneous_monom_mult)
	with assms(1) 1 show ?thesis by (simp add: shift_list.simps hom_decomp_def hU)
	qed

	lemma valid_decomp_shift_list:
	assumes "valid_decomp X ps" and "(h, U) \<in> set ps" and "x \<in> U"
	shows "valid_decomp X (shift_list (h, U) x ps)"
	proof -
	let ?x = "Poly_Mapping.single x (1::nat)"
	from assms(1, 2) have "h \<in> P[X]" and "h \<noteq> 0" and "U \<subseteq> X" by (rule valid_decompD)+
	moreover from this(1) have "punit.monom_mult 1 ?x h \<in> P[X]"
	proof (intro Polys_closed_monom_mult PPs_closed_single)
	from \<open>x \<in> U\<close> \<open>U \<subseteq> X\<close> show "x \<in> X" ..
	qed
	moreover from \<open>U \<subseteq> X\<close> have "U - {x} \<subseteq> X" by blast
	ultimately show ?thesis
	using assms(1) \<open>h \<noteq> 0\<close> by (simp add: valid_decomp_def punit.monom_mult_eq_zero_iff shift_list.simps)
	qed

	lemma standard_decomp_shift_list:
	assumes "standard_decomp k ps" and "(h1, U1) \<in> set ps" and "(h2, U2) \<in> set ps"
	and "poly_deg h1 = poly_deg h2" and "card U2 \<le> card U1" and "(h1, U1) \<noteq> (h2, U2)" and "x \<in> U2"
	shows "standard_decomp k (shift_list (h2, U2) x ps)"
	proof (rule standard_decompI)
	let ?p1 = "(punit.monom_mult 1 (Poly_Mapping.single x 1) h2, U2)"
	let ?p2 = "(h2, U2 - {x})"
	let ?qs = "removeAll (h2, U2) ps"
	fix h U
	assume "(h, U) \<in> set ((shift_list (h2, U2) x ps)\<^sub>+)"
	hence disj: "(h, U) = ?p1 \<or> ((h, U) = ?p2 \<and> U2 - {x} \<noteq> {}) \<or> (h, U) \<in> set (ps\<^sub>+)"
	by (auto simp: pos_decomp_def shift_list.simps split: if_split_asm)
	from assms(7) have "U2 \<noteq> {}" by blast
	with assms(3) have "(h2, U2) \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	with assms(1) have k_le: "k \<le> poly_deg h2" by (rule standard_decompD)

	let ?x = "Poly_Mapping.single x 1"
	from disj show "k \<le> poly_deg h"
	proof (elim disjE)
	assume "(h, U) = ?p1"
	hence h: "h = punit.monom_mult (1::'a) ?x h2" by simp
	note k_le
	also have "poly_deg h2 \<le> poly_deg h" by (cases "h2 = 0") (simp_all add: h poly_deg_monom_mult)
	finally show ?thesis .
	next
	assume "(h, U) = ?p2 \<and> U2 - {x} \<noteq> {}"
	with k_le show ?thesis by simp
	next
	assume "(h, U) \<in> set (ps\<^sub>+)"
	with assms(1) show ?thesis by (rule standard_decompD)
	qed

	fix d
	assume "k \<le> d" and "d \<le> poly_deg h"
	from disj obtain h' U' where 1: "(h', U') \<in> set (?p1 # ps)" and "poly_deg h' = d"
	and "card U \<le> card U'"
	proof (elim disjE)
	assume "(h, U) = ?p1"
	hence h: "h = punit.monom_mult 1 ?x h2" and "U = U2" by simp_all
	from \<open>d \<le> poly_deg h\<close> have "d \<le> poly_deg h2 \<or> poly_deg h = d"
	by (cases "h2 = 0") (auto simp: h poly_deg_monom_mult deg_pm_single)
	thus ?thesis
	proof
	assume "d \<le> poly_deg h2"
	with assms(1) \<open>(h2, U2) \<in> set (ps\<^sub>+)\<close> \<open>k \<le> d\<close> obtain h' U'
	where "(h', U') \<in> set ps" and "poly_deg h' = d" and "card U2 \<le> card U'"
	by (rule standard_decompE)
	from this(1) have "(h', U') \<in> set (?p1 # ps)" by simp
	moreover note \<open>poly_deg h' = d\<close>
	moreover from \<open>card U2 \<le> card U'\<close> have "card U \<le> card U'" by (simp only: \<open>U = U2\<close>)
	ultimately show ?thesis ..
	next
	have "(h, U) \<in> set (?p1 # ps)" by (simp add: \<open>(h, U) = ?p1\<close>)
	moreover assume "poly_deg h = d"
	ultimately show ?thesis using le_refl ..
	qed
	next
	assume "(h, U) = ?p2 \<and> U2 - {x} \<noteq> {}"
	hence "h = h2" and U: "U = U2 - {x}" by simp_all
	from \<open>d \<le> poly_deg h\<close> this(1) have "d \<le> poly_deg h2" by simp
	with assms(1) \<open>(h2, U2) \<in> set (ps\<^sub>+)\<close> \<open>k \<le> d\<close> obtain h' U'
	where "(h', U') \<in> set ps" and "poly_deg h' = d" and "card U2 \<le> card U'"
	by (rule standard_decompE)
	from this(1) have "(h', U') \<in> set (?p1 # ps)" by simp
	moreover note \<open>poly_deg h' = d\<close>
	moreover from _ \<open>card U2 \<le> card U'\<close> have "card U \<le> card U'" unfolding U
	by (rule le_trans) (metis Diff_empty card_Diff1_le card.infinite finite_Diff_insert order_refl)
	ultimately show ?thesis ..
	next
	assume "(h, U) \<in> set (ps\<^sub>+)"
	from assms(1) this \<open>k \<le> d\<close> \<open>d \<le> poly_deg h\<close> obtain h' U'
	where "(h', U') \<in> set ps" and "poly_deg h' = d" and "card U \<le> card U'"
	by (rule standard_decompE)
	from this(1) have "(h', U') \<in> set (?p1 # ps)" by simp
	thus ?thesis using \<open>poly_deg h' = d\<close> \<open>card U \<le> card U'\<close> ..
	qed
	show "\<exists>h' U'. (h', U') \<in> set (shift_list (h2, U2) x ps) \<and> poly_deg h' = d \<and> card U \<le> card U'"
	proof (cases "(h', U') = (h2, U2)")
	case True
	hence "h' = h2" and "U' = U2" by simp_all
	from assms(2, 6) have "(h1, U1) \<in> set (shift_list (h2, U2) x ps)" by (simp add: shift_list.simps)
	moreover from \<open>poly_deg h' = d\<close> have "poly_deg h1 = d" by (simp only: \<open>h' = h2\<close> assms(4))
	moreover from \<open>card U \<le> card U'\<close> assms(5) have "card U \<le> card U1" by (simp add: \<open>U' = U2\<close>)
	ultimately show ?thesis by blast
	next
	case False
	with 1 have "(h', U') \<in> set (shift_list (h2, U2) x ps)" by (auto simp: shift_list.simps)
	thus ?thesis using \<open>poly_deg h' = d\<close> \<open>card U \<le> card U'\<close> by blast
	qed
	qed

	lemma cone_decomp_shift_list:
	assumes "valid_decomp X ps" and "cone_decomp T ps" and "(h, U) \<in> set ps" and "x \<in> U"
	shows "cone_decomp T (shift_list (h, U) x ps)"
	proof -
	let ?p1 = "(punit.monom_mult 1 (Poly_Mapping.single x 1) h, U)"
	let ?p2 = "(h, U - {x})"
	let ?qs = "removeAll (h, U) ps"
	from assms(3) obtain ps1 ps2 where ps: "ps = ps1 @ (h, U) # ps2" and *: "(h, U) \<notin> set ps1"
	by (meson split_list_first)
	have "count_list ps2 (h, U) = 0"
	proof (rule ccontr)
	from assms(1, 3) have "h \<noteq> 0" by (rule valid_decompD)
	assume "count_list ps2 (h, U) \<noteq> 0"
	- hence "1 < count_list ps (h, U)" by (simp add: ps count_list_append)
	+ hence "1 < count_list ps (h, U)" by (simp add: ps)
	also have "\<dots> \<le> count_list (map cone ps) (cone (h, U))" by (fact count_list_map_ge)
	finally have "1 < count_list (map cone ps) (cone (h, U))" .
	with cone_decompD have "cone (h, U) = {0}"
	proof (rule direct_decomp_repeated_eq_zero)
	fix s
	assume "s \<in> set (map cone ps)"
	thus "0 \<in> s" by (auto intro: zero_in_cone)
	qed (fact assms(2))
	with tip_in_cone[of h U] have "h = 0" by simp
	with \<open>h \<noteq> 0\<close> show False ..
	qed
	- hence **: "(h, U) \<notin> set ps2" by (simp add: count_list_eq_0_iff)
	+ hence **: "(h, U) \<notin> set ps2" by (simp add: count_list_0_iff)
	have "mset ps = mset ((h, U) # ps1 @ ps2)" (is "mset _ = mset ?ps")
	by (simp add: ps)
	with assms(2) have "cone_decomp T ?ps" by (rule cone_decomp_perm)
	hence "direct_decomp T (map cone ?ps)" by (rule cone_decompD)
	hence "direct_decomp T (cone (h, U) # map cone (ps1 @ ps2))" by simp
	hence "direct_decomp T ((map cone (ps1 @ ps2)) @ [cone ?p1, cone ?p2])"
	proof (rule direct_decomp_direct_decomp)
	let ?x = "Poly_Mapping.single x (Suc 0)"
	have "direct_decomp (cone (h, insert x (U - {x})))
	[cone (h, U - {x}), cone (monomial (1::'a) ?x * h, insert x (U - {x}))]"
	by (rule direct_decomp_cone_insert) simp
	with assms(4) show "direct_decomp (cone (h, U)) [cone ?p1, cone ?p2]"
	by (simp add: insert_absorb times_monomial_left direct_decomp_perm)
	qed
	hence "direct_decomp T (map cone (ps1 @ ps2 @ [?p1, ?p2]))" by simp
	hence "cone_decomp T (ps1 @ ps2 @ [?p1, ?p2])" by (rule cone_decompI)
	moreover have "mset (ps1 @ ps2 @ [?p1, ?p2]) = mset (?p1 # ?p2 # (ps1 @ ps2))"
	by simp
	ultimately have "cone_decomp T (?p1 # ?p2 # (ps1 @ ps2))" by (rule cone_decomp_perm)
	also from * ** have "ps1 @ ps2 = removeAll (h, U) ps" by (simp add: remove1_append ps)
	finally show ?thesis by (simp only: shift_list.simps)
	qed

	subsection \<open>Functions \<open>shift\<close> and \<open>exact\<close>\<close>

	context
	fixes k m :: nat
	begin

	context
	fixes d :: nat
	begin

	definition shift2_inv :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<times> 'x set) list \<Rightarrow> bool" where
	"shift2_inv qs \<longleftrightarrow> valid_decomp X qs \<and> standard_decomp k qs \<and> exact_decomp (Suc m) qs \<and>
	(\<forall>d0<d. card {q \<in> set qs. poly_deg (fst q) = d0 \<and> m < card (snd q)} \<le> 1)"

	fun shift1_inv :: "(((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<times> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<times> 'x set) set) \<Rightarrow> bool"
	where "shift1_inv (qs, B) \<longleftrightarrow> B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)} \<and> shift2_inv qs"

	lemma shift2_invI:
	"valid_decomp X qs \<Longrightarrow> standard_decomp k qs \<Longrightarrow> exact_decomp (Suc m) qs \<Longrightarrow>
	(\<And>d0. d0 < d \<Longrightarrow> card {q \<in> set qs. poly_deg (fst q) = d0 \<and> m < card (snd q)} \<le> 1) \<Longrightarrow>
	shift2_inv qs"
	by (simp add: shift2_inv_def)

	lemma shift2_invD:
	assumes "shift2_inv qs"
	shows "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	and "d0 < d \<Longrightarrow> card {q \<in> set qs. poly_deg (fst q) = d0 \<and> m < card (snd q)} \<le> 1"
	using assms by (simp_all add: shift2_inv_def)

	lemma shift1_invI:
	"B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)} \<Longrightarrow> shift2_inv qs \<Longrightarrow> shift1_inv (qs, B)"
	by simp

	lemma shift1_invD:
	assumes "shift1_inv (qs, B)"
	shows "B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}" and "shift2_inv qs"
	using assms by simp_all

	declare shift1_inv.simps[simp del]

	lemma shift1_inv_finite_snd:
	assumes "shift1_inv (qs, B)"
	shows "finite B"
	proof (rule finite_subset)
	from assms have "B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}" by (rule shift1_invD)
	also have "\<dots> \<subseteq> set qs" by blast
	finally show "B \<subseteq> set qs" .
	qed (fact finite_set)

	lemma shift1_inv_some_snd:
	assumes "shift1_inv (qs, B)" and "1 < card B" and "(h, U) = (SOME b. b \<in> B \<and> card (snd b) = Suc m)"
	shows "(h, U) \<in> B" and "(h, U) \<in> set qs" and "poly_deg h = d" and "card U = Suc m"
	proof -
	define A where "A = {q \<in> B. card (snd q) = Suc m}"
	define Y where "Y = {q \<in> set qs. poly_deg (fst q) = d \<and> Suc m < card (snd q)}"
	from assms(1) have B: "B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}"
	and inv2: "shift2_inv qs" by (rule shift1_invD)+
	have B': "B = A \<union> Y" by (auto simp: B A_def Y_def)
	have "finite A"
	proof (rule finite_subset)
	show "A \<subseteq> B" unfolding A_def by blast
	next
	from assms(1) show "finite B" by (rule shift1_inv_finite_snd)
	qed
	moreover have "finite Y"
	proof (rule finite_subset)
	show "Y \<subseteq> set qs" unfolding Y_def by blast
	qed (fact finite_set)
	moreover have "A \<inter> Y = {}" by (auto simp: A_def Y_def)
	ultimately have "card (A \<union> Y) = card A + card Y" by (rule card_Un_disjoint)
	with assms(2) have "1 < card A + card Y" by (simp only: B')
	thm card_le_Suc0_iff_eq[OF \<open>finite Y\<close>]
	moreover have "card Y \<le> 1" unfolding One_nat_def card_le_Suc0_iff_eq[OF \<open>finite Y\<close>]
	proof (intro ballI)
	fix q1 q2 :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set"
	obtain h1 U1 where q1: "q1 = (h1, U1)" using prod.exhaust by blast
	obtain h2 U2 where q2: "q2 = (h2, U2)" using prod.exhaust by blast
	assume "q1 \<in> Y"
	hence "(h1, U1) \<in> set qs" and "poly_deg h1 = d" and "Suc m < card U1" by (simp_all add: q1 Y_def)
	assume "q2 \<in> Y"
	hence "(h2, U2) \<in> set qs" and "poly_deg h2 = d" and "Suc m < card U2" by (simp_all add: q2 Y_def)
	from this(2) have "poly_deg h1 = poly_deg h2" by (simp only: \<open>poly_deg h1 = d\<close>)
	from inv2 have "exact_decomp (Suc m) qs" by (rule shift2_invD)
	thus "q1 = q2" unfolding q1 q2 by (rule exact_decompD) fact+
	qed
	ultimately have "0 < card A" by simp
	hence "A \<noteq> {}" by auto
	then obtain a where "a \<in> A" by blast
	have "(h, U) \<in> B \<and> card (snd (h, U)) = Suc m" unfolding assms(3)
	proof (rule someI)
	from \<open>a \<in> A\<close> show "a \<in> B \<and> card (snd a) = Suc m" by (simp add: A_def)
	qed
	thus "(h, U) \<in> B" and "card U = Suc m" by simp_all
	from this(1) show "(h, U) \<in> set qs" and "poly_deg h = d" by (simp_all add: B)
	qed

	lemma shift1_inv_preserved:
	assumes "shift1_inv (qs, B)" and "1 < card B" and "(h, U) = (SOME b. b \<in> B \<and> card (snd b) = Suc m)"
	and "x = (SOME y. y \<in> U)"
	shows "shift1_inv (shift_list (h, U) x qs, B - {(h, U)})"
	proof -
	let ?p1 = "(punit.monom_mult 1 (Poly_Mapping.single x 1) h, U)"
	let ?p2 = "(h, U - {x})"
	let ?qs = "removeAll (h, U) qs"
	let ?B = "B - {(h, U)}"
	from assms(1, 2, 3) have "(h, U) \<in> B" and "(h, U) \<in> set qs" and deg_h: "poly_deg h = d"
	and card_U: "card U = Suc m" by (rule shift1_inv_some_snd)+
	from card_U have "U \<noteq> {}" by auto
	then obtain y where "y \<in> U" by blast
	hence "x \<in> U" unfolding assms(4) by (rule someI)
	with card_U have card_Ux: "card (U - {x}) = m"
	by (metis card_Diff_singleton card.infinite diff_Suc_1 nat.simps(3))
	from assms(1) have B: "B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}"
	and inv2: "shift2_inv qs" by (rule shift1_invD)+
	from inv2 have valid_qs: "valid_decomp X qs" by (rule shift2_invD)
	hence "h \<noteq> 0" using \<open>(h, U) \<in> set qs\<close> by (rule valid_decompD)
	show ?thesis
	proof (intro shift1_invI shift2_invI)
	show "?B = {q \<in> set (shift_list (h, U) x qs). poly_deg (fst q) = d \<and> m < card (snd q)}" (is "_ = ?C")
	proof (rule Set.set_eqI)
	fix b
	show "b \<in> ?B \<longleftrightarrow> b \<in> ?C"
	proof
	assume "b \<in> ?C"
	hence "b \<in> insert ?p1 (insert ?p2 (set ?qs))" and b1: "poly_deg (fst b) = d"
	and b2: "m < card (snd b)" by (simp_all add: shift_list.simps)
	from this(1) show "b \<in> ?B"
	proof (elim insertE)
	assume "b = ?p1"
	with \<open>h \<noteq> 0\<close> have "poly_deg (fst b) = Suc d"
	by (simp add: poly_deg_monom_mult deg_pm_single deg_h)
	thus ?thesis by (simp add: b1)
	next
	assume "b = ?p2"
	hence "card (snd b) = m" by (simp add: card_Ux)
	with b2 show ?thesis by simp
	next
	assume "b \<in> set ?qs"
	with b1 b2 show ?thesis by (auto simp: B)
	qed
	qed (auto simp: B shift_list.simps)
	qed
	next
	from valid_qs \<open>(h, U) \<in> set qs\<close> \<open>x \<in> U\<close> show "valid_decomp X (shift_list (h, U) x qs)"
	by (rule valid_decomp_shift_list)
	next
	from inv2 have std: "standard_decomp k qs" by (rule shift2_invD)
	have "?B \<noteq> {}"
	proof
	assume "?B = {}"
	hence "B \<subseteq> {(h, U)}" by simp
	with _ have "card B \<le> card {(h, U)}" by (rule card_mono) simp
	with assms(2) show False by simp
	qed
	then obtain h' U' where "(h', U') \<in> B" and "(h', U') \<noteq> (h, U)" by auto
	from this(1) have "(h', U') \<in> set qs" and "poly_deg h' = d" and "Suc m \<le> card U'"
	by (simp_all add: B)
	note std this(1) \<open>(h, U) \<in> set qs\<close>
	moreover from \<open>poly_deg h' = d\<close> have "poly_deg h' = poly_deg h" by (simp only: deg_h)
	moreover from \<open>Suc m \<le> card U'\<close> have "card U \<le> card U'" by (simp only: card_U)
	ultimately show "standard_decomp k (shift_list (h, U) x qs)"
	by (rule standard_decomp_shift_list) fact+
	next
	from inv2 have exct: "exact_decomp (Suc m) qs" by (rule shift2_invD)
	show "exact_decomp (Suc m) (shift_list (h, U) x qs)"
	proof (rule exact_decompI)
	fix h' U'
	assume "(h', U') \<in> set (shift_list (h, U) x qs)"
	hence *: "(h', U') \<in> insert ?p1 (insert ?p2 (set ?qs))" by (simp add: shift_list.simps)
	thus "h' \<in> P[X]"
	proof (elim insertE)
	assume "(h', U') = ?p1"
	hence h': "h' = punit.monom_mult 1 (Poly_Mapping.single x 1) h" by simp
	from exct \<open>(h, U) \<in> set qs\<close> have "U \<subseteq> X" by (rule exact_decompD)
	with \<open>x \<in> U\<close> have "x \<in> X" ..
	hence "Poly_Mapping.single x 1 \<in> .[X]" by (rule PPs_closed_single)
	moreover from exct \<open>(h, U) \<in> set qs\<close> have "h \<in> P[X]" by (rule exact_decompD)
	ultimately show ?thesis unfolding h' by (rule Polys_closed_monom_mult)
	next
	assume "(h', U') = ?p2"
	hence "h' = h" by simp
	also from exct \<open>(h, U) \<in> set qs\<close> have "\<dots> \<in> P[X]" by (rule exact_decompD)
	finally show ?thesis .
	next
	assume "(h', U') \<in> set ?qs"
	hence "(h', U') \<in> set qs" by simp
	with exct show ?thesis by (rule exact_decompD)
	qed

	from * show "U' \<subseteq> X"
	proof (elim insertE)
	assume "(h', U') = ?p1"
	hence "U' = U" by simp
	also from exct \<open>(h, U) \<in> set qs\<close> have "\<dots> \<subseteq> X" by (rule exact_decompD)
	finally show ?thesis .
	next
	assume "(h', U') = ?p2"
	hence "U' = U - {x}" by simp
	also have "\<dots> \<subseteq> U" by blast
	also from exct \<open>(h, U) \<in> set qs\<close> have "\<dots> \<subseteq> X" by (rule exact_decompD)
	finally show ?thesis .
	next
	assume "(h', U') \<in> set ?qs"
	hence "(h', U') \<in> set qs" by simp
	with exct show ?thesis by (rule exact_decompD)
	qed
	next
	fix h1 h2 U1 U2
	assume "(h1, U1) \<in> set (shift_list (h, U) x qs)" and "Suc m < card U1"
	hence "(h1, U1) \<in> set qs" using card_U card_Ux by (auto simp: shift_list.simps)
	assume "(h2, U2) \<in> set (shift_list (h, U) x qs)" and "Suc m < card U2"
	hence "(h2, U2) \<in> set qs" using card_U card_Ux by (auto simp: shift_list.simps)
	assume "poly_deg h1 = poly_deg h2"
	from exct show "(h1, U1) = (h2, U2)" by (rule exact_decompD) fact+
	qed
	next
	fix d0
	assume "d0 < d"
	have "finite {q \<in> set qs. poly_deg (fst q) = d0 \<and> m < card (snd q)}" (is "finite ?A")
	by auto
	moreover have "{q \<in> set (shift_list (h, U) x qs). poly_deg (fst q) = d0 \<and> m < card (snd q)} \<subseteq> ?A"
	(is "?C \<subseteq> _")
	proof
	fix q
	assume "q \<in> ?C"
	hence "q = ?p1 \<or> q = ?p2 \<or> q \<in> set ?qs" and 1: "poly_deg (fst q) = d0" and 2: "m < card (snd q)"
	by (simp_all add: shift_list.simps)
	from this(1) show "q \<in> ?A"
	proof (elim disjE)
	assume "q = ?p1"
	with \<open>h \<noteq> 0\<close> have "d \<le> poly_deg (fst q)" by (simp add: poly_deg_monom_mult deg_h)
	with \<open>d0 < d\<close> show ?thesis by (simp only: 1)
	next
	assume "q = ?p2"
	hence "d \<le> poly_deg (fst q)" by (simp add: deg_h)
	with \<open>d0 < d\<close> show ?thesis by (simp only: 1)
	next
	assume "q \<in> set ?qs"
	with 1 2 show ?thesis by simp
	qed
	qed
	ultimately have "card ?C \<le> card ?A" by (rule card_mono)
	also from inv2 \<open>d0 < d\<close> have "\<dots> \<le> 1" by (rule shift2_invD)
	finally show "card ?C \<le> 1" .
	qed
	qed

	function (domintros) shift1 :: "(((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<times> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) set) \<Rightarrow>
	(((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<times>
	((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}) \<times> 'x set) set)"
	where
	"shift1 (qs, B) =
	(if 1 < card B then
	let (h, U) = SOME b. b \<in> B \<and> card (snd b) = Suc m; x = SOME y. y \<in> U in
	shift1 (shift_list (h, U) x qs, B - {(h, U)})
	else (qs, B))"
	by auto

	lemma shift1_domI:
	assumes "shift1_inv args"
	shows "shift1_dom args"
	proof -
	from wf_measure[of "card \<circ> snd"] show ?thesis using assms
	proof (induct)
	case (less args)
	obtain qs B where args: "args = (qs, B)" using prod.exhaust by blast
	have IH: "shift1_dom (qs0, B0)" if "card B0 < card B" and "shift1_inv (qs0, B0)"
	for qs0 and B0::"((_ \<Rightarrow>\<^sub>0 'a) \<times> _) set"
	using _ that(2)
	proof (rule less)
	from that(1) show "((qs0, B0), args) \<in> measure (card \<circ> snd)" by (simp add: args)
	qed
	from less(2) have inv: "shift1_inv (qs, B)" by (simp only: args)
	show ?case unfolding args
	proof (rule shift1.domintros)
	fix h U
	assume hU: "(h, U) = (SOME b. b \<in> B \<and> card (snd b) = Suc m)"
	define x where "x = (SOME y. y \<in> U)"
	assume "Suc 0 < card B"
	hence "1 < card B" by simp
	have "shift1_dom (shift_list (h, U) x qs, B - {(h, U)})"
	proof (rule IH)
	from inv have "finite B" by (rule shift1_inv_finite_snd)
	moreover from inv \<open>1 < card B\<close> hU have "(h, U) \<in> B" by (rule shift1_inv_some_snd)
	ultimately show "card (B - {(h, U)}) < card B" by (rule card_Diff1_less)
	next
	from inv \<open>1 < card B\<close> hU x_def show "shift1_inv (shift_list (h, U) x qs, (B - {(h, U)}))"
	by (rule shift1_inv_preserved)
	qed
	thus "shift1_dom (shift_list (SOME b. b \<in> B \<and> card (snd b) = Suc m) (SOME y. y \<in> U) qs,
	B - {SOME b. b \<in> B \<and> card (snd b) = Suc m})" by (simp add: hU x_def)
	qed
	qed
	qed

	lemma shift1_induct [consumes 1, case_names base step]:
	assumes "shift1_inv args"
	assumes "\<And>qs B. shift1_inv (qs, B) \<Longrightarrow> card B \<le> 1 \<Longrightarrow> P (qs, B) (qs, B)"
	assumes "\<And>qs B h U x. shift1_inv (qs, B) \<Longrightarrow> 1 < card B \<Longrightarrow>
	(h, U) = (SOME b. b \<in> B \<and> card (snd b) = Suc m) \<Longrightarrow> x = (SOME y. y \<in> U) \<Longrightarrow>
	finite U \<Longrightarrow> x \<in> U \<Longrightarrow> card (U - {x}) = m \<Longrightarrow>
	P (shift_list (h, U) x qs, B - {(h, U)}) (shift1 (shift_list (h, U) x qs, B - {(h, U)})) \<Longrightarrow>
	P (qs, B) (shift1 (shift_list (h, U) x qs, B - {(h, U)}))"
	shows "P args (shift1 args)"
	proof -
	from assms(1) have "shift1_dom args" by (rule shift1_domI)
	thus ?thesis using assms(1)
	proof (induct args rule: shift1.pinduct)
	case step: (1 qs B)
	obtain h U where hU: "(h, U) = (SOME b. b \<in> B \<and> card (snd b) = Suc m)" by (smt prod.exhaust)
	define x where "x = (SOME y. y \<in> U)"
	show ?case
	proof (simp add: shift1.psimps[OF step.hyps(1)] flip: hU x_def del: One_nat_def,
	intro conjI impI)
	let ?args = "(shift_list (h, U) x qs, B - {(h, U)})"
	assume "1 < card B"
	with step.prems have card_U: "card U = Suc m" using hU by (rule shift1_inv_some_snd)
	from card_U have "finite U" using card.infinite by fastforce
	from card_U have "U \<noteq> {}" by auto
	then obtain y where "y \<in> U" by blast
	hence "x \<in> U" unfolding x_def by (rule someI)
	with step.prems \<open>1 < card B\<close> hU x_def \<open>finite U\<close> show "P (qs, B) (shift1 ?args)"
	proof (rule assms(3))
	from \<open>finite U\<close> \<open>x \<in> U\<close> show "card (U - {x}) = m" by (simp add: card_U)
	next
	from \<open>1 < card B\<close> refl hU x_def show "P ?args (shift1 ?args)"
	proof (rule step.hyps)
	from step.prems \<open>1 < card B\<close> hU x_def show "shift1_inv ?args" by (rule shift1_inv_preserved)
	qed
	qed
	next
	assume "\<not> 1 < card B"
	hence "card B \<le> 1" by simp
	with step.prems show "P (qs, B) (qs, B)" by (rule assms(2))
	qed
	qed
	qed

	lemma shift1_1:
	assumes "shift1_inv args" and "d0 \<le> d"
	shows "card {q \<in> set (fst (shift1 args)). poly_deg (fst q) = d0 \<and> m < card (snd q)} \<le> 1"
	using assms(1)
	proof (induct args rule: shift1_induct)
	case (base qs B)
	from assms(2) have "d0 < d \<or> d0 = d" by auto
	thus ?case
	proof
	from base(1) have "shift2_inv qs" by (rule shift1_invD)
	moreover assume "d0 < d"
	ultimately show ?thesis unfolding fst_conv by (rule shift2_invD)
	next
	assume "d0 = d"
	from base(1) have "B = {q \<in> set (fst (qs, B)). poly_deg (fst q) = d0 \<and> m < card (snd q)}"
	unfolding fst_conv \<open>d0 = d\<close> by (rule shift1_invD)
	with base(2) show ?thesis by simp
	qed
	qed

	lemma shift1_2:
	"shift1_inv args \<Longrightarrow>
	card {q \<in> set (fst (shift1 args)). m < card (snd q)} \<le> card {q \<in> set (fst args). m < card (snd q)}"
	proof (induct args rule: shift1_induct)
	case (base qs B)
	show ?case ..
	next
	case (step qs B h U x)
	let ?x = "Poly_Mapping.single x (1::nat)"
	let ?p1 = "(punit.monom_mult 1 ?x h, U)"
	let ?A = "{q \<in> set qs. m < card (snd q)}"
	from step(1-3) have card_U: "card U = Suc m" and "(h, U) \<in> set qs" by (rule shift1_inv_some_snd)+
	from step(1) have "shift2_inv qs" by (rule shift1_invD)
	hence "valid_decomp X qs" by (rule shift2_invD)
	hence "h \<noteq> 0" using \<open>(h, U) \<in> set qs\<close> by (rule valid_decompD)
	have fin1: "finite ?A" by auto
	hence fin2: "finite (insert ?p1 ?A)" by simp
	from \<open>(h, U) \<in> set qs\<close> have hU_in: "(h, U) \<in> insert ?p1 ?A" by (simp add: card_U)
	have "?p1 \<noteq> (h, U)"
	proof
	assume "?p1 = (h, U)"
	hence "lpp (punit.monom_mult 1 ?x h) = lpp h" by simp
	with \<open>h \<noteq> 0\<close> show False by (simp add: punit.lt_monom_mult monomial_0_iff)
	qed
	let ?qs = "shift_list (h, U) x qs"
	have "{q \<in> set (fst (?qs, B - {(h, U)})). m < card (snd q)} = (insert ?p1 ?A) - {(h, U)}"
	using step(7) card_U \<open>?p1 \<noteq> (h, U)\<close> by (fastforce simp: shift_list.simps)
	also from fin2 hU_in have "card \<dots> = card (insert ?p1 ?A) - 1" by (simp add: card_Diff_singleton_if)
	also from fin1 have "\<dots> \<le> Suc (card ?A) - 1" by (simp add: card_insert_if)
	also have "\<dots> = card {q \<in> set (fst (qs, B)). m < card (snd q)}" by simp
	finally have "card {q \<in> set (fst (?qs, B - {(h, U)})). m < card (snd q)} \<le>
	card {q \<in> set (fst (qs, B)). m < card (snd q)}" .
	with step(8) show ?case by (rule le_trans)
	qed

	lemma shift1_3: "shift1_inv args \<Longrightarrow> cone_decomp T (fst args) \<Longrightarrow> cone_decomp T (fst (shift1 args))"
	proof (induct args rule: shift1_induct)
	case (base qs B)
	from base(3) show ?case .
	next
	case (step qs B h U x)
	from step.hyps(1) have "shift2_inv qs" by (rule shift1_invD)
	hence "valid_decomp X qs" by (rule shift2_invD)
	moreover from step.prems have "cone_decomp T qs" by (simp only: fst_conv)
	moreover from step.hyps(1-3) have "(h, U) \<in> set qs" by (rule shift1_inv_some_snd)
	ultimately have "cone_decomp T (fst (shift_list (h, U) x qs, B - {(h, U)}))"
	unfolding fst_conv using step.hyps(6) by (rule cone_decomp_shift_list)
	thus ?case by (rule step.hyps(8))
	qed

	lemma shift1_4:
	"shift1_inv args \<Longrightarrow>
	Max (poly_deg ` fst ` set (fst args)) \<le> Max (poly_deg ` fst ` set (fst (shift1 args)))"
	proof (induct args rule: shift1_induct)
	case (base qs B)
	show ?case ..
	next
	case (step qs B h U x)
	let ?x = "Poly_Mapping.single x 1"
	let ?p1 = "(punit.monom_mult 1 ?x h, U)"
	let ?qs = "shift_list (h, U) x qs"
	from step(1) have "B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}"
	and inv2: "shift2_inv qs" by (rule shift1_invD)+
	from this(1) have "B \<subseteq> set qs" by auto
	with step(2) have "set qs \<noteq> {}" by auto
	from finite_set have fin: "finite (poly_deg ` fst ` set ?qs)" by (intro finite_imageI)
	have "Max (poly_deg ` fst ` set (fst (qs, B))) \<le> Max (poly_deg ` fst ` set (fst (?qs, B - {(h, U)})))"
	unfolding fst_conv
	proof (rule Max.boundedI)
	from finite_set show "finite (poly_deg ` fst ` set qs)" by (intro finite_imageI)
	next
	from \<open>set qs \<noteq> {}\<close> show "poly_deg ` fst ` set qs \<noteq> {}" by simp
	next
	fix a
	assume "a \<in> poly_deg ` fst ` set qs"
	then obtain q where "q \<in> set qs" and a: "a = poly_deg (fst q)" by blast
	show "a \<le> Max (poly_deg ` fst ` set ?qs)"
	proof (cases "q = (h, U)")
	case True
	hence "a \<le> poly_deg (fst ?p1)" by (cases "h = 0") (simp_all add: a poly_deg_monom_mult)
	also from fin have "\<dots> \<le> Max (poly_deg ` fst ` set ?qs)"
	proof (rule Max_ge)
	have "?p1 \<in> set ?qs" by (simp add: shift_list.simps)
	thus "poly_deg (fst ?p1) \<in> poly_deg ` fst ` set ?qs" by (intro imageI)
	qed
	finally show ?thesis .
	next
	case False
	with \<open>q \<in> set qs\<close> have "q \<in> set ?qs" by (simp add: shift_list.simps)
	hence "a \<in> poly_deg ` fst ` set ?qs" unfolding a by (intro imageI)
	with fin show ?thesis by (rule Max_ge)
	qed
	qed
	thus ?case using step(8) by (rule le_trans)
	qed

	lemma shift1_5: "shift1_inv args \<Longrightarrow> fst (shift1 args) = [] \<longleftrightarrow> fst args = []"
	proof (induct args rule: shift1_induct)
	case (base qs B)
	show ?case ..
	next
	case (step qs B h U x)
	let ?p1 = "(punit.monom_mult 1 (Poly_Mapping.single x 1) h, U)"
	let ?qs = "shift_list (h, U) x qs"
	from step(1) have "B = {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}"
	and inv2: "shift2_inv qs" by (rule shift1_invD)+
	from this(1) have "B \<subseteq> set qs" by auto
	with step(2) have "qs \<noteq> []" by auto
	moreover have "fst (shift1 (?qs, B - {(h, U)})) \<noteq> []"
	by (simp add: step.hyps(8) del: One_nat_def) (simp add: shift_list.simps)
	ultimately show ?case by simp
	qed

	lemma shift1_6: "shift1_inv args \<Longrightarrow> monomial_decomp (fst args) \<Longrightarrow> monomial_decomp (fst (shift1 args))"
	proof (induct args rule: shift1_induct)
	case (base qs B)
	from base(3) show ?case .
	next
	case (step qs B h U x)
	from step(1-3) have "(h, U) \<in> set qs" by (rule shift1_inv_some_snd)
	with step.prems have "monomial_decomp (fst (shift_list (h, U) x qs, B - {(h, U)}))"
	unfolding fst_conv by (rule monomial_decomp_shift_list)
	thus ?case by (rule step.hyps)
	qed

	lemma shift1_7: "shift1_inv args \<Longrightarrow> hom_decomp (fst args) \<Longrightarrow> hom_decomp (fst (shift1 args))"
	proof (induct args rule: shift1_induct)
	case (base qs B)
	from base(3) show ?case .
	next
	case (step qs B h U x)
	from step(1-3) have "(h, U) \<in> set qs" by (rule shift1_inv_some_snd)
	with step.prems have "hom_decomp (fst (shift_list (h, U) x qs, B - {(h, U)}))"
	unfolding fst_conv by (rule hom_decomp_shift_list)
	thus ?case by (rule step.hyps)
	qed

	end

	lemma shift2_inv_preserved:
	assumes "shift2_inv d qs"
	shows "shift2_inv (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})))"
	proof -
	define args where "args = (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})"
	from refl assms have inv1: "shift1_inv d args" unfolding args_def
	by (rule shift1_invI)
	hence "shift1_inv d (shift1 args)" by (induct args rule: shift1_induct)
	hence "shift1_inv d (fst (shift1 args), snd (shift1 args))" by simp
	hence "shift2_inv d (fst (shift1 args))" by (rule shift1_invD)
	hence "valid_decomp X (fst (shift1 args))" and "standard_decomp k (fst (shift1 args))"
	and "exact_decomp (Suc m) (fst (shift1 args))" by (rule shift2_invD)+
	thus "shift2_inv (Suc d) (fst (shift1 args))"
	proof (rule shift2_invI)
	fix d0
	assume "d0 < Suc d"
	hence "d0 \<le> d" by simp
	with inv1 show "card {q \<in> set (fst (shift1 args)). poly_deg (fst q) = d0 \<and> m < card (snd q)} \<le> 1"
	by (rule shift1_1)
	qed
	qed

	function shift2 :: "nat \<Rightarrow> nat \<Rightarrow> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<Rightarrow>
	((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}) \<times> 'x set) list" where
	"shift2 c d qs =
	(if c \<le> d then qs
	else shift2 c (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}))))"
	by auto
	termination proof
	show "wf (measure (\<lambda>(c, d, _). c - d))" by (fact wf_measure)
	qed simp

	lemma shift2_1: "shift2_inv d qs \<Longrightarrow> shift2_inv c (shift2 c d qs)"
	proof (induct c d qs rule: shift2.induct)
	case IH: (1 c d qs)
	show ?case
	proof (subst shift2.simps, simp del: shift2.simps, intro conjI impI)
	assume "c \<le> d"
	show "shift2_inv c qs"
	proof (rule shift2_invI)
	from IH(2) show "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	by (rule shift2_invD)+
	next
	fix d0
	assume "d0 < c"
	hence "d0 < d" using \<open>c \<le> d\<close> by (rule less_le_trans)
	with IH(2) show "card {q \<in> set qs. poly_deg (fst q) = d0 \<and> m < card (snd q)} \<le> 1"
	by (rule shift2_invD)
	qed
	next
	assume "\<not> c \<le> d"
	thus "shift2_inv c (shift2 c (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}))))"
	proof (rule IH)
	from IH(2) show "shift2_inv (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})))"
	by (rule shift2_inv_preserved)
	qed
	qed
	qed

	lemma shift2_2:
	"shift2_inv d qs \<Longrightarrow>
	card {q \<in> set (shift2 c d qs). m < card (snd q)} \<le> card {q \<in> set qs. m < card (snd q)}"
	proof (induct c d qs rule: shift2.induct)
	case IH: (1 c d qs)
	let ?A = "{q \<in> set (shift2 c (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})))). m < card (snd q)}"
	show ?case
	proof (subst shift2.simps, simp del: shift2.simps, intro impI)
	assume "\<not> c \<le> d"
	hence "card ?A \<le> card {q \<in> set (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}))). m < card (snd q)}"
	proof (rule IH)
	show "shift2_inv (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})))"
	using IH(2) by (rule shift2_inv_preserved)
	qed
	also have "\<dots> \<le> card {q \<in> set (fst (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})). m < card (snd q)}"
	using refl IH(2) by (intro shift1_2 shift1_invI)
	finally show "card ?A \<le> card {q \<in> set qs. m < card (snd q)}" by (simp only: fst_conv)
	qed
	qed

	lemma shift2_3: "shift2_inv d qs \<Longrightarrow> cone_decomp T qs \<Longrightarrow> cone_decomp T (shift2 c d qs)"
	proof (induct c d qs rule: shift2.induct)
	case IH: (1 c d qs)
	have inv2: "shift2_inv (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})))"
	using IH(2) by (rule shift2_inv_preserved)
	show ?case
	proof (subst shift2.simps, simp add: IH.prems del: shift2.simps, intro impI)
	assume "\<not> c \<le> d"
	moreover note inv2
	moreover have "cone_decomp T (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})))"
	proof (rule shift1_3)
	from refl IH(2) show "shift1_inv d (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})"
	by (rule shift1_invI)
	qed (simp add: IH.prems)
	ultimately show "cone_decomp T (shift2 c (Suc d) (fst (shift1 (qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)}))))"
	by (rule IH)
	qed
	qed

	lemma shift2_4:
	"shift2_inv d qs \<Longrightarrow> Max (poly_deg ` fst ` set qs) \<le> Max (poly_deg ` fst ` set (shift2 c d qs))"
	proof (induct c d qs rule: shift2.induct)
	case IH: (1 c d qs)
	let ?args = "(qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})"
	show ?case
	proof (subst shift2.simps, simp del: shift2.simps, intro impI)
	assume "\<not> c \<le> d"
	have "Max (poly_deg ` fst ` set (fst ?args)) \<le> Max (poly_deg ` fst ` set (fst (shift1 ?args)))"
	using refl IH(2) by (intro shift1_4 shift1_invI)
	also from \<open>\<not> c \<le> d\<close> have "\<dots> \<le> Max (poly_deg ` fst ` set (shift2 c (Suc d) (fst (shift1 ?args))))"
	proof (rule IH)
	from IH(2) show "shift2_inv (Suc d) (fst (shift1 ?args))"
	by (rule shift2_inv_preserved)
	qed
	finally show "Max (poly_deg ` fst ` set qs) \<le> Max (poly_deg ` fst ` set (shift2 c (Suc d) (fst (shift1 ?args))))"
	by (simp only: fst_conv)
	qed
	qed

	lemma shift2_5:
	"shift2_inv d qs \<Longrightarrow> shift2 c d qs = [] \<longleftrightarrow> qs = []"
	proof (induct c d qs rule: shift2.induct)
	case IH: (1 c d qs)
	let ?args = "(qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})"
	show ?case
	proof (subst shift2.simps, simp del: shift2.simps, intro impI)
	assume "\<not> c \<le> d"
	hence "shift2 c (Suc d) (fst (shift1 ?args)) = [] \<longleftrightarrow> fst (shift1 ?args) = []"
	proof (rule IH)
	from IH(2) show "shift2_inv (Suc d) (fst (shift1 ?args))"
	by (rule shift2_inv_preserved)
	qed
	also from refl IH(2) have "\<dots> \<longleftrightarrow> fst ?args = []" by (intro shift1_5 shift1_invI)
	finally show "shift2 c (Suc d) (fst (shift1 ?args)) = [] \<longleftrightarrow> qs = []" by (simp only: fst_conv)
	qed
	qed

	lemma shift2_6:
	"shift2_inv d qs \<Longrightarrow> monomial_decomp qs \<Longrightarrow> monomial_decomp (shift2 c d qs)"
	proof (induct c d qs rule: shift2.induct)
	case IH: (1 c d qs)
	let ?args = "(qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})"
	show ?case
	proof (subst shift2.simps, simp del: shift2.simps, intro conjI impI IH)
	from IH(2) show "shift2_inv (Suc d) (fst (shift1 ?args))" by (rule shift2_inv_preserved)
	next
	from refl IH(2) have "shift1_inv d ?args" by (rule shift1_invI)
	moreover from IH(3) have "monomial_decomp (fst ?args)" by simp
	ultimately show "monomial_decomp (fst (shift1 ?args))" by (rule shift1_6)
	qed
	qed

	lemma shift2_7:
	"shift2_inv d qs \<Longrightarrow> hom_decomp qs \<Longrightarrow> hom_decomp (shift2 c d qs)"
	proof (induct c d qs rule: shift2.induct)
	case IH: (1 c d qs)
	let ?args = "(qs, {q \<in> set qs. poly_deg (fst q) = d \<and> m < card (snd q)})"
	show ?case
	proof (subst shift2.simps, simp del: shift2.simps, intro conjI impI IH)
	from IH(2) show "shift2_inv (Suc d) (fst (shift1 ?args))" by (rule shift2_inv_preserved)
	next
	from refl IH(2) have "shift1_inv d ?args" by (rule shift1_invI)
	moreover from IH(3) have "hom_decomp (fst ?args)" by simp
	ultimately show "hom_decomp (fst (shift1 ?args))" by (rule shift1_7)
	qed
	qed

	definition shift :: "((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<Rightarrow>
	((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}) \<times> 'x set) list"
	where "shift qs = shift2 (k + card {q \<in> set qs. m < card (snd q)}) k qs"

	lemma shift2_inv_init:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	shows "shift2_inv k qs"
	using assms
	proof (rule shift2_invI)
	fix d0
	assume "d0 < k"
	have "{q \<in> set qs. poly_deg (fst q) = d0 \<and> m < card (snd q)} = {}"
	proof -
	{
	fix q
	assume "q \<in> set qs"
	obtain h U where q: "q = (h, U)" using prod.exhaust by blast
	assume "poly_deg (fst q) = d0" and "m < card (snd q)"
	hence "poly_deg h < k" and "m < card U" using \<open>d0 < k\<close> by (simp_all add: q)
	from this(2) have "U \<noteq> {}" by auto
	with \<open>q \<in> set qs\<close> have "(h, U) \<in> set (qs\<^sub>+)" by (simp add: q pos_decomp_def)
	with assms(2) have "k \<le> poly_deg h" by (rule standard_decompD)
	with \<open>poly_deg h < k\<close> have False by simp
	}
	thus ?thesis by blast
	qed
	thus "card {q \<in> set qs. poly_deg (fst q) = d0 \<and> m < card (snd q)} \<le> 1" by (simp only: card.empty)
	qed

	lemma shift:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	shows "valid_decomp X (shift qs)" and "standard_decomp k (shift qs)" and "exact_decomp m (shift qs)"
	proof -
	define c where "c = card {q \<in> set qs. m < card (snd q)}"
	define A where "A = {q \<in> set (shift qs). m < card (snd q)}"
	from assms have "shift2_inv k qs" by (rule shift2_inv_init)
	hence inv2: "shift2_inv (k + c) (shift qs)" and "card A \<le> c"
	unfolding shift_def c_def A_def by (rule shift2_1, rule shift2_2)
	from inv2 have fin: "valid_decomp X (shift qs)" and std: "standard_decomp k (shift qs)"
	and exct: "exact_decomp (Suc m) (shift qs)"
	by (rule shift2_invD)+
	show "valid_decomp X (shift qs)" and "standard_decomp k (shift qs)" by fact+
	have "finite A" by (auto simp: A_def)

	show "exact_decomp m (shift qs)"
	proof (rule exact_decompI)
	fix h U
	assume "(h, U) \<in> set (shift qs)"
	with exct show "h \<in> P[X]" and "U \<subseteq> X" by (rule exact_decompD)+
	next
	fix h1 h2 U1 U2
	assume 1: "(h1, U1) \<in> set (shift qs)" and 2: "(h2, U2) \<in> set (shift qs)"
	assume 3: "poly_deg h1 = poly_deg h2" and 4: "m < card U1" and 5: "m < card U2"
	from 5 have "U2 \<noteq> {}" by auto
	with 2 have "(h2, U2) \<in> set ((shift qs)\<^sub>+)" by (simp add: pos_decomp_def)
	let ?C = "{q \<in> set (shift qs). poly_deg (fst q) = poly_deg h2 \<and> m < card (snd q)}"
	define B where "B = {q \<in> A. k \<le> poly_deg (fst q) \<and> poly_deg (fst q) \<le> poly_deg h2}"
	have "Suc (poly_deg h2) - k \<le> card B"
	proof -
	have "B = (\<Union>d0\<in>{k..poly_deg h2}. {q \<in> A. poly_deg (fst q) = d0})" by (auto simp: B_def)
	also have "card \<dots> = (\<Sum>d0=k..poly_deg h2. card {q \<in> A. poly_deg (fst q) = d0})"
	proof (intro card_UN_disjoint ballI impI)
	fix d0
	from _ \<open>finite A\<close> show "finite {q \<in> A. poly_deg (fst q) = d0}" by (rule finite_subset) blast
	next
	fix d0 d1 :: nat
	assume "d0 \<noteq> d1"
	thus "{q \<in> A. poly_deg (fst q) = d0} \<inter> {q \<in> A. poly_deg (fst q) = d1} = {}" by blast
	qed (fact finite_atLeastAtMost)
	also have "\<dots> \<ge> (\<Sum>d0=k..poly_deg h2. 1)"
	proof (rule sum_mono)
	fix d0
	assume "d0 \<in> {k..poly_deg h2}"
	hence "k \<le> d0" and "d0 \<le> poly_deg h2" by simp_all
	with std \<open>(h2, U2) \<in> set ((shift qs)\<^sub>+)\<close> obtain h' U' where "(h', U') \<in> set (shift qs)"
	and "poly_deg h' = d0" and "card U2 \<le> card U'" by (rule standard_decompE)
	from 5 this(3) have "m < card U'" by (rule less_le_trans)
	with \<open>(h', U') \<in> set (shift qs)\<close> have "(h', U') \<in> {q \<in> A. poly_deg (fst q) = d0}"
	by (simp add: A_def \<open>poly_deg h' = d0\<close>)
	hence "{q \<in> A. poly_deg (fst q) = d0} \<noteq> {}" by blast
	moreover from _ \<open>finite A\<close> have "finite {q \<in> A. poly_deg (fst q) = d0}"
	by (rule finite_subset) blast
	ultimately show "1 \<le> card {q \<in> A. poly_deg (fst q) = d0}"
	by (simp add: card_gt_0_iff Suc_le_eq)
	qed
	also have "(\<Sum>d0=k..poly_deg h2. 1) = Suc (poly_deg h2) - k" by auto
	finally show ?thesis .
	qed
	also from \<open>finite A\<close> _ have "\<dots> \<le> card A" by (rule card_mono) (auto simp: B_def)
	also have "\<dots> \<le> c" by fact
	finally have "poly_deg h2 < k + c" by simp
	with inv2 have "card ?C \<le> 1" by (rule shift2_invD)
	have "finite ?C" by auto
	moreover note \<open>card ?C \<le> 1\<close>
	moreover from 1 3 4 have "(h1, U1) \<in> ?C" by simp
	moreover from 2 5 have "(h2, U2) \<in> ?C" by simp
	ultimately show "(h1, U1) = (h2, U2)" by (auto simp: card_le_Suc0_iff_eq)
	qed
	qed

	lemma monomial_decomp_shift:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	and "monomial_decomp qs"
	shows "monomial_decomp (shift qs)"
	proof -
	from assms(1, 2, 3) have "shift2_inv k qs" by (rule shift2_inv_init)
	thus ?thesis unfolding shift_def using assms(4) by (rule shift2_6)
	qed

	lemma hom_decomp_shift:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	and "hom_decomp qs"
	shows "hom_decomp (shift qs)"
	proof -
	from assms(1, 2, 3) have "shift2_inv k qs" by (rule shift2_inv_init)
	thus ?thesis unfolding shift_def using assms(4) by (rule shift2_7)
	qed

	lemma cone_decomp_shift:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	and "cone_decomp T qs"
	shows "cone_decomp T (shift qs)"
	proof -
	from assms(1, 2, 3) have "shift2_inv k qs" by (rule shift2_inv_init)
	thus ?thesis unfolding shift_def using assms(4) by (rule shift2_3)
	qed

	lemma Max_shift_ge:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	shows "Max (poly_deg ` fst ` set qs) \<le> Max (poly_deg ` fst ` set (shift qs))"
	proof -
	from assms(1-3) have "shift2_inv k qs" by (rule shift2_inv_init)
	thus ?thesis unfolding shift_def by (rule shift2_4)
	qed

	lemma shift_Nil_iff:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp (Suc m) qs"
	shows "shift qs = [] \<longleftrightarrow> qs = []"
	proof -
	from assms(1-3) have "shift2_inv k qs" by (rule shift2_inv_init)
	thus ?thesis unfolding shift_def by (rule shift2_5)
	qed

	end

	primrec exact_aux :: "nat \<Rightarrow> nat \<Rightarrow> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<Rightarrow>
	((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}) \<times> 'x set) list" where
	"exact_aux k 0 qs = qs" \|
	"exact_aux k (Suc m) qs = exact_aux k m (shift k m qs)"

	lemma exact_aux:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp m qs"
	shows "valid_decomp X (exact_aux k m qs)" (is ?thesis1)
	and "standard_decomp k (exact_aux k m qs)" (is ?thesis2)
	and "exact_decomp 0 (exact_aux k m qs)" (is ?thesis3)
	proof -
	from assms have "?thesis1 \<and> ?thesis2 \<and> ?thesis3"
	proof (induct m arbitrary: qs)
	case 0
	thus ?case by simp
	next
	case (Suc m)
	let ?qs = "shift k m qs"
	have "valid_decomp X (exact_aux k m ?qs) \<and> standard_decomp k (exact_aux k m ?qs) \<and>
	exact_decomp 0 (exact_aux k m ?qs)"
	proof (rule Suc)
	from Suc.prems show "valid_decomp X ?qs" and "standard_decomp k ?qs" and "exact_decomp m ?qs"
	by (rule shift)+
	qed
	thus ?case by simp
	qed
	thus ?thesis1 and ?thesis2 and ?thesis3 by simp_all
	qed

	lemma monomial_decomp_exact_aux:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp m qs" and "monomial_decomp qs"
	shows "monomial_decomp (exact_aux k m qs)"
	using assms
	proof (induct m arbitrary: qs)
	case 0
	thus ?case by simp
	next
	case (Suc m)
	let ?qs = "shift k m qs"
	have "monomial_decomp (exact_aux k m ?qs)"
	proof (rule Suc)
	show "valid_decomp X ?qs" and "standard_decomp k ?qs" and "exact_decomp m ?qs"
	using Suc.prems(1, 2, 3) by (rule shift)+
	next
	from Suc.prems show "monomial_decomp ?qs" by (rule monomial_decomp_shift)
	qed
	thus ?case by simp
	qed

	lemma hom_decomp_exact_aux:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp m qs" and "hom_decomp qs"
	shows "hom_decomp (exact_aux k m qs)"
	using assms
	proof (induct m arbitrary: qs)
	case 0
	thus ?case by simp
	next
	case (Suc m)
	let ?qs = "shift k m qs"
	have "hom_decomp (exact_aux k m ?qs)"
	proof (rule Suc)
	show "valid_decomp X ?qs" and "standard_decomp k ?qs" and "exact_decomp m ?qs"
	using Suc.prems(1, 2, 3) by (rule shift)+
	next
	from Suc.prems show "hom_decomp ?qs" by (rule hom_decomp_shift)
	qed
	thus ?case by simp
	qed

	lemma cone_decomp_exact_aux:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp m qs" and "cone_decomp T qs"
	shows "cone_decomp T (exact_aux k m qs)"
	using assms
	proof (induct m arbitrary: qs)
	case 0
	thus ?case by simp
	next
	case (Suc m)
	let ?qs = "shift k m qs"
	have "cone_decomp T (exact_aux k m ?qs)"
	proof (rule Suc)
	show "valid_decomp X ?qs" and "standard_decomp k ?qs" and "exact_decomp m ?qs"
	using Suc.prems(1, 2, 3) by (rule shift)+
	next
	from Suc.prems show "cone_decomp T ?qs" by (rule cone_decomp_shift)
	qed
	thus ?case by simp
	qed

	lemma Max_exact_aux_ge:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp m qs"
	shows "Max (poly_deg ` fst ` set qs) \<le> Max (poly_deg ` fst ` set (exact_aux k m qs))"
	using assms
	proof (induct m arbitrary: qs)
	case 0
	thus ?case by simp
	next
	case (Suc m)
	let ?qs = "shift k m qs"
	from Suc.prems have "Max (poly_deg ` fst ` set qs) \<le> Max (poly_deg ` fst ` set ?qs)"
	by (rule Max_shift_ge)
	also have "\<dots> \<le> Max (poly_deg ` fst ` set (exact_aux k m ?qs))"
	proof (rule Suc)
	from Suc.prems show "valid_decomp X ?qs" and "standard_decomp k ?qs" and "exact_decomp m ?qs"
	by (rule shift)+
	qed
	finally show ?case by simp
	qed

	lemma exact_aux_Nil_iff:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "exact_decomp m qs"
	shows "exact_aux k m qs = [] \<longleftrightarrow> qs = []"
	using assms
	proof (induct m arbitrary: qs)
	case 0
	thus ?case by simp
	next
	case (Suc m)
	let ?qs = "shift k m qs"
	have "exact_aux k m ?qs = [] \<longleftrightarrow> ?qs = []"
	proof (rule Suc)
	from Suc.prems show "valid_decomp X ?qs" and "standard_decomp k ?qs" and "exact_decomp m ?qs"
	by (rule shift)+
	qed
	also from Suc.prems have "\<dots> \<longleftrightarrow> qs = []" by (rule shift_Nil_iff)
	finally show ?case by simp
	qed

	definition exact :: "nat \<Rightarrow> ((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) list \<Rightarrow>
	((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::{comm_ring_1,ring_no_zero_divisors}) \<times> 'x set) list"
	where "exact k qs = exact_aux k (card X) qs"

	lemma exact:
	assumes "valid_decomp X qs" and "standard_decomp k qs"
	shows "valid_decomp X (exact k qs)" (is ?thesis1)
	and "standard_decomp k (exact k qs)" (is ?thesis2)
	and "exact_decomp 0 (exact k qs)" (is ?thesis3)
	proof -
	from assms(1) le_refl have "exact_decomp (card X) qs" by (rule exact_decomp_card_X)
	with assms show ?thesis1 and ?thesis2 and ?thesis3 unfolding exact_def by (rule exact_aux)+
	qed

	lemma monomial_decomp_exact:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "monomial_decomp qs"
	shows "monomial_decomp (exact k qs)"
	proof -
	from assms(1) le_refl have "exact_decomp (card X) qs" by (rule exact_decomp_card_X)
	with assms(1, 2) show ?thesis unfolding exact_def using assms(3) by (rule monomial_decomp_exact_aux)
	qed

	lemma hom_decomp_exact:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "hom_decomp qs"
	shows "hom_decomp (exact k qs)"
	proof -
	from assms(1) le_refl have "exact_decomp (card X) qs" by (rule exact_decomp_card_X)
	with assms(1, 2) show ?thesis unfolding exact_def using assms(3) by (rule hom_decomp_exact_aux)
	qed

	lemma cone_decomp_exact:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "cone_decomp T qs"
	shows "cone_decomp T (exact k qs)"
	proof -
	from assms(1) le_refl have "exact_decomp (card X) qs" by (rule exact_decomp_card_X)
	with assms(1, 2) show ?thesis unfolding exact_def using assms(3) by (rule cone_decomp_exact_aux)
	qed

	lemma Max_exact_ge:
	assumes "valid_decomp X qs" and "standard_decomp k qs"
	shows "Max (poly_deg ` fst ` set qs) \<le> Max (poly_deg ` fst ` set (exact k qs))"
	proof -
	from assms(1) le_refl have "exact_decomp (card X) qs" by (rule exact_decomp_card_X)
	with assms(1, 2) show ?thesis unfolding exact_def by (rule Max_exact_aux_ge)
	qed

	lemma exact_Nil_iff:
	assumes "valid_decomp X qs" and "standard_decomp k qs"
	shows "exact k qs = [] \<longleftrightarrow> qs = []"
	proof -
	from assms(1) le_refl have "exact_decomp (card X) qs" by (rule exact_decomp_card_X)
	with assms(1, 2) show ?thesis unfolding exact_def by (rule exact_aux_Nil_iff)
	qed

	corollary \<b>_zero_exact:
	assumes "valid_decomp X qs" and "standard_decomp k qs" and "qs \<noteq> []"
	shows "Suc (Max (poly_deg ` fst ` set qs)) \<le> \<b> (exact k qs) 0"
	proof -
	from assms(1, 2) have "Max (poly_deg ` fst ` set qs) \<le> Max (poly_deg ` fst ` set (exact k qs))"
	by (rule Max_exact_ge)
	also have "Suc \<dots> \<le> \<b> (exact k qs) 0"
	proof (rule \<b>_zero)
	from assms show "exact k qs \<noteq> []" by (simp add: exact_Nil_iff)
	qed
	finally show ?thesis by simp
	qed

	lemma normal_form_exact_decompE:
	assumes "F \<subseteq> P[X]"
	obtains qs where "valid_decomp X qs" and "standard_decomp 0 qs" and "monomial_decomp qs"
	and "cone_decomp (normal_form F ` P[X]) qs" and "exact_decomp 0 qs"
	and "\<And>g. (\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> g \<in> punit.reduced_GB F \<Longrightarrow> poly_deg g \<le> \<b> qs 0"
	proof -
	let ?G = "punit.reduced_GB F"
	let ?S = "lpp ` ?G"
	let ?N = "normal_form F ` P[X]"
	define qs::"((_ \<Rightarrow>\<^sub>0 'a) \<times> _) list" where "qs = snd (split 0 X ?S)"
	from fin_X assms have std: "standard_decomp 0 qs" and cn: "cone_decomp ?N qs"
	unfolding qs_def by (rule standard_cone_decomp_snd_split)+
	from fin_X assms have "finite ?G" by (rule finite_reduced_GB_Polys)
	hence "finite ?S" by (rule finite_imageI)
	with fin_X subset_refl have valid: "valid_decomp X qs" unfolding qs_def using zero_in_PPs
	by (rule valid_decomp_split)
	from fin_X subset_refl \<open>finite ?S\<close> have md: "monomial_decomp qs"
	unfolding qs_def by (rule monomial_decomp_split)
	let ?qs = "exact 0 qs"
	from valid std have "valid_decomp X ?qs" and "standard_decomp 0 ?qs" by (rule exact)+
	moreover from valid std md have "monomial_decomp ?qs" by (rule monomial_decomp_exact)
	moreover from valid std cn have "cone_decomp ?N ?qs" by (rule cone_decomp_exact)
	moreover from valid std have "exact_decomp 0 ?qs" by (rule exact)
	moreover have "poly_deg g \<le> \<b> ?qs 0" if "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "g \<in> ?G" for g
	proof (cases "qs = []")
	case True
	from one_in_Polys have "normal_form F 1 \<in> ?N" by (rule imageI)
	also from True cn have "\<dots> = {0}" by (simp add: cone_decomp_def direct_decomp_def bij_betw_def)
	finally have "?G = {1}" using fin_X assms
	by (simp add: normal_form_zero_iff ideal_eq_UNIV_iff_reduced_GB_eq_one_Polys
	flip: ideal_eq_UNIV_iff_contains_one)
	with that(2) show ?thesis by simp
	next
	case False
	from fin_X assms that have "poly_deg g \<le> Suc (Max (poly_deg ` fst ` set qs))"
	unfolding qs_def by (rule standard_cone_decomp_snd_split)
	also from valid std False have "\<dots> \<le> \<b> ?qs 0" by (rule \<b>_zero_exact)
	finally show ?thesis .
	qed
	ultimately show ?thesis ..
	qed

	end

	end

	end (* pm_powerprod *)

	end (* theory *)
	diff --git a/thys/Groebner_Macaulay/Dube_Bound.thy b/thys/Groebner_Macaulay/Dube_Bound.thy
	--- a/thys/Groebner_Macaulay/Dube_Bound.thy
	+++ b/thys/Groebner_Macaulay/Dube_Bound.thy
	@@ -1,1583 +1,1583 @@
	(* Author: Alexander Maletzky *)

	section \<open>Dub\'{e}'s Degree-Bound for Homogeneous Gr\"obner Bases\<close>

	theory Dube_Bound
	imports Poly_Fun Cone_Decomposition Degree_Bound_Utils
	begin

	context fixes n d :: nat
	begin

	function Dube_aux :: "nat \<Rightarrow> nat" where
	"Dube_aux j = (if j + 2 < n then
	2 + ((Dube_aux (j + 1)) choose 2) + (\<Sum>i=j+3..n-1. (Dube_aux i) choose (Suc (i - j)))
	else if j + 2 = n then d\<^sup>2 + 2 * d else 2 * d)"
	by pat_completeness auto
	termination proof
	show "wf (measure ((-) n))" by (fact wf_measure)
	qed auto

	definition Dube :: nat where "Dube = (if n \<le> 1 \<or> d = 0 then d else Dube_aux 1)"

	lemma Dube_aux_ge_d: "d \<le> Dube_aux j"
	proof (induct j rule: Dube_aux.induct)
	case step: (1 j)
	have "j + 2 < n \<or> j + 2 = n \<or> n < j + 2" by auto
	show ?case
	proof (rule linorder_cases)
	assume *: "j + 2 < n"
	hence 1: "d \<le> Dube_aux (j + 1)"
	by (rule step.hyps)+
	show ?thesis
	proof (cases "d \<le> 2")
	case True
	also from * have "2 \<le> Dube_aux j" by simp
	finally show ?thesis .
	next
	case False
	hence "2 < d" by simp
	hence "2 < Dube_aux (j + 1)" using 1 by (rule less_le_trans)
	with _ have "Dube_aux (j + 1) \<le> Dube_aux (j + 1) choose 2" by (rule upper_le_binomial) simp
	also from * have "\<dots> \<le> Dube_aux j" by simp
	finally have "Dube_aux (j + 1) \<le> Dube_aux j" .
	with 1 show ?thesis by (rule le_trans)
	qed
	next
	assume "j + 2 = n"
	thus ?thesis by simp
	next
	assume "n < j + 2"
	thus ?thesis by simp
	qed
	qed

	corollary Dube_ge_d: "d \<le> Dube"
	by (simp add: Dube_def Dube_aux_ge_d del: Dube_aux.simps)

	text \<open>Dub\'{e} in @{cite Dube1990} proves the following theorem, to obtain a short closed form for
	the degree bound. However, the proof he gives is wrong: In the last-but-one proof step of Lemma 8.1
	the sum on the right-hand-side of the inequality can be greater than 1/2 (e.g. for @{prop "n = 7"},
	@{prop "d = 2"} and @{prop "j = 1"}), rendering the value inside the big brackets negative. This is
	also true without the additional summand \<open>2\<close> we had to introduce in function @{const Dube_aux} to
	correct another mistake found in @{cite Dube1990}.
	Nonetheless, experiments carried out in Mathematica still suggest that the short closed form is a
	valid upper bound for @{const Dube}, even with the additional summand \<open>2\<close>. So, with some effort it
	might be possible to prove the theorem below; but in fact function @{const Dube} gives typically
	much better (i.e. smaller) values for concrete values of \<open>n\<close> and \<open>d\<close>, so it is better to stick to
	@{const Dube} instead of the closed form anyway. Asymptotically, as \<open>n\<close> tends to infinity,
	@{const Dube} grows double exponentially, too.\<close>

	theorem "rat_of_nat Dube \<le> 2 * ((rat_of_nat d)\<^sup>2 / 2 + (rat_of_nat d)) ^ (2 ^ (n - 2))"
	oops

	end

	subsection \<open>Hilbert Function and Hilbert Polynomial\<close>

	context pm_powerprod
	begin

	context
	fixes X :: "'x set"
	assumes fin_X: "finite X"
	begin

	lemma Hilbert_fun_cone_aux:
	assumes "h \<in> P[X]" and "h \<noteq> 0" and "U \<subseteq> X" and "homogeneous (h::_ \<Rightarrow>\<^sub>0 'a::field)"
	shows "Hilbert_fun (cone (h, U)) z = card {t \<in> .[U]. deg_pm t + poly_deg h = z}"
	proof -
	from assms(2) have "lpp h \<in> keys h" by (rule punit.lt_in_keys)
	with assms(4) have deg_h[symmetric]: "deg_pm (lpp h) = poly_deg h"
	by (rule homogeneousD_poly_deg)
	from assms(1, 3) have "cone (h, U) \<subseteq> P[X]" by (rule cone_subset_PolysI)
	with fin_X have "Hilbert_fun (cone (h, U)) z = card (lpp ` (hom_deg_set z (cone (h, U)) - {0}))"
	using subspace_cone[of "(h, U)"] by (simp only: Hilbert_fun_alt)
	also from assms(4) have "lpp ` (hom_deg_set z (cone (h, U)) - {0}) =
	{t \<in> lpp ` (cone (h, U) - {0}). deg_pm t = z}"
	by (intro image_lt_hom_deg_set homogeneous_set_coneI)
	also have "{t \<in> lpp ` (cone (h, U) - {0}). deg_pm t = z} =
	(\<lambda>t. t + lpp h) ` {t \<in> .[U]. deg_pm t + poly_deg h = z}" (is "?A = ?B")
	proof
	show "?A \<subseteq> ?B"
	proof
	fix t
	assume "t \<in> ?A"
	hence "t \<in> lpp ` (cone (h, U) - {0})" and "deg_pm t = z" by simp_all
	from this(1) obtain a where "a \<in> cone (h, U) - {0}" and 2: "t = lpp a" ..
	from this(1) have "a \<in> cone (h, U)" and "a \<noteq> 0" by simp_all
	from this(1) obtain q where "q \<in> P[U]" and a: "a = q * h" by (rule coneE)
	from \<open>a \<noteq> 0\<close> have "q \<noteq> 0" by (auto simp: a)
	hence t: "t = lpp q + lpp h" using assms(2) unfolding 2 a by (rule lp_times)
	hence "deg_pm (lpp q) + poly_deg h = deg_pm t" by (simp add: deg_pm_plus deg_h)
	also have "\<dots> = z" by fact
	finally have "deg_pm (lpp q) + poly_deg h = z" .
	moreover from \<open>q \<in> P[U]\<close> have "lpp q \<in> .[U]" by (rule PPs_closed_lpp)
	ultimately have "lpp q \<in> {t \<in> .[U]. deg_pm t + poly_deg h = z}" by simp
	moreover have "t = lpp q + lpp h" by (simp only: t)
	ultimately show "t \<in> ?B" by (rule rev_image_eqI)
	qed
	next
	show "?B \<subseteq> ?A"
	proof
	fix t
	assume "t \<in> ?B"
	then obtain s where "s \<in> {t \<in> .[U]. deg_pm t + poly_deg h = z}"
	and t1: "t = s + lpp h" ..
	from this(1) have "s \<in> .[U]" and 1: "deg_pm s + poly_deg h = z" by simp_all
	let ?q = "monomial (1::'a) s"
	have "?q \<noteq> 0" by (simp add: monomial_0_iff)
	hence "?q * h \<noteq> 0" and "lpp (?q * h) = lpp ?q + lpp h" using \<open>h \<noteq> 0\<close>
	by (rule times_not_zero, rule lp_times)
	hence t: "t = lpp (?q * h)" by (simp add: t1 punit.lt_monomial)
	from \<open>s \<in> .[U]\<close> have "?q \<in> P[U]" by (rule Polys_closed_monomial)
	with refl have "?q * h \<in> cone (h, U)" by (rule coneI)
	moreover from _ assms(2) have "?q * h \<noteq> 0" by (rule times_not_zero) (simp add: monomial_0_iff)
	ultimately have "?q * h \<in> cone (h, U) - {0}" by simp
	hence "t \<in> lpp ` (cone (h, U) - {0})" unfolding t by (rule imageI)
	moreover have "deg_pm t = int z" by (simp add: t1) (simp add: deg_pm_plus deg_h flip: 1)
	ultimately show "t \<in> ?A" by simp
	qed
	qed
	also have "card \<dots> = card {t \<in> .[U]. deg_pm t + poly_deg h = z}" by (simp add: card_image)
	finally show ?thesis .
	qed

	lemma Hilbert_fun_cone_empty:
	assumes "h \<in> P[X]" and "h \<noteq> 0" and "homogeneous (h::_ \<Rightarrow>\<^sub>0 'a::field)"
	shows "Hilbert_fun (cone (h, {})) z = (if poly_deg h = z then 1 else 0)"
	proof -
	have "Hilbert_fun (cone (h, {})) z = card {t \<in> .[{}::'x set]. deg_pm t + poly_deg h = z}"
	using assms(1, 2) empty_subsetI assms(3) by (rule Hilbert_fun_cone_aux)
	also have "\<dots> = (if poly_deg h = z then 1 else 0)" by simp
	finally show ?thesis .
	qed

	lemma Hilbert_fun_cone_nonempty:
	assumes "h \<in> P[X]" and "h \<noteq> 0" and "U \<subseteq> X" and "homogeneous (h::_ \<Rightarrow>\<^sub>0 'a::field)" and "U \<noteq> {}"
	shows "Hilbert_fun (cone (h, U)) z =
	(if poly_deg h \<le> z then ((z - poly_deg h) + (card U - 1)) choose (card U - 1) else 0)"
	proof (cases "poly_deg h \<le> z")
	case True
	from assms(3) fin_X have "finite U" by (rule finite_subset)
	from assms(1-4) have "Hilbert_fun (cone (h, U)) z = card {t \<in> .[U]. deg_pm t + poly_deg h = z}"
	by (rule Hilbert_fun_cone_aux)
	also from True have "{t \<in> .[U]. deg_pm t + poly_deg h = z} = deg_sect U (z - poly_deg h)"
	by (auto simp: deg_sect_def)
	also from \<open>finite U\<close> assms(5) have "card \<dots> = (z - poly_deg h) + (card U - 1) choose (card U - 1)"
	by (rule card_deg_sect)
	finally show ?thesis by (simp add: True)
	next
	case False
	from assms(1-4) have "Hilbert_fun (cone (h, U)) z = card {t \<in> .[U]. deg_pm t + poly_deg h = z}"
	by (rule Hilbert_fun_cone_aux)
	also from False have "{t \<in> .[U]. deg_pm t + poly_deg h = z} = {}" by auto
	hence "card {t \<in> .[U]. deg_pm t + poly_deg h = z} = card ({}::('x \<Rightarrow>\<^sub>0 nat) set)" by (rule arg_cong)
	also have "\<dots> = 0" by simp
	finally show ?thesis by (simp add: False)
	qed

	corollary Hilbert_fun_Polys:
	assumes "X \<noteq> {}"
	shows "Hilbert_fun (P[X]::(_ \<Rightarrow>\<^sub>0 'a::field) set) z = (z + (card X - 1)) choose (card X - 1)"
	proof -
	let ?one = "1::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a"
	have "Hilbert_fun (P[X]::(_ \<Rightarrow>\<^sub>0 'a) set) z = Hilbert_fun (cone (?one, X)) z" by simp
	also have "\<dots> = (if poly_deg ?one \<le> z then ((z - poly_deg ?one) + (card X - 1)) choose (card X - 1) else 0)"
	using one_in_Polys _ subset_refl _ assms by (rule Hilbert_fun_cone_nonempty) simp_all
	also have "\<dots> = (z + (card X - 1)) choose (card X - 1)" by simp
	finally show ?thesis .
	qed

	lemma Hilbert_fun_cone_decomp:
	assumes "cone_decomp T ps" and "valid_decomp X ps" and "hom_decomp ps"
	shows "Hilbert_fun T z = (\<Sum>hU\<in>set ps. Hilbert_fun (cone hU) z)"
	proof -
	note fin_X
	moreover from assms(2, 1) have "T \<subseteq> P[X]" by (rule valid_cone_decomp_subset_Polys)
	moreover from assms(1) have dd: "direct_decomp T (map cone ps)" by (rule cone_decompD)
	ultimately have "Hilbert_fun T z = (\<Sum>s\<in>set (map cone ps). Hilbert_fun s z)"
	proof (rule Hilbert_fun_direct_decomp)
	fix cn
	assume "cn \<in> set (map cone ps)"
	then obtain hU where "hU \<in> set ps" and cn: "cn = cone hU" unfolding set_map ..
	note this(1)
	moreover obtain h U where hU: "hU = (h, U)" using prod.exhaust by blast
	ultimately have "(h, U) \<in> set ps" by simp
	with assms(3) have "homogeneous h" by (rule hom_decompD)
	thus "homogeneous_set cn" unfolding cn hU by (rule homogeneous_set_coneI)
	show "phull.subspace cn" unfolding cn by (fact subspace_cone)
	qed
	also have "\<dots> = (\<Sum>hU\<in>set ps. ((\<lambda>s. Hilbert_fun s z) \<circ> cone) hU)" unfolding set_map using finite_set
	proof (rule sum.reindex_nontrivial)
	fix hU1 hU2
	assume "hU1 \<in> set ps" and "hU2 \<in> set ps" and "hU1 \<noteq> hU2"
	with dd have "cone hU1 \<inter> cone hU2 = {0}" using zero_in_cone by (rule direct_decomp_map_Int_zero)
	moreover assume "cone hU1 = cone hU2"
	ultimately show "Hilbert_fun (cone hU1) z = 0" by simp
	qed
	finally show ?thesis by simp
	qed

	definition Hilbert_poly :: "(nat \<Rightarrow> nat) \<Rightarrow> int \<Rightarrow> int"
	where "Hilbert_poly b =
	(\<lambda>z::int. let n = card X in
	((z - b (Suc n) + n) gchoose n) - 1 - (\<Sum>i=1..n. (z - b i + i - 1) gchoose i))"

	lemma poly_fun_Hilbert_poly: "poly_fun (Hilbert_poly b)"
	by (simp add: Hilbert_poly_def Let_def)

	lemma Hilbert_fun_eq_Hilbert_poly_plus_card:
	assumes "X \<noteq> {}" and "valid_decomp X ps" and "hom_decomp ps" and "cone_decomp T ps"
	and "standard_decomp k ps" and "exact_decomp X 0 ps" and "\<b> ps (Suc 0) \<le> d"
	shows "int (Hilbert_fun T d) = card {h::_ \<Rightarrow>\<^sub>0 'a::field. (h, {}) \<in> set ps \<and> poly_deg h = d} + Hilbert_poly (\<b> ps) d"
	proof -
	define n where "n = card X"
	with assms(1) have "0 < n" using fin_X by (simp add: card_gt_0_iff)
	hence "1 \<le> n" and "Suc 0 \<le> n" by simp_all
	from pos_decomp_subset have eq0: "(set ps - set (ps\<^sub>+)) \<union> set (ps\<^sub>+) = set ps" by blast
	have "set ps - set (ps\<^sub>+) \<subseteq> set ps" by blast
	hence fin2: "finite (set ps - set (ps\<^sub>+))" using finite_set by (rule finite_subset)

	have "(\<Sum>hU\<in>set ps - set (ps\<^sub>+). Hilbert_fun (cone hU) d) =
	(\<Sum>(h, U)\<in>set ps - set (ps\<^sub>+). if poly_deg h = d then 1 else 0)"
	using refl
	proof (rule sum.cong)
	fix x
	assume "x \<in> set ps - set (ps\<^sub>+)"
	moreover obtain h U where x: "x = (h, U)" using prod.exhaust by blast
	ultimately have "U = {}" and "(h, U) \<in> set ps" by (simp_all add: pos_decomp_def)
	from assms(2) this(2) have "h \<in> P[X]" and "h \<noteq> 0" by (rule valid_decompD)+
	moreover from assms(3) \<open>(h, U) \<in> set ps\<close> have "homogeneous h" by (rule hom_decompD)
	ultimately show "Hilbert_fun (cone x) d = (case x of (h, U) \<Rightarrow> if poly_deg h = d then 1 else 0)"
	by (simp add: x \<open>U = {}\<close> Hilbert_fun_cone_empty split del: if_split)
	qed
	also from fin2 have "\<dots> = (\<Sum>(h, U)\<in>{(h', U') \<in> set ps - set (ps\<^sub>+). poly_deg h' = d}. 1)"
	by (rule sum.mono_neutral_cong_right) (auto split: if_splits)
	also have "\<dots> = card {(h, U) \<in> set ps - set (ps\<^sub>+). poly_deg h = d}" by auto
	also have "\<dots> = card {h. (h, {}) \<in> set ps \<and> poly_deg h = d}" by (fact card_Diff_pos_decomp)
	finally have eq1: "(\<Sum>hU\<in>set ps - set (ps\<^sub>+). Hilbert_fun (cone hU) d) =
	card {h. (h, {}) \<in> set ps \<and> poly_deg h = d}" .

	let ?f = "\<lambda>a b. (int d) - a + b gchoose b"
	have "int (\<Sum>hU\<in>set (ps\<^sub>+). Hilbert_fun (cone hU) d) = (\<Sum>hU\<in>set (ps\<^sub>+). int (Hilbert_fun (cone hU) d))"
	by (simp add: int_sum prod.case_distrib)
	also have "\<dots> = (\<Sum>(h, U)\<in>(\<Union>i\<in>{1..n}. {(h, U) \<in> set (ps\<^sub>+). card U = i}). ?f (poly_deg h) (card U - 1))"
	proof (rule sum.cong)
	show "set (ps\<^sub>+) = (\<Union>i\<in>{1..n}. {(h, U). (h, U) \<in> set (ps\<^sub>+) \<and> card U = i})"
	proof (rule Set.set_eqI, rule)
	fix x
	assume "x \<in> set (ps\<^sub>+)"
	moreover obtain h U where x: "x = (h, U)" using prod.exhaust by blast
	ultimately have "(h, U) \<in> set (ps\<^sub>+)" by simp
	hence "(h, U) \<in> set ps" and "U \<noteq> {}" by (simp_all add: pos_decomp_def)
	from fin_X assms(6) this(1) have "U \<subseteq> X" by (rule exact_decompD)
	hence "finite U" using fin_X by (rule finite_subset)
	with \<open>U \<noteq> {}\<close> have "0 < card U" by (simp add: card_gt_0_iff)
	moreover from fin_X \<open>U \<subseteq> X\<close> have "card U \<le> n" unfolding n_def by (rule card_mono)
	ultimately have "card U \<in> {1..n}" by simp
	moreover from \<open>(h, U) \<in> set (ps\<^sub>+)\<close> have "(h, U) \<in> {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> card U' = card U}"
	by simp
	ultimately show "x \<in> (\<Union>i\<in>{1..n}. {(h, U). (h, U) \<in> set (ps\<^sub>+) \<and> card U = i})" by (simp add: x)
	qed blast
	next
	fix x
	assume "x \<in> (\<Union>i\<in>{1..n}. {(h, U). (h, U) \<in> set (ps\<^sub>+) \<and> card U = i})"
	then obtain j where "j \<in> {1..n}" and "x \<in> {(h, U). (h, U) \<in> set (ps\<^sub>+) \<and> card U = j}" ..
	from this(2) obtain h U where "(h, U) \<in> set (ps\<^sub>+)" and "card U = j" and x: "x = (h, U)" by blast
	from fin_X assms(2, 5) this(1) have "poly_deg h < \<b> ps (Suc 0)" by (rule \<b>_one_gr)
	also have "\<dots> \<le> d" by fact
	finally have "poly_deg h < d" .
	hence int1: "int (d - poly_deg h) = int d - int (poly_deg h)" by simp
	from \<open>card U = j\<close> \<open>j \<in> {1..n}\<close> have "0 < card U" by simp
	hence int2: "int (card U - Suc 0) = int (card U) - 1" by simp
	from \<open>(h, U) \<in> set (ps\<^sub>+)\<close> have "(h, U) \<in> set ps" using pos_decomp_subset ..
	with assms(2) have "h \<in> P[X]" and "h \<noteq> 0" and "U \<subseteq> X" by (rule valid_decompD)+
	moreover from assms(3) \<open>(h, U) \<in> set ps\<close> have "homogeneous h" by (rule hom_decompD)
	moreover from \<open>0 < card U\<close> have "U \<noteq> {}" by auto
	ultimately have "Hilbert_fun (cone (h, U)) d =
	(if poly_deg h \<le> d then (d - poly_deg h + (card U - 1)) choose (card U - 1) else 0)"
	by (rule Hilbert_fun_cone_nonempty)
	also from \<open>poly_deg h < d\<close> have "\<dots> = (d - poly_deg h + (card U - 1)) choose (card U - 1)" by simp
	finally
	have "int (Hilbert_fun (cone (h, U)) d) = (int d - int (poly_deg h) + (int (card U - 1))) gchoose (card U - 1)"
	by (simp add: int_binomial int1 int2)
	thus "int (Hilbert_fun (cone x) d) =
	(case x of (h, U) \<Rightarrow> int d - int (poly_deg h) + (int (card U - 1)) gchoose (card U - 1))"
	by (simp add: x)
	qed
	also have "\<dots> = (\<Sum>j=1..n. \<Sum>(h, U)\<in>{(h', U') \<in> set (ps\<^sub>+). card U' = j}. ?f (poly_deg h) (card U - 1))"
	proof (intro sum.UNION_disjoint ballI)
	fix j
	have "{(h, U). (h, U) \<in> set (ps\<^sub>+) \<and> card U = j} \<subseteq> set (ps\<^sub>+)" by blast
	thus "finite {(h, U). (h, U) \<in> set (ps\<^sub>+) \<and> card U = j}" using finite_set by (rule finite_subset)
	qed blast+
	also from refl have "\<dots> = (\<Sum>j=1..n. ?f (\<b> ps (Suc j)) j - ?f (\<b> ps j) j)"
	proof (rule sum.cong)
	fix j
	assume "j \<in> {1..n}"
	hence "Suc 0 \<le> j" and "0 < j" and "j \<le> n" by simp_all
	from fin_X this(1) have "\<b> ps j \<le> \<b> ps (Suc 0)" by (rule \<b>_decreasing)
	also have "\<dots> \<le> d" by fact
	finally have "\<b> ps j \<le> d" .
	from fin_X have "\<b> ps (Suc j) \<le> \<b> ps j" by (rule \<b>_decreasing) simp
	hence "\<b> ps (Suc j) \<le> d" using \<open>\<b> ps j \<le> d\<close> by (rule le_trans)
	from \<open>0 < j\<close> have int_j: "int (j - Suc 0) = int j - 1" by simp
	have "(\<Sum>(h, U)\<in>{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> card U' = j}. ?f (poly_deg h) (card U - 1)) =
	(\<Sum>(h, U)\<in>(\<Union>d0\<in>{\<b> ps (Suc j)..int (\<b> ps j) - 1}. {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> int (poly_deg h') = d0 \<and> card U' = j}).
	?f (poly_deg h) (card U - 1))"
	using _ refl
	proof (rule sum.cong)
	show "{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> card U' = j} =
	(\<Union>d0\<in>{\<b> ps (Suc j)..int (\<b> ps j) - 1}. {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> int (poly_deg h') = d0 \<and> card U' = j})"
	proof (rule Set.set_eqI, rule)
	fix x
	assume "x \<in> {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> card U' = j}"
	moreover obtain h U where x: "x = (h, U)" using prod.exhaust by blast
	ultimately have "(h, U) \<in> set (ps\<^sub>+)" and "card U = j" by simp_all
	with fin_X assms(5, 6) \<open>Suc 0 \<le> j\<close> \<open>j \<le> n\<close> have "\<b> ps (Suc j) \<le> poly_deg h"
	unfolding n_def by (rule lem_6_1_3)
	moreover from fin_X have "poly_deg h < \<b> ps j"
	proof (rule \<b>)
	from \<open>(h, U) \<in> set (ps\<^sub>+)\<close> show "(h, U) \<in> set ps" using pos_decomp_subset ..
	next
	show "j \<le> card U" by (simp add: \<open>card U = j\<close>)
	qed
	ultimately have "poly_deg h \<in> {\<b> ps (Suc j)..int (\<b> ps j) - 1}" by simp
	moreover have "(h, U) \<in> {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = poly_deg h \<and> card U' = card U}"
	using \<open>(h, U) \<in> set (ps\<^sub>+)\<close> by simp
	ultimately show "x \<in> (\<Union>d0\<in>{\<b> ps (Suc j)..int (\<b> ps j) - 1}.
	{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> int (poly_deg h') = d0 \<and> card U' = j})"
	by (simp add: x \<open>card U = j\<close>)
	qed blast
	qed
	also have "\<dots> = (\<Sum>d0=\<b> ps (Suc j)..int (\<b> ps j) - 1.
	\<Sum>(h, U)\<in>{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = d0 \<and> card U' = j}.
	?f (poly_deg h) (card U - 1))"
	proof (intro sum.UNION_disjoint ballI)
	fix d0::int
	have "{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = d0 \<and> card U' = j} \<subseteq> set (ps\<^sub>+)" by blast
	thus "finite {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = d0 \<and> card U' = j}"
	using finite_set by (rule finite_subset)
	qed blast+
	also from refl have "\<dots> = (\<Sum>d0=\<b> ps (Suc j)..int (\<b> ps j) - 1. ?f d0 (j - 1))"
	proof (rule sum.cong)
	fix d0
	assume "d0 \<in> {\<b> ps (Suc j)..int (\<b> ps j) - 1}"
	hence "\<b> ps (Suc j) \<le> d0" and "d0 < int (\<b> ps j)" by simp_all
	hence "\<b> ps (Suc j) \<le> nat d0" and "nat d0 < \<b> ps j" by simp_all
	have "(\<Sum>(h, U)\<in>{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = d0 \<and> card U' = j}. ?f (poly_deg h) (card U - 1)) =
	(\<Sum>(h, U)\<in>{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = d0 \<and> card U' = j}. ?f d0 (j - 1))"
	using refl by (rule sum.cong) auto
	also have "\<dots> = card {(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = nat d0 \<and> card U' = j} * ?f d0 (j - 1)"
	using \<open>\<b> ps (Suc j) \<le> d0\<close> by (simp add: int_eq_iff)
	also have "\<dots> = ?f d0 (j - 1)"
	using fin_X assms(5, 6) \<open>Suc 0 \<le> j\<close> \<open>j \<le> n\<close> \<open>\<b> ps (Suc j) \<le> nat d0\<close> \<open>nat d0 < \<b> ps j\<close>
	by (simp only: n_def lem_6_1_2'(3))
	finally show "(\<Sum>(h, U)\<in>{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> poly_deg h' = d0 \<and> card U' = j}.
	?f (poly_deg h) (card U - 1)) = ?f d0 (j - 1)" .
	qed
	also have "\<dots> = (\<Sum>d0\<in>(-) (int d) ` {\<b> ps (Suc j)..int (\<b> ps j) - 1}. d0 + int (j - 1) gchoose (j - 1))"
	proof -
	have "inj_on ((-) (int d)) {\<b> ps (Suc j)..int (\<b> ps j) - 1}" by (auto simp: inj_on_def)
	thus ?thesis by (simp only: sum.reindex o_def)
	qed
	also have "\<dots> = (\<Sum>d0\<in>{0..int d - (\<b> ps (Suc j))}-{0..int d - \<b> ps j}. d0 + int (j - 1) gchoose (j - 1))"
	using _ refl
	proof (rule sum.cong)
	have "(-) (int d) ` {\<b> ps (Suc j)..int (\<b> ps j) - 1} = {int d - (int (\<b> ps j) - 1)..int d - int (\<b> ps (Suc j))}"
	by (simp only: image_diff_atLeastAtMost)
	also have "\<dots> = {0..int d - int (\<b> ps (Suc j))} - {0..int d - int (\<b> ps j)}"
	proof -
	from \<open>\<b> ps j \<le> d\<close> have "int (\<b> ps j) - 1 \<le> int d" by simp
	thus ?thesis by auto
	qed
	finally show "(-) (int d) ` {\<b> ps (Suc j)..int (\<b> ps j) - 1} =
	{0..int d - int (\<b> ps (Suc j))} - {0..int d - int (\<b> ps j)}" .
	qed
	also have "\<dots> = (\<Sum>d0=0..int d - (\<b> ps (Suc j)). d0 + int (j - 1) gchoose (j - 1)) -
	(\<Sum>d0=0..int d - \<b> ps j. d0 + int (j - 1) gchoose (j - 1))"
	by (rule sum_diff) (auto simp: \<open>\<b> ps (Suc j) \<le> \<b> ps j\<close>)
	also from \<open>\<b> ps (Suc j) \<le> d\<close> \<open>\<b> ps j \<le> d\<close> have "\<dots> = ?f (\<b> ps (Suc j)) j - ?f (\<b> ps j) j"
	by (simp add: gchoose_rising_sum, simp add: int_j ac_simps \<open>0 < j\<close>)
	finally show "(\<Sum>(h, U)\<in>{(h', U'). (h', U') \<in> set (ps\<^sub>+) \<and> card U' = j}. ?f (poly_deg h) (card U - 1)) =
	?f (\<b> ps (Suc j)) j - ?f (\<b> ps j) j" .
	qed
	also have "\<dots> = (\<Sum>j=1..n. ?f (\<b> ps (Suc j)) j) - (\<Sum>j=1..n. ?f (\<b> ps j) j)"
	by (fact sum_subtractf)
	also have "\<dots> = ?f (\<b> ps (Suc n)) n + (\<Sum>j=1..n-1. ?f (\<b> ps (Suc j)) j) - (\<Sum>j=1..n. ?f (\<b> ps j) j)"
	by (simp only: sum_tail_nat[OF \<open>0 < n\<close> \<open>1 \<le> n\<close>])
	also have "\<dots> = ?f (\<b> ps (Suc n)) n - ?f (\<b> ps 1) 1 +
	((\<Sum>j=1..n-1. ?f (\<b> ps (Suc j)) j) - (\<Sum>j=1..n-1. ?f (\<b> ps (Suc j)) (Suc j)))"
	by (simp only: sum.atLeast_Suc_atMost[OF \<open>1 \<le> n\<close>] sum_atLeast_Suc_shift[OF \<open>0 < n\<close> \<open>1 \<le> n\<close>])
	also have "\<dots> = ?f (\<b> ps (Suc n)) n - ?f (\<b> ps 1) 1 -
	(\<Sum>j=1..n-1. ?f (\<b> ps (Suc j)) (Suc j) - ?f (\<b> ps (Suc j)) j)"
	by (simp only: sum_subtractf)
	also have "\<dots> = ?f (\<b> ps (Suc n)) n - 1 - ((int d - \<b> ps (Suc 0)) gchoose (Suc 0)) -
	(\<Sum>j=1..n-1. (int d - \<b> ps (Suc j) + j) gchoose (Suc j))"
	proof -
	have "?f (\<b> ps 1) 1 = 1 + ((int d - \<b> ps (Suc 0)) gchoose (Suc 0))"
	by (simp add: plus_Suc_gbinomial)
	moreover from refl have "(\<Sum>j=1..n-1. ?f (\<b> ps (Suc j)) (Suc j) - ?f (\<b> ps (Suc j)) j) =
	(\<Sum>j=1..n-1. (int d - \<b> ps (Suc j) + j) gchoose (Suc j))"
	by (rule sum.cong) (simp add: plus_Suc_gbinomial)
	ultimately show ?thesis by (simp only:)
	qed
	also have "\<dots> = ?f (\<b> ps (Suc n)) n - 1 - (\<Sum>j=0..n-1. (int d - \<b> ps (Suc j) + j) gchoose (Suc j))"
	by (simp only: sum.atLeast_Suc_atMost[OF le0], simp)
	also have "\<dots> = ?f (\<b> ps (Suc n)) n - 1 - (\<Sum>j=Suc 0..Suc (n-1). (int d - \<b> ps j + j - 1) gchoose j)"
	by (simp only: sum.shift_bounds_cl_Suc_ivl, simp add: ac_simps)
	also have "\<dots> = Hilbert_poly (\<b> ps) d" using \<open>0 < n\<close> by (simp add: Hilbert_poly_def Let_def n_def)
	finally have eq2: "int (\<Sum>hU\<in>set (ps\<^sub>+). Hilbert_fun (cone hU) d) = Hilbert_poly (\<b> ps) (int d)" .

	from assms(4, 2, 3) have "Hilbert_fun T d = (\<Sum>hU\<in>set ps. Hilbert_fun (cone hU) d)"
	by (rule Hilbert_fun_cone_decomp)
	also have "\<dots> = (\<Sum>hU\<in>(set ps - set (ps\<^sub>+)) \<union> set (ps\<^sub>+). Hilbert_fun (cone hU) d)" by (simp only: eq0)
	also have "\<dots> = (\<Sum>hU\<in>set ps - set (ps\<^sub>+). Hilbert_fun (cone hU) d) + (\<Sum>hU\<in>set (ps\<^sub>+). Hilbert_fun (cone hU) d)"
	using fin2 finite_set by (rule sum.union_disjoint) blast
	also have "\<dots> = card {h. (h, {}) \<in> set ps \<and> poly_deg h = d} + (\<Sum>hU\<in>set (ps\<^sub>+). Hilbert_fun (cone hU) d)"
	by (simp only: eq1)
	also have "int \<dots> = card {h. (h, {}) \<in> set ps \<and> poly_deg h = d} + Hilbert_poly (\<b> ps) d"
	by (simp only: eq2 int_plus)
	finally show ?thesis .
	qed

	corollary Hilbert_fun_eq_Hilbert_poly:
	assumes "X \<noteq> {}" and "valid_decomp X ps" and "hom_decomp ps" and "cone_decomp T ps"
	and "standard_decomp k ps" and "exact_decomp X 0 ps" and "\<b> ps 0 \<le> d"
	shows "int (Hilbert_fun (T::(_ \<Rightarrow>\<^sub>0 'a::field) set) d) = Hilbert_poly (\<b> ps) d"
	proof -
	from fin_X have "\<b> ps (Suc 0) \<le> \<b> ps 0" using le0 by (rule \<b>_decreasing)
	also have "\<dots> \<le> d" by fact
	finally have "\<b> ps (Suc 0) \<le> d" .
	with assms(1-6) have "int (Hilbert_fun T d) =
	int (card {h. (h, {}) \<in> set ps \<and> poly_deg h = d}) + Hilbert_poly (\<b> ps) (int d)"
	by (rule Hilbert_fun_eq_Hilbert_poly_plus_card)
	also have "\<dots> = Hilbert_poly (\<b> ps) (int d)"
	proof -
	have eq: "{h. (h, {}) \<in> set ps \<and> poly_deg h = d} = {}"
	proof -
	{
	fix h
	assume "(h, {}) \<in> set ps" and "poly_deg h = d"
	from fin_X this(1) le0 have "poly_deg h < \<b> ps 0" by (rule \<b>)
	with assms(7) have False by (simp add: \<open>poly_deg h = d\<close>)
	}
	thus ?thesis by blast
	qed
	show ?thesis by (simp add: eq)
	qed
	finally show ?thesis .
	qed

	subsection \<open>Dub\'{e}'s Bound\<close>

	context
	fixes f :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field"
	fixes F
	assumes n_gr_1: "1 < card X" and fin_F: "finite F" and F_sub: "F \<subseteq> P[X]" and f_in: "f \<in> F"
	and hom_F: "\<And>f'. f' \<in> F \<Longrightarrow> homogeneous f'" and f_max: "\<And>f'. f' \<in> F \<Longrightarrow> poly_deg f' \<le> poly_deg f"
	and d_gr_0: "0 < poly_deg f" and ideal_f_neq: "ideal {f} \<noteq> ideal F"
	begin

	private abbreviation (input) "n \<equiv> card X"
	private abbreviation (input) "d \<equiv> poly_deg f"

	lemma f_in_Polys: "f \<in> P[X]"
	using f_in F_sub ..

	lemma hom_f: "homogeneous f"
	using f_in by (rule hom_F)

	lemma f_not_0: "f \<noteq> 0"
	using d_gr_0 by auto

	lemma X_not_empty: "X \<noteq> {}"
	using n_gr_1 by auto

	lemma n_gr_0: "0 < n"
	using \<open>1 < n\<close> by simp

	corollary int_n_minus_1 [simp]: "int (n - Suc 0) = int n - 1"
	using n_gr_0 by simp

	lemma int_n_minus_2 [simp]: "int (n - Suc (Suc 0)) = int n - 2"
	using n_gr_1 by simp

	lemma cone_f_X_sub: "cone (f, X) \<subseteq> P[X]"
	proof -
	have "cone (f, X) = cone (f * 1, X)" by simp
	also from f_in_Polys have "\<dots> \<subseteq> cone (1, X)" by (rule cone_mono_1)
	finally show ?thesis by simp
	qed

	lemma ideal_Int_Polys_eq_cone: "ideal {f} \<inter> P[X] = cone (f, X)"
	proof (intro subset_antisym subsetI)
	fix p
	assume "p \<in> ideal {f} \<inter> P[X]"
	hence "p \<in> ideal {f}" and "p \<in> P[X]" by simp_all
	have "finite {f}" by simp
	then obtain q where "p = (\<Sum>f'\<in>{f}. q f' * f')" using \<open>p \<in> ideal {f}\<close>
	by (rule ideal.span_finiteE)
	hence p: "p = q f * f" by simp
	with \<open>p \<in> P[X]\<close> have "f * q f \<in> P[X]" by (simp only: mult.commute)
	hence "q f \<in> P[X]" using f_in_Polys f_not_0 by (rule times_in_PolysD)
	with p show "p \<in> cone (f, X)" by (rule coneI)
	next
	fix p
	assume "p \<in> cone (f, X)"
	then obtain q where "q \<in> P[X]" and p: "p = q * f" by (rule coneE)
	have "f \<in> ideal {f}" by (rule ideal.span_base) simp
	with \<open>q \<in> P[X]\<close> f_in_Polys show "p \<in> ideal {f} \<inter> P[X]"
	unfolding p by (intro IntI ideal.span_scale Polys_closed_times)
	qed

	private definition P_ps where
	"P_ps = (SOME x. valid_decomp X (snd x) \<and> standard_decomp d (snd x) \<and>
	exact_decomp X 0 (snd x) \<and> cone_decomp (fst x) (snd x) \<and> hom_decomp (snd x) \<and>
	direct_decomp (ideal F \<inter> P[X]) [ideal {f} \<inter> P[X], fst x])"

	private definition P where "P = fst P_ps"

	private definition ps where "ps = snd P_ps"

	lemma
	shows valid_ps: "valid_decomp X ps" (is ?thesis1)
	and std_ps: "standard_decomp d ps" (is ?thesis2)
	and ext_ps: "exact_decomp X 0 ps" (is ?thesis3)
	and cn_ps: "cone_decomp P ps" (is ?thesis4)
	and hom_ps: "hom_decomp ps" (is ?thesis5)
	and decomp_F: "direct_decomp (ideal F \<inter> P[X]) [ideal {f} \<inter> P[X], P]" (is ?thesis6)
	proof -
	note fin_X
	moreover from fin_F have "finite (F - {f})" by simp
	moreover from F_sub have "F - {f} \<subseteq> P[X]" by blast
	ultimately obtain P' ps' where 1: "valid_decomp X ps'" and 2: "standard_decomp d ps'"
	and 3: "cone_decomp P' ps'" and 40: "(\<And>f'. f' \<in> F - {f} \<Longrightarrow> homogeneous f') \<Longrightarrow> hom_decomp ps'"
	and 50: "direct_decomp (ideal (insert f (F - {f})) \<inter> P[X]) [ideal {f} \<inter> P[X], P']"
	using f_in_Polys f_max by (rule ideal_decompE) blast+
	have 4: "hom_decomp ps'" by (intro 40 hom_F) simp
	from 50 f_in have 5: "direct_decomp (ideal F \<inter> P[X]) [ideal {f} \<inter> P[X], P']"
	by (simp add: insert_absorb)
	let ?ps = "exact X (poly_deg f) ps'"
	from fin_X 1 2 have "valid_decomp X ?ps" and "standard_decomp d ?ps" and "exact_decomp X 0 ?ps"
	by (rule exact)+
	moreover from fin_X 1 2 3 have "cone_decomp P' ?ps" by (rule cone_decomp_exact)
	moreover from fin_X 1 2 4 have "hom_decomp ?ps" by (rule hom_decomp_exact)
	ultimately have "valid_decomp X (snd (P', ?ps)) \<and> standard_decomp d (snd (P', ?ps)) \<and>
	exact_decomp X 0 (snd (P', ?ps)) \<and> cone_decomp (fst (P', ?ps)) (snd (P', ?ps)) \<and>
	hom_decomp (snd (P', ?ps)) \<and>
	direct_decomp (ideal F \<inter> P[X]) [ideal {f} \<inter> P[X], fst (P', ?ps)]"
	using 5 by simp
	hence "?thesis1 \<and> ?thesis2 \<and> ?thesis3 \<and> ?thesis4 \<and> ?thesis5 \<and> ?thesis6"
	unfolding P_def ps_def P_ps_def by (rule someI)
	thus ?thesis1 and ?thesis2 and ?thesis3 and ?thesis4 and ?thesis5 and ?thesis6 by simp_all
	qed

	lemma P_sub: "P \<subseteq> P[X]"
	using valid_ps cn_ps by (rule valid_cone_decomp_subset_Polys)

	lemma ps_not_Nil: "ps\<^sub>+ \<noteq> []"
	proof
	assume "ps\<^sub>+ = []"
	have "Keys P \<subseteq> (\<Union>hU\<in>set ps. keys (fst hU))" (is "_ \<subseteq> ?A")
	proof
	fix t
	assume "t \<in> Keys P"
	then obtain p where "p \<in> P" and "t \<in> keys p" by (rule in_KeysE)
	from cn_ps have "direct_decomp P (map cone ps)" by (rule cone_decompD)
	then obtain qs where qs: "qs \<in> listset (map cone ps)" and p: "p = sum_list qs" using \<open>p \<in> P\<close>
	by (rule direct_decompE)
	from \<open>t \<in> keys p\<close> keys_sum_list_subset have "t \<in> Keys (set qs)" unfolding p ..
	then obtain q where "q \<in> set qs" and "t \<in> keys q" by (rule in_KeysE)
	from this(1) obtain i where "i < length qs" and "q = qs ! i" by (metis in_set_conv_nth)
	with qs have "i < length ps" and "q \<in> (map cone ps) ! i" by (simp_all add: listsetD del: nth_map)
	hence "q \<in> cone (ps ! i)" by simp
	obtain h U where eq: "ps ! i = (h, U)" using prod.exhaust by blast
	from \<open>i < length ps\<close> this[symmetric] have "(h, U) \<in> set ps" by simp
	have "U = {}"
	proof (rule ccontr)
	assume "U \<noteq> {}"
	with \<open>(h, U) \<in> set ps\<close> have "(h, U) \<in> set (ps\<^sub>+)" by (simp add: pos_decomp_def)
	with \<open>ps\<^sub>+ = []\<close> show False by simp
	qed
	with \<open>q \<in> cone (ps ! i)\<close> have "q \<in> range (\<lambda>c. c \<cdot> h)" by (simp only: eq cone_empty)
	then obtain c where "q = c \<cdot> h" ..
	also have "keys \<dots> \<subseteq> keys h" by (fact keys_map_scale_subset)
	finally have "t \<in> keys h" using \<open>t \<in> keys q\<close> ..
	hence "t \<in> keys (fst (h, U))" by simp
	with \<open>(h, U) \<in> set ps\<close> show "t \<in> ?A" ..
	qed
	moreover from finite_set finite_keys have "finite ?A" by (rule finite_UN_I)
	ultimately have "finite (Keys P)" by (rule finite_subset)

	have "\<exists>q\<in>ideal F. q \<in> P[X] \<and> q \<noteq> 0 \<and> \<not> lpp f adds lpp q"
	proof (rule ccontr)
	assume "\<not> (\<exists>q\<in>ideal F. q \<in> P[X] \<and> q \<noteq> 0 \<and> \<not> lpp f adds lpp q)"
	hence adds: "lpp f adds lpp q" if "q \<in> ideal F" and "q \<in> P[X]" and "q \<noteq> 0" for q
	using that by blast
	from fin_X _ F_sub have "ideal {f} = ideal F"
	proof (rule punit.pmdl_eqI_adds_lt_dgrad_p_set[simplified, OF dickson_grading_varnum,
	where m=0, simplified dgrad_p_set_varnum])
	from f_in_Polys show "{f} \<subseteq> P[X]" by simp
	next
	from f_in have "{f} \<subseteq> F" by simp
	thus "ideal {f} \<subseteq> ideal F" by (rule ideal.span_mono)
	next
	fix q
	assume "q \<in> ideal F" and "q \<in> P[X]" and "q \<noteq> 0"
	hence "lpp f adds lpp q" by (rule adds)
	with f_not_0 show "\<exists>g\<in>{f}. g \<noteq> 0 \<and> lpp g adds lpp q" by blast
	qed
	with ideal_f_neq show False ..
	qed
	then obtain q0 where "q0 \<in> ideal F" and "q0 \<in> P[X]" and "q0 \<noteq> 0"
	and nadds_q0: "\<not> lpp f adds lpp q0" by blast
	define q where "q = hom_component q0 (deg_pm (lpp q0))"
	from hom_F \<open>q0 \<in> ideal F\<close> have "q \<in> ideal F" unfolding q_def by (rule homogeneous_ideal)
	from homogeneous_set_Polys \<open>q0 \<in> P[X]\<close> have "q \<in> P[X]" unfolding q_def by (rule homogeneous_setD)
	from \<open>q0 \<noteq> 0\<close> have "q \<noteq> 0" and "lpp q = lpp q0" unfolding q_def by (rule hom_component_lpp)+
	from nadds_q0 this(2) have nadds_q: "\<not> lpp f adds lpp q" by simp
	have hom_q: "homogeneous q" by (simp only: q_def homogeneous_hom_component)
	from nadds_q obtain x where x: "\<not> lookup (lpp f) x \<le> lookup (lpp q) x"
	by (auto simp add: adds_poly_mapping le_fun_def)
	obtain y where "y \<in> X" and "y \<noteq> x"
	proof -
	from n_gr_1 have "2 \<le> n" by simp
	then obtain Y where "Y \<subseteq> X" and "card Y = 2" by (rule card_geq_ex_subset)
	from this(2) obtain u v where "u \<noteq> v" and "Y = {u, v}" by (rule card_2_E)
	from this obtain y where "y \<in> Y" and "y \<noteq> x" by blast
	from this(1) \<open>Y \<subseteq> X\<close> have "y \<in> X" ..
	thus ?thesis using \<open>y \<noteq> x\<close> ..
	qed
	define q' where "q' = (\<lambda>k. punit.monom_mult 1 (Poly_Mapping.single y k) q)"
	have inj1: "inj q'" by (auto intro!: injI simp: q'_def \<open>q \<noteq> 0\<close> dest: punit.monom_mult_inj_2 monomial_inj)
	have q'_in: "q' k \<in> ideal F \<inter> P[X]" for k unfolding q'_def using \<open>q \<in> ideal F\<close> \<open>q \<in> P[X]\<close> \<open>y \<in> X\<close>
	by (intro IntI punit.pmdl_closed_monom_mult[simplified] Polys_closed_monom_mult PPs_closed_single)
	have lpp_q': "lpp (q' k) = Poly_Mapping.single y k + lpp q" for k
	using \<open>q \<noteq> 0\<close> by (simp add: q'_def punit.lt_monom_mult)
	have inj2: "inj_on (deg_pm \<circ> lpp) (range q')"
	by (auto intro!: inj_onI simp: lpp_q' deg_pm_plus deg_pm_single dest: monomial_inj)
	have "(deg_pm \<circ> lpp) ` range q' \<subseteq> deg_pm ` Keys P"
	proof
	fix d
	assume "d \<in> (deg_pm \<circ> lpp) ` range q'"
	then obtain k where d: "d = deg_pm (lpp (q' k))" (is "_ = deg_pm ?t") by auto
	from hom_q have hom_q': "homogeneous (q' k)" by (simp add: q'_def homogeneous_monom_mult)
	from \<open>q \<noteq> 0\<close> have "q' k \<noteq> 0" by (simp add: q'_def punit.monom_mult_eq_zero_iff)
	hence "?t \<in> keys (q' k)" by (rule punit.lt_in_keys)
	with hom_q' have deg_q': "d = poly_deg (q' k)" unfolding d by (rule homogeneousD_poly_deg)
	from decomp_F q'_in obtain qs where "qs \<in> listset [ideal {f} \<inter> P[X], P]" and "q' k = sum_list qs"
	by (rule direct_decompE)
	moreover from this(1) obtain f0 p0 where f0: "f0 \<in> ideal {f} \<inter> P[X]" and p0: "p0 \<in> P"
	and "qs = [f0, p0]" by (rule listset_doubletonE)
	ultimately have q': "q' k = f0 + p0" by simp
	define f1 where "f1 = hom_component f0 d"
	define p1 where "p1 = hom_component p0 d"
	from hom_q have "homogeneous (q' k)" by (simp add: q'_def homogeneous_monom_mult)
	hence "q' k = hom_component (q' k) d" by (simp add: hom_component_of_homogeneous deg_q')
	also have "\<dots> = f1 + p1" by (simp only: q' hom_component_plus f1_def p1_def)
	finally have "q' k = f1 + p1" .
	have "keys p1 \<noteq> {}"
	proof
	assume "keys p1 = {}"
	with \<open>q' k = f1 + p1\<close> \<open>q' k \<noteq> 0\<close> have t: "?t = lpp f1" and "f1 \<noteq> 0" by simp_all
	from f0 have "f0 \<in> ideal {f}" by simp
	with _ have "f1 \<in> ideal {f}" unfolding f1_def by (rule homogeneous_ideal) (simp add: hom_f)
	with punit.is_Groebner_basis_singleton obtain g where "g \<in> {f}" and "lpp g adds lpp f1"
	using \<open>f1 \<noteq> 0\<close> by (rule punit.GB_adds_lt[simplified])
	hence "lpp f adds ?t" by (simp add: t)
	hence "lookup (lpp f) x \<le> lookup ?t x" by (simp add: adds_poly_mapping le_fun_def)
	also have "\<dots> = lookup (lpp q) x" by (simp add: lpp_q' lookup_add lookup_single \<open>y \<noteq> x\<close>)
	finally have "lookup (lpp f) x \<le> lookup (lpp q) x" .
	with x show False ..
	qed
	then obtain t where "t \<in> keys p1" by blast
	hence "d = deg_pm t" by (simp add: p1_def keys_hom_component)
	from cn_ps hom_ps have "homogeneous_set P" by (intro homogeneous_set_cone_decomp)
	hence "p1 \<in> P" using \<open>p0 \<in> P\<close> unfolding p1_def by (rule homogeneous_setD)
	with \<open>t \<in> keys p1\<close> have "t \<in> Keys P" by (rule in_KeysI)
	with \<open>d = deg_pm t\<close> show "d \<in> deg_pm ` Keys P" by (rule image_eqI)
	qed
	moreover from inj1 inj2 have "infinite ((deg_pm \<circ> lpp) ` range q')"
	by (simp add: finite_image_iff o_def)
	ultimately have "infinite (deg_pm ` Keys P)" by (rule infinite_super)
	hence "infinite (Keys P)" by blast
	thus False using \<open>finite (Keys P)\<close> ..
	qed

	private definition N where "N = normal_form F ` P[X]"

	private definition qs where "qs = (SOME qs'. valid_decomp X qs' \<and> standard_decomp 0 qs' \<and>
	monomial_decomp qs' \<and> cone_decomp N qs' \<and> exact_decomp X 0 qs' \<and>
	(\<forall>g\<in>punit.reduced_GB F. poly_deg g \<le> \<b> qs' 0))"

	private definition "aa \<equiv> \<b> ps"
	private definition "bb \<equiv> \<b> qs"
	private abbreviation (input) "cc \<equiv> (\<lambda>i. aa i + bb i)"

	lemma
	shows valid_qs: "valid_decomp X qs" (is ?thesis1)
	and std_qs: "standard_decomp 0 qs" (is ?thesis2)
	and mon_qs: "monomial_decomp qs" (is ?thesis3)
	and hom_qs: "hom_decomp qs" (is ?thesis6)
	and cn_qs: "cone_decomp N qs" (is ?thesis4)
	and ext_qs: "exact_decomp X 0 qs" (is ?thesis5)
	and deg_RGB: "g \<in> punit.reduced_GB F \<Longrightarrow> poly_deg g \<le> bb 0"
	proof -
	from fin_X F_sub obtain qs' where 1: "valid_decomp X qs'" and 2: "standard_decomp 0 qs'"
	and 3: "monomial_decomp qs'" and 4: "cone_decomp (normal_form F ` P[X]) qs'"
	and 5: "exact_decomp X 0 qs'"
	and 60: "\<And>g. (\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> g \<in> punit.reduced_GB F \<Longrightarrow> poly_deg g \<le> \<b> qs' 0"
	by (rule normal_form_exact_decompE) blast
	from hom_F have "\<And>g. g \<in> punit.reduced_GB F \<Longrightarrow> poly_deg g \<le> \<b> qs' 0" by (rule 60)
	with 1 2 3 4 5 have "valid_decomp X qs' \<and> standard_decomp 0 qs' \<and>
	monomial_decomp qs' \<and> cone_decomp N qs' \<and> exact_decomp X 0 qs' \<and>
	(\<forall>g\<in>punit.reduced_GB F. poly_deg g \<le> \<b> qs' 0)" by (simp add: N_def)
	hence "?thesis1 \<and> ?thesis2 \<and> ?thesis3 \<and> ?thesis4 \<and> ?thesis5 \<and> (\<forall>g\<in>punit.reduced_GB F. poly_deg g \<le> bb 0)"
	unfolding qs_def bb_def by (rule someI)
	thus ?thesis1 and ?thesis2 and ?thesis3 and ?thesis4 and ?thesis5
	and "g \<in> punit.reduced_GB F \<Longrightarrow> poly_deg g \<le> bb 0" by simp_all
	from \<open>?thesis3\<close> show ?thesis6 by (rule monomial_decomp_imp_hom_decomp)
	qed

	lemma N_sub: "N \<subseteq> P[X]"
	using valid_qs cn_qs by (rule valid_cone_decomp_subset_Polys)

	lemma decomp_Polys: "direct_decomp P[X] [ideal {f} \<inter> P[X], P, N]"
	proof -
	from fin_X F_sub have "direct_decomp P[X] [ideal F \<inter> P[X], N]" unfolding N_def
	by (rule direct_decomp_ideal_normal_form)
	hence "direct_decomp P[X] ([N] @ [ideal {f} \<inter> P[X], P])" using decomp_F
	by (rule direct_decomp_direct_decomp)
	hence "direct_decomp P[X] ([ideal {f} \<inter> P[X], P] @ [N])"
	by (rule direct_decomp_perm) simp
	thus ?thesis by simp
	qed

	lemma aa_Suc_n [simp]: "aa (Suc n) = d"
	proof -
	from fin_X ext_ps le_refl have "aa (Suc n) = \<a> ps" unfolding aa_def by (rule \<b>_card_X)
	also from fin_X valid_ps std_ps ps_not_Nil have "\<dots> = d" by (rule \<a>_nonempty_unique)
	finally show ?thesis .
	qed

	lemma bb_Suc_n [simp]: "bb (Suc n) = 0"
	proof -
	from fin_X ext_qs le_refl have "bb (Suc n) = \<a> qs" unfolding bb_def by (rule \<b>_card_X)
	also from std_qs have "\<dots> = 0" unfolding \<a>_def[OF fin_X] by (rule Least_eq_0)
	finally show ?thesis .
	qed

	lemma Hilbert_fun_X:
	assumes "d \<le> z"
	shows "Hilbert_fun (P[X]::(_ \<Rightarrow>\<^sub>0 'a) set) z =
	((z - d) + (n - 1)) choose (n - 1) + Hilbert_fun P z + Hilbert_fun N z"
	proof -
	define ss where "ss = [ideal {f} \<inter> P[X], P, N]"
	have "homogeneous_set A \<and> phull.subspace A" if "A \<in> set ss" for A
	proof -
	from that have "A = ideal {f} \<inter> P[X] \<or> A = P \<or> A = N" by (simp add: ss_def)
	thus ?thesis
	proof (elim disjE)
	assume A: "A = ideal {f} \<inter> P[X]"
	show ?thesis unfolding A
	by (intro conjI homogeneous_set_IntI phull.subspace_inter homogeneous_set_homogeneous_ideal
	homogeneous_set_Polys subspace_ideal subspace_Polys) (simp add: hom_f)
	next
	assume A: "A = P"
	from cn_ps hom_ps show ?thesis unfolding A
	by (intro conjI homogeneous_set_cone_decomp subspace_cone_decomp)
	next
	assume A: "A = N"
	from cn_qs hom_qs show ?thesis unfolding A
	by (intro conjI homogeneous_set_cone_decomp subspace_cone_decomp)
	qed
	qed
	hence 1: "\<And>A. A \<in> set ss \<Longrightarrow> homogeneous_set A" and 2: "\<And>A. A \<in> set ss \<Longrightarrow> phull.subspace A"
	by simp_all
	have "Hilbert_fun (P[X]::(_ \<Rightarrow>\<^sub>0 'a) set) z = (\<Sum>p\<in>set ss. Hilbert_fun p z)"
	using fin_X subset_refl decomp_Polys unfolding ss_def
	proof (rule Hilbert_fun_direct_decomp)
	fix A
	assume "A \<in> set [ideal {f} \<inter> P[X], P, N]"
	hence "A \<in> set ss" by (simp only: ss_def)
	thus "homogeneous_set A" and "phull.subspace A" by (rule 1, rule 2)
	qed
	also have "\<dots> = (\<Sum>p\<in>set ss. count_list ss p * Hilbert_fun p z)"
	using refl
	proof (rule sum.cong)
	fix p
	assume "p \<in> set ss"
	- hence "count_list ss p \<noteq> 0" by (simp only: count_list_eq_0_iff not_not)
	+ hence "count_list ss p \<noteq> 0" by (simp only: count_list_0_iff not_not)
	hence "count_list ss p = 1 \<or> 1 < count_list ss p" by auto
	thus "Hilbert_fun p z = count_list ss p * Hilbert_fun p z"
	proof
	assume "1 < count_list ss p"
	with decomp_Polys have "p = {0}" unfolding ss_def[symmetric] using phull.subspace_0
	by (rule direct_decomp_repeated_eq_zero) (rule 2)
	thus ?thesis by simp
	qed simp
	qed
	also have "\<dots> = sum_list (map (\<lambda>p. Hilbert_fun p z) ss)"
	by (rule sym) (rule sum_list_map_eq_sum_count)
	also have "\<dots> = Hilbert_fun (cone (f, X)) z + Hilbert_fun P z + Hilbert_fun N z"
	by (simp add: ss_def ideal_Int_Polys_eq_cone)
	also have "Hilbert_fun (cone (f, X)) z = (z - d + (n - 1)) choose (n - 1)"
	using f_not_0 f_in_Polys fin_X hom_f X_not_empty by (simp add: Hilbert_fun_cone_nonempty assms)
	finally show ?thesis .
	qed

	lemma dube_eq_0:
	"(\<lambda>z::int. (z + int n - 1) gchoose (n - 1)) =
	(\<lambda>z::int. ((z - d + n - 1) gchoose (n - 1)) + Hilbert_poly aa z + Hilbert_poly bb z)"
	(is "?f = ?g")
	proof (rule poly_fun_eqI_ge)
	fix z::int
	let ?z = "nat z"
	assume "max (aa 0) (bb 0) \<le> z"
	hence "aa 0 \<le> nat z" and "bb 0 \<le> nat z" and "0 \<le> z" by simp_all
	from this(3) have int_z: "int ?z = z" by simp
	have "d \<le> aa 0" unfolding aa_Suc_n[symmetric] using fin_X le0 unfolding aa_def by (rule \<b>_decreasing)
	hence "d \<le> ?z" using \<open>aa 0 \<le> nat z\<close> by (rule le_trans)
	hence int_zd: "int (?z - d) = z - int d" using int_z by linarith
	from \<open>d \<le> ?z\<close> have "Hilbert_fun (P[X]::(_ \<Rightarrow>\<^sub>0 'a) set) ?z =
	((?z - d) + (n - 1)) choose (n - 1) + Hilbert_fun P ?z + Hilbert_fun N ?z"
	by (rule Hilbert_fun_X)
	also have "int \<dots> = (z - d + (n - 1)) gchoose (n - 1) + Hilbert_poly aa z + Hilbert_poly bb z"
	using X_not_empty valid_ps hom_ps cn_ps std_ps ext_ps \<open>aa 0 \<le> nat z\<close>
	valid_qs hom_qs cn_qs std_qs ext_qs \<open>bb 0 \<le> nat z\<close> \<open>0 \<le> z\<close>
	by (simp add: Hilbert_fun_eq_Hilbert_poly int_z aa_def bb_def int_binomial int_zd)
	finally show "?f z = ?g z" using fin_X X_not_empty \<open>0 \<le> z\<close>
	by (simp add: Hilbert_fun_Polys int_binomial) smt
	qed (simp_all add: poly_fun_Hilbert_poly)

	corollary dube_eq_1:
	"(\<lambda>z::int. (z + int n - 1) gchoose (n - 1)) =
	(\<lambda>z::int. ((z - d + n - 1) gchoose (n - 1)) + ((z - d + n) gchoose n) + ((z + n) gchoose n) - 2 -
	(\<Sum>i=1..n. ((z - aa i + i - 1) gchoose i) + ((z - bb i + i - 1) gchoose i)))"
	by (simp only: dube_eq_0) (auto simp: Hilbert_poly_def Let_def sum.distrib)

	lemma dube_eq_2:
	assumes "j < n"
	shows "(\<lambda>z::int. (z + int n - int j - 1) gchoose (n - j - 1)) =
	(\<lambda>z::int. ((z - d + n - int j - 1) gchoose (n - j - 1)) + ((z - d + n - j) gchoose (n - j)) +
	((z + n - j) gchoose (n - j)) - 2 -
	(\<Sum>i=Suc j..n. ((z - aa i + i - j - 1) gchoose (i - j)) + ((z - bb i + i - j - 1) gchoose (i - j))))"
	(is "?f = ?g")
	proof -
	let ?h = "\<lambda>z i. ((z + (int i - aa i - 1)) gchoose i) + ((z + (int i - bb i - 1)) gchoose i)"
	let ?hj = "\<lambda>z i. ((z + (int i - aa i - 1) - j) gchoose (i - j)) + ((z + (int i - bb i - 1) - j) gchoose (i - j))"
	from assms have 1: "j \<le> n - Suc 0" and 2: "j \<le> n" by simp_all

	have eq1: "(bw_diff ^^ j) (\<lambda>z. \<Sum>i=1..j. ?h z i) = (\<lambda>_. if j = 0 then 0 else 2)"
	proof (cases j)
	case 0
	thus ?thesis by simp
	next
	case (Suc j0)
	hence "j \<noteq> 0" by simp
	have "(\<lambda>z::int. \<Sum>i = 1..j. ?h z i) = (\<lambda>z::int. (\<Sum>i = 1..j0. ?h z i) + ?h z j)"
	by (simp add: \<open>j = Suc j0\<close>)
	moreover have "(bw_diff ^^ j) \<dots> = (\<lambda>z::int. (\<Sum>i = 1..j0. (bw_diff ^^ j) (\<lambda>z. ?h z i) z) + 2)"
	by (simp add: bw_diff_gbinomial_pow)
	moreover have "(\<Sum>i = 1..j0. (bw_diff ^^ j) (\<lambda>z. ?h z i) z) = (\<Sum>i = 1..j0. 0)" for z::int
	using refl
	proof (rule sum.cong)
	fix i
	assume "i \<in> {1..j0}"
	hence "\<not> j \<le> i" by (simp add: \<open>j = Suc j0\<close>)
	thus "(bw_diff ^^ j) (\<lambda>z. ?h z i) z = 0" by (simp add: bw_diff_gbinomial_pow)
	qed
	ultimately show ?thesis by (simp add: \<open>j \<noteq> 0\<close>)
	qed

	have eq2: "(bw_diff ^^ j) (\<lambda>z. \<Sum>i=Suc j..n. ?h z i) = (\<lambda>z. (\<Sum>i=Suc j..n. ?hj z i))"
	proof -
	have "(bw_diff ^^ j) (\<lambda>z. \<Sum>i=Suc j..n. ?h z i) = (\<lambda>z. \<Sum>i=Suc j..n. (bw_diff ^^ j) (\<lambda>z. ?h z i) z)"
	by simp
	also have "\<dots> = (\<lambda>z. (\<Sum>i=Suc j..n. ?hj z i))"
	proof (intro ext sum.cong)
	fix z i
	assume "i \<in> {Suc j..n}"
	hence "j \<le> i" by simp
	thus "(bw_diff ^^ j) (\<lambda>z. ?h z i) z = ?hj z i" by (simp add: bw_diff_gbinomial_pow)
	qed (fact refl)
	finally show ?thesis .
	qed

	from 1 have "?f = (bw_diff ^^ j) (\<lambda>z::int. (z + (int n - 1)) gchoose (n - 1))"
	by (simp add: bw_diff_gbinomial_pow) (simp only: algebra_simps)
	also have "\<dots> = (bw_diff ^^ j) (\<lambda>z::int. (z + int n - 1) gchoose (n - 1))"
	by (simp only: algebra_simps)
	also have "\<dots> = (bw_diff ^^ j)
	(\<lambda>z::int. ((z - d + n - 1) gchoose (n - 1)) + ((z - d + n) gchoose n) + ((z + n) gchoose n) - 2 -
	(\<Sum>i=1..n. ((z - aa i + i - 1) gchoose i) + ((z - bb i + i - 1) gchoose i)))"
	by (simp only: dube_eq_1)
	also have "\<dots> = (bw_diff ^^ j)
	(\<lambda>z::int. ((z + (int n - d - 1)) gchoose (n - 1)) + ((z + (int n - d)) gchoose n) +
	((z + n) gchoose n) - 2 - (\<Sum>i=1..n. ?h z i))"
	by (simp only: algebra_simps)
	also have "\<dots> = (\<lambda>z::int. ((z + (int n - d - 1) - j) gchoose (n - 1 - j)) +
	((z + (int n - d) - j) gchoose (n - j)) + ((z + n - j) gchoose (n - j)) - (if j = 0 then 2 else 0) -
	(bw_diff ^^ j) (\<lambda>z. \<Sum>i=1..n. ?h z i) z)"
	using 1 2 by (simp add: bw_diff_const_pow bw_diff_gbinomial_pow del: bw_diff_sum_pow)
	also from \<open>j \<le> n\<close> have "(\<lambda>z. \<Sum>i=1..n. ?h z i) = (\<lambda>z. (\<Sum>i=1..j. ?h z i) + (\<Sum>i=Suc j..n. ?h z i))"
	by (simp add: sum_split_nat_ivl)
	also have "(bw_diff ^^ j) \<dots> = (\<lambda>z. (bw_diff ^^ j) (\<lambda>z. \<Sum>i=1..j. ?h z i) z + (bw_diff ^^ j) (\<lambda>z. \<Sum>i=Suc j..n. ?h z i) z)"
	by (simp only: bw_diff_plus_pow)
	also have "\<dots> = (\<lambda>z. (if j = 0 then 0 else 2) + (\<Sum>i=Suc j..n. ?hj z i))"
	by (simp only: eq1 eq2)
	finally show ?thesis by (simp add: algebra_simps)
	qed

	lemma dube_eq_3:
	assumes "j < n"
	shows "(1::int) = (- 1)^(n - Suc j) * ((int d - 1) gchoose (n - Suc j)) +
	(- 1)^(n - j) * ((int d - 1) gchoose (n - j)) - 1 -
	(\<Sum>i=Suc j..n. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	proof -
	from assms have 1: "int (n - Suc j) = int n - j - 1" and 2: "int (n - j) = int n - j" by simp_all
	from assms have "int n - int j - 1 = int (n - j - 1)" by simp
	hence eq1: "int n - int j - 1 gchoose (n - Suc j) = 1" by simp
	from assms have "int n - int j = int (n - j)" by simp
	hence eq2: "int n - int j gchoose (n - j) = 1" by simp
	have eq3: "int n - d - j - 1 gchoose (n - Suc j) = (- 1)^(n - Suc j) * (int d - 1 gchoose (n - Suc j))"
	by (simp add: gbinomial_int_negated_upper[of "int n - d - j - 1"] 1)
	have eq4: "int n - d - j gchoose (n - j) = (- 1)^(n - j) * (int d - 1 gchoose (n - j))"
	by (simp add: gbinomial_int_negated_upper[of "int n - d - j"] 2)
	have eq5: "(\<Sum>i = Suc j..n. int i - aa i - j - 1 gchoose (i - j) + (int i - bb i - j - 1 gchoose (i - j))) =
	(\<Sum>i=Suc j..n. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	using refl
	proof (rule sum.cong)
	fix i
	assume "i \<in> {Suc j..n}"
	hence "j \<le> i" by simp
	hence 3: "int (i - j) = int i - j" by simp
	show "int i - aa i - j - 1 gchoose (i - j) + (int i - bb i - j - 1 gchoose (i - j)) =
	(- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j)))"
	by (simp add: gbinomial_int_negated_upper[of "int i - aa i - j - 1"]
	gbinomial_int_negated_upper[of "int i - bb i - j - 1"] 3 distrib_left)
	qed
	from fun_cong[OF dube_eq_2, OF assms, of 0] show ?thesis by (simp add: eq1 eq2 eq3 eq4 eq5)
	qed

	lemma dube_aux_1:
	assumes "(h, {}) \<in> set ps \<union> set qs"
	shows "poly_deg h < max (aa 1) (bb 1)"
	proof (rule ccontr)
	define z where "z = poly_deg h"
	assume "\<not> z < max (aa 1) (bb 1)"

	let ?S = "\<lambda>A. {h. (h, {}) \<in> A \<and> poly_deg h = z}"
	have fin: "finite (?S A)" if "finite A" for A::"((('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<times> 'x set) set"
	proof -
	have "(\<lambda>t. (t, {})) ` ?S A \<subseteq> A" by blast
	hence "finite ((\<lambda>t. (t, {}::'x set)) ` ?S A)" using that by (rule finite_subset)
	moreover have "inj_on (\<lambda>t. (t, {}::'x set)) (?S A)" by (rule inj_onI) simp
	ultimately show ?thesis by (rule finite_imageD)
	qed
	from finite_set have 1: "finite (?S (set ps))" by (rule fin)
	from finite_set have 2: "finite (?S (set qs))" by (rule fin)

	from \<open>\<not> z < max (aa 1) (bb 1)\<close> have "aa 1 \<le> z" and "bb 1 \<le> z" by simp_all
	have "d \<le> aa 1" unfolding aa_Suc_n[symmetric] aa_def using fin_X by (rule \<b>_decreasing) simp
	hence "d \<le> z" using \<open>aa 1 \<le> z\<close> by (rule le_trans)
	hence eq: "int (z - d) = int z - int d" by simp
	from \<open>d \<le> z\<close> have "Hilbert_fun (P[X]::(_ \<Rightarrow>\<^sub>0 'a) set) z =
	((z - d) + (n - 1)) choose (n - 1) + Hilbert_fun P z + Hilbert_fun N z"
	by (rule Hilbert_fun_X)
	also have "int \<dots> = ((int z - d + (n - 1)) gchoose (n - 1) + Hilbert_poly aa z + Hilbert_poly bb z) +
	(int (card (?S (set ps))) + int (card (?S (set qs))))"
	using X_not_empty valid_ps hom_ps cn_ps std_ps ext_ps \<open>aa 1 \<le> z\<close>
	valid_qs hom_qs cn_qs std_qs ext_qs \<open>bb 1 \<le> z\<close>
	by (simp add: Hilbert_fun_eq_Hilbert_poly_plus_card aa_def bb_def int_binomial eq)
	finally have "((int z - d + n - 1) gchoose (n - 1) + Hilbert_poly aa z + Hilbert_poly bb z) +
	(int (card (?S (set ps))) + int (card (?S (set qs)))) = int z + n - 1 gchoose (n - 1)"
	using fin_X X_not_empty by (simp add: Hilbert_fun_Polys int_binomial algebra_simps)
	also have "\<dots> = (int z - d + n - 1) gchoose (n - 1) + Hilbert_poly aa z + Hilbert_poly bb z"
	by (fact dube_eq_0[THEN fun_cong])
	finally have "int (card (?S (set ps))) + int (card (?S (set qs))) = 0" by simp
	hence "card (?S (set ps)) = 0" and "card (?S (set qs)) = 0" by simp_all
	with 1 2 have "?S (set ps \<union> set qs) = {}" by auto
	moreover from assms have "h \<in> ?S (set ps \<union> set qs)" by (simp add: z_def)
	ultimately have "h \<in> {}" by (rule subst)
	thus False by simp
	qed

	lemma
	shows aa_n: "aa n = d" and bb_n: "bb n = 0" and bb_0: "bb 0 \<le> max (aa 1) (bb 1)"
	proof -
	let ?j = "n - Suc 0"
	from n_gr_0 have "?j < n" and eq1: "Suc ?j = n" and eq2: "n - ?j = 1" by simp_all
	from this(1) have "(1::int) = (- 1)^(n - Suc ?j) * ((int d - 1) gchoose (n - Suc ?j)) +
	(- 1)^(n - ?j) * ((int d - 1) gchoose (n - ?j)) - 1 -
	(\<Sum>i=Suc ?j..n. (- 1)^(i - ?j) * ((int (aa i) gchoose (i - ?j)) + (int (bb i) gchoose (i - ?j))))"
	by (rule dube_eq_3)
	hence eq: "aa n + bb n = d" by (simp add: eq1 eq2)
	hence "aa n \<le> d" by simp
	moreover have "d \<le> aa n" unfolding aa_Suc_n[symmetric] aa_def using fin_X by (rule \<b>_decreasing) simp
	ultimately show "aa n = d" by (rule antisym)
	with eq show "bb n = 0" by simp

	have "bb 0 = \<b> qs 0" by (simp only: bb_def)
	also from fin_X have "\<dots> \<le> max (aa 1) (bb 1)" (is "_ \<le> ?m")
	proof (rule \<b>_le)
	from fin_X ext_qs have "\<a> qs = bb (Suc n)" by (simp add: \<b>_card_X bb_def)
	also have "\<dots> \<le> bb 1" unfolding bb_def using fin_X by (rule \<b>_decreasing) simp
	also have "\<dots> \<le> ?m" by (rule max.cobounded2)
	finally show "\<a> qs \<le> ?m" .
	next
	fix h U
	assume "(h, U) \<in> set qs"
	show "poly_deg h < ?m"
	proof (cases "card U = 0")
	case True
	from fin_X valid_qs \<open>(h, U) \<in> set qs\<close> have "finite U" by (rule valid_decompD_finite)
	with True have "U = {}" by simp
	with \<open>(h, U) \<in> set qs\<close> have "(h, {}) \<in> set ps \<union> set qs" by simp
	thus ?thesis by (rule dube_aux_1)
	next
	case False
	hence "1 \<le> card U" by simp
	with fin_X \<open>(h, U) \<in> set qs\<close> have "poly_deg h < bb 1" unfolding bb_def by (rule \<b>)
	also have "\<dots> \<le> ?m" by (rule max.cobounded2)
	finally show ?thesis .
	qed
	qed
	finally show "bb 0 \<le> ?m" .
	qed

	lemma dube_eq_4:
	assumes "j < n"
	shows "(1::int) = 2 * (- 1)^(n - Suc j) * ((int d - 1) gchoose (n - Suc j)) - 1 -
	(\<Sum>i=Suc j..n-1. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	proof -
	from assms have "Suc j \<le> n" and "0 < n" and 1: "Suc (n - Suc j) = n - j" by simp_all
	have 2: "(- 1) ^ (n - Suc j) = - ((- (1::int)) ^ (n - j))" by (simp flip: 1)
	from assms have "(1::int) = (- 1)^(n - Suc j) * ((int d - 1) gchoose (n - Suc j)) +
	(- 1)^(n - j) * ((int d - 1) gchoose (n - j)) - 1 -
	(\<Sum>i=Suc j..n. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	by (rule dube_eq_3)
	also have "\<dots> = (- 1)^(n - Suc j) * ((int d - 1) gchoose (n - Suc j)) +
	(- 1)^(n - j) * ((int d - 1) gchoose (n - j)) - 1 -
	(- 1)^(n - j) * ((int (aa n) gchoose (n - j)) + (int (bb n) gchoose (n - j))) -
	(\<Sum>i=Suc j..n-1. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	using \<open>0 < n\<close> \<open>Suc j \<le> n\<close> by (simp only: sum_tail_nat)
	also have "\<dots> = (- 1)^(n - Suc j) * ((int d - 1) gchoose (n - Suc j)) +
	(- 1)^(n - j) * (((int d - 1) gchoose (n - j)) - (int d gchoose (n - j))) - 1 -
	(\<Sum>i=Suc j..n-1. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	using assms by (simp add: aa_n bb_n gbinomial_0_left right_diff_distrib)
	also have "(- 1)^(n - j) * (((int d - 1) gchoose (n - j)) - (int d gchoose (n - j))) =
	(- 1)^(n - Suc j) * (((int d - 1 + 1) gchoose (Suc (n - Suc j))) - ((int d - 1) gchoose (Suc (n - Suc j))))"
	by (simp add: 1 2 flip: mult_minus_right)
	also have "\<dots> = (- 1)^(n - Suc j) * ((int d - 1) gchoose (n - Suc j))"
	by (simp only: gbinomial_int_Suc_Suc, simp)
	finally show ?thesis by simp
	qed

	lemma cc_Suc:
	assumes "j < n - 1"
	shows "int (cc (Suc j)) = 2 + 2 * (- 1)^(n - j) * ((int d - 1) gchoose (n - Suc j)) +
	(\<Sum>i=j+2..n-1. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	proof -
	from assms have "j < n" and "Suc j \<le> n - 1" by simp_all
	hence "n - j = Suc (n - Suc j)" by simp
	hence eq: "(- 1) ^ (n - Suc j) = - ((- (1::int)) ^ (n - j))" by simp
	from \<open>j < n\<close> have "(1::int) = 2 * (- 1)^(n - Suc j) * ((int d - 1) gchoose (n - Suc j)) - 1 -
	(\<Sum>i=Suc j..n-1. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	by (rule dube_eq_4)
	also have "\<dots> = cc (Suc j) - 2 * (- 1)^(n - j) * ((int d - 1) gchoose (n - Suc j)) - 1 -
	(\<Sum>i=j+2..n-1. (- 1)^(i - j) * ((int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))))"
	using \<open>Suc j \<le> n - 1\<close> by (simp add: sum.atLeast_Suc_atMost eq)
	finally show ?thesis by simp
	qed

	lemma cc_n_minus_1: "cc (n - 1) = 2 * d"
	proof -
	let ?j = "n - 2"
	from n_gr_1 have 1: "Suc ?j = n - 1" and "?j < n - 1" and 2: "Suc (n - 1) = n"
	and 3: "n - (n - Suc 0) = Suc 0" and 4: "n - ?j = 2"
	by simp_all
	have "int (cc (n - 1)) = int (cc (Suc ?j))" by (simp only: 1)
	also from \<open>?j < n - 1\<close> have "\<dots> = 2 + 2 * (- 1) ^ (n - ?j) * (int d - 1 gchoose (n - Suc ?j)) +
	(\<Sum>i = ?j+2..n-1. (- 1) ^ (i - ?j) * (int (aa i) gchoose (i - ?j) + (int (bb i) gchoose (i - ?j))))"
	by (rule cc_Suc)
	also have "\<dots> = int (2 * d)" by (simp add: 1 2 3 4)
	finally show ?thesis by (simp only: int_int_eq)
	qed

	text \<open>Since the case @{prop "n = 2"} is settled, we can concentrate on @{prop "2 < n"} now.\<close>

	context
	assumes n_gr_2: "2 < n"
	begin

	lemma cc_n_minus_2: "cc (n - 2) \<le> d\<^sup>2 + 2 * d"
	proof -
	let ?j = "n - 3"
	from n_gr_2 have 1: "Suc ?j = n - 2" and "?j < n - 1" and 2: "Suc (n - 2) = n - Suc 0"
	and 3: "n - (n - 2) = 2" and 4: "n - ?j = 3"
	by simp_all
	have "int (cc (n - 2)) = int (cc (Suc ?j))" by (simp only: 1)
	also from \<open>?j < n - 1\<close> have "\<dots> = 2 + 2 * (- 1) ^ (n - ?j) * (int d - 1 gchoose (n - Suc ?j)) +
	(\<Sum>i = ?j+2..n-1. (- 1) ^ (i - ?j) * (int (aa i) gchoose (i - ?j) + (int (bb i) gchoose (i - ?j))))"
	by (rule cc_Suc)
	also have "\<dots> = (2 - 2 * (int d - 1 gchoose 2)) + ((int (aa (n - 1)) gchoose 2) + (int (bb (n - 1)) gchoose 2))"
	by (simp add: 1 2 3 4)
	also have "\<dots> \<le> (2 - 2 * (int d - 1 gchoose 2)) + (2 * int d gchoose 2)"
	proof (rule add_left_mono)
	have "int (aa (n - 1)) gchoose 2 + (int (bb (n - 1)) gchoose 2) \<le> int (aa (n - 1)) + int (bb (n - 1)) gchoose 2"
	by (rule gbinomial_int_plus_le) simp_all
	also have "\<dots> = int (2 * d) gchoose 2" by (simp flip: cc_n_minus_1)
	also have "\<dots> = 2 * int d gchoose 2" by (simp add: int_ops(7))
	finally show "int (aa (n - 1)) gchoose 2 + (int (bb (n - 1)) gchoose 2) \<le> 2 * int d gchoose 2" .
	qed
	also have "\<dots> = 2 - fact 2 * (int d - 1 gchoose 2) + (2 * int d gchoose 2)" by (simp only: fact_2)
	also have "\<dots> = 2 - (int d - 1) * (int d - 2) + (2 * int d gchoose 2)"
	by (simp only: gbinomial_int_mult_fact) (simp add: numeral_2_eq_2 prod.atLeast0_lessThan_Suc)
	also have "\<dots> = 2 - (int d - 1) * (int d - 2) + int d * (2 * int d - 1)"
	by (simp add: gbinomial_prod_rev numeral_2_eq_2 prod.atLeast0_lessThan_Suc)
	also have "\<dots> = int (d\<^sup>2 + 2 * d)" by (simp add: power2_eq_square) (simp only: algebra_simps)
	finally show ?thesis by (simp only: int_int_eq)
	qed

	lemma cc_Suc_le:
	assumes "j < n - 3"
	shows "int (cc (Suc j)) \<le> 2 + (int (cc (j + 2)) gchoose 2) + (\<Sum>i=j+4..n-1. int (cc i) gchoose (i - j))"
	\<comment>\<open>Could be proved without coercing to @{typ int}, because everything is non-negative.\<close>
	proof -
	let ?f = "\<lambda>i j. (int (aa i) gchoose (i - j)) + (int (bb i) gchoose (i - j))"
	let ?S = "\<lambda>x y. (\<Sum>i=j+x..n-y. (- 1)^(i - j) * ?f i j)"
	let ?S3 = "\<lambda>x y. (\<Sum>i=j+x..n-y. (int (cc i) gchoose (i - j)))"
	have ie1: "int (aa i) gchoose k + (int (bb i) gchoose k) \<le> int (cc i) gchoose k" if "0 < k" for i k
	proof -
	from that have "int (aa i) gchoose k + (int (bb i) gchoose k) \<le> int (aa i) + int (bb i) gchoose k"
	by (rule gbinomial_int_plus_le) simp_all
	also have "\<dots> = int (cc i) gchoose k" by simp
	finally show ?thesis .
	qed
	from d_gr_0 have "0 \<le> int d - 1" by simp
	from assms have "0 < n - Suc j" by simp
	have f_nonneg: "0 \<le> ?f i j" for i by (simp add: gbinomial_int_nonneg)

	show ?thesis
	proof (cases "n = j + 4")
	case True
	hence j: "j = n - 4" by simp
	have 1: "n - Suc j = 3" and "j < n - 1" and 2: "Suc (n - 3) = Suc (Suc j)" and 3: "n - (n - 3) = 3"
	and 4: "n - j = 4" and 5: "n - Suc 0 = Suc (Suc (Suc j))" and 6: "n - 2 = Suc (Suc j)"
	by (simp_all add: True)
	from \<open>j < n - 1\<close> have "int (cc (Suc j)) = 2 + 2 * (- 1) ^ (n - j) * (int d - 1 gchoose (n - Suc j)) +
	(\<Sum>i = j+2..n-1. (- 1) ^ (i - j) * (int (aa i) gchoose (i - j) + (int (bb i) gchoose (i - j))))"
	by (rule cc_Suc)
	also have "\<dots> = (2 + ((int (aa (n - 2)) gchoose 2) + (int (bb (n - 2)) gchoose 2))) +
	(2 * (int d - 1 gchoose 3) - ((int (aa (n - 1)) gchoose 3) + (int (bb (n - 1)) gchoose 3)))"
	by (simp add: 1 2 3 4 5 6)
	also have "\<dots> \<le> (2 + ((int (aa (n - 2)) gchoose 2) + (int (bb (n - 2)) gchoose 2))) + 0"
	proof (rule add_left_mono)
	from cc_n_minus_1 have eq1: "int (aa (n - 1)) + int (bb (n - 1)) = 2 * int d" by simp
	hence ie2: "int (aa (n - 1)) \<le> 2 * int d" by simp
	from \<open>0 \<le> int d - 1\<close> have "int d - 1 gchoose 3 \<le> int d gchoose 3" by (rule gbinomial_int_mono) simp
	hence "2 * (int d - 1 gchoose 3) \<le> 2 * (int d gchoose 3)" by simp
	also from _ ie2 have "\<dots> \<le> int (aa (n - 1)) gchoose 3 + (2 * int d - int (aa (n - 1)) gchoose 3)"
	by (rule binomial_int_ineq_3) simp
	also have "\<dots> = int (aa (n - 1)) gchoose 3 + (int (bb (n - 1)) gchoose 3)" by (simp flip: eq1)
	finally show "2 * (int d - 1 gchoose 3) - (int (aa (n - 1)) gchoose 3 + (int (bb (n - 1)) gchoose 3)) \<le> 0"
	by simp
	qed
	also have "\<dots> = 2 + ((int (aa (n - 2)) gchoose 2) + (int (bb (n - 2)) gchoose 2))" by simp
	also from ie1 have "\<dots> \<le> 2 + (int (cc (n - 2)) gchoose 2)" by (rule add_left_mono) simp
	also have "\<dots> = 2 + (int (cc (j + 2)) gchoose 2) + ?S3 4 1" by (simp add: True)
	finally show ?thesis .
	next
	case False
	with assms have "j + 4 \<le> n - 1" by simp
	from n_gr_1 have "0 < n - 1" by simp
	from assms have "j + 2 \<le> n - 1" and "j + 2 \<le> n - 2" by simp_all
	hence "n - j = Suc (n - Suc j)" by simp
	hence 1: "(- 1) ^ (n - Suc j) = - ((- (1::int)) ^ (n - j))" by simp
	from assms have "j < n - 1" by simp
	hence "int (cc (Suc j)) = 2 + 2 * (- 1)^(n - j) * ((int d - 1) gchoose (n - Suc j)) + ?S 2 1"
	by (rule cc_Suc)
	also have "\<dots> = 2 * (- 1)^(n - j) * ((int d - 1) gchoose (n - Suc j)) +
	(- 1)^(n - Suc j) * ((int (aa (n - 1)) gchoose (n - Suc j)) + (int (bb (n - 1)) gchoose (n - Suc j))) +
	(2 + ?S 2 2)"
	using \<open>0 < n - 1\<close> \<open>j + 2 \<le> n - 1\<close> by (simp only: sum_tail_nat) (simp flip: numeral_2_eq_2)
	also have "\<dots> \<le> (int (cc (n - 1)) gchoose (n - Suc j)) + (2 + ?S 2 2)"
	proof (rule add_right_mono)
	have rl: "x - y \<le> x" if "0 \<le> y" for x y :: int using that by simp
	have "2 * (- 1)^(n - j) * ((int d - 1) gchoose (n - Suc j)) +
	(- 1)^(n - Suc j) * ((int (aa (n - 1)) gchoose (n - Suc j)) + (int (bb (n - 1)) gchoose (n - Suc j))) =
	(-1)^(n - j) * (2 * ((int d - 1) gchoose (n - Suc j)) -
	(int (aa (n - 1)) gchoose (n - Suc j)) - (int (bb (n - 1)) gchoose (n - Suc j)))"
	by (simp only: 1 algebra_simps)
	also have "\<dots> \<le> (int (cc (n - 1))) gchoose (n - Suc j)"
	proof (cases "even (n - j)")
	case True
	hence "(- 1) ^ (n - j) * (2 * (int d - 1 gchoose (n - Suc j)) - (int (aa (n - 1)) gchoose (n - Suc j)) -
	(int (bb (n - 1)) gchoose (n - Suc j))) =
	2 * (int d - 1 gchoose (n - Suc j)) - ((int (aa (n - 1)) gchoose (n - Suc j)) +
	(int (bb (n - 1)) gchoose (n - Suc j)))"
	by simp
	also have "\<dots> \<le> 2 * (int d - 1 gchoose (n - Suc j))" by (rule rl) (simp add: gbinomial_int_nonneg)
	also have "\<dots> = (int d - 1 gchoose (n - Suc j)) + (int d - 1 gchoose (n - Suc j))" by simp
	also have "\<dots> \<le> (int d - 1) + (int d - 1) gchoose (n - Suc j)"
	using \<open>0 < n - Suc j\<close> \<open>0 \<le> int d - 1\<close> \<open>0 \<le> int d - 1\<close> by (rule gbinomial_int_plus_le)
	also have "\<dots> \<le> 2 * int d gchoose (n - Suc j)"
	proof (rule gbinomial_int_mono)
	from \<open>0 \<le> int d - 1\<close> show "0 \<le> int d - 1 + (int d - 1)" by simp
	qed simp
	also have "\<dots> = int (cc (n - 1)) gchoose (n - Suc j)" by (simp only: cc_n_minus_1) simp
	finally show ?thesis .
	next
	case False
	hence "(- 1) ^ (n - j) * (2 * (int d - 1 gchoose (n - Suc j)) - (int (aa (n - 1)) gchoose (n - Suc j)) -
	(int (bb (n - 1)) gchoose (n - Suc j))) =
	((int (aa (n - 1)) gchoose (n - Suc j)) + (int (bb (n - 1)) gchoose (n - Suc j))) -
	2 * (int d - 1 gchoose (n - Suc j))"
	by simp
	also have "\<dots> \<le> (int (aa (n - 1)) gchoose (n - Suc j)) + (int (bb (n - 1)) gchoose (n - Suc j))"
	by (rule rl) (simp add: gbinomial_int_nonneg d_gr_0)
	also from \<open>0 < n - Suc j\<close> have "\<dots> \<le> int (cc (n - 1)) gchoose (n - Suc j)" by (rule ie1)
	finally show ?thesis .
	qed
	finally show "2 * (- 1)^(n - j) * ((int d - 1) gchoose (n - Suc j)) +
	(- 1)^(n - Suc j) * ((int (aa (n - 1)) gchoose (n - Suc j)) + (int (bb (n - 1)) gchoose (n - Suc j))) \<le>
	(int (cc (n - 1))) gchoose (n - Suc j)" .
	qed
	also have "\<dots> = 2 + (int (cc (n - 1)) gchoose ((n - 1) - j)) + ((int (aa (j + 2)) gchoose 2) +
	(int (bb (j + 2)) gchoose 2)) + ?S 3 2"
	using \<open>j + 2 \<le> n - 2\<close> by (simp add: sum.atLeast_Suc_atMost numeral_3_eq_3)
	also have "\<dots> \<le> 2 + (int (cc (n - 1)) gchoose ((n - 1) - j)) + ((int (aa (j + 2)) gchoose 2) +
	(int (bb (j + 2)) gchoose 2)) + ?S3 4 2"
	proof (rule add_left_mono)
	from \<open>j + 4 \<le> n - 1\<close> have "j + 3 \<le> n - 2" by simp
	hence "?S 3 2 = ?S 4 2 - ?f (j + 3) j" by (simp add: sum.atLeast_Suc_atMost add.commute)
	hence "?S 3 2 \<le> ?S 4 2" using f_nonneg[of "j + 3"] by simp
	also have "\<dots> \<le> ?S3 4 2"
	proof (rule sum_mono)
	fix i
	assume "i \<in> {j + 4..n - 2}"
	hence "0 < i - j" by simp
	from f_nonneg[of i] have "(- 1)^(i - j) * ?f i j \<le> ?f i j"
	by (smt minus_one_mult_self mult_cancel_right1 pos_zmult_eq_1_iff_lemma zero_less_mult_iff)
	also from \<open>0 < i - j\<close> have "\<dots> \<le> int (cc i) gchoose (i - j)" by (rule ie1)
	finally show "(- 1)^(i - j) * ?f i j \<le> int (cc i) gchoose (i - j)" .
	qed
	finally show "?S 3 2 \<le> ?S3 4 2" .
	qed
	also have "\<dots> = ((int (aa (j + 2)) gchoose 2) + (int (bb (j + 2)) gchoose 2)) + (2 + ?S3 4 1)"
	using \<open>0 < n - 1\<close> \<open>j + 4 \<le> n - 1\<close> by (simp only: sum_tail_nat) (simp flip: numeral_2_eq_2)
	also from ie1 have "\<dots> \<le> int (cc (j + 2)) gchoose 2 + (2 + ?S3 4 1)"
	by (rule add_right_mono) simp
	also have "\<dots> = 2 + (int (cc (j + 2)) gchoose 2) + ?S3 4 1" by (simp only: ac_simps)
	finally show ?thesis .
	qed
	qed

	corollary cc_le:
	assumes "0 < j" and "j < n - 2"
	shows "cc j \<le> 2 + (cc (j + 1) choose 2) + (\<Sum>i=j+3..n-1. cc i choose (Suc (i - j)))"
	proof -
	define j0 where "j0 = j - 1"
	with assms have j: "j = Suc j0" and "j0 < n - 3" by simp_all
	have "int (cc j) = int (cc (Suc j0))" by (simp only: j)
	also have "\<dots> \<le> 2 + (int (cc (j0 + 2)) gchoose 2) + (\<Sum>i=j0+4..n-1. int (cc i) gchoose (i - j0))"
	using \<open>j0 < n - 3\<close> by (rule cc_Suc_le)
	also have "\<dots> = 2 + (int (cc (j + 1)) gchoose 2) + (\<Sum>i=j0+4..n-1. int (cc i) gchoose (i - j0))"
	by (simp add: j)
	also have "(\<Sum>i=j0+4..n-1. int (cc i) gchoose (i - j0)) = int (\<Sum>i=j+3..n-1. cc i choose (Suc (i - j)))"
	unfolding int_sum
	proof (rule sum.cong)
	fix i
	assume "i \<in> {j + 3..n - 1}"
	hence "Suc j0 < i" by (simp add: j)
	hence "i - j0 = Suc (i - j)" by (simp add: j)
	thus "int (cc i) gchoose (i - j0) = int (cc i choose (Suc (i - j)))" by (simp add: int_binomial)
	qed (simp add: j)
	finally have "int (cc j) \<le> int (2 + (cc (j + 1) choose 2) + (\<Sum>i = j + 3..n - 1. cc i choose (Suc (i - j))))"
	by (simp only: int_plus int_binomial)
	thus ?thesis by (simp only: zle_int)
	qed

	corollary cc_le_Dube_aux: "0 < j \<Longrightarrow> j + 1 \<le> n \<Longrightarrow> cc j \<le> Dube_aux n d j"
	proof (induct j rule: Dube_aux.induct[where n=n])
	case step: (1 j)
	from step.prems(2) have "j + 2 < n \<or> j + 2 = n \<or> j + 1 = n" by auto
	thus ?case
	proof (elim disjE)
	assume *: "j + 2 < n"
	moreover have "0 < j + 1" by simp
	moreover from * have "j + 1 + 1 \<le> n" by simp
	ultimately have "cc (j + 1) \<le> Dube_aux n d (j + 1)" by (rule step.hyps)
	hence 1: "cc (j + 1) choose 2 \<le> Dube_aux n d (j + 1) choose 2"
	by (rule Binomial_Int.binomial_mono)
	have 2: "(\<Sum>i = j + 3..n - 1. cc i choose Suc (i - j)) \<le>
	(\<Sum>i = j + 3..n - 1. Dube_aux n d i choose Suc (i - j))"
	proof (rule sum_mono)
	fix i::nat
	note *
	moreover assume "i \<in> {j + 3..n - 1}"
	moreover from this \<open>2 < n\<close> have "0 < i" and "i + 1 \<le> n" by auto
	ultimately have "cc i \<le> Dube_aux n d i" by (rule step.hyps)
	thus "cc i choose Suc (i - j) \<le> Dube_aux n d i choose Suc (i - j)"
	by (rule Binomial_Int.binomial_mono)
	qed
	from * have "j < n - 2" by simp
	with step.prems(1) have "cc j \<le> 2 + (cc (j + 1) choose 2) + (\<Sum>i = j + 3..n - 1. cc i choose Suc (i - j))"
	by (rule cc_le)
	also from * 1 2 have "\<dots> \<le> Dube_aux n d j" by simp
	finally show ?thesis .
	next
	assume "j + 2 = n"
	hence "j = n - 2" and "Dube_aux n d j = d\<^sup>2 + 2 * d" by simp_all
	thus ?thesis by (simp only: cc_n_minus_2)
	next
	assume "j + 1 = n"
	hence "j = n - 1" and "Dube_aux n d j = 2 * d" by simp_all
	thus ?thesis by (simp only: cc_n_minus_1)
	qed
	qed

	end

	lemma Dube_aux:
	assumes "g \<in> punit.reduced_GB F"
	shows "poly_deg g \<le> Dube_aux n d 1"
	proof (cases "n = 2")
	case True
	from assms have "poly_deg g \<le> bb 0" by (rule deg_RGB)
	also have "\<dots> \<le> max (aa 1) (bb 1)" by (fact bb_0)
	also have "\<dots> \<le> cc (n - 1)" by (simp add: True)
	also have "\<dots> = 2 * d" by (fact cc_n_minus_1)
	also have "\<dots> = Dube_aux n d 1" by (simp add: True)
	finally show ?thesis .
	next
	case False
	with \<open>1 < n\<close> have "2 < n" and "1 + 1 \<le> n" by simp_all
	from assms have "poly_deg g \<le> bb 0" by (rule deg_RGB)
	also have "\<dots> \<le> max (aa 1) (bb 1)" by (fact bb_0)
	also have "\<dots> \<le> cc 1" by simp
	also from \<open>2 < n\<close> _ \<open>1 + 1 \<le> n\<close> have "\<dots> \<le> Dube_aux n d 1" by (rule cc_le_Dube_aux) simp
	finally show ?thesis .
	qed

	end

	theorem Dube:
	assumes "finite F" and "F \<subseteq> P[X]" and "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "g \<in> punit.reduced_GB F"
	shows "poly_deg g \<le> Dube (card X) (maxdeg F)"
	proof (cases "F \<subseteq> {0}")
	case True
	hence "F = {} \<or> F = {0}" by blast
	with assms(4) show ?thesis by (auto simp: punit.reduced_GB_empty punit.reduced_GB_singleton)
	next
	case False
	hence "F - {0} \<noteq> {}" by simp
	hence "F \<noteq> {}" by blast
	hence "poly_deg ` F \<noteq> {}" by simp
	from assms(1) have fin1: "finite (poly_deg ` F)" by (rule finite_imageI)
	from assms(1) have "finite (F - {0})" by simp
	hence fin: "finite (poly_deg ` (F - {0}))" by (rule finite_imageI)
	moreover from \<open>F - {0} \<noteq> {}\<close> have *: "poly_deg ` (F - {0}) \<noteq> {}" by simp
	ultimately have "maxdeg (F - {0}) \<in> poly_deg ` (F - {0})" unfolding maxdeg_def by (rule Max_in)
	then obtain f where "f \<in> F - {0}" and md1: "maxdeg (F - {0}) = poly_deg f" ..
	note this(2)
	moreover have "maxdeg (F - {0}) \<le> maxdeg F"
	unfolding maxdeg_def using image_mono * fin1 by (rule Max_mono) blast
	ultimately have "poly_deg f \<le> maxdeg F" by simp
	from \<open>f \<in> F - {0}\<close> have "f \<in> F" and "f \<noteq> 0" by simp_all
	from this(1) assms(2) have "f \<in> P[X]" ..
	have f_max: "poly_deg f' \<le> poly_deg f" if "f' \<in> F" for f'
	proof (cases "f' = 0")
	case True
	thus ?thesis by simp
	next
	case False
	with that have "f' \<in> F - {0}" by simp
	hence "poly_deg f' \<in> poly_deg ` (F - {0})" by (rule imageI)
	with fin show "poly_deg f' \<le> poly_deg f" unfolding md1[symmetric] maxdeg_def by (rule Max_ge)
	qed
	have "maxdeg F \<le> poly_deg f" unfolding maxdeg_def using fin1 \<open>poly_deg ` F \<noteq> {}\<close>
	proof (rule Max.boundedI)
	fix d
	assume "d \<in> poly_deg ` F"
	then obtain f' where "f' \<in> F" and "d = poly_deg f'" ..
	note this(2)
	also from \<open>f' \<in> F\<close> have "poly_deg f' \<le> poly_deg f" by (rule f_max)
	finally show "d \<le> poly_deg f" .
	qed
	with \<open>poly_deg f \<le> maxdeg F\<close> have md: "poly_deg f = maxdeg F" by (rule antisym)
	show ?thesis
	proof (cases "ideal {f} = ideal F")
	case True
	note assms(4)
	also have "punit.reduced_GB F = punit.reduced_GB {f}"
	using punit.finite_reduced_GB_finite punit.reduced_GB_is_reduced_GB_finite
	by (rule punit.reduced_GB_unique) (simp_all add: punit.reduced_GB_pmdl_finite[simplified] True)
	also have "\<dots> \<subseteq> {punit.monic f}" by (simp add: punit.reduced_GB_singleton)
	finally have "g \<in> {punit.monic f}" .
	hence "poly_deg g = poly_deg (punit.monic f)" by simp
	also from poly_deg_monom_mult_le[where c="1 / lcf f" and t=0 and p=f] have "\<dots> \<le> poly_deg f"
	by (simp add: punit.monic_def)
	also have "\<dots> = maxdeg F" by (fact md)
	also have "\<dots> \<le> Dube (card X) (maxdeg F)" by (fact Dube_ge_d)
	finally show ?thesis .
	next
	case False
	show ?thesis
	proof (cases "poly_deg f = 0")
	case True
	hence "monomial (lookup f 0) 0 = f" by (rule poly_deg_zero_imp_monomial)
	moreover define c where "c = lookup f 0"
	ultimately have f: "f = monomial c 0" by simp
	with \<open>f \<noteq> 0\<close> have "c \<noteq> 0" by (simp add: monomial_0_iff)
	from \<open>f \<in> F\<close> have "f \<in> ideal F" by (rule ideal.span_base)
	hence "punit.monom_mult (1 / c) 0 f \<in> ideal F" by (rule punit.pmdl_closed_monom_mult[simplified])
	with \<open>c \<noteq> 0\<close> have "ideal F = UNIV"
	by (simp add: f punit.monom_mult_monomial ideal_eq_UNIV_iff_contains_one)
	with assms(1) have "punit.reduced_GB F = {1}"
	by (simp only: ideal_eq_UNIV_iff_reduced_GB_eq_one_finite)
	with assms(4) show ?thesis by simp
	next
	case False
	hence "0 < poly_deg f" by simp
	have "card X \<le> 1 \<or> 1 < card X" by auto
	thus ?thesis
	proof
	note fin_X
	moreover assume "card X \<le> 1"
	moreover note assms(2)
	moreover from \<open>f \<in> F\<close> have "f \<in> ideal F" by (rule ideal.span_base)
	ultimately have "poly_deg g \<le> poly_deg f"
	using \<open>f \<noteq> 0\<close> assms(4) by (rule deg_reduced_GB_univariate_le)
	also have "\<dots> \<le> Dube (card X) (maxdeg F)" unfolding md by (fact Dube_ge_d)
	finally show ?thesis .
	next
	assume "1 < card X"
	hence "poly_deg g \<le> Dube_aux (card X) (poly_deg f) 1"
	using assms(1, 2) \<open>f \<in> F\<close> assms(3) f_max \<open>0 < poly_deg f\<close> \<open>ideal {f} \<noteq> ideal F\<close> assms(4)
	by (rule Dube_aux)
	also from \<open>1 < card X\<close> \<open>0 < poly_deg f\<close> have "\<dots> = Dube (card X) (maxdeg F)"
	by (simp add: Dube_def md)
	finally show ?thesis .
	qed
	qed
	qed
	qed

	corollary Dube_is_hom_GB_bound:
	"finite F \<Longrightarrow> F \<subseteq> P[X] \<Longrightarrow> is_hom_GB_bound F (Dube (card X) (maxdeg F))"
	by (intro is_hom_GB_boundI Dube)

	end

	corollary Dube_indets:
	assumes "finite F" and "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "g \<in> punit.reduced_GB F"
	shows "poly_deg g \<le> Dube (card (\<Union>(indets ` F))) (maxdeg F)"
	using _ assms(1) _ assms(2, 3)
	proof (rule Dube)
	from assms show "finite (\<Union>(indets ` F))" by (simp add: finite_indets)
	next
	show "F \<subseteq> P[\<Union>(indets ` F)]" by (auto simp: Polys_alt)
	qed

	corollary Dube_is_hom_GB_bound_indets:
	"finite F \<Longrightarrow> is_hom_GB_bound F (Dube (card (\<Union>(indets ` F))) (maxdeg F))"
	by (intro is_hom_GB_boundI Dube_indets)

	end (* pm_powerprod *)

	hide_const (open) pm_powerprod.\<a> pm_powerprod.\<b>

	context extended_ord_pm_powerprod
	begin

	lemma Dube_is_GB_cofactor_bound:
	assumes "finite X" and "finite F" and "F \<subseteq> P[X]"
	shows "is_GB_cofactor_bound F (Dube (Suc (card X)) (maxdeg F))"
	using assms(1, 3)
	proof (rule hom_GB_bound_is_GB_cofactor_bound)
	let ?F = "homogenize None ` extend_indets ` F"
	let ?X = "insert None (Some ` X)"
	from assms(1) have "finite ?X" by simp
	moreover from assms(2) have "finite ?F" by (intro finite_imageI)
	moreover have "?F \<subseteq> P[?X]"
	proof
	fix f'
	assume "f' \<in> ?F"
	then obtain f where "f \<in> F" and f': "f' = homogenize None (extend_indets f)" by blast
	from this(1) assms(3) have "f \<in> P[X]" ..
	hence "extend_indets f \<in> P[Some ` X]" by (auto simp: Polys_alt indets_extend_indets)
	thus "f' \<in> P[?X]" unfolding f' by (rule homogenize_in_Polys)
	qed
	ultimately have "extended_ord.is_hom_GB_bound ?F (Dube (card ?X) (maxdeg ?F))"
	by (rule extended_ord.Dube_is_hom_GB_bound)
	moreover have "maxdeg ?F = maxdeg F"
	proof -
	have "maxdeg ?F = maxdeg (extend_indets ` F)"
	by (auto simp: indets_extend_indets intro: maxdeg_homogenize)
	also have "\<dots> = maxdeg F" by (simp add: maxdeg_def image_image)
	finally show "maxdeg ?F = maxdeg F" .
	qed
	moreover from assms(1) have "card ?X = card X + 1" by (simp add: card_image)
	ultimately show "extended_ord.is_hom_GB_bound ?F (Dube (Suc (card X)) (maxdeg F))" by simp
	qed

	lemma Dube_is_GB_cofactor_bound_explicit:
	assumes "finite X" and "finite F" and "F \<subseteq> P[X]"
	obtains G where "punit.is_Groebner_basis G" and "ideal G = ideal F" and "G \<subseteq> P[X]"
	and "\<And>g. g \<in> G \<Longrightarrow> \<exists>q. g = (\<Sum>f\<in>F. q f * f) \<and>
	(\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> Dube (Suc (card X)) (maxdeg F) \<and>
	(f \<notin> F \<longrightarrow> q f = 0))"
	proof -
	from assms have "is_GB_cofactor_bound F (Dube (Suc (card X)) (maxdeg F))"
	(is "is_GB_cofactor_bound _ ?b") by (rule Dube_is_GB_cofactor_bound)
	moreover note assms(3)
	ultimately obtain G where "punit.is_Groebner_basis G" and "ideal G = ideal F" and "G \<subseteq> P[X]"
	and 1: "\<And>g. g \<in> G \<Longrightarrow> \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
	(\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> ?b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
	by (rule is_GB_cofactor_boundE_Polys) blast
	from this(1-3) show ?thesis
	proof
	fix g
	assume "g \<in> G"
	hence "\<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
	(\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> ?b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
	by (rule 1)
	then obtain F' q where "F' \<subseteq> F" and g: "g = (\<Sum>f\<in>F'. q f * f)" and "\<And>f. q f \<in> P[X]"
	and "\<And>f. poly_deg (q f * f) \<le> ?b" and 2: "\<And>f. f \<notin> F' \<Longrightarrow> q f = 0" by blast
	show "\<exists>q. g = (\<Sum>f\<in>F. q f * f) \<and> (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> ?b \<and> (f \<notin> F \<longrightarrow> q f = 0))"
	proof (intro exI allI conjI impI)
	from assms(2) \<open>F' \<subseteq> F\<close> have "(\<Sum>f\<in>F'. q f * f) = (\<Sum>f\<in>F. q f * f)"
	proof (intro sum.mono_neutral_left ballI)
	fix f
	assume "f \<in> F - F'"
	hence "f \<notin> F'" by simp
	hence "q f = 0" by (rule 2)
	thus "q f * f = 0" by simp
	qed
	thus "g = (\<Sum>f\<in>F. q f * f)" by (simp only: g)
	next
	fix f
	assume "f \<notin> F"
	with \<open>F' \<subseteq> F\<close> have "f \<notin> F'" by blast
	thus "q f = 0" by (rule 2)
	qed fact+
	qed
	qed

	corollary Dube_is_GB_cofactor_bound_indets:
	assumes "finite F"
	shows "is_GB_cofactor_bound F (Dube (Suc (card (\<Union>(indets ` F)))) (maxdeg F))"
	using _ assms _
	proof (rule Dube_is_GB_cofactor_bound)
	from assms show "finite (\<Union>(indets ` F))" by (simp add: finite_indets)
	next
	show "F \<subseteq> P[\<Union>(indets ` F)]" by (auto simp: Polys_alt)
	qed

	end (* extended_ord_pm_powerprod *)

	end (* theory *)
	diff --git a/thys/Groebner_Macaulay/Dube_Prelims.thy b/thys/Groebner_Macaulay/Dube_Prelims.thy
	--- a/thys/Groebner_Macaulay/Dube_Prelims.thy
	+++ b/thys/Groebner_Macaulay/Dube_Prelims.thy
	@@ -1,391 +1,382 @@
	(* Author: Alexander Maletzky *)

	section \<open>Preliminaries\<close>

	theory Dube_Prelims
	imports Groebner_Bases.General
	begin

	subsection \<open>Sets\<close>

	lemma card_geq_ex_subset:
	assumes "card A \<ge> n"
	obtains B where "card B = n" and "B \<subseteq> A"
	using assms
	proof (induct n arbitrary: thesis)
	case base: 0
	show ?case
	proof (rule base(1))
	show "card {} = 0" by simp
	next
	show "{} \<subseteq> A" ..
	qed
	next
	case ind: (Suc n)
	from ind(3) have "n < card A" by simp
	obtain B where card: "card B = n" and "B \<subseteq> A"
	proof (rule ind(1))
	from \<open>n < card A\<close> show "n \<le> card A" by simp
	qed
	from \<open>n < card A\<close> have "card A \<noteq> 0" by simp
	with card.infinite[of A] have "finite A" by blast
	let ?C = "A - B"
	have "?C \<noteq> {}"
	proof
	assume "A - B = {}"
	hence "A \<subseteq> B" by simp
	from this \<open>B \<subseteq> A\<close> have "A = B" ..
	from \<open>n < card A\<close> show False unfolding \<open>A = B\<close> card by simp
	qed
	then obtain c where "c \<in> ?C" by auto
	hence "c \<notin> B" by simp
	hence "B - {c} = B" by simp
	show ?case
	proof (rule ind(2))
	thm card.insert_remove
	have "card (B \<union> {c}) = card (insert c B)" by simp
	also have "... = Suc (card (B - {c}))"
	by (rule card.insert_remove, rule finite_subset, fact \<open>B \<subseteq> A\<close>, fact)
	finally show "card (B \<union> {c}) = Suc n" unfolding \<open>B - {c} = B\<close> card .
	next
	show "B \<union> {c} \<subseteq> A" unfolding Un_subset_iff
	proof (intro conjI, fact)
	from \<open>c \<in> ?C\<close> show "{c} \<subseteq> A" by auto
	qed
	qed
	qed

	lemma card_2_E_1:
	assumes "card A = 2" and "x \<in> A"
	obtains y where "x \<noteq> y" and "A = {x, y}"
	proof -
	have "A - {x} \<noteq> {}"
	proof
	assume "A - {x} = {}"
	with assms(2) have "A = {x}" by auto
	hence "card A = 1" by simp
	with assms show False by simp
	qed
	then obtain y where "y \<in> A - {x}" by auto
	hence "y \<in> A" and "x \<noteq> y" by auto
	show ?thesis
	proof
	show "A = {x, y}"
	proof (rule sym, rule card_seteq)
	from assms(1) show "finite A" using card.infinite by fastforce
	next
	from \<open>x \<in> A\<close> \<open>y \<in> A\<close> show "{x, y} \<subseteq> A" by simp
	next
	from \<open>x \<noteq> y\<close> show "card A \<le> card {x, y}" by (simp add: assms(1))
	qed
	qed fact
	qed

	lemma card_2_E:
	assumes "card A = 2"
	obtains x y where "x \<noteq> y" and "A = {x, y}"
	proof -
	from assms have "A \<noteq> {}" by auto
	then obtain x where "x \<in> A" by blast
	with assms obtain y where "x \<noteq> y" and "A = {x, y}" by (rule card_2_E_1)
	thus ?thesis ..
	qed

	subsection \<open>Sums\<close>

	lemma sum_tail_nat: "0 < b \<Longrightarrow> a \<le> (b::nat) \<Longrightarrow> sum f {a..b} = f b + sum f {a..b - 1}"
	by (metis One_nat_def Suc_pred add.commute not_le sum.cl_ivl_Suc)

	lemma sum_atLeast_Suc_shift: "0 < b \<Longrightarrow> a \<le> b \<Longrightarrow> sum f {Suc a..b} = (\<Sum>i=a..b - 1. f (Suc i))"
	by (metis Suc_pred' sum.shift_bounds_cl_Suc_ivl)

	lemma sum_split_nat_ivl:
	"a \<le> Suc j \<Longrightarrow> j \<le> b \<Longrightarrow> sum f {a..j} + sum f {Suc j..b} = sum f {a..b}"
	by (metis Suc_eq_plus1 le_Suc_ex sum.ub_add_nat)

	subsection \<open>@{const count_list}\<close>

	-lemma count_list_eq_0_iff: "count_list xs x = 0 \<longleftrightarrow> x \<notin> set xs"
	- by (induct xs) simp_all
	-
	-lemma count_list_append: "count_list (xs @ ys) x = count_list xs x + count_list ys x"
	- by (induct xs) simp_all
	-
	-lemma count_list_map_ge: "count_list xs x \<le> count_list (map f xs) (f x)"
	- by (induct xs) simp_all
	-
	lemma count_list_gr_1_E:
	assumes "1 < count_list xs x"
	obtains i j where "i < j" and "j < length xs" and "xs ! i = x" and "xs ! j = x"
	proof -
	from assms have "count_list xs x \<noteq> 0" by simp
	- hence "x \<in> set xs" by (simp only: count_list_eq_0_iff not_not)
	+ hence "x \<in> set xs" by (simp only: count_list_0_iff not_not)
	then obtain ys zs where xs: "xs = ys @ x # zs" and "x \<notin> set ys" by (meson split_list_first)
	- hence "count_list xs x = Suc (count_list zs x)" by (simp add: count_list_append)
	+ hence "count_list xs x = Suc (count_list zs x)" by (simp)
	with assms have "count_list zs x \<noteq> 0" by simp
	- hence "x \<in> set zs" by (simp only: count_list_eq_0_iff not_not)
	+ hence "x \<in> set zs" by (simp only: count_list_0_iff not_not)
	then obtain j where "j < length zs" and "x = zs ! j" by (metis in_set_conv_nth)
	show ?thesis
	proof
	show "length ys < length ys + Suc j" by simp
	next
	from \<open>j < length zs\<close> show "length ys + Suc j < length xs" by (simp add: xs)
	next
	show "xs ! length ys = x" by (simp add: xs)
	next
	show "xs ! (length ys + Suc j) = x"
	by (simp only: xs \<open>x = zs ! j\<close> nth_append_length_plus nth_Cons_Suc)
	qed
	qed

	subsection \<open>@{const listset}\<close>

	lemma listset_Cons: "listset (x # xs) = (\<Union>y\<in>x. (#) y ` listset xs)"
	by (auto simp: set_Cons_def)

	lemma listset_ConsI: "y \<in> x \<Longrightarrow> ys' \<in> listset xs \<Longrightarrow> ys = y # ys' \<Longrightarrow> ys \<in> listset (x # xs)"
	by (simp add: set_Cons_def)

	lemma listset_ConsE:
	assumes "ys \<in> listset (x# xs)"
	obtains y ys' where "y \<in> x" and "ys' \<in> listset xs" and "ys = y # ys'"
	using assms by (auto simp: set_Cons_def)

	lemma listsetI:
	"length ys = length xs \<Longrightarrow> (\<And>i. i < length xs \<Longrightarrow> ys ! i \<in> xs ! i) \<Longrightarrow> ys \<in> listset xs"
	by (induct ys xs rule: list_induct2)
	(simp_all, smt Suc_mono list.sel(3) mem_Collect_eq nth_Cons_0 nth_tl set_Cons_def zero_less_Suc)

	lemma listsetD:
	assumes "ys \<in> listset xs"
	shows "length ys = length xs" and "\<And>i. i < length xs \<Longrightarrow> ys ! i \<in> xs ! i"
	proof -
	from assms have "length ys = length xs \<and> (\<forall>i<length xs. ys ! i \<in> xs ! i)"
	proof (induct xs arbitrary: ys)
	case Nil
	thus ?case by simp
	next
	case (Cons x xs)
	from Cons.prems obtain y ys' where "y \<in> x" and "ys' \<in> listset xs" and ys: "ys = y # ys'"
	by (rule listset_ConsE)
	from this(2) have "length ys' = length xs \<and> (\<forall>i<length xs. ys' ! i \<in> xs ! i)" by (rule Cons.hyps)
	hence 1: "length ys' = length xs" and 2: "\<And>i. i < length xs \<Longrightarrow> ys' ! i \<in> xs ! i" by simp_all
	show ?case
	proof (intro conjI allI impI)
	fix i
	assume "i < length (x # xs)"
	show "ys ! i \<in> (x # xs) ! i"
	proof (cases i)
	case 0
	with \<open>y \<in> x\<close> show ?thesis by (simp add: ys)
	next
	case (Suc j)
	with \<open>i < length (x # xs)\<close> have "j < length xs" by simp
	hence "ys' ! j \<in> xs ! j" by (rule 2)
	thus ?thesis by (simp add: ys \<open>i = Suc j\<close>)
	qed
	qed (simp add: ys 1)
	qed
	thus "length ys = length xs" and "\<And>i. i < length xs \<Longrightarrow> ys ! i \<in> xs ! i" by simp_all
	qed

	lemma listset_singletonI: "a \<in> A \<Longrightarrow> ys = [a] \<Longrightarrow> ys \<in> listset [A]"
	by simp

	lemma listset_singletonE:
	assumes "ys \<in> listset [A]"
	obtains a where "a \<in> A" and "ys = [a]"
	using assms by auto

	lemma listset_doubletonI: "a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> ys = [a, b] \<Longrightarrow> ys \<in> listset [A, B]"
	by (simp add: set_Cons_def)

	lemma listset_doubletonE:
	assumes "ys \<in> listset [A, B]"
	obtains a b where "a \<in> A" and "b \<in> B" and "ys = [a, b]"
	using assms by (auto simp: set_Cons_def)

	lemma listset_appendI:
	"ys1 \<in> listset xs1 \<Longrightarrow> ys2 \<in> listset xs2 \<Longrightarrow> ys = ys1 @ ys2 \<Longrightarrow> ys \<in> listset (xs1 @ xs2)"
	by (induct xs1 arbitrary: ys ys1 ys2)
	(simp, auto simp del: listset.simps elim!: listset_ConsE intro!: listset_ConsI)

	lemma listset_appendE:
	assumes "ys \<in> listset (xs1 @ xs2)"
	obtains ys1 ys2 where "ys1 \<in> listset xs1" and "ys2 \<in> listset xs2" and "ys = ys1 @ ys2"
	using assms
	proof (induct xs1 arbitrary: thesis ys)
	case Nil
	have "[] \<in> listset []" by simp
	moreover from Nil(2) have "ys \<in> listset xs2" by simp
	ultimately show ?case by (rule Nil) simp
	next
	case (Cons x xs1)
	from Cons.prems(2) have "ys \<in> listset (x # (xs1 @ xs2))" by simp
	then obtain y ys' where "y \<in> x" and "ys' \<in> listset (xs1 @ xs2)" and ys: "ys = y # ys'"
	by (rule listset_ConsE)
	from _ this(2) obtain ys1 ys2 where ys1: "ys1 \<in> listset xs1" and "ys2 \<in> listset xs2"
	and ys': "ys' = ys1 @ ys2" by (rule Cons.hyps)
	show ?case
	proof (rule Cons.prems)
	from \<open>y \<in> x\<close> ys1 refl show "y # ys1 \<in> listset (x # xs1)" by (rule listset_ConsI)
	next
	show "ys = (y # ys1) @ ys2" by (simp add: ys ys')
	qed fact
	qed

	lemma listset_map_imageI: "ys' \<in> listset xs \<Longrightarrow> ys = map f ys' \<Longrightarrow> ys \<in> listset (map ((`) f) xs)"
	by (induct xs arbitrary: ys ys')
	(simp, auto simp del: listset.simps elim!: listset_ConsE intro!: listset_ConsI)

	lemma listset_map_imageE:
	assumes "ys \<in> listset (map ((`) f) xs)"
	obtains ys' where "ys' \<in> listset xs" and "ys = map f ys'"
	using assms
	proof (induct xs arbitrary: thesis ys)
	case Nil
	from Nil(2) have "ys = map f []" by simp
	with _ show ?case by (rule Nil) simp
	next
	case (Cons x xs)
	from Cons.prems(2) have "ys \<in> listset (f ` x # map ((`) f) xs)" by simp
	then obtain y ys' where "y \<in> f ` x" and "ys' \<in> listset (map ((`) f) xs)" and ys: "ys = y # ys'"
	by (rule listset_ConsE)
	from _ this(2) obtain ys1 where ys1: "ys1 \<in> listset xs" and ys': "ys' = map f ys1" by (rule Cons.hyps)
	from \<open>y \<in> f ` x\<close> obtain y1 where "y1 \<in> x" and y: "y = f y1" ..
	show ?case
	proof (rule Cons.prems)
	from \<open>y1 \<in> x\<close> ys1 refl show "y1 # ys1 \<in> listset (x # xs)" by (rule listset_ConsI)
	qed (simp add: ys ys' y)
	qed

	lemma listset_permE:
	assumes "ys \<in> listset xs" and "bij_betw f {..<length xs} {..<length xs'}"
	and "\<And>i. i < length xs \<Longrightarrow> xs' ! i = xs ! f i"
	obtains ys' where "ys' \<in> listset xs'" and "length ys' = length ys"
	and "\<And>i. i < length ys \<Longrightarrow> ys' ! i = ys ! f i"
	proof -
	from assms(1) have len_ys: "length ys = length xs" by (rule listsetD)
	from assms(2) have "card {..<length xs} = card {..<length xs'}" by (rule bij_betw_same_card)
	hence len_xs: "length xs = length xs'" by simp
	define ys' where "ys' = map (\<lambda>i. ys ! (f i)) [0..<length ys]"
	have 1: "ys' ! i = ys ! f i" if "i < length ys" for i using that by (simp add: ys'_def)
	show ?thesis
	proof
	show "ys' \<in> listset xs'"
	proof (rule listsetI)
	show "length ys' = length xs'" by (simp add: ys'_def len_ys len_xs)

	fix i
	assume "i < length xs'"
	hence "i < length xs" by (simp only: len_xs)
	hence "i < length ys" by (simp only: len_ys)
	hence "ys' ! i = ys ! (f i)" by (rule 1)
	also from assms(1) have "\<dots> \<in> xs ! (f i)"
	proof (rule listsetD)
	from \<open>i < length xs\<close> have "i \<in> {..<length xs}" by simp
	hence "f i \<in> f ` {..<length xs}" by (rule imageI)
	also from assms(2) have "\<dots> = {..<length xs'}" by (simp add: bij_betw_def)
	finally show "f i < length xs" by (simp add: len_xs)
	qed
	also have "\<dots> = xs' ! i" by (rule sym) (rule assms(3), fact)
	finally show "ys' ! i \<in> xs' ! i" .
	qed
	next
	show "length ys' = length ys" by (simp add: ys'_def)
	qed (rule 1)
	qed

	lemma listset_closed_map:
	assumes "ys \<in> listset xs" and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> x \<Longrightarrow> f y \<in> x"
	shows "map f ys \<in> listset xs"
	using assms
	proof (induct xs arbitrary: ys)
	case Nil
	from Nil(1) show ?case by simp
	next
	case (Cons x xs)
	from Cons.prems(1) obtain y ys' where "y \<in> x" and "ys' \<in> listset xs" and ys: "ys = y # ys'"
	by (rule listset_ConsE)
	show ?case
	proof (rule listset_ConsI)
	from _ \<open>y \<in> x\<close> show "f y \<in> x" by (rule Cons.prems) simp
	next
	show "map f ys' \<in> listset xs"
	proof (rule Cons.hyps)
	fix x0 y0
	assume "x0 \<in> set xs"
	hence "x0 \<in> set (x # xs)" by simp
	moreover assume "y0 \<in> x0"
	ultimately show "f y0 \<in> x0" by (rule Cons.prems)
	qed fact
	qed (simp add: ys)
	qed

	lemma listset_closed_map2:
	assumes "ys1 \<in> listset xs" and "ys2 \<in> listset xs"
	and "\<And>x y1 y2. x \<in> set xs \<Longrightarrow> y1 \<in> x \<Longrightarrow> y2 \<in> x \<Longrightarrow> f y1 y2 \<in> x"
	shows "map2 f ys1 ys2 \<in> listset xs"
	using assms
	proof (induct xs arbitrary: ys1 ys2)
	case Nil
	from Nil(1) show ?case by simp
	next
	case (Cons x xs)
	from Cons.prems(1) obtain y1 ys1' where "y1 \<in> x" and "ys1' \<in> listset xs" and ys1: "ys1 = y1 # ys1'"
	by (rule listset_ConsE)
	from Cons.prems(2) obtain y2 ys2' where "y2 \<in> x" and "ys2' \<in> listset xs" and ys2: "ys2 = y2 # ys2'"
	by (rule listset_ConsE)
	show ?case
	proof (rule listset_ConsI)
	from _ \<open>y1 \<in> x\<close> \<open>y2 \<in> x\<close> show "f y1 y2 \<in> x" by (rule Cons.prems) simp
	next
	show "map2 f ys1' ys2' \<in> listset xs"
	proof (rule Cons.hyps)
	fix x' y1' y2'
	assume "x' \<in> set xs"
	hence "x' \<in> set (x # xs)" by simp
	moreover assume "y1' \<in> x'" and "y2' \<in> x'"
	ultimately show "f y1' y2' \<in> x'" by (rule Cons.prems)
	qed fact+
	qed (simp add: ys1 ys2)
	qed

	lemma listset_empty_iff: "listset xs = {} \<longleftrightarrow> {} \<in> set xs"
	by (induct xs) (auto simp: listset_Cons simp del: listset.simps(2))

	lemma listset_mono:
	assumes "length xs = length ys" and "\<And>i. i < length ys \<Longrightarrow> xs ! i \<subseteq> ys ! i"
	shows "listset xs \<subseteq> listset ys"
	using assms
	proof (induct xs ys rule: list_induct2)
	case Nil
	show ?case by simp
	next
	case (Cons x xs y ys)
	show ?case
	proof
	fix zs'
	assume "zs' \<in> listset (x # xs)"
	then obtain z zs where "z \<in> x" and zs: "zs \<in> listset xs" and zs': "zs' = z # zs"
	by (rule listset_ConsE)
	have "0 < length (y # ys)" by simp
	hence "(x # xs) ! 0 \<subseteq> (y # ys) ! 0" by (rule Cons.prems)
	hence "x \<subseteq> y" by simp
	with \<open>z \<in> x\<close> have "z \<in> y" ..
	moreover from zs have "zs \<in> listset ys"
	proof
	show "listset xs \<subseteq> listset ys"
	proof (rule Cons.hyps)
	fix i
	assume "i < length ys"
	hence "Suc i < length (y # ys)" by simp
	hence "(x # xs) ! Suc i \<subseteq> (y # ys) ! Suc i" by (rule Cons.prems)
	thus "xs ! i \<subseteq> ys ! i" by simp
	qed
	qed
	ultimately show "zs' \<in> listset (y # ys)" using zs' by (rule listset_ConsI)
	qed
	qed

	end (* theory *)
	diff --git a/thys/Hidden_Markov_Models/Hidden_Markov_Model.thy b/thys/Hidden_Markov_Models/Hidden_Markov_Model.thy
	--- a/thys/Hidden_Markov_Models/Hidden_Markov_Model.thy
	+++ b/thys/Hidden_Markov_Models/Hidden_Markov_Model.thy
	@@ -1,626 +1,626 @@
	section \<open>Hidden Markov Models\<close>

	theory Hidden_Markov_Model
	imports
	Markov_Models.Discrete_Time_Markov_Chain Auxiliary
	"HOL-Library.IArray"
	begin

	subsection \<open>Definitions\<close>

	text \<open>Definition of Markov Kernels that are closed w.r.t. to a set of states.\<close>
	locale Closed_Kernel =
	fixes K :: "'s \<Rightarrow> 't pmf" and S :: "'t set"
	assumes finite: "finite S"
	and wellformed: "S \<noteq> {}"
	and closed: "\<forall> s. K s \<subseteq> S"

	text \<open>
	An HMM is parameterized by a Markov kernel for the transition probabilites between internal states,
	a Markov kernel for the output probabilities of observations,
	and a fixed set of observations.
	\<close>
	locale HMM_defs =
	fixes \<K> :: "'s \<Rightarrow> 's pmf" and \<O> :: "'s \<Rightarrow> 't pmf" and \<O>\<^sub>s :: "'t set"

	locale HMM =
	HMM_defs + O: Closed_Kernel \<O> \<O>\<^sub>s
	begin

	lemma observations_finite: "finite \<O>\<^sub>s"
	and observations_wellformed: "\<O>\<^sub>s \<noteq> {}"
	and observations_closed: "\<forall> s. \<O> s \<subseteq> \<O>\<^sub>s"
	using O.finite O.wellformed O.closed by -

	end

	text \<open>Fixed set of internal states.\<close>
	locale HMM2_defs = HMM_defs \<K> \<O> for \<K> :: "'s \<Rightarrow> 's pmf" and \<O> :: "'s \<Rightarrow> 't pmf" +
	fixes \<S> :: "'s set"

	locale HMM2 = HMM2_defs + HMM + K: Closed_Kernel \<K> \<S>
	begin

	lemma states_finite: "finite \<S>"
	and states_wellformed: "\<S> \<noteq> {}"
	and states_closed: "\<forall> s. \<K> s \<subseteq> \<S>"
	using K.finite K.wellformed K.closed by -

	end

	text \<open>
	The set of internal states is now given as a list to iterate over.
	This is needed for the computations on HMMs.
	\<close>
	locale HMM3_defs = HMM2_defs \<O>\<^sub>s \<K> for \<O>\<^sub>s :: "'t set" and \<K> :: "'s \<Rightarrow> 's pmf" +
	fixes state_list :: "'s list"

	locale HMM3 = HMM3_defs _ _ \<O>\<^sub>s \<K> + HMM2 \<O>\<^sub>s \<K> for \<O>\<^sub>s :: "'t set" and \<K> :: "'s \<Rightarrow> 's pmf" +
	assumes state_list_\<S>: "set state_list = \<S>"

	context HMM_defs
	begin

	no_notation (ASCII) comp (infixl "o" 55)

	text \<open>The ``default'' observation.\<close>
	definition
	"obs \<equiv> SOME x. x \<in> \<O>\<^sub>s"

	lemma (in HMM) obs:
	"obs \<in> \<O>\<^sub>s"
	unfolding obs_def using observations_wellformed by (auto intro: someI_ex)

	text \<open>
	The HMM is encoded as a Markov chain over pairs of states and observations.
	This is the Markov chain's defining Markov kernel.
	\<close>
	definition
	"K \<equiv> \<lambda> (s\<^sub>1, o\<^sub>1 :: 't). bind_pmf (\<K> s\<^sub>1) (\<lambda> s\<^sub>2. map_pmf (\<lambda> o\<^sub>2. (s\<^sub>2, o\<^sub>2)) (\<O> s\<^sub>2))"

	sublocale MC_syntax K .

	text \<open>
	Uniform distribution of the pairs \<open>(s, o)\<close> for a fixed state \<open>s\<close>.
	\<close>
	definition "I (s :: 's) = map_pmf (\<lambda> x. (s, x)) (pmf_of_set \<O>\<^sub>s)"

	text \<open>
	The likelihood of an observation sequence given a starting state \<open>s\<close> is defined in terms of
	the trace space of the Markov kernel given the uniform distribution of pairs for \<open>s\<close>.
	\<close>
	definition
	"likelihood s os = T' (I s) {\<omega> \<in> space S. \<exists> o\<^sub>0 xs \<omega>'. \<omega> = (s, o\<^sub>0) ## xs @- \<omega>' \<and> map snd xs = os}"

	abbreviation (input) "L os \<omega> \<equiv> \<exists> xs \<omega>'. \<omega> = xs @- \<omega>' \<and> map snd xs = os"

	lemma likelihood_alt_def: "likelihood s os = T' (I s) {(s, o) ## xs @- \<omega>' \|o xs \<omega>'. map snd xs = os}"
	unfolding likelihood_def by (simp add: in_S)


	subsection \<open>Iteration Rule For Likelihood\<close>

	lemma L_Nil:
	"L [] \<omega> = True"
	by simp

	lemma emeasure_T_observation_Nil:
	"T (s, o\<^sub>0) {\<omega> \<in> space S. L [] \<omega>} = 1"
	by simp

	lemma L_Cons:
	"L (o # os) \<omega> \<longleftrightarrow> snd (shd \<omega>) = o \<and> L os (stl \<omega>)"
	apply (cases \<omega>; cases "shd \<omega>"; safe; clarsimp)
	apply force
	subgoal for x xs \<omega>'
	by (force intro: exI[where x = "(x, o) # xs"])
	done

	lemma L_measurable[measurable]:
	"Measurable.pred S (L os)"
	apply (induction os)
	apply (simp; fail)
	subgoal premises that for o os
	by(subst L_Cons)
	(intro Measurable.pred_intros_logic
	measurable_compose[OF measurable_shd] measurable_compose[OF measurable_stl that];
	measurable)
	done

	lemma init_measurable[measurable]:
	"Measurable.pred S (\<lambda>x. \<exists>o\<^sub>0 xs \<omega>'. x = (s, o\<^sub>0) ## xs @- \<omega>' \<and> map snd xs = os)"
	(is "Measurable.pred S ?f")
	proof -
	have *: "?f \<omega> \<longleftrightarrow> fst (shd \<omega>) = s \<and> L os (stl \<omega>)" for \<omega>
	by (cases \<omega>) auto
	show ?thesis
	by (subst *)
	(intro Measurable.pred_intros_logic measurable_compose[OF measurable_shd]; measurable)
	qed

	lemma T_init_observation_eq:
	"T (s, o) {\<omega> \<in> space S. L os \<omega>} = T (s, o') {\<omega> \<in> space S. L os \<omega>}"
	apply (subst emeasure_Collect_T[unfolded space_T], (measurable; fail))
	apply (subst (2) emeasure_Collect_T[unfolded space_T], (measurable; fail))
	apply (simp add: K_def)
	done

	text \<open>
	Shows that it is equivalent to define likelihood in terms of the trace space starting at a single
	pair of an internal state \<open>s\<close> and the default observation @{term obs}.
	\<close>
	lemma (in HMM) likelihood_init:
	"likelihood s os = T (s, obs) {\<omega> \<in> space S. L os \<omega>}"
	proof -
	have *: "(\<Sum>o\<in>\<O>\<^sub>s. emeasure (T (s, o)) {\<omega> \<in> space S. L os \<omega>}) =
	of_nat (card \<O>\<^sub>s) * emeasure (T (s, obs)) {\<omega> \<in> space S. L os \<omega>}"
	by (subst sum_constant[symmetric]) (fastforce intro: sum.cong T_init_observation_eq[simplified])
	show ?thesis
	unfolding likelihood_def
	apply (subst emeasure_T')
	subgoal
	by measurable
	using *
	apply (simp add: I_def in_S observations_finite observations_wellformed nn_integral_pmf_of_set)
	apply (subst mult.commute)
	apply (simp add: observations_finite observations_wellformed mult_divide_eq_ennreal)
	done
	qed

	lemma emeasure_T_observation_Cons:
	"T (s, o\<^sub>0) {\<omega> \<in> space S. L (o\<^sub>1 # os) \<omega>} =
	(\<integral>\<^sup>+ t. ennreal (pmf (\<O> t) o\<^sub>1) * T (t, o\<^sub>1) {\<omega> \<in> space S. L os \<omega>} \<partial>(\<K> s))" (is "?l = ?r")
	proof -
	have *:
	"\<integral>\<^sup>+ y. T (s', y) {x \<in> space S. \<exists>xs. (\<exists>\<omega>'. (s', y) ## x = xs @- \<omega>') \<and> map snd xs = o\<^sub>1 # os}
	\<partial>measure_pmf (\<O> s') =
	ennreal (pmf (\<O> s') o\<^sub>1) * T (s', o\<^sub>1) {\<omega> \<in> space S. \<exists>xs. (\<exists>\<omega>'. \<omega> = xs @- \<omega>') \<and> map snd xs = os}"
	(is "?L = ?R") for s'
	proof -
	have "?L = \<integral>\<^sup>+ x. ennreal (pmf (\<O> s') x) *
	T (s', x) {\<omega> \<in> space S. \<exists>xs. (\<exists>\<omega>'. (s', x) ## \<omega> = xs @- \<omega>') \<and> map snd xs = o\<^sub>1 # os}
	\<partial>count_space UNIV"
	by (rule nn_integral_measure_pmf)
	also have "\<dots> =
	\<integral>\<^sup>+ o\<^sub>2. (if o\<^sub>2 = o\<^sub>1
	then ennreal (pmf (\<O> s') o\<^sub>1) * T (s', o\<^sub>1) {\<omega> \<in> space S. L os \<omega>}
	else 0)
	\<partial>count_space UNIV"
	apply (rule nn_integral_cong_AE
	[where v = "\<lambda> o\<^sub>2. if o\<^sub>2 = o\<^sub>1
	then ennreal (pmf (\<O> s') o\<^sub>1) * T (s', o\<^sub>1) {\<omega> \<in> space S. L os \<omega>} else 0"]
	)
	apply (rule AE_I2)
	apply (split if_split, safe)
	subgoal
	by (auto intro!: arg_cong2[where f = times, OF HOL.refl] arg_cong2[where f = emeasure];
	metis list.simps(9) shift.simps(2) snd_conv
	)
	subgoal
	by (subst arg_cong2[where f = emeasure and d = "{}", OF HOL.refl]) auto
	done
	also have "\<dots> = \<integral>\<^sup>+o\<^sub>2\<in>{o\<^sub>1}.
	(ennreal (pmf (\<O> s') o\<^sub>1) * T (s', o\<^sub>1) {\<omega> \<in> space S. L os \<omega>})
	\<partial>count_space UNIV"
	by (rule nn_integral_cong_AE) auto
	also have "\<dots> = ?R"
	by simp
	finally show ?thesis .
	qed
	have "?l = \<integral>\<^sup>+ t. T t {x \<in> space S. \<exists>xs \<omega>'. t ## x = xs @- \<omega>' \<and> map snd xs = o\<^sub>1 # os} \<partial> (K (s, o\<^sub>0))"
	by (subst emeasure_Collect_T[unfolded space_T], measurable)
	also have "\<dots> = ?r"
	using * by (simp add: K_def)
	finally show ?thesis .
	qed


	subsection \<open>Computation of Likelihood\<close>

	fun backward where
	"backward s [] = 1" \|
	"backward s (o # os) = (\<integral>\<^sup>+ t. ennreal (pmf (\<O> t) o) * backward t os \<partial>measure_pmf (\<K> s))"

	lemma emeasure_T_observation_backward:
	"emeasure (T (s, o)) {\<omega> \<in> space S. L os \<omega>} = backward s os"
	using emeasure_T_observation_Cons by (induction os arbitrary: s o; simp)

	lemma (in HMM) likelihood_backward:
	"likelihood s os = backward s os"
	unfolding likelihood_init emeasure_T_observation_backward ..

	end (* HMM Defs *)

	context HMM2
	begin

	fun (in HMM2_defs) forward where
	"forward s t_end [] = indicator {t_end} s" \|
	"forward s t_end (o # os) =
	(\<Sum>t \<in> \<S>. ennreal (pmf (\<O> t) o) * ennreal (pmf (\<K> s) t) * forward t t_end os)"

	lemma forward_split:
	"forward s t (os1 @ os2) = (\<Sum>t' \<in> \<S>. forward s t' os1 * forward t' t os2)"
	if "s \<in> \<S>"
	using that
	apply (induction os1 arbitrary: s)
	subgoal for s
	apply (simp add: sum_indicator_mult[OF states_finite])
	apply (subst sum.cong[where B = "{s}"])
	by auto
	subgoal for a os1 s
	apply simp
	apply (subst sum_distrib_right)
	apply (subst sum.swap)
	apply (simp add: sum_distrib_left algebra_simps)
	done
	done

	lemma (in -)
	"(\<Sum>t \<in> S. f t) = f t" if "finite S" "t \<in> S" "\<forall> s \<in> S - {t}. f s = 0"
	thm sum.empty sum.insert sum.mono_neutral_right[of S "{t}"]
	apply (subst sum.mono_neutral_right[of S "{t}"])
	using that
	apply auto
	done
	(*
	oops
	by (metis add.right_neutral empty_iff finite.intros(1) insert_iff subsetI sum.empty sum.insert sum.mono_neutral_right that)

	using that
	apply auto
	*)

	lemma forward_backward:
	"(\<Sum>t \<in> \<S>. forward s t os) = backward s os" if "s \<in> \<S>"
	using \<open>s \<in> \<S>\<close>
	apply (induction os arbitrary: s)
	subgoal for s
	by (subst sum.mono_neutral_right[of \<S> "{s}", OF states_finite])
	(auto split: if_split_asm simp: indicator_def)
	subgoal for a os s
	apply (simp add: sum.swap sum_distrib_left[symmetric])
	apply (subst nn_integral_measure_pmf_support[where A = \<S>])
	using states_finite states_closed by (auto simp: algebra_simps)
	done

	theorem likelihood_forward:
	"likelihood s os = (\<Sum>t \<in> \<S>. forward s t os)" if \<open>s \<in> \<S>\<close>
	unfolding likelihood_backward forward_backward[symmetric, OF \<open>s \<in> \<S>\<close>] ..


	subsection \<open>Definition of Maximum Probabilities\<close>

	abbreviation (input) "V os as \<omega> \<equiv> (\<exists> \<omega>'. \<omega> = zip as os @- \<omega>')"

	definition
	"max_prob s os =
	Max {T' (I s) {\<omega> \<in> space S. \<exists>o \<omega>'. \<omega> = (s, o) ## zip as os @- \<omega>'}
	\| as. length as = length os \<and> set as \<subseteq> \<S>}"

	fun viterbi_prob where
	"viterbi_prob s t_end [] = indicator {t_end} s" \|
	"viterbi_prob s t_end (o # os) =
	(MAX t \<in> \<S>. ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * viterbi_prob t t_end os)"

	definition
	"is_decoding s os as \<equiv>
	T' (I s) {\<omega> \<in> space S. \<exists>o \<omega>'. \<omega> = (s, o) ## zip as os @- \<omega>'} = max_prob s os \<and>
	length as = length os \<and> set as \<subseteq> \<S>"


	subsection \<open>Iteration Rule For Maximum Probabilities\<close>

	lemma emeasure_T_state_Nil:
	"T (s, o\<^sub>0) {\<omega> \<in> space S. V [] as \<omega>} = 1"
	by simp

	lemma max_prob_T_state_Nil:
	"Max {T (s, o) {\<omega> \<in> space S. V [] as \<omega>} \| as. length as = length [] \<and> set as \<subseteq> \<S>} = 1"
	by (simp add: emeasure_T_state_Nil)

	lemma V_Cons: "V (o # os) (a # as) \<omega> \<longleftrightarrow> fst (shd \<omega>) = a \<and> snd (shd \<omega>) = o \<and> V os as (stl \<omega>)"
	by (cases \<omega>) auto

	lemma measurable_V[measurable]:
	"Measurable.pred S (\<lambda>\<omega>. V os as \<omega>)"
	proof (induction os as rule: list_induct2')
	case (4 x xs y ys)
	then show ?case
	by (subst V_Cons)
	(intro Measurable.pred_intros_logic
	measurable_compose[OF measurable_shd] measurable_compose[OF measurable_stl];
	measurable)
	qed simp+

	lemma init_V_measurable[measurable]:
	"Measurable.pred S (\<lambda>x. \<exists>o \<omega>'. x = (s, o) ## zip as os @- \<omega>')" (is "Measurable.pred S ?f")
	proof -
	have *: "?f \<omega> \<longleftrightarrow> fst (shd \<omega>) = s \<and> V os as (stl \<omega>)" for \<omega>
	by (cases \<omega>) auto
	show ?thesis
	by (subst *)
	(intro Measurable.pred_intros_logic measurable_compose[OF measurable_shd]; measurable)
	qed

	lemma max_prob_Cons':
	"Max {T (s, o\<^sub>1) {\<omega> \<in> space S. V (o # os) as \<omega>} \| as. length as = length (o # os) \<and> set as \<subseteq> \<S>} =
	(
	MAX t \<in> \<S>. ennreal (pmf (\<O> t) o * pmf (\<K> s) t) *
	(MAX as \<in> {as. length as = length os \<and> set as \<subseteq> \<S>}. T (t, o) {\<omega> \<in> space S. V os as \<omega>})
	)" (is "?l = ?r")
	and T_V_Cons:
	"T (s, o\<^sub>1) {\<omega> \<in> space S. V (o # os) (t # as) \<omega>}
	= ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * T (t, o) {\<omega> \<in> space S. V os as \<omega>}"
	(is "?l' = ?r'")
	if "length as = length os"
	proof -
	let ?S = "\<lambda> os. {as. length as = length os \<and> set as \<subseteq> \<S>}"
	have S_finite: "finite (?S os)" for os :: "'t list"
	using finite_lists_length_eq[OF states_finite] by (rule finite_subset[rotated]) auto
	have S_nonempty: "?S os \<noteq> {}" for os :: "'t list"
	proof -
	let ?a = "SOME a. a \<in> \<S>" let ?as = "replicate (length os) ?a"
	from states_wellformed have "?a \<in> \<S>"
	by (auto intro: someI_ex)
	then have "?as \<in> ?S os"
	by auto
	then show ?thesis
	by force
	qed
	let ?f = "\<lambda>t as os. T t {\<omega> \<in> space S. V os as (t ## \<omega>)}"
	let ?g = "\<lambda>t as os. T t {\<omega> \<in> space S. V os as \<omega>}"
	have : "?f t as (o # os) = ?g t (tl as) os indicator {(hd as, o)} t"
	if "length as = Suc n" for t as n
	unfolding indicator_def using that by (cases as) auto
	have *: "K (s, o\<^sub>1) {(t, o)} = pmf (\<O> t) o pmf (\<K> s) t" for t
	unfolding K_def
	apply (simp add: vimage_def)
	apply (subst arg_cong2[where
	f = nn_integral and d = "\<lambda> x. \<O> x {xa. xa = o \<and> x = t} * indicator {t} x",
	OF HOL.refl])
	subgoal
	by (auto simp: indicator_def)
	by (simp add: emeasure_pmf_single ennreal_mult')
	have "?l = (MAX as \<in> ?S (o # os). \<integral>\<^sup>+ t. ?f t as (o # os) \<partial>K (s, o\<^sub>1))"
	by (subst Max_to_image2; subst emeasure_Collect_T[unfolded space_T]; rule measurable_V HOL.refl)
	also have "\<dots> = (MAX as \<in> ?S (o # os). \<integral>\<^sup>+ t. ?g t (tl as) os * indicator {(hd as,o)} t \<partial>K (s,o\<^sub>1))"
	by (simp cong: Max_image_cong_simp add: *)
	also have "\<dots> = (MAX(t, as)\<in> \<S> \<times> ?S os. ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * ?g (t, o) as os)"
	proof ((rule Max_eq_image_if; clarsimp?), goal_cases)
	case 1
	from S_finite[of "o # os"] show ?case
	by simp
	next
	case 2
	from states_finite show ?case
	by (blast intro: S_finite)
	next
	case (3 as)
	then show ?case
	by - (rule bexI[where x = "hd as"]; cases as; auto simp: algebra_simps **)
	next
	case (4 x as)
	then show ?case
	by - (rule exI[where x = "x # as"], simp add: algebra_simps **)
	qed
	also have "\<dots> = ?r"
	by (subst Max_image_left_mult[symmetric], fact+)
	(rule sym, rule Max_image_pair, rule states_finite, fact+)
	finally show "?l = ?r" .
	have "?l' = \<integral>\<^sup>+ t'. ?f t' (t # as) (o # os) \<partial>K (s, o\<^sub>1)"
	by (rule emeasure_Collect_T[unfolded space_T]; rule measurable_V)
	also from that have "\<dots> = \<integral>\<^sup>+ t'. ?g t' as os * indicator {(t,o)} t' \<partial>K (s,o\<^sub>1)"
	by (subst *[of _ "length as"]; simp)
	also have "\<dots> = ?r'"
	by (simp add: **, simp only: algebra_simps)
	finally show "?l' = ?r'" .
	qed

	lemmas max_prob_Cons = max_prob_Cons'[OF length_replicate]



	subsection \<open>Computation of Maximum Probabilities\<close>

	lemma T_init_V_eq:
	"T (s, o) {\<omega> \<in> space S. V os as \<omega>} = T (s, o') {\<omega> \<in> space S. V os as \<omega>}"
	apply (subst emeasure_Collect_T[unfolded space_T], (measurable; fail))
	apply (subst (2) emeasure_Collect_T[unfolded space_T], (measurable; fail))
	apply (simp add: K_def)
	done

	lemma T'_I_T:
	"T' (I s) {\<omega> \<in> space S. \<exists>o \<omega>'. \<omega> = (s, o) ## zip as os @- \<omega>'} = T (s,o) {\<omega> \<in> space S. V os as \<omega>}"
	proof -
	have "(\<Sum>o\<in>\<O>\<^sub>s. T (s, o) {\<omega> \<in> space S. V os as \<omega>}) =
	of_nat (card \<O>\<^sub>s) * T (s, o) {\<omega> \<in> space S. V os as \<omega>}" for as
	by (subst sum_constant[symmetric]) (fastforce intro: sum.cong T_init_V_eq[simplified])
	then show ?thesis
	unfolding max_prob_def
	apply (subst emeasure_T')
	subgoal
	by measurable
	apply (simp add: I_def in_S observations_finite observations_wellformed nn_integral_pmf_of_set)
	apply (subst mult.commute)
	apply (simp add: observations_finite observations_wellformed mult_divide_eq_ennreal)
	done
	qed

	lemma max_prob_init:
	"max_prob s os = Max {T (s,o) {\<omega> \<in> space S. V os as \<omega>} \| as. length as = length os \<and> set as \<subseteq> \<S>}"
	unfolding max_prob_def by (simp add: T'_I_T[symmetric])

	lemma max_prob_Nil[simp]:
	"max_prob s [] = 1"
	unfolding max_prob_init[where o = obs] by auto

	lemma Max_start:
	"(MAX t\<in>\<S>. (indicator {t} s :: ennreal)) = 1" if "s \<in> \<S>"
	using states_finite that by (auto simp: indicator_def intro: Max_eqI)

	lemma Max_V_viterbi:
	"(MAX t \<in> \<S>. viterbi_prob s t os) =
	Max {T (s, o) {\<omega> \<in> space S. V os as \<omega>} \| as. length as = length os \<and> set as \<subseteq> \<S>}" if "s \<in> \<S>"
	using that states_finite states_wellformed
	by (induction os arbitrary: s o; simp
	add: Max_start max_prob_Cons[simplified] Max_image_commute Max_image_left_mult Max_to_image2
	cong: Max_image_cong
	)

	lemma max_prob_viterbi:
	"(MAX t \<in> \<S>. viterbi_prob s t os) = max_prob s os" if "s \<in> \<S>"
	using max_prob_init[of s os] Max_V_viterbi[OF \<open>s \<in> \<S>\<close>, symmetric] by simp

	end

	subsection \<open>Decoding the Most Probable Hidden State Sequence\<close>

	context HMM3
	begin

	fun viterbi where
	"viterbi s t_end [] = ([], indicator {t_end} s)" \|
	"viterbi s t_end (o # os) = fst (
	argmax snd (map
	(\<lambda>t. let (xs, v) = viterbi t t_end os in (t # xs, ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * v))
	state_list))"

	lemma state_list_nonempty:
	"state_list \<noteq> []"
	using state_list_\<S> states_wellformed by auto

	lemma viterbi_viterbi_prob:
	"snd (viterbi s t_end os) = viterbi_prob s t_end os"
	proof (induction os arbitrary: s)
	case Nil
	then show ?case
	by simp
	next
	case (Cons o os)
	let ?f =
	"\<lambda>t. let (xs, v) = viterbi t t_end os in (t # xs, ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * v)"
	let ?xs = "map ?f state_list"
	from state_list_nonempty have "map ?f state_list \<noteq> []"
	by simp
	from argmax(2,3)[OF this, of snd] have *:
	"snd (fst (argmax snd ?xs)) = snd (argmax snd ?xs)"
	"snd (argmax snd ?xs) = (MAX x \<in> set ?xs. snd x)" .
	then show ?case
	apply (simp add: state_list_\<S>)
	apply (rule Max_eq_image_if)
	apply (intro finite_imageI states_finite; fail)
	apply (intro finite_imageI states_finite; fail)
	subgoal
	apply clarsimp
	subgoal for x
	using Cons.IH[of x] by (auto split: prod.splits)
	done
	apply clarsimp
	subgoal for x
	using Cons.IH[of x] by (force split: prod.splits)
	done
	qed

	context
	begin

	private fun val_of where
	"val_of s [] [] = 1" \|
	"val_of s (t # xs) (o # os) = ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * val_of t xs os"

	lemma val_of_T:
	"val_of s as os = T (s, o\<^sub>1) {\<omega> \<in> space S. V os as \<omega>}" if "length as = length os"
	using that by (induction arbitrary: o\<^sub>1 rule: val_of.induct; (subst T_V_Cons)?; simp)

	lemma viterbi_sequence:
	"snd (viterbi s t_end os) = val_of s (fst (viterbi s t_end os)) os"
	if "snd (viterbi s t_end os) > 0"
	using that
	proof (induction os arbitrary: s)
	case Nil
	then show ?case
	- by (simp add: indicator_def split: if_split_asm)
	+ by (simp add: indicator_def split: if_split_asm split_of_bool_asm)
	next
	case (Cons o os s)
	let ?xs = "map
	(\<lambda>t. let (xs, v) = viterbi t t_end os in (t # xs, ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * v))
	state_list"
	from state_list_nonempty have "?xs \<noteq> []"
	by simp
	from argmax(1)[OF this, of snd] obtain t where
	"t \<in> set state_list"
	"fst (argmax snd ?xs) =
	(t # fst (viterbi t t_end os), ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * snd (viterbi t t_end os))"
	by (auto split: prod.splits)
	with Cons show ?case
	by (auto simp: ennreal_zero_less_mult_iff)
	qed

	lemma viterbi_valid_path:
	"length as = length os \<and> set as \<subseteq> \<S>" if "viterbi s t_end os = (as, v)"
	using that proof (induction os arbitrary: s as v)
	case Nil
	then show ?case
	by simp
	next
	case (Cons o os s as v)
	let ?xs = "map
	(\<lambda>t. let (xs, v) = viterbi t t_end os in (t # xs, ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * v))
	state_list"
	from state_list_nonempty have "?xs \<noteq> []"
	by simp
	from argmax(1)[OF this, of snd] obtain t where "t \<in> \<S>"
	"fst (argmax snd ?xs) =
	(t # fst (viterbi t t_end os), ennreal (pmf (\<O> t) o * pmf (\<K> s) t) * snd (viterbi t t_end os))"
	by (auto simp: state_list_\<S> split: prod.splits)
	with Cons.prems show ?case
	by (cases "viterbi t t_end os"; simp add: Cons.IH)
	qed

	definition
	"viterbi_final s os = fst (argmax snd (map (\<lambda> t. viterbi s t os) state_list))"

	lemma viterbi_finalE:
	obtains t where
	"t \<in> \<S>" "viterbi_final s os = viterbi s t os"
	"snd (viterbi s t os) = Max ((\<lambda>t. snd (viterbi s t os)) ` \<S>)"
	proof -
	from state_list_nonempty have "map (\<lambda> t. viterbi s t os) state_list \<noteq> []"
	by simp
	from argmax[OF this, of snd] show ?thesis
	by (auto simp: state_list_\<S> image_comp comp_def viterbi_final_def intro: that)
	qed

	theorem viterbi_final_max_prob:
	assumes "viterbi_final s os = (as, v)" "s \<in> \<S>"
	shows "v = max_prob s os"
	proof -
	obtain t where "t \<in> \<S>" "viterbi_final s os = viterbi s t os"
	"snd (viterbi s t os) = Max ((\<lambda>t. snd (viterbi s t os)) ` \<S>)"
	by (rule viterbi_finalE)
	with assms show ?thesis
	by (simp add: viterbi_viterbi_prob max_prob_viterbi)
	qed

	theorem viterbi_final_is_decoding:
	assumes "viterbi_final s os = (as, v)" "v > 0" "s \<in> \<S>"
	shows "is_decoding s os as"
	proof -
	from viterbi_valid_path[of s _ os as v] assms have as: "length as = length os" "set as \<subseteq> \<S>"
	by - (rule viterbi_finalE[of s os]; simp)+
	obtain t where "t \<in> \<S>" "viterbi_final s os = viterbi s t os"
	by (rule viterbi_finalE)
	with assms viterbi_sequence[of s t os] have "val_of s as os = v"
	by (cases "viterbi s t os") (auto simp: snd_def split!: prod.splits)
	with val_of_T as have "max_prob s os = T (s, obs) {\<omega> \<in> space S. V os as \<omega>}"
	by (simp add: viterbi_final_max_prob[OF assms(1,3)])
	with as show ?thesis
	unfolding is_decoding_def by (simp only: T'_I_T)
	qed

	end (* Anonymous context *)

	end (* HMM 3 *)

	end (* Theory *)
	\ No newline at end of file
	diff --git a/thys/IEEE_Floating_Point/IEEE.thy b/thys/IEEE_Floating_Point/IEEE.thy
	--- a/thys/IEEE_Floating_Point/IEEE.thy
	+++ b/thys/IEEE_Floating_Point/IEEE.thy
	@@ -1,448 +1,457 @@
	(* Formalization of IEEE-754 Standard for binary floating-point arithmetic *)
	-(* Author: Lei Yu, University of Cambridge *)
	+(* Author: Lei Yu, University of Cambridge
	+
	+ Contrib: Peter Lammich: fixed wrong sign handling in fmadd
	+
	+*)

	section \<open>Specification of the IEEE standard\<close>

	theory IEEE
	imports
	"HOL-Library.Float"
	Word_Lib.Word_Lemmas
	begin

	typedef (overloaded) ('e::len, 'f::len) float = "UNIV::(1 word \<times> 'e word \<times> 'f word) set"
	by auto

	setup_lifting type_definition_float

	syntax "_float" :: "type \<Rightarrow> type \<Rightarrow> type" ("'(_, _') float")
	text \<open>parse \<open>('a, 'b) float\<close> as ('a::len, 'b::len) float.\<close>

	parse_translation \<open>
	let
	fun float t u = Syntax.const @{type_syntax float} $ t $ u;
	fun len_tr u =
	(case Term_Position.strip_positions u of
	v as Free (x, _) =>
	if Lexicon.is_tid x then
	(Syntax.const @{syntax_const "_ofsort"} $ v $
	Syntax.const @{class_syntax len})
	else u
	\| _ => u)
	fun len_float_tr [t, u] =
	float (len_tr t) (len_tr u)
	in
	[(@{syntax_const "_float"}, K len_float_tr)]
	end
	\<close>

	subsection \<open>Derived parameters for floating point formats\<close>

	definition wordlength :: "('e, 'f) float itself \<Rightarrow> nat"
	where "wordlength x = LENGTH('e) + LENGTH('f) + 1"

	definition bias :: "('e, 'f) float itself \<Rightarrow> nat"
	where "bias x = 2^(LENGTH('e) - 1) - 1"

	definition emax :: "('e, 'f) float itself \<Rightarrow> nat"
	where "emax x = unat (- 1::'e word)"

	abbreviation fracwidth::"('e, 'f) float itself \<Rightarrow> nat" where
	"fracwidth _ \<equiv> LENGTH('f)"

	subsection \<open>Predicates for the four IEEE formats\<close>

	definition is_single :: "('e, 'f) float itself \<Rightarrow> bool"
	where "is_single x \<longleftrightarrow> LENGTH('e) = 8 \<and> wordlength x = 32"

	definition is_double :: "('e, 'f) float itself \<Rightarrow> bool"
	where "is_double x \<longleftrightarrow> LENGTH('e) = 11 \<and> wordlength x = 64"

	definition is_single_extended :: "('e, 'f) float itself \<Rightarrow> bool"
	where "is_single_extended x \<longleftrightarrow> LENGTH('e) \<ge> 11 \<and> wordlength x \<ge> 43"

	definition is_double_extended :: "('e, 'f) float itself \<Rightarrow> bool"
	where "is_double_extended x \<longleftrightarrow> LENGTH('e) \<ge> 15 \<and> wordlength x \<ge> 79"


	subsection \<open>Extractors for fields\<close>

	lift_definition sign::"('e, 'f) float \<Rightarrow> nat" is
	"\<lambda>(s::1 word, _::'e word, _::'f word). unat s" .

	lift_definition exponent::"('e, 'f) float \<Rightarrow> nat" is
	"\<lambda>(_, e::'e word, _). unat e" .

	lift_definition fraction::"('e, 'f) float \<Rightarrow> nat" is
	"\<lambda>(_, _, f::'f word). unat f" .

	abbreviation "real_of_word x \<equiv> real (unat x)"

	lift_definition valof :: "('e, 'f) float \<Rightarrow> real"
	is "\<lambda>(s, e, f).
	let x = (TYPE(('e, 'f) float)) in
	(if e = 0
	then (-1::real)^(unat s) * (2 / (2^bias x)) * (real_of_word f/2^(LENGTH('f)))
	else (-1::real)^(unat s) * ((2^(unat e)) / (2^bias x)) * (1 + real_of_word f/2^LENGTH('f)))"
	.

	subsection \<open>Partition of numbers into disjoint classes\<close>

	definition is_nan :: "('e, 'f) float \<Rightarrow> bool"
	where "is_nan a \<longleftrightarrow> exponent a = emax TYPE(('e, 'f)float) \<and> fraction a \<noteq> 0"

	definition is_infinity :: "('e, 'f) float \<Rightarrow> bool"
	where "is_infinity a \<longleftrightarrow> exponent a = emax TYPE(('e, 'f)float) \<and> fraction a = 0"

	definition is_normal :: "('e, 'f) float \<Rightarrow> bool"
	where "is_normal a \<longleftrightarrow> 0 < exponent a \<and> exponent a < emax TYPE(('e, 'f)float)"

	definition is_denormal :: "('e, 'f) float \<Rightarrow> bool"
	where "is_denormal a \<longleftrightarrow> exponent a = 0 \<and> fraction a \<noteq> 0"

	definition is_zero :: "('e, 'f) float \<Rightarrow> bool"
	where "is_zero a \<longleftrightarrow> exponent a = 0 \<and> fraction a = 0"

	definition is_finite :: "('e, 'f) float \<Rightarrow> bool"
	where "is_finite a \<longleftrightarrow> (is_normal a \<or> is_denormal a \<or> is_zero a)"


	subsection \<open>Special values\<close>

	lift_definition plus_infinity :: "('e, 'f) float" ("\<infinity>") is "(0, - 1, 0)" .

	lift_definition topfloat :: "('e, 'f) float" is "(0, - 2, 2^LENGTH('f) - 1)" .

	instantiation float::(len, len) zero begin

	lift_definition zero_float :: "('e, 'f) float" is "(0, 0, 0)" .

	instance proof qed

	end

	subsection \<open>Negation operation on floating point values\<close>

	instantiation float::(len, len) uminus begin
	lift_definition uminus_float :: "('e, 'f) float \<Rightarrow> ('e, 'f) float" is "\<lambda>(s, e, f). (1 - s, e, f)" .
	instance proof qed
	end

	abbreviation (input) "minus_zero \<equiv> - (0::('e, 'f)float)"
	abbreviation (input) "minus_infinity \<equiv> - \<infinity>"
	abbreviation (input) "bottomfloat \<equiv> - topfloat"


	subsection \<open>Real number valuations\<close>

	text \<open>The largest value that can be represented in floating point format.\<close>
	definition largest :: "('e, 'f) float itself \<Rightarrow> real"
	where "largest x = (2^(emax x - 1) / 2^bias x) * (2 - 1/(2^fracwidth x))"

	text \<open>Threshold, used for checking overflow.\<close>
	definition threshold :: "('e, 'f) float itself \<Rightarrow> real"
	where "threshold x = (2^(emax x - 1) / 2^bias x) * (2 - 1/(2^(Suc(fracwidth x))))"

	text \<open>Unit of least precision.\<close>

	lift_definition one_lp::"('e ,'f) float \<Rightarrow> ('e ,'f) float" is "\<lambda>(s, e, f). (0, e::'e word, 1)" .
	lift_definition zero_lp::"('e ,'f) float \<Rightarrow> ('e ,'f) float" is "\<lambda>(s, e, f). (0, e::'e word, 0)" .

	definition ulp :: "('e, 'f) float \<Rightarrow> real" where "ulp a = valof (one_lp a) - valof (zero_lp a)"

	text \<open>Enumerated type for rounding modes.\<close>
	datatype roundmode = To_nearest \| float_To_zero \| To_pinfinity \| To_ninfinity

	text \<open>Characterization of best approximation from a set of abstract values.\<close>
	definition "is_closest v s x a \<longleftrightarrow> a \<in> s \<and> (\<forall>b. b \<in> s \<longrightarrow> \<bar>v a - x\<bar> \<le> \<bar>v b - x\<bar>)"

	text \<open>Best approximation with a deciding preference for multiple possibilities.\<close>
	definition "closest v p s x =
	(SOME a. is_closest v s x a \<and> ((\<exists>b. is_closest v s x b \<and> p b) \<longrightarrow> p a))"


	subsection \<open>Rounding\<close>

	fun round :: "roundmode \<Rightarrow> real \<Rightarrow> ('e ,'f) float"
	where
	"round To_nearest y =
	(if y \<le> - threshold TYPE(('e ,'f) float) then minus_infinity
	else if y \<ge> threshold TYPE(('e ,'f) float) then plus_infinity
	else closest (valof) (\<lambda>a. even (fraction a)) {a. is_finite a} y)"
	\| "round float_To_zero y =
	(if y < - largest TYPE(('e ,'f) float) then bottomfloat
	else if y > largest TYPE(('e ,'f) float) then topfloat
	else closest (valof) (\<lambda>a. True) {a. is_finite a \<and> \<bar>valof a\<bar> \<le> \<bar>y\<bar>} y)"
	\| "round To_pinfinity y =
	(if y < - largest TYPE(('e ,'f) float) then bottomfloat
	else if y > largest TYPE(('e ,'f) float) then plus_infinity
	else closest (valof) (\<lambda>a. True) {a. is_finite a \<and> valof a \<ge> y} y)"
	\| "round To_ninfinity y =
	(if y < - largest TYPE(('e ,'f) float) then minus_infinity
	else if y > largest TYPE(('e ,'f) float) then topfloat
	else closest (valof) (\<lambda>a. True) {a. is_finite a \<and> valof a \<le> y} y)"

	text \<open>Rounding to integer values in floating point format.\<close>

	definition is_integral :: "('e ,'f) float \<Rightarrow> bool"
	where "is_integral a \<longleftrightarrow> is_finite a \<and> (\<exists>n::nat. \<bar>valof a\<bar> = real n)"

	fun intround :: "roundmode \<Rightarrow> real \<Rightarrow> ('e ,'f) float"
	where
	"intround To_nearest y =
	(if y \<le> - threshold TYPE(('e ,'f) float) then minus_infinity
	else if y \<ge> threshold TYPE(('e ,'f) float) then plus_infinity
	else closest (valof) (\<lambda>a. (\<exists>n::nat. even n \<and> \<bar>valof a\<bar> = real n)) {a. is_integral a} y)"
	\|"intround float_To_zero y =
	(if y < - largest TYPE(('e ,'f) float) then bottomfloat
	else if y > largest TYPE(('e ,'f) float) then topfloat
	else closest (valof) (\<lambda>x. True) {a. is_integral a \<and> \<bar>valof a\<bar> \<le> \<bar>y\<bar>} y)"
	\|"intround To_pinfinity y =
	(if y < - largest TYPE(('e ,'f) float) then bottomfloat
	else if y > largest TYPE(('e ,'f) float) then plus_infinity
	else closest (valof) (\<lambda>x. True) {a. is_integral a \<and> valof a \<ge> y} y)"
	\|"intround To_ninfinity y =
	(if y < - largest TYPE(('e ,'f) float) then minus_infinity
	else if y > largest TYPE(('e ,'f) float) then topfloat
	else closest (valof) (\<lambda>x. True) {a. is_integral a \<and> valof a \<ge> y} y)"

	text \<open>Round, choosing between -0.0 or +0.0\<close>

	definition float_round::"roundmode \<Rightarrow> bool \<Rightarrow> real \<Rightarrow> ('e, 'f) float"
	where "float_round mode toneg r =
	(let x = round mode r in
	if is_zero x
	then if toneg
	then minus_zero
	else 0
	else x)"

	text \<open>Non-standard of NaN.\<close>
	definition some_nan :: "('e ,'f) float"
	where "some_nan = (SOME a. is_nan a)"

	text \<open>Coercion for signs of zero results.\<close>
	definition zerosign :: "nat \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "zerosign s a =
	(if is_zero a then (if s = 0 then 0 else - 0) else a)"

	text \<open>Remainder operation.\<close>
	definition rem :: "real \<Rightarrow> real \<Rightarrow> real"
	where "rem x y =
	(let n = closest id (\<lambda>x. \<exists>n::nat. even n \<and> \<bar>x\<bar> = real n) {x. \<exists>n :: nat. \<bar>x\<bar> = real n} (x / y)
	in x - n * y)"

	definition frem :: "roundmode \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "frem m a b =
	(if is_nan a \<or> is_nan b \<or> is_infinity a \<or> is_zero b then some_nan
	else zerosign (sign a) (round m (rem (valof a) (valof b))))"


	subsection \<open>Definitions of the arithmetic operations\<close>

	definition fintrnd :: "roundmode \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "fintrnd m a =
	(if is_nan a then (some_nan)
	else if is_infinity a then a
	else zerosign (sign a) (intround m (valof a)))"

	definition fadd :: "roundmode \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "fadd m a b =
	(if is_nan a \<or> is_nan b \<or> (is_infinity a \<and> is_infinity b \<and> sign a \<noteq> sign b)
	then some_nan
	else if (is_infinity a) then a
	else if (is_infinity b) then b
	else
	zerosign
	(if is_zero a \<and> is_zero b \<and> sign a = sign b then sign a
	else if m = To_ninfinity then 1 else 0)
	(round m (valof a + valof b)))"

	definition fsub :: "roundmode \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "fsub m a b =
	(if is_nan a \<or> is_nan b \<or> (is_infinity a \<and> is_infinity b \<and> sign a = sign b)
	then some_nan
	else if is_infinity a then a
	else if is_infinity b then - b
	else
	zerosign
	(if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then sign a
	else if m = To_ninfinity then 1 else 0)
	(round m (valof a - valof b)))"

	definition fmul :: "roundmode \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "fmul m a b =
	(if is_nan a \<or> is_nan b \<or> (is_zero a \<and> is_infinity b) \<or> (is_infinity a \<and> is_zero b)
	then some_nan
	else if is_infinity a \<or> is_infinity b
	then (if sign a = sign b then plus_infinity else minus_infinity)
	else zerosign (if sign a = sign b then 0 else 1 ) (round m (valof a * valof b)))"

	definition fdiv :: "roundmode \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "fdiv m a b =
	(if is_nan a \<or> is_nan b \<or> (is_zero a \<and> is_zero b) \<or> (is_infinity a \<and> is_infinity b)
	then some_nan
	else if is_infinity a \<or> is_zero b
	then (if sign a = sign b then plus_infinity else minus_infinity)
	else if is_infinity b
	then (if sign a = sign b then 0 else - 0)
	else zerosign (if sign a = sign b then 0 else 1) (round m (valof a / valof b)))"

	definition fsqrt :: "roundmode \<Rightarrow> ('e ,'f) float \<Rightarrow> ('e ,'f) float"
	where "fsqrt m a =
	(if is_nan a then some_nan
	else if is_zero a \<or> is_infinity a \<and> sign a = 0 then a
	else if sign a = 1 then some_nan
	else zerosign (sign a) (round m (sqrt (valof a))))"

	definition fmul_add :: "roundmode \<Rightarrow> ('t ,'w) float \<Rightarrow> ('t ,'w) float \<Rightarrow> ('t ,'w) float \<Rightarrow> ('t ,'w) float"
	- where "fmul_add mode x y z =
	- (let signP = if sign x = sign y then 0 else 1 in
	- let infP = is_infinity x \<or> is_infinity y
	- in
	- if is_nan x \<or> is_nan y \<or> is_nan z then some_nan
	- else if is_infinity x \<and> is_zero y \<or>
	- is_zero x \<and> is_infinity y \<or>
	- is_infinity z \<and> infP \<and> signP \<noteq> sign z then
	- some_nan
	- else if is_infinity z \<and> (sign z = 0) \<or> infP \<and> (signP = 0)
	- then plus_infinity
	- else if is_infinity z \<and> (sign z = 1) \<or> infP \<and> (signP = 1)
	- then minus_infinity
	- else
	- let r1 = valof x * valof y;
	- r2 = valof z
	- in
	- float_round mode
	- (if (r1 = 0) \<and> (r2 = 0) \<and> (signP = sign z) then
	- signP = 1
	- else mode = To_ninfinity) (r1 + r2))"
	+ where "fmul_add mode x y z = (let
	+ signP = if sign x = sign y then 0 else 1;
	+ infP = is_infinity x \<or> is_infinity y
	+ in
	+ if is_nan x \<or> is_nan y \<or> is_nan z then some_nan
	+ else if is_infinity x \<and> is_zero y \<or>
	+ is_zero x \<and> is_infinity y \<or>
	+ is_infinity z \<and> infP \<and> signP \<noteq> sign z
	+ then some_nan
	+ else if is_infinity z \<and> (sign z = 0) \<or> infP \<and> (signP = 0)
	+ then plus_infinity
	+ else if is_infinity z \<and> (sign z = 1) \<or> infP \<and> (signP = 1)
	+ then minus_infinity
	+ else let
	+ r1 = valof x * valof y;
	+ r2 = valof z;
	+ r = r1+r2
	+ in
	+ if r=0 then ( \<comment> \<open>Exact Zero Case. Same sign rules as for add apply. \<close>
	+ if r1=0 \<and> r2=0 \<and> signP=sign z then zerosign signP 0
	+ else if mode = To_ninfinity then -0
	+ else 0
	+ ) else ( \<comment> \<open>Not exactly zero: Rounding has sign of exact value, even if rounded val is zero\<close>
	+ zerosign (if r<0 then 1 else 0) (round mode r)
	+ )
	+ )"


	subsection \<open>Comparison operations\<close>

	datatype ccode = Gt \| Lt \| Eq \| Und

	definition fcompare :: "('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> ccode"
	where "fcompare a b =
	(if is_nan a \<or> is_nan b then Und
	else if is_infinity a \<and> sign a = 1
	then (if is_infinity b \<and> sign b = 1 then Eq else Lt)
	else if is_infinity a \<and> sign a = 0
	then (if is_infinity b \<and> sign b = 0 then Eq else Gt)
	else if is_infinity b \<and> sign b = 1 then Gt
	else if is_infinity b \<and> sign b = 0 then Lt
	else if valof a < valof b then Lt
	else if valof a = valof b then Eq
	else Gt)"

	definition flt :: "('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> bool"
	where "flt a b \<longleftrightarrow> fcompare a b = Lt"

	definition fle :: "('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> bool"
	where "fle a b \<longleftrightarrow> fcompare a b = Lt \<or> fcompare a b = Eq"

	definition fgt :: "('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> bool"
	where "fgt a b \<longleftrightarrow> fcompare a b = Gt"

	definition fge :: "('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> bool"
	where "fge a b \<longleftrightarrow> fcompare a b = Gt \<or> fcompare a b = Eq"

	definition feq :: "('e ,'f) float \<Rightarrow> ('e ,'f) float \<Rightarrow> bool"
	where "feq a b \<longleftrightarrow> fcompare a b = Eq"


	section \<open>Specify float to be double precision and round to even\<close>

	instantiation float :: (len, len) plus
	begin

	definition plus_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "a + b = fadd To_nearest a b"

	instance ..

	end

	instantiation float :: (len, len) minus
	begin

	definition minus_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "a - b = fsub To_nearest a b"

	instance ..

	end

	instantiation float :: (len, len) times
	begin

	definition times_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "a * b = fmul To_nearest a b"

	instance ..

	end

	instantiation float :: (len, len) one
	begin

	lift_definition one_float :: "('a, 'b) float" is "(0, 2^(LENGTH('a) - 1) - 1, 0)" .

	instance ..

	end

	instantiation float :: (len, len) inverse
	begin

	definition divide_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "a div b = fdiv To_nearest a b"

	definition inverse_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "inverse_float a = fdiv To_nearest 1 a"

	instance ..

	end

	definition float_rem :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "float_rem a b = frem To_nearest a b"

	definition float_sqrt :: "('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "float_sqrt a = fsqrt To_nearest a"

	definition ROUNDFLOAT ::"('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "ROUNDFLOAT a = fintrnd To_nearest a"


	instantiation float :: (len, len) ord
	begin

	definition less_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> bool"
	where "a < b \<longleftrightarrow> flt a b"

	definition less_eq_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> bool"
	where "a \<le> b \<longleftrightarrow> fle a b"

	instance ..

	end

	definition float_eq :: "('a, 'b) float \<Rightarrow> ('a, 'b) float \<Rightarrow> bool" (infixl "\<doteq>" 70)
	where "float_eq a b = feq a b"

	instantiation float :: (len, len) abs
	begin

	definition abs_float :: "('a, 'b) float \<Rightarrow> ('a, 'b) float"
	where "abs_float a = (if sign a = 0 then a else - a)"

	instance ..
	end

	text \<open>The \<open>1 + \<epsilon>\<close> property.\<close>
	definition normalizes :: "_ itself \<Rightarrow> real \<Rightarrow> bool"
	where "normalizes float_format x =
	(1/ (2::real)^(bias float_format - 1) \<le> \<bar>x\<bar> \<and> \<bar>x\<bar> < threshold float_format)"

	end
	diff --git a/thys/Interpolation_Polynomials_HOL_Algebra/Bounded_Degree_Polynomials.thy b/thys/Interpolation_Polynomials_HOL_Algebra/Bounded_Degree_Polynomials.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Interpolation_Polynomials_HOL_Algebra/Bounded_Degree_Polynomials.thy
	@@ -0,0 +1,160 @@
	+section \<open>Bounded Degree Polynomials\<close>
	+
	+text \<open>This section contains a definition for the set of polynomials with a degree bound and
	+establishes its cardinality.\<close>
	+
	+theory Bounded_Degree_Polynomials
	+ imports "HOL-Algebra.Polynomial_Divisibility"
	+begin
	+
	+lemma (in ring) coeff_in_carrier: "p \<in> carrier (poly_ring R) \<Longrightarrow> coeff p i \<in> carrier R"
	+ using poly_coeff_in_carrier carrier_is_subring by (simp add: univ_poly_carrier)
	+
	+definition bounded_degree_polynomials
	+ where "bounded_degree_polynomials F n = {x. x \<in> carrier (poly_ring F) \<and> (degree x < n \<or> x = [])}"
	+
	+text \<open>Note: The definition for @{term "bounded_degree_polynomials"} includes the zero polynomial
	+in @{term "bounded_degree_polynomials F 0"}. The reason for this adjustment is that, contrary to
	+definition in HOL Algebra, most authors set the degree of the zero polynomial to
	+$-\infty$~\cite[\textsection 7.2.2]{shoup2009computational}. That
	+definition make some identities, such as $\mathrm{deg}(f g) = \mathrm{deg}\, f + \mathrm{deg}\, g$
	+for polynomials $f$ and $g$ unconditionally true.
	+In particular, it prevents an unnecessary corner case in the statement of the results established
	+in this entry.\<close>
	+
	+lemma bounded_degree_polynomials_length:
	+ "bounded_degree_polynomials F n = {x. x \<in> carrier (poly_ring F) \<and> length x \<le> n}"
	+ unfolding bounded_degree_polynomials_def using leI order_less_le_trans by fastforce
	+
	+lemma (in ring) fin_degree_bounded:
	+ assumes "finite (carrier R)"
	+ shows "finite (bounded_degree_polynomials R n)"
	+proof -
	+ have "bounded_degree_polynomials R n \<subseteq> {p. set p \<subseteq> carrier R \<and> length p \<le> n}"
	+ unfolding bounded_degree_polynomials_length
	+ using assms polynomial_incl univ_poly_carrier by blast
	+ thus ?thesis
	+ using assms finite_lists_length_le finite_subset by fast
	+qed
	+
	+lemma (in ring) non_empty_bounded_degree_polynomials:
	+ "bounded_degree_polynomials R k \<noteq> {}"
	+proof -
	+ have "\<zero>\<^bsub>poly_ring R\<^esub> \<in> bounded_degree_polynomials R k"
	+ by (simp add: bounded_degree_polynomials_def univ_poly_zero univ_poly_zero_closed)
	+ thus ?thesis by auto
	+qed
	+
	+lemma in_image_by_witness:
	+ assumes "\<And>x. x \<in> A \<Longrightarrow> g x \<in> B \<and> f (g x) = x"
	+ shows "A \<subseteq> f ` B"
	+ by (metis assms image_eqI subsetI)
	+
	+lemma card_mostly_constant_maps:
	+ assumes "y \<in> B"
	+ shows "card {f. range f \<subseteq> B \<and> (\<forall>x. x \<ge> n \<longrightarrow> f x = y)} = card B ^ n" (is "card ?A = ?B")
	+proof -
	+ define f where "f = (\<lambda>f k. if k < n then f k else y)"
	+
	+ have a:"?A \<subseteq> (f ` ({0..<n} \<rightarrow>\<^sub>E B))"
	+ unfolding f_def
	+ by (rule in_image_by_witness[where g="\<lambda>f. restrict f {0..<n}"], auto)
	+
	+ have b:"(f ` ({0..<n} \<rightarrow>\<^sub>E B)) \<subseteq> ?A"
	+ using f_def assms by auto
	+
	+ have c: "inj_on f ({0..<n} \<rightarrow>\<^sub>E B)"
	+ by (rule inj_onI, metis PiE_E atLeastLessThan_iff ext f_def)
	+
	+ have "card ?A = card (f ` ({0..<n} \<rightarrow>\<^sub>E B))"
	+ using a b by auto
	+ also have "... = card ({0..<n} \<rightarrow>\<^sub>E B)"
	+ by (metis c card_image)
	+ also have "... = card B ^ n"
	+ by (simp add: card_PiE[OF finite_atLeastLessThan])
	+ finally show ?thesis by simp
	+qed
	+
	+definition (in ring) build_poly where
	+ "build_poly f n = normalize (rev (map f [0..<n]))"
	+
	+lemma (in ring) poly_degree_bound_from_coeff:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ assumes "\<And>k. k \<ge> n \<Longrightarrow> coeff x k = \<zero>"
	+ shows "degree x < n \<or> x = \<zero>\<^bsub>poly_ring R\<^esub>"
	+proof (rule ccontr)
	+ assume a:"\<not>(degree x < n \<or> x = \<zero>\<^bsub>poly_ring R\<^esub>)"
	+ hence b:"lead_coeff x \<noteq> \<zero>\<^bsub>R\<^esub>"
	+ by (metis assms(1) polynomial_def univ_poly_carrier univ_poly_zero)
	+ hence "coeff x (degree x) \<noteq> \<zero>"
	+ by (metis a lead_coeff_simp univ_poly_zero)
	+ moreover have "degree x \<ge> n" by (meson a not_le)
	+ ultimately show "False" using assms(2) by blast
	+qed
	+
	+lemma (in ring) poly_degree_bound_from_coeff_1:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ assumes "\<And>k. k \<ge> n \<Longrightarrow> coeff x k = \<zero>"
	+ shows "x \<in> bounded_degree_polynomials R n"
	+ using poly_degree_bound_from_coeff[OF assms]
	+ by (simp add:bounded_degree_polynomials_def univ_poly_zero assms)
	+
	+lemma (in ring) length_build_poly:
	+ "length (build_poly f n) \<le> n"
	+ by (metis length_map build_poly_def normalize_length_le length_rev length_upt
	+ less_imp_diff_less linorder_not_less)
	+
	+lemma (in ring) build_poly_degree:
	+ "degree (build_poly f n) \<le> n-1"
	+ using length_build_poly diff_le_mono by presburger
	+
	+lemma (in ring) build_poly_poly:
	+ assumes "\<And>i. i < n \<Longrightarrow> f i \<in> carrier R"
	+ shows "build_poly f n \<in> carrier (poly_ring R)"
	+ unfolding build_poly_def univ_poly_carrier[symmetric]
	+ by (rule normalize_gives_polynomial, simp add:image_subset_iff Ball_def assms)
	+
	+lemma (in ring) build_poly_coeff:
	+ "coeff (build_poly f n) i = (if i < n then f i else \<zero>)"
	+proof -
	+ show "coeff (build_poly f n) i = (if i < n then f i else \<zero>)"
	+ unfolding build_poly_def normalize_coeff[symmetric]
	+ by (cases "i < n", (simp add:coeff_nth rev_nth coeff_length)+)
	+qed
	+
	+lemma (in ring) build_poly_bounded:
	+ assumes "\<And>k. k < n \<Longrightarrow> f k \<in> carrier R"
	+ shows "build_poly f n \<in> bounded_degree_polynomials R n"
	+ unfolding bounded_degree_polynomials_length
	+ using build_poly_poly[OF assms] length_build_poly by auto
	+
	+text \<open>The following establishes the total number of polynomials with a degree less than $n$.
	+Unlike the results in the following sections, it is already possible to establish this property for
	+polynomials with coefficients in a ring.\<close>
	+
	+lemma (in ring) bounded_degree_polynomials_card:
	+ "card (bounded_degree_polynomials R n) = card (carrier R) ^ n"
	+proof -
	+ have a:"coeff ` bounded_degree_polynomials R n \<subseteq> {f. range f \<subseteq> (carrier R) \<and> (\<forall>k \<ge> n. f k = \<zero>)}"
	+ by (rule image_subsetI, auto simp add:bounded_degree_polynomials_def coeff_length coeff_in_carrier)
	+
	+ have b:"{f. range f \<subseteq> (carrier R) \<and> (\<forall>k \<ge> n. f k = \<zero>)} \<subseteq> coeff ` bounded_degree_polynomials R n"
	+ apply (rule in_image_by_witness[where g="\<lambda>x. build_poly x n"])
	+ by (auto simp add:build_poly_coeff intro:build_poly_bounded)
	+
	+ have "inj_on coeff (carrier (poly_ring R))"
	+ by (rule inj_onI, simp add: coeff_iff_polynomial_cond univ_poly_carrier)
	+
	+ hence coeff_inj: "inj_on coeff (bounded_degree_polynomials R n)"
	+ using inj_on_subset bounded_degree_polynomials_def by blast
	+
	+ have "card ( bounded_degree_polynomials R n) = card (coeff ` bounded_degree_polynomials R n)"
	+ using coeff_inj card_image[symmetric] by blast
	+ also have "... = card {f. range f \<subseteq> (carrier R) \<and> (\<forall>k \<ge> n. f k = \<zero>)}"
	+ by (rule arg_cong[where f="card"], rule order_antisym[OF a b])
	+ also have "... = card (carrier R)^n"
	+ by (rule card_mostly_constant_maps, simp)
	+ finally show ?thesis by simp
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Interpolation_Polynomials_HOL_Algebra/Interpolation_Polynomial_Cardinalities.thy b/thys/Interpolation_Polynomials_HOL_Algebra/Interpolation_Polynomial_Cardinalities.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Interpolation_Polynomials_HOL_Algebra/Interpolation_Polynomial_Cardinalities.thy
	@@ -0,0 +1,375 @@
	+section \<open>Cardinalities of Interpolation Polynomials\<close>
	+
	+text \<open>This section establishes the cardinalities of the set of polynomials with a degree bound
	+interpolating a given set of points.\<close>
	+
	+theory Interpolation_Polynomial_Cardinalities
	+ imports Bounded_Degree_Polynomials Lagrange_Interpolation
	+begin
	+
	+lemma (in ring) poly_add_coeff:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ assumes "y \<in> carrier (poly_ring R)"
	+ shows "coeff (x \<oplus>\<^bsub>poly_ring R\<^esub> y) k = coeff x k \<oplus> coeff y k"
	+ by (metis assms univ_poly_carrier polynomial_incl univ_poly_add poly_add_coeff)
	+
	+lemma (in domain) poly_neg_coeff:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ shows "coeff (\<ominus>\<^bsub>poly_ring R\<^esub> x) k = \<ominus>coeff x k"
	+proof -
	+ interpret x:cring "poly_ring R"
	+ using assms cring_def carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ have a:"\<zero>\<^bsub>poly_ring R\<^esub> = x \<ominus>\<^bsub>poly_ring R\<^esub> x"
	+ by (metis x.r_right_minus_eq assms(1))
	+
	+ have "\<zero> = coeff (\<zero>\<^bsub>poly_ring R\<^esub>) k" by (simp add:univ_poly_zero)
	+ also have "... = coeff x k \<oplus> coeff (\<ominus>\<^bsub>poly_ring R\<^esub> x) k" using a assms
	+ by (simp add:a_minus_def poly_add_coeff)
	+ finally have "\<zero> = coeff x k \<oplus> coeff (\<ominus>\<^bsub>poly_ring R\<^esub> x) k" by simp
	+ thus ?thesis
	+ by (metis local.minus_minus x.a_inv_closed sum_zero_eq_neg coeff_in_carrier assms)
	+qed
	+
	+lemma (in domain) poly_substract_coeff:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ assumes "y \<in> carrier (poly_ring R)"
	+ shows "coeff (x \<ominus>\<^bsub>poly_ring R\<^esub> y) k = coeff x k \<ominus> coeff y k"
	+proof -
	+ interpret x:cring "poly_ring R"
	+ using assms cring_def carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+ show ?thesis
	+ using assms by (simp add:a_minus_def poly_add_coeff poly_neg_coeff)
	+qed
	+
	+text \<open>A polynomial with more zeros than its degree is the zero polynomial.\<close>
	+
	+lemma (in field) max_roots:
	+ assumes "p \<in> carrier (poly_ring R)"
	+ assumes "K \<subseteq> carrier R"
	+ assumes "finite K"
	+ assumes "degree p < card K"
	+ assumes "\<And>x. x \<in> K \<Longrightarrow> eval p x = \<zero>"
	+ shows "p = \<zero>\<^bsub>poly_ring R\<^esub>"
	+proof (rule ccontr)
	+ assume "p \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>"
	+ hence a:"p \<noteq> []" by (simp add: univ_poly_zero)
	+ have "\<And>x. count (mset_set K) x \<le> count (roots p) x"
	+ proof -
	+ fix x
	+ show "count (mset_set K) x \<le> count (roots p) x"
	+ proof (cases "x \<in> K")
	+ case True
	+ hence "is_root p x"
	+ by (meson a assms(2,5) is_ring is_root_def subsetD)
	+ hence "x \<in> set_mset (roots p)"
	+ using assms(1) roots_mem_iff_is_root field_def by force
	+ hence "1 \<le> count (roots p) x" by simp
	+ moreover have "count (mset_set K) x = 1" using True assms(3) by simp
	+ ultimately show ?thesis by presburger
	+ next
	+ case False
	+ hence "count (mset_set K) x = 0" by simp
	+ then show ?thesis by presburger
	+ qed
	+ qed
	+ hence "mset_set K \<subseteq># roots p"
	+ by (simp add: subseteq_mset_def)
	+ hence "card K \<le> size (roots p)"
	+ by (metis size_mset_mono size_mset_set)
	+ moreover have "size (roots p) \<le> degree p"
	+ using a size_roots_le_degree assms by auto
	+ ultimately show "False" using assms(4)
	+ by (meson leD less_le_trans)
	+qed
	+
	+definition (in ring) split_poly
	+ where "split_poly K p = (restrict (eval p) K, \<lambda>k. coeff p (k+card K))"
	+
	+text \<open>To establish the count of the number of polynomials of degree less than
	+$n$ interpolating a function $f$ on $K$ where $\lvert K \rvert \leq n$, the function
	+@{term "split_poly K"} establishes a bijection between the polynomials of degree less than
	+$n$ and the values of the polynomials on $K$ in combination with the coefficients of order
	+$\lvert K \rvert$ and greater.
	+
	+For the injectivity: Note that the difference of two polynomials whose coefficients of order
	+$\lvert K \rvert$ and larger agree must have a degree less than $\lvert K \rvert$ and because
	+their values agree on $k$ points, it must have $\lvert K \rvert$ zeros and hence is the zero
	+polynomial.
	+
	+For the surjectivty: Let $p$ be a polynomial whose coefficients larger than $\lvert K \rvert$ are
	+chosen, and all other coefficients be $0$. Now it is possible to find a polynomial $q$ interpolating
	+$f - p$ on $K$ using Lagrange interpolation. Then $p + q$ will interpolate $f$ on $K$ and because
	+the degree of $q$ is less than $\lvert K \rvert$ its coefficients of order $\lvert K \rvert$ will
	+be the same as those of $p$.
	+
	+A tempting question is whether it would be easier to instead establish a bijection between the
	+polynomials of degree less than $n$ and its values on $K \cup K'$ where $K'$ are arbitrarily chosen
	+$n-\lvert K \rvert$ points in the field. This approach is indeed easier, however, it fails for
	+the case where the size of the field is less than $n$.\<close>
	+
	+lemma (in field) split_poly_inj:
	+ assumes "finite K"
	+ assumes "K \<subseteq> carrier R"
	+ shows "inj_on (split_poly K) (carrier (poly_ring R))"
	+proof
	+ fix x
	+ fix y
	+ assume a1:"x \<in> carrier (poly_ring R)"
	+ assume a2:"y \<in> carrier (poly_ring R)"
	+ assume a3:"split_poly K x = split_poly K y"
	+
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ have x_y_carrier: "x \<ominus>\<^bsub>poly_ring R\<^esub> y \<in> carrier (poly_ring R)" using a1 a2 by simp
	+ have "\<And>k. coeff x (k+card K) = coeff y (k+card K)"
	+ using a3 by (simp add:split_poly_def, meson)
	+ hence "\<And>k. coeff (x \<ominus>\<^bsub>poly_ring R\<^esub> y) (k+card K) = \<zero>"
	+ using coeff_in_carrier a1 a2 by (simp add:poly_substract_coeff)
	+ hence "degree (x \<ominus>\<^bsub>poly_ring R\<^esub> y) < card K \<or> (x \<ominus>\<^bsub>poly_ring R\<^esub> y) = \<zero>\<^bsub>poly_ring R\<^esub>"
	+ by (metis poly_degree_bound_from_coeff add.commute le_iff_add x_y_carrier)
	+ moreover have "\<And>k. k \<in> K \<Longrightarrow> eval x k = eval y k"
	+ using a3 by (simp add:split_poly_def restrict_def, meson)
	+ hence "\<And>k. k \<in> K \<Longrightarrow> eval x k \<ominus> eval y k = \<zero>"
	+ by (metis eval_in_carrier univ_poly_carrier polynomial_incl a1 assms(2) in_mono r_right_minus_eq)
	+ hence "\<And>k. k \<in> K \<Longrightarrow> eval (x \<ominus>\<^bsub>poly_ring R\<^esub> y) k = \<zero>"
	+ using a1 a2 subsetD[OF assms(2)] carrier_is_subring
	+ by (simp add: ring_hom_cring.hom_sub[OF eval_cring_hom])
	+ ultimately have "x \<ominus>\<^bsub>poly_ring R\<^esub> y = \<zero>\<^bsub>poly_ring R\<^esub>"
	+ using max_roots x_y_carrier assms by blast
	+ then show "x = y"
	+ using x.r_right_minus_eq[OF a1 a2] by simp
	+qed
	+
	+lemma (in field) split_poly_image:
	+ assumes "finite K"
	+ assumes "K \<subseteq> carrier R"
	+ shows "split_poly K ` carrier (poly_ring R) \<supseteq>
	+ (K \<rightarrow>\<^sub>E carrier R) \<times> {f. range f \<subseteq> carrier R \<and> (\<exists>n. \<forall>k \<ge> n. f k = \<zero>\<^bsub>R\<^esub>)}"
	+proof (rule subsetI)
	+ fix x
	+ assume a:"x \<in> (K \<rightarrow>\<^sub>E carrier R) \<times> {f. range f \<subseteq> carrier R \<and> (\<exists>(n::nat). \<forall>k \<ge> n. f k = \<zero>)}"
	+ have a1: "fst x \<in> (K \<rightarrow>\<^sub>E carrier R)"
	+ using a by (simp add:mem_Times_iff)
	+ obtain n where a2: "snd x \<in> {f. range f \<subseteq> carrier R \<and> (\<forall>k \<ge> n. f k = \<zero>)}"
	+ using a mem_Times_iff by force
	+ have a3: "\<And>y. snd x y \<in> carrier R" using a2 by blast
	+
	+ define w where "w = build_poly (\<lambda>i. if i \<ge> card K then (snd x (i - card K)) else \<zero>) (card K + n)"
	+
	+ have w_carr: "w \<in> carrier (poly_ring R)"
	+ unfolding w_def by (rule build_poly_poly, simp add:a3)
	+
	+ have w_eval_range: "\<And>x. x \<in> carrier R \<Longrightarrow> local.eval w x \<in> carrier R"
	+ proof -
	+ fix x
	+ assume w_eval_range_1:"x \<in> carrier R"
	+ interpret x:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p x)"
	+ using eval_cring_hom[OF carrier_is_subring] assms w_eval_range_1 by blast
	+ show "eval w x \<in> carrier R"
	+ by (rule x.hom_closed[OF w_carr])
	+ qed
	+
	+ interpret r:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ define y where "y = interpolate K (\<lambda>k. fst x k \<ominus> eval w k)"
	+ define r where "r = y \<oplus>\<^bsub>poly_ring R\<^esub> w"
	+
	+ have x_minus_w_in_carrier: "\<And>z. z \<in> K \<Longrightarrow> fst x z \<ominus> eval w z \<in> carrier R"
	+ using a1 PiE_def Pi_def minus_closed subsetD[OF assms(2)] w_eval_range by auto
	+
	+ have y_poly: "y \<in> carrier (poly_ring R)" unfolding y_def
	+ using x_minus_w_in_carrier interpolate_poly[OF assms(1) assms(2)] image_subsetI by force
	+
	+ have y_degree: "degree y \<le> card K - 1"
	+ unfolding y_def
	+ using x_minus_w_in_carrier interpolate_degree[OF assms(1) assms(2)] image_subsetI by force
	+
	+ have y_len: "length y \<le> card K"
	+ proof (cases "K={}")
	+ case True
	+ then show ?thesis
	+ by (simp add:y_def interpolate_def univ_poly_zero)
	+ next
	+ case False
	+ then show ?thesis
	+ by (metis y_degree Suc_le_D assms(1) card_gt_0_iff diff_Suc_1 not_less_eq_eq order.strict_iff_not)
	+ qed
	+
	+ have r_poly: "r \<in> carrier (poly_ring R)"
	+ using r_def y_poly w_carr by simp
	+
	+ have coeff_r: "\<And>k. coeff r (k + card K) = snd x k"
	+ proof -
	+ fix k :: nat
	+ have y_len': "length y \<le> k + card K" using y_len trans_le_add2 by blast
	+ have "coeff r (k + card K) = coeff y (k + card K) \<oplus> coeff w (k+card K)"
	+ by (simp add:r_def poly_add_coeff[OF y_poly w_carr])
	+ also have "... = \<zero> \<oplus> coeff w (k+card K)"
	+ using coeff_length[OF y_len'] by simp
	+ also have "... = coeff w (k+card K)"
	+ using coeff_in_carrier[OF w_carr] by simp
	+ also have "... = snd x k"
	+ using a2 by (simp add:w_def build_poly_coeff not_less)
	+ finally show "coeff r (k + card K) = snd x k" by simp
	+ qed
	+
	+ have eval_r: "\<And>k. k \<in> K \<Longrightarrow> eval r k = fst x k"
	+ proof -
	+ fix k
	+ assume b:"k \<in> K"
	+ interpret s:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p k)"
	+ using eval_cring_hom[OF carrier_is_subring] assms b by blast
	+
	+ have k_carr: "k \<in> carrier R" using assms(2) b by blast
	+ have fst_x_k_carr: "\<And>k. k \<in> K \<Longrightarrow> fst x k \<in> carrier R"
	+ using a1 PiE_def Pi_def by blast
	+ have "eval r k = eval y k \<oplus> eval w k"
	+ using y_poly w_carr by (simp add:r_def)
	+ also have "... = fst x k \<ominus> local.eval w k \<oplus> local.eval w k"
	+ using assms b x_minus_w_in_carrier
	+ by (simp add:y_def interpolate_eval[OF _ _ image_subsetI])
	+ also have "... = fst x k \<oplus> (\<ominus> local.eval w k \<oplus> local.eval w k)"
	+ using fst_x_k_carr[OF b] w_eval_range[OF k_carr]
	+ by (simp add:a_minus_def a_assoc)
	+ also have "... = fst x k"
	+ using fst_x_k_carr[OF b] w_eval_range[OF k_carr]
	+ by (simp add:a_comm r_neg)
	+ finally show "eval r k = fst x k" by simp
	+ qed
	+
	+ have "r \<in> (carrier (poly_ring R))"
	+ by (metis r_poly)
	+ moreover have "\<And>y. (if y \<in> K then eval r y else undefined) = fst x y"
	+ using a1 eval_r PiE_E by auto
	+ hence "split_poly K r = x"
	+ by (simp add:split_poly_def prod_eq_iff coeff_r restrict_def)
	+ ultimately show "x \<in> split_poly K ` (carrier (poly_ring R))"
	+ by blast
	+qed
	+
	+text \<open>This is like @{thm [source] card_vimage_inj} but supports @{term "inj_on"} instead.\<close>
	+lemma card_vimage_inj_on:
	+ assumes "inj_on f B"
	+ assumes "A \<subseteq> f ` B"
	+ shows "card (f -` A \<inter> B) = card A"
	+proof -
	+ have "A = f ` (f -` A \<inter> B)" using assms(2) by auto
	+ thus ?thesis using assms card_image
	+ by (metis inf_le2 inj_on_subset)
	+qed
	+
	+lemma inv_subsetI:
	+ assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B \<Longrightarrow> x \<in> C"
	+ shows "f -` B \<inter> A \<subseteq> C"
	+ using assms by force
	+
	+text \<open>The following establishes the main result of this section: There are $\lvert F \rvert^{n-k}$
	+polynomials of degree less than $n$ interpolating $k \leq n$ points.\<close>
	+
	+lemma restrict_eq_imp:
	+ assumes "restrict f A = restrict g A"
	+ assumes "x \<in> A"
	+ shows "f x = g x"
	+ by (metis restrict_def assms)
	+
	+theorem (in field) interpolating_polynomials_card:
	+ assumes "finite K"
	+ assumes "K \<subseteq> carrier R"
	+ assumes "f ` K \<subseteq> carrier R"
	+ shows "card {\<omega> \<in> bounded_degree_polynomials R (card K + n). (\<forall>k \<in> K. eval \<omega> k = f k)} = card (carrier R)^n"
	+ (is "card ?A = ?B")
	+proof -
	+ define z where "z = restrict f K"
	+ define M where "M = {f. range f \<subseteq> carrier R \<and> (\<forall>k \<ge> n. f k = \<zero>)}"
	+
	+ hence inj_on_bounded: "inj_on (split_poly K) (carrier (poly_ring R))"
	+ using split_poly_inj[OF assms(1) assms(2)] by blast
	+
	+ have "?A \<subseteq> split_poly K -` ({z} \<times> M)"
	+ unfolding split_poly_def z_def M_def bounded_degree_polynomials_length
	+ by (rule subsetI, auto intro!:coeff_in_carrier coeff_length)
	+ moreover have "?A \<subseteq> carrier (poly_ring R)"
	+ unfolding bounded_degree_polynomials_length by blast
	+ ultimately have a:"?A \<subseteq> split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R)"
	+ by blast
	+
	+ have "\<And>x k . (\<lambda>k. coeff x (k + card K)) \<in> M \<Longrightarrow> k \<ge> n + card K \<Longrightarrow> coeff x k = \<zero>"
	+ by (simp add:M_def, metis Nat.le_diff_conv2 Nat.le_imp_diff_is_add add_leD2)
	+ hence "split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R) \<subseteq> bounded_degree_polynomials R (card K + n)"
	+ unfolding split_poly_def z_def using poly_degree_bound_from_coeff_1 inv_subsetI by force
	+ moreover have "\<And>\<omega> k. \<omega> \<in> split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R) \<Longrightarrow> k \<in> K \<Longrightarrow> eval \<omega> k = f k"
	+ unfolding split_poly_def z_def using restrict_eq_imp by fastforce
	+ ultimately have b:"split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R) \<subseteq> ?A"
	+ by blast
	+
	+ have "z \<in> K \<rightarrow>\<^sub>E carrier R"
	+ unfolding z_def using assms(3) by auto
	+ moreover have "M \<subseteq> {f. range f \<subseteq> carrier R \<and> (\<exists>n. (\<forall>k \<ge> n. f k = \<zero>))}"
	+ unfolding M_def by blast
	+ ultimately have c:"{z} \<times> M \<subseteq> split_poly K ` carrier (poly_ring R)"
	+ using split_poly_image[OF assms(1) assms(2)] by fast
	+
	+ have "card ?A = card (split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R))"
	+ using order_antisym[OF a b] by simp
	+ also have "... = card ({z} \<times> M)"
	+ using card_vimage_inj_on[OF inj_on_bounded] c by blast
	+ also have "... = card (carrier R)^n"
	+ by (simp add:card_cartesian_product M_def card_mostly_constant_maps)
	+ finally show ?thesis by simp
	+qed
	+
	+text \<open>A corollary is the classic result~\cite[Theorem 7.15]{shoup2009computational} that there is
	+exactly one polynomial of degree less than $n$ interpolating $n$ points:\<close>
	+
	+corollary (in field) interpolating_polynomial_one:
	+ assumes "finite K"
	+ assumes "K \<subseteq> carrier R"
	+ assumes "f ` K \<subseteq> carrier R"
	+ shows "card {\<omega> \<in> bounded_degree_polynomials R (card K). (\<forall>k \<in> K. eval \<omega> k = f k)} = 1"
	+ using interpolating_polynomials_card[OF assms(1) assms(2) assms(3), where n="0"]
	+ by simp
	+
	+text \<open>In the case of fields with infinite carriers, it is possible to conclude that there are
	+infinitely many polynomials of degree less than $n$ interpolating $k < n$ points.\<close>
	+
	+corollary (in field) interpolating_polynomial_inf:
	+ assumes "infinite (carrier R)"
	+ assumes "finite K" "K \<subseteq> carrier R" "f ` K \<subseteq> carrier R"
	+ assumes "n > 0"
	+ shows "infinite {\<omega> \<in> bounded_degree_polynomials R (card K + n). (\<forall>k \<in> K. eval \<omega> k = f k)}"
	+ (is "infinite ?A")
	+proof -
	+ have "{} \<subset> {\<omega> \<in> bounded_degree_polynomials R (card K). (\<forall>k \<in> K. eval \<omega> k = f k)}"
	+ using interpolating_polynomial_one[OF assms(2) assms(3) assms(4)] by fastforce
	+ also have "... \<subseteq> ?A"
	+ unfolding bounded_degree_polynomials_def by auto
	+ finally have a:"?A \<noteq> {}" by auto
	+
	+ have "card ?A = card (carrier R)^n"
	+ using interpolating_polynomials_card[OF assms(2) assms(3) assms(4), where n="n"] by simp
	+ also have "... = 0"
	+ using assms(1) assms(5) by simp
	+ finally have b:"card ?A = 0" by simp
	+
	+ show ?thesis using a b card_0_eq by blast
	+qed
	+
	+text \<open>The following is an additional independent result: The evaluation homomorphism is injective
	+for degree one polynomials.\<close>
	+
	+lemma (in field) eval_inj_if_degree_1:
	+ assumes "p \<in> carrier (poly_ring R)" "degree p = 1"
	+ shows "inj_on (eval p) (carrier R)"
	+proof -
	+ obtain u v where p_def: "p = [u,v]" using assms
	+ by (cases p, cases "(tl p)", auto)
	+
	+ have "u \<in> carrier R - {\<zero>}" using p_def assms by blast
	+ moreover have "v \<in> carrier R" using p_def assms by blast
	+ ultimately show ?thesis by (simp add:p_def field_Units inj_on_def)
	+qed
	+
	+end
	diff --git a/thys/Interpolation_Polynomials_HOL_Algebra/Lagrange_Interpolation.thy b/thys/Interpolation_Polynomials_HOL_Algebra/Lagrange_Interpolation.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Interpolation_Polynomials_HOL_Algebra/Lagrange_Interpolation.thy
	@@ -0,0 +1,358 @@
	+section \<open>Lagrange Interpolation\<close>
	+
	+text \<open>This section introduces the function @{term "interpolate"}, which constructs the Lagrange
	+interpolation polynomials for a given set of points, followed by a theorem of its correctness.\<close>
	+
	+theory Lagrange_Interpolation
	+ imports "HOL-Algebra.Polynomial_Divisibility"
	+begin
	+
	+text \<open>A finite product in a domain is $0$ if and only if at least one factor is. This could be added
	+to @{theory "HOL-Algebra.FiniteProduct"} or @{theory "HOL-Algebra.Ring"}.\<close>
	+lemma (in domain) finprod_zero_iff:
	+ assumes "finite A"
	+ assumes "\<And>a. a \<in> A \<Longrightarrow> f a \<in> carrier R"
	+ shows "finprod R f A = \<zero> \<longleftrightarrow> (\<exists>x \<in> A. f x = \<zero>)"
	+ using assms
	+proof (induct A rule: finite_induct)
	+ case empty
	+ then show ?case by simp
	+next
	+ case (insert y F)
	+ moreover have "f \<in> F \<rightarrow> carrier R" using insert by blast
	+ ultimately show ?case by (simp add:integral_iff)
	+qed
	+
	+lemma (in ring) poly_of_const_in_carrier:
	+ assumes "s \<in> carrier R"
	+ shows "poly_of_const s \<in> carrier (poly_ring R)"
	+ using poly_of_const_def assms
	+ by (simp add:univ_poly_carrier[symmetric] polynomial_def)
	+
	+lemma (in ring) eval_poly_of_const:
	+ assumes "x \<in> carrier R"
	+ shows "eval (poly_of_const x) y = x"
	+ using assms by (simp add:poly_of_const_def)
	+
	+lemma (in ring) eval_in_carrier_2:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ assumes "y \<in> carrier R"
	+ shows "eval x y \<in> carrier R"
	+ using eval_in_carrier univ_poly_carrier polynomial_incl assms by blast
	+
	+lemma (in domain) poly_mult_degree_le_1:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ assumes "y \<in> carrier (poly_ring R)"
	+ shows "degree (x \<otimes>\<^bsub>poly_ring R\<^esub> y) \<le> degree x + degree y"
	+proof -
	+ have "degree (x \<otimes>\<^bsub>poly_ring R\<^esub> y) = (if x = [] \<or> y = [] then 0 else degree x + degree y)"
	+ unfolding univ_poly_mult
	+ by (metis univ_poly_carrier assms(1,2) carrier_is_subring poly_mult_degree_eq)
	+ thus ?thesis by (metis nat_le_linear zero_le)
	+qed
	+
	+lemma (in domain) poly_mult_degree_le:
	+ assumes "x \<in> carrier (poly_ring R)"
	+ assumes "y \<in> carrier (poly_ring R)"
	+ assumes "degree x \<le> n"
	+ assumes "degree y \<le> m"
	+ shows "degree (x \<otimes>\<^bsub>poly_ring R\<^esub> y) \<le> n + m"
	+ using poly_mult_degree_le_1 assms add_mono by force
	+
	+lemma (in domain) poly_add_degree_le:
	+ assumes "x \<in> carrier (poly_ring R)" "degree x \<le> n"
	+ assumes "y \<in> carrier (poly_ring R)" "degree y \<le> n"
	+ shows "degree (x \<oplus>\<^bsub>poly_ring R\<^esub> y) \<le> n"
	+ using assms poly_add_degree
	+ by (metis dual_order.trans max.bounded_iff univ_poly_add)
	+
	+lemma (in domain) poly_sub_degree_le:
	+ assumes "x \<in> carrier (poly_ring R)" "degree x \<le> n"
	+ assumes "y \<in> carrier (poly_ring R)" "degree y \<le> n"
	+ shows "degree (x \<ominus>\<^bsub>poly_ring R\<^esub> y) \<le> n"
	+proof -
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ show ?thesis
	+ unfolding a_minus_def
	+ using assms univ_poly_a_inv_degree carrier_is_subring poly_add_degree_le x.a_inv_closed
	+ by simp
	+qed
	+
	+lemma (in domain) poly_sum_degree_le:
	+ assumes "finite A"
	+ assumes "\<And>x. x \<in> A \<Longrightarrow> degree (f x) \<le> n"
	+ assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> carrier (poly_ring R)"
	+ shows "degree (finsum (poly_ring R) f A) \<le> n"
	+ using assms
	+proof (induct A rule:finite_induct)
	+ case empty
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+ show ?case using empty by (simp add:univ_poly_zero)
	+next
	+ case (insert x F)
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+ have a: "degree (f x \<oplus>\<^bsub>poly_ring R\<^esub> finsum (poly_ring R) f F) \<le> n"
	+ using insert poly_add_degree_le x.finsum_closed by auto
	+ show ?case using insert a by auto
	+qed
	+
	+definition (in ring) lagrange_basis_polynomial_aux where
	+ "lagrange_basis_polynomial_aux S =
	+ (\<Otimes>\<^bsub>poly_ring R\<^esub> s \<in> S. X \<ominus>\<^bsub>poly_ring R\<^esub> (poly_of_const s))"
	+
	+lemma (in domain) lagrange_aux_eval:
	+ assumes "finite S"
	+ assumes "S \<subseteq> carrier R"
	+ assumes "x \<in> carrier R"
	+ shows "(eval (lagrange_basis_polynomial_aux S) x) = (\<Otimes>s \<in> S. x \<ominus> s)"
	+proof -
	+ interpret x:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p x)"
	+ by (rule eval_cring_hom[OF carrier_is_subring assms(3)])
	+
	+ have "\<And>a. a \<in> S \<Longrightarrow> X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const a \<in> carrier (poly_ring R)"
	+ by (meson poly_of_const_in_carrier carrier_is_subring assms(2) cring.cring_simprules(4)
	+ domain_def subsetD univ_poly_is_domain var_closed(1))
	+
	+ moreover have "\<And>s. s \<in> S \<Longrightarrow> eval (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const s) x = x \<ominus> s"
	+ using assms var_closed carrier_is_subring poly_of_const_in_carrier subsetD[OF assms(2)]
	+ by (simp add:eval_var eval_poly_of_const)
	+
	+ moreover have "a_minus R x \<in> S \<rightarrow> carrier R"
	+ using assms by blast
	+
	+ ultimately show ?thesis
	+ by (simp add:lagrange_basis_polynomial_aux_def x.hom_finprod cong:finprod_cong')
	+qed
	+
	+lemma (in domain) lagrange_aux_poly:
	+ assumes "finite S"
	+ assumes "S \<subseteq> carrier R"
	+ shows "lagrange_basis_polynomial_aux S \<in> carrier (poly_ring R)"
	+proof -
	+ have a:"subring (carrier R) R"
	+ using carrier_is_subring assms by blast
	+
	+ have b: "\<And>a. a \<in> S \<Longrightarrow> X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const a \<in> carrier (poly_ring R)"
	+ by (meson poly_of_const_in_carrier a assms(2) cring.cring_simprules(4) domain_def subsetD
	+ univ_poly_is_domain var_closed(1))
	+
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ show ?thesis
	+ using lagrange_basis_polynomial_aux_def b x.finprod_closed[OF Pi_I] by simp
	+qed
	+
	+lemma (in domain) poly_prod_degree_le:
	+ assumes "finite A"
	+ assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> carrier (poly_ring R)"
	+ shows "degree (finprod (poly_ring R) f A) \<le> (\<Sum>x \<in> A. degree (f x))"
	+ using assms
	+proof (induct A rule:finite_induct)
	+ case empty
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+ show ?case by (simp add:univ_poly_one)
	+next
	+ case (insert x F)
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+ have a:"f \<in> F \<rightarrow> carrier (poly_ring R)"
	+ using insert by blast
	+ have b:"f x \<in> carrier (poly_ring R)"
	+ using insert by blast
	+ have "degree (finprod (poly_ring R) f (insert x F)) = degree (f x \<otimes>\<^bsub>poly_ring R\<^esub> finprod (poly_ring R) f F)"
	+ using a b insert by simp
	+ also have "... \<le> degree (f x) + degree (finprod (poly_ring R) f F)"
	+ using poly_mult_degree_le x.finprod_closed[OF a] b by auto
	+ also have "... \<le> degree (f x) + (\<Sum>y \<in> F. degree (f y))"
	+ using insert(3) a add_mono by auto
	+ also have "... = (\<Sum>y \<in> (insert x F). degree (f y))" using insert by simp
	+ finally show ?case by simp
	+qed
	+
	+lemma (in domain) lagrange_aux_degree:
	+ assumes "finite S"
	+ assumes "S \<subseteq> carrier R"
	+ shows "degree (lagrange_basis_polynomial_aux S) \<le> card S"
	+proof -
	+ interpret x:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ have "degree X \<le> 1" by (simp add:var_def)
	+ moreover have "\<And>y. y\<in> S \<Longrightarrow> degree (poly_of_const y) \<le> 1" by (simp add:poly_of_const_def)
	+ ultimately have a: "\<And>y. y\<in> S \<Longrightarrow> degree (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const y) \<le> 1"
	+ by (meson assms(2) in_mono poly_of_const_in_carrier poly_sub_degree_le var_closed[OF carrier_is_subring])
	+
	+ have b:"\<And>y. y \<in> S \<Longrightarrow> (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const y) \<in> carrier (poly_ring R)"
	+ by (meson subsetD x.minus_closed var_closed(1)[OF carrier_is_subring] poly_of_const_in_carrier assms(2))
	+
	+ have "degree (lagrange_basis_polynomial_aux S) \<le> (\<Sum>y \<in> S. degree (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const y))"
	+ using lagrange_basis_polynomial_aux_def b poly_prod_degree_le[OF assms(1)] by auto
	+ also have "... \<le> (\<Sum>y \<in> S. 1)"
	+ using sum_mono a by force
	+ also have "... = card S" by simp
	+ finally show ?thesis by simp
	+qed
	+
	+definition (in ring) lagrange_basis_polynomial where
	+ "lagrange_basis_polynomial S x = lagrange_basis_polynomial_aux S
	+ \<otimes>\<^bsub>poly_ring R\<^esub> (poly_of_const (inv\<^bsub>R\<^esub> (\<Otimes>s \<in> S. x \<ominus> s)))"
	+
	+lemma (in field)
	+ assumes "finite S"
	+ assumes "S \<subseteq> carrier R"
	+ assumes "x \<in> carrier R - S"
	+ shows
	+ lagrange_one: "eval (lagrange_basis_polynomial S x) x = \<one>" and
	+ lagrange_degree: "degree (lagrange_basis_polynomial S x) \<le> card S" and
	+ lagrange_zero: "\<And>s. s \<in> S \<Longrightarrow> eval (lagrange_basis_polynomial S x) s = \<zero>" and
	+ lagrange_poly: "lagrange_basis_polynomial S x \<in> carrier (poly_ring R)"
	+proof -
	+ interpret x:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p x)"
	+ using assms carrier_is_subring eval_cring_hom by blast
	+
	+ define p where "p = lagrange_basis_polynomial_aux S"
	+ have a:"eval p x = (\<Otimes>s \<in> S. x \<ominus> s)"
	+ using assms by (simp add:p_def lagrange_aux_eval)
	+
	+ have b:"p \<in> carrier (poly_ring R)" using assms
	+ by (simp add:p_def lagrange_aux_poly)
	+
	+ have "\<And>y. y \<in> S \<Longrightarrow> a_minus R x y \<in> carrier R"
	+ using assms by blast
	+
	+ hence c:"finprod R (a_minus R x) S \<in> Units R"
	+ using finprod_closed[OF Pi_I] assms
	+ by (auto simp add:field_Units finprod_zero_iff)
	+
	+ have "eval (lagrange_basis_polynomial S x) x =
	+ (\<Otimes>s \<in> S. x \<ominus> s) \<otimes> eval (poly_of_const (inv finprod R (a_minus R x) S)) x"
	+ using poly_of_const_in_carrier Units_inv_closed c p_def[symmetric]
	+ by (simp add: lagrange_basis_polynomial_def x.hom_mult[OF b] a)
	+ also have "... = \<one>"
	+ using poly_of_const_in_carrier Units_inv_closed c eval_poly_of_const by simp
	+ finally show "eval (lagrange_basis_polynomial S x) x = \<one>" by simp
	+
	+ have "degree (lagrange_basis_polynomial S x) \<le> degree p + degree (poly_of_const (inv finprod R (a_minus R x) S))"
	+ unfolding lagrange_basis_polynomial_def p_def[symmetric]
	+ using poly_mult_degree_le[OF b] poly_of_const_in_carrier Units_inv_closed c by auto
	+ also have "... \<le> card S + 0"
	+ using add_mono lagrange_aux_degree[OF assms(1) assms(2)] p_def poly_of_const_def by auto
	+ finally show "degree (lagrange_basis_polynomial S x) \<le> card S" by simp
	+
	+ show "\<And>s. s \<in> S \<Longrightarrow> eval (lagrange_basis_polynomial S x) s = \<zero>"
	+ proof -
	+ fix s
	+ assume d:"s \<in> S"
	+
	+ interpret s:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p s)"
	+ using eval_cring_hom carrier_is_subring assms d by blast
	+
	+ have "eval p s = finprod R (a_minus R s) S"
	+ using subsetD[OF assms(2) d] assms
	+ by (simp add:p_def lagrange_aux_eval)
	+ also have "... = \<zero>"
	+ using subsetD[OF assms(2)] d assms by (simp add: finprod_zero_iff)
	+ finally have "eval p s = \<zero>\<^bsub>R\<^esub>" by simp
	+
	+ moreover have "eval (poly_of_const (inv finprod R (a_minus R x) S)) s \<in> carrier R"
	+ using s.hom_closed poly_of_const_in_carrier Units_inv_closed c by blast
	+
	+ ultimately show "eval (lagrange_basis_polynomial S x) s = \<zero>"
	+ using poly_of_const_in_carrier Units_inv_closed c
	+ by (simp add:lagrange_basis_polynomial_def Let_def p_def[symmetric] s.hom_mult[OF b])
	+ qed
	+
	+ interpret r:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ show "lagrange_basis_polynomial S x \<in> carrier (poly_ring R)"
	+ using lagrange_basis_polynomial_def p_def[symmetric] poly_of_const_in_carrier Units_inv_closed
	+ a b c by simp
	+qed
	+
	+definition (in ring) interpolate where
	+ "interpolate S f =
	+ (\<Oplus>\<^bsub>poly_ring R\<^esub>s \<in> S. lagrange_basis_polynomial (S - {s}) s \<otimes>\<^bsub>poly_ring R\<^esub> (poly_of_const (f s)))"
	+
	+text \<open>Let @{term "f"} be a function and @{term "S"} be a finite subset of the domain of the field.
	+Then @{term "interpolate S f"} will return a polynomial with degree less than @{term "card S"}
	+interpolating @{term "f"} on @{term "S"}.\<close>
	+
	+theorem (in field)
	+ assumes "finite S"
	+ assumes "S \<subseteq> carrier R"
	+ assumes "f ` S \<subseteq> carrier R"
	+ shows
	+ interpolate_poly: "interpolate S f \<in> carrier (poly_ring R)" and
	+ interpolate_degree: "degree (interpolate S f) \<le> card S - 1" and
	+ interpolate_eval: "\<And>s. s \<in> S \<Longrightarrow> eval (interpolate S f) s = f s"
	+proof -
	+ interpret r:cring "poly_ring R"
	+ using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
	+
	+ have a:"\<And>x. x \<in> S \<Longrightarrow> lagrange_basis_polynomial (S - {x}) x \<in> carrier (poly_ring R)"
	+ by (meson lagrange_poly assms Diff_iff finite_Diff in_mono insertI1 subset_insertI2 subset_insert_iff)
	+
	+ have b:"\<And>x. x \<in> S \<Longrightarrow> f x \<in> carrier R" using assms by blast
	+
	+ have c:"\<And>x. x \<in> S \<Longrightarrow> degree (lagrange_basis_polynomial (S - {x}) x) \<le> card S - 1"
	+ by (metis (full_types) lagrange_degree DiffI Diff_insert_absorb assms(1) assms(2)
	+ card_Diff_singleton finite_insert insert_subset mk_disjoint_insert)
	+
	+ have d: "\<And>x. x \<in> S \<Longrightarrow>
	+ degree (lagrange_basis_polynomial (S - {x}) x \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f x)) \<le> (card S - 1) + 0"
	+ using poly_of_const_in_carrier[OF b] poly_mult_degree_le[OF a] c poly_of_const_def by fastforce
	+
	+ show "interpolate S f \<in> carrier (poly_ring R)"
	+ using interpolate_def poly_of_const_in_carrier a b by simp
	+
	+ show "degree (interpolate S f) \<le> card S - 1"
	+ using poly_sum_degree_le[OF assms(1) d] poly_of_const_in_carrier[OF b] interpolate_def a by simp
	+
	+ have e:"subring (carrier R) R"
	+ using carrier_is_subring assms by blast
	+
	+ show "\<And>s. s \<in> S \<Longrightarrow> eval (interpolate S f) s = f s"
	+ proof -
	+ fix s
	+ assume f:"s \<in> S"
	+ interpret s:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p s)"
	+ using eval_cring_hom[OF e] assms f by blast
	+ have g:"\<And>i. i \<in> S \<Longrightarrow>
	+ eval (lagrange_basis_polynomial (S - {i}) i \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f i)) s =
	+ (if s = i then f s else \<zero>)"
	+ proof -
	+ fix i
	+ assume i_in_S: "i \<in> S"
	+ have "eval (lagrange_basis_polynomial (S - {i}) i \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f i)) s =
	+ eval (lagrange_basis_polynomial (S - {i}) i) s \<otimes> f i"
	+ using b i_in_S poly_of_const_in_carrier
	+ by (simp add: s.hom_mult[OF a] eval_poly_of_const)
	+ also have "... = (if s = i then f s else \<zero>)"
	+ using b i_in_S poly_of_const_in_carrier assms f
	+ apply (cases "s=i", simp, subst lagrange_one, auto)
	+ by (subst lagrange_zero, auto)
	+ finally show
	+ "eval (lagrange_basis_polynomial (S - {i}) i \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f i)) s =
	+ (if s = i then f s else \<zero>)" by simp
	+ qed
	+
	+ have "eval (interpolate S f) s =
	+ (\<Oplus>x\<in>S. eval (lagrange_basis_polynomial (S - {x}) x \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f x)) s)"
	+ using poly_of_const_in_carrier[OF b] a e
	+ by (simp add: interpolate_def s.hom_finsum[OF Pi_I] comp_def)
	+ also have "... = (\<Oplus>x\<in>S. if s = x then f s else \<zero>)"
	+ using b g by (simp cong: finsum_cong)
	+ also have "... = f s"
	+ using finsum_singleton[OF f assms(1)] f assms by auto
	+ finally show "eval (interpolate S f) s = f s" by simp
	+ qed
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Interpolation_Polynomials_HOL_Algebra/ROOT b/thys/Interpolation_Polynomials_HOL_Algebra/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Interpolation_Polynomials_HOL_Algebra/ROOT
	@@ -0,0 +1,12 @@
	+chapter AFP
	+
	+session Interpolation_Polynomials_HOL_Algebra (AFP) = "HOL-Algebra" +
	+ options [timeout = 300]
	+ theories
	+ Bounded_Degree_Polynomials
	+ Lagrange_Interpolation
	+ Interpolation_Polynomial_Cardinalities
	+ document_files
	+ "root.tex"
	+ "root.bib"
	+
	diff --git a/thys/Interpolation_Polynomials_HOL_Algebra/document/root.bib b/thys/Interpolation_Polynomials_HOL_Algebra/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Interpolation_Polynomials_HOL_Algebra/document/root.bib
	@@ -0,0 +1,17 @@
	+@article{Polynomial_Interpolation-AFP,
	+ author = {René Thiemann and Akihisa Yamada},
	+ title = {Polynomial Interpolation},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2016,
	+ note = {\url{https://isa-afp.org/entries/Polynomial_Interpolation.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+
	+@book{shoup2009computational,
	+ title={A Computational Introduction to Number theory and Algebra},
	+ author={Shoup, Victor},
	+ year={2009},
	+ publisher={Cambridge university press}
	+}
	\ No newline at end of file
	diff --git a/thys/Interpolation_Polynomials_HOL_Algebra/document/root.tex b/thys/Interpolation_Polynomials_HOL_Algebra/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Interpolation_Polynomials_HOL_Algebra/document/root.tex
	@@ -0,0 +1,76 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amsmath}
	+
	+% further packages required for unusual symbols (see also
	+% isabellesym.sty), use only when needed
	+
	+%\usepackage{amssymb}
	+ %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
	+ %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
	+ %\<triangleq>, \<yen>, \<lozenge>
	+
	+%\usepackage{eurosym}
	+ %for \<euro>
	+
	+%\usepackage[only,bigsqcap,bigparallel,fatsemi,interleave,sslash]{stmaryrd}
	+ %for \<Sqinter>, \<Parallel>, \<Zsemi>, \<Parallel>, \<sslash>
	+
	+%\usepackage{eufrak}
	+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
	+
	+%\usepackage{textcomp}
	+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	+ %\<currency>
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+% for uniform font size
	+%\renewcommand{\isastyle}{\isastyleminor}
	+
	+
	+\begin{document}
	+
	+\title{Interpolation Polynomials (in HOL-Algebra)}
	+\author{Emin Karayel}
	+\maketitle
	+\begin{abstract}
	+A well known result from algebra is that, on any field, there is exactly one polynomial of degree
	+less than $n$ interpolating $n$ points~\cite[\textsection 7]{shoup2009computational}.
	+
	+This entry contains a formalization of the above result, as well as the following generalization
	+in the case of finite fields $F$: There are $\lvert F\rvert^{m-n}$ polynomials of degree less
	+than $m \geq n$ interpolating the same $n$ points, where $\lvert F \rvert$ denotes the size of the
	+domain of the field. To establish the result the entry also includes a formalization of
	+Lagrange interpolation, which might be of independent interest.
	+
	+The formalized results are defined on the algebraic structures from HOL-Algebra, which are
	+distinct from the type-class based structures defined in HOL. Note that there is an existing
	+formalization for polynomial interpolation and, in particular, Lagrange interpolation by Thiemann and
	+Yamada~\cite{Polynomial_Interpolation-AFP} on the type-class based structures in HOL.
	+\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/Iptables_Semantics/Primitive_Matchers/Code_Interface.thy b/thys/Iptables_Semantics/Primitive_Matchers/Code_Interface.thy
	--- a/thys/Iptables_Semantics/Primitive_Matchers/Code_Interface.thy
	+++ b/thys/Iptables_Semantics/Primitive_Matchers/Code_Interface.thy
	@@ -1,208 +1,208 @@
	theory Code_Interface
	imports
	Common_Primitive_toString
	IP_Addresses.IP_Address_Parser
	"../Call_Return_Unfolding"
	Transform
	No_Spoof
	"../Simple_Firewall/SimpleFw_Compliance"
	Simple_Firewall.SimpleFw_toString
	Simple_Firewall.Service_Matrix
	"../Semantics_Ternary/Optimizing" (do we use this?)
	"../Semantics_Goto"
	- Native_Word.Code_Target_Bits_Int
	"HOL-Library.Code_Target_Nat"
	"HOL-Library.Code_Target_Int"
	+ Native_Word.Code_Target_Int_Bit
	begin

	(Note: common_primitive_match_expr_ipv4_toString can be really slow)

	section\<open>Code Interface\<close>

	text\<open>HACK: rewrite quotes such that they are better printable by Isabelle\<close>
	definition quote_rewrite :: "string \<Rightarrow> string" where
	"quote_rewrite \<equiv> map (\<lambda>c. if c = char_of_nat 34 then CHR ''~'' else c)"

	lemma "quote_rewrite (''foo''@[char_of_nat 34]) = ''foo~''" by eval

	text\<open>The parser returns the @{typ "'i::len common_primitive ruleset"} not as a map but as an association list.
	This function converts it\<close>

	(this is only to tighten the types)
	definition map_of_string_ipv4
	:: "(string \<times> 32 common_primitive rule list) list \<Rightarrow> string \<rightharpoonup> 32 common_primitive rule list" where
	"map_of_string_ipv4 rs = map_of rs"
	definition map_of_string_ipv6
	:: "(string \<times> 128 common_primitive rule list) list \<Rightarrow> string \<rightharpoonup> 128 common_primitive rule list" where
	"map_of_string_ipv6 rs = map_of rs"
	definition map_of_string
	:: "(string \<times> 'i common_primitive rule list) list \<Rightarrow> string \<rightharpoonup> 'i common_primitive rule list" where
	"map_of_string rs = map_of rs"


	definition unfold_ruleset_CHAIN_safe :: "string \<Rightarrow> action \<Rightarrow> 'i::len common_primitive ruleset \<Rightarrow> 'i common_primitive rule list option" where
	"unfold_ruleset_CHAIN_safe = unfold_optimize_ruleset_CHAIN optimize_primitive_univ"

	lemma "(unfold_ruleset_CHAIN_safe chain a rs = Some rs') \<Longrightarrow> simple_ruleset rs'"
	by(simp add: Let_def unfold_ruleset_CHAIN_safe_def unfold_optimize_ruleset_CHAIN_def split: if_split_asm)

	(This is just for legacy code compatibility. Use the new _safe function instead)
	definition unfold_ruleset_CHAIN :: "string \<Rightarrow> action \<Rightarrow> 'i::len common_primitive ruleset \<Rightarrow> 'i common_primitive rule list" where
	"unfold_ruleset_CHAIN chain default_action rs = the (unfold_ruleset_CHAIN_safe chain default_action rs)"


	definition unfold_ruleset_FORWARD :: "action \<Rightarrow> 'i::len common_primitive ruleset \<Rightarrow> 'i::len common_primitive rule list" where
	"unfold_ruleset_FORWARD = unfold_ruleset_CHAIN ''FORWARD''"

	definition unfold_ruleset_INPUT :: "action \<Rightarrow> 'i::len common_primitive ruleset \<Rightarrow> 'i::len common_primitive rule list" where
	"unfold_ruleset_INPUT = unfold_ruleset_CHAIN ''INPUT''"

	definition unfold_ruleset_OUTPUT :: "action \<Rightarrow> 'i::len common_primitive ruleset \<Rightarrow> 'i::len common_primitive rule list" where
	"unfold_ruleset_OUTPUT \<equiv> unfold_ruleset_CHAIN ''OUTPUT''"


	lemma "let fw = [''FORWARD'' \<mapsto> []] in
	unfold_ruleset_FORWARD action.Drop fw
	= [Rule (MatchAny :: 32 common_primitive match_expr) action.Drop]" by eval


	(* only used for ML/Haskell code to convert types *)
	definition nat_to_8word :: "nat \<Rightarrow> 8 word" where
	"nat_to_8word i \<equiv> of_nat i"

	definition nat_to_16word :: "nat \<Rightarrow> 16 word" where
	"nat_to_16word i \<equiv> of_nat i"

	definition integer_to_16word :: "integer \<Rightarrow> 16 word" where
	"integer_to_16word i \<equiv> nat_to_16word (nat_of_integer i)"




	context
	begin
	private definition is_pos_Extra :: "'i::len common_primitive negation_type \<Rightarrow> bool" where
	"is_pos_Extra a \<equiv> (case a of Pos (Extra _) \<Rightarrow> True \| _ \<Rightarrow> False)"
	private definition get_pos_Extra :: "'i::len common_primitive negation_type \<Rightarrow> string" where
	"get_pos_Extra a \<equiv> (case a of Pos (Extra e) \<Rightarrow> e \| _ \<Rightarrow> undefined)"

	fun compress_parsed_extra
	:: "'i::len common_primitive negation_type list \<Rightarrow> 'i common_primitive negation_type list" where
	"compress_parsed_extra [] = []" \|
	"compress_parsed_extra (a1#a2#as) = (if is_pos_Extra a1 \<and> is_pos_Extra a2
	then compress_parsed_extra (Pos (Extra (get_pos_Extra a1@'' ''@get_pos_Extra a2))#as)
	else a1#compress_parsed_extra (a2#as)
	)" \|
	"compress_parsed_extra (a#as) = a#compress_parsed_extra as"

	lemma "compress_parsed_extra
	(map Pos [Extra ''-m'', (Extra ''recent'' :: 32 common_primitive),
	Extra ''--update'', Extra ''--seconds'', Extra ''60'',
	IIface (Iface ''foobar''),
	Extra ''--name'', Extra ''DEFAULT'', Extra ''--rsource'']) =
	map Pos [Extra ''-m recent --update --seconds 60'',
	IIface (Iface ''foobar''),
	Extra ''--name DEFAULT --rsource'']" by eval

	private lemma eval_ternary_And_Unknown_Unkown:
	"eval_ternary_And TernaryUnknown (eval_ternary_And TernaryUnknown tv) =
	eval_ternary_And TernaryUnknown tv"
	by(cases tv) (simp_all)

	private lemma is_pos_Extra_alist_and:
	"is_pos_Extra a \<Longrightarrow> alist_and (a#as) = MatchAnd (Match (Extra (get_pos_Extra a))) (alist_and as)"
	apply(cases a)
	apply(simp_all add: get_pos_Extra_def is_pos_Extra_def)
	apply(rename_tac e)
	by(case_tac e)(simp_all)

	private lemma compress_parsed_extra_matchexpr_helper:
	"ternary_ternary_eval (map_match_tac common_matcher p (alist_and (compress_parsed_extra as))) =
	ternary_ternary_eval (map_match_tac common_matcher p (alist_and as))"
	proof(induction as rule: compress_parsed_extra.induct)
	case 1 thus ?case by(simp)
	next
	case (2 a1 a2) thus ?case
	apply(simp add: is_pos_Extra_alist_and)
	apply(cases a1)
	apply(simp_all add: eval_ternary_And_Unknown_Unkown)
	done
	next
	case 3 thus ?case by(simp)
	qed

	text\<open>This lemma justifies that it is okay to fold together the parsed unknown tokens\<close>
	lemma compress_parsed_extra_matchexpr:
	"matches (common_matcher, \<alpha>) (alist_and (compress_parsed_extra as)) =
	matches (common_matcher, \<alpha>) (alist_and as)"
	apply(simp add: fun_eq_iff)
	apply(intro allI)
	apply(rule matches_iff_apply_f)
	apply(simp add: compress_parsed_extra_matchexpr_helper)
	done
	end




	subsection\<open>L4 Ports Parser Helper\<close>

	context
	begin
	text\<open>Replace all matches on ports with the unspecified @{term 0} protocol with the given @{typ primitive_protocol}.\<close>
	private definition fill_l4_protocol_raw
	:: "primitive_protocol \<Rightarrow> 'i::len common_primitive negation_type list \<Rightarrow> 'i common_primitive negation_type list"
	where
	"fill_l4_protocol_raw protocol \<equiv> NegPos_map
	(\<lambda> m. case m of Src_Ports (L4Ports x pts) \<Rightarrow> if x \<noteq> 0 then undefined else Src_Ports (L4Ports protocol pts)
	\| Dst_Ports (L4Ports x pts) \<Rightarrow> if x \<noteq> 0 then undefined else Dst_Ports (L4Ports protocol pts)
	\| MultiportPorts (L4Ports x pts) \<Rightarrow> if x \<noteq> 0 then undefined else MultiportPorts (L4Ports protocol pts)
	\| Prot _ \<Rightarrow> undefined \<comment> \<open>there should be no more match on the protocol if it was parsed from an iptables-save line\<close>
	\| m \<Rightarrow> m
	)"

	lemma "fill_l4_protocol_raw TCP [Neg (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)), Pos (Src_Ports (L4Ports 0 [(22,22)]))] =
	[Neg (Dst (IpAddrNetmask 0x7F000000 8)), Pos (Src_Ports (L4Ports 6 [(0x16, 0x16)]))]" by eval

	fun fill_l4_protocol
	:: "'i::len common_primitive negation_type list \<Rightarrow> 'i::len common_primitive negation_type list"
	where
	"fill_l4_protocol [] = []" \|
	"fill_l4_protocol (Pos (Prot (Proto protocol)) # ms) = Pos (Prot (Proto protocol)) # fill_l4_protocol_raw protocol ms" \|
	"fill_l4_protocol (Pos (Src_Ports _) # _) = undefined" \| (need to find proto first)
	"fill_l4_protocol (Pos (Dst_Ports _) # _) = undefined" \|
	"fill_l4_protocol (Pos (MultiportPorts _) # _) = undefined" \|
	"fill_l4_protocol (Neg (Src_Ports _) # _) = undefined" \|
	"fill_l4_protocol (Neg (Dst_Ports _) # _) = undefined" \|
	"fill_l4_protocol (Neg (MultiportPorts _) # _) = undefined" \|
	"fill_l4_protocol (m # ms) = m # fill_l4_protocol ms"

	lemma "fill_l4_protocol [ Neg (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))
	, Neg (Prot (Proto UDP))
	, Pos (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))
	, Pos (Prot (Proto TCP))
	, Pos (Extra ''foo'')
	, Pos (Src_Ports (L4Ports 0 [(22,22)]))
	, Neg (Extra ''Bar'')] =
	[ Neg (Dst (IpAddrNetmask 0x7F000000 8))
	, Neg (Prot (Proto UDP))
	, Pos (Src (IpAddrNetmask 0x7F000000 8))
	, Pos (Prot (Proto TCP))
	, Pos (Extra ''foo'')
	, Pos (Src_Ports (L4Ports TCP [(0x16, 0x16)]))
	, Neg (Extra ''Bar'')]" by eval
	end



	(currently unused and unverifed. may be needed for future use)
	definition prefix_to_strange_inverse_cisco_mask:: "nat \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat)" where
	"prefix_to_strange_inverse_cisco_mask n \<equiv> dotdecimal_of_ipv4addr (Bit_Operations.not (mask n << 32 - n))"

	lemma "prefix_to_strange_inverse_cisco_mask 8 = (0, 255, 255, 255)" by eval
	lemma "prefix_to_strange_inverse_cisco_mask 16 = (0, 0, 255, 255)" by eval
	lemma "prefix_to_strange_inverse_cisco_mask 24 = (0, 0, 0, 255)" by eval
	lemma "prefix_to_strange_inverse_cisco_mask 32 = (0, 0, 0, 0)" by eval


	end
	diff --git a/thys/Irrationals_From_THEBOOK/Irrationals_From_THEBOOK.thy b/thys/Irrationals_From_THEBOOK/Irrationals_From_THEBOOK.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Irrationals_From_THEBOOK/Irrationals_From_THEBOOK.thy
	@@ -0,0 +1,290 @@
	+section \<open>Some irrational numbers\<close>
	+text \<open>From Aigner and Ziegler, \emph{Proofs from THE BOOK} (Springer, 2018), Chapter 8, pp. 50--51.\<close>
	+
	+theory Irrationals_From_THEBOOK imports "Stirling_Formula.Stirling_Formula"
	+
	+begin
	+
	+subsection \<open>Basic definitions and their consequences\<close>
	+
	+definition hf where "hf \<equiv> \<lambda>n. \<lambda>x::real. (x^n * (1-x)^n) / fact n"
	+
	+definition cf where "cf \<equiv> \<lambda>n i. if i < n then 0 else (n choose (i-n)) * (-1)^(i-n)"
	+
	+text \<open>Mere knowledge that the coefficients are integers is not enough later on.\<close>
	+lemma hf_int_poly:
	+ fixes x::real
	+ shows "hf n = (\<lambda>x. (1 / fact n) * (\<Sum>i=0..2n. real_of_int (cf n i) x^i))"
	+proof
	+ fix x
	+ have inj: "inj_on ((+)n) {..n}"
	+ by (auto simp: inj_on_def)
	+ have [simp]: "((+)n) ` {..n} = {n..2*n}"
	+ using nat_le_iff_add by fastforce
	+ have "(x^n * (-x + 1)^n) = x ^ n * (\<Sum>k\<le>n. real (n choose k) * (- x) ^ k)"
	+ unfolding binomial_ring by simp
	+ also have "\<dots> = x ^ n * (\<Sum>k\<le>n. real_of_int ((n choose k) * (-1)^k) * x ^ k)"
	+ by (simp add: mult.assoc flip: power_minus)
	+ also have "\<dots> = (\<Sum>k\<le>n. real_of_int ((n choose k) * (-1)^k) * x ^ (n+k))"
	+ by (simp add: sum_distrib_left mult_ac power_add)
	+ also have "\<dots> = (\<Sum>i=n..2n. real_of_int (cf n i) x^i)"
	+ by (simp add: sum.reindex [OF inj, simplified] cf_def)
	+ finally have "hf n x = (1 / fact n) * (\<Sum>i = n..2 * n. real_of_int (cf n i) * x^i)"
	+ by (simp add: hf_def)
	+ moreover have "(\<Sum>i = 0..<n. real_of_int (cf n i) * x^i) = 0"
	+ by (simp add: cf_def)
	+ ultimately show "hf n x = (1 / fact n) * (\<Sum>i = 0..2 * n. real_of_int (cf n i) * x^i)"
	+ using sum.union_disjoint [of "{0..<n}" "{n..2n}" "\<lambda>i. real_of_int (cf n i) x^i"]
	+ by (simp add: ivl_disj_int_two(7) ivl_disj_un_two(7) mult_2)
	+qed
	+
	+text \<open>Lemma (ii) in the text has strict inequalities, but that's more work and is less useful.\<close>
	+lemma
	+ assumes "0 \<le> x" "x \<le> 1"
	+ shows hf_nonneg: "0 \<le> hf n x" and hf_le_inverse_fact: "hf n x \<le> 1/fact n"
	+ using assms by (auto simp: hf_def divide_simps mult_le_one power_le_one)
	+
	+lemma hf_differt [iff]: "hf n differentiable at x"
	+ unfolding hf_int_poly differentiable_def
	+ by (intro derivative_eq_intros exI \| simp)+
	+
	+lemma deriv_sum_int:
	+ "deriv (\<lambda>x. \<Sum>i=0..n. real_of_int (c i) * x^i) x
	+ = (if n=0 then 0 else (\<Sum>i=0..n - Suc 0. real_of_int ((int i + 1) * c (Suc i)) * x^i))"
	+ (is "deriv ?f x = (if n=0 then 0 else ?g)")
	+proof -
	+ have "(?f has_real_derivative ?g) (at x)" if "n > 0"
	+ proof -
	+ have "(\<Sum>i = 0..n. i * x ^ (i - Suc 0) * (c i))
	+ = (\<Sum>i = Suc 0..n. (real (i - Suc 0) + 1) * real_of_int (c i) * x ^ (i - Suc 0))"
	+ using that by (auto simp add: sum.atLeast_Suc_atMost intro!: sum.cong)
	+ also have "\<dots> = sum ((\<lambda>i. (real i + 1) * real_of_int (c (Suc i)) * x^i) \<circ> (\<lambda>n. n - Suc 0))
	+ {Suc 0..Suc (n - Suc 0)}"
	+ using that by simp
	+ also have "\<dots> = ?g"
	+ by (simp flip: sum.atLeast_atMost_pred_shift [where m=0])
	+ finally have \<section>: "(\<Sum>a = 0..n. a * x ^ (a - Suc 0) * (c a)) = ?g" .
	+ show ?thesis
	+ by (rule derivative_eq_intros \<section> \| simp)+
	+ qed
	+ then show ?thesis
	+ by (force intro: DERIV_imp_deriv)
	+qed
	+
	+text \<open>We calculate the coefficients of the $k$th derivative precisely.\<close>
	+lemma hf_deriv_int_poly:
	+ "(deriv^^k) (hf n) = (\<lambda>x. (1/fact n) * (\<Sum>i=0..2n-k. of_int (int(\<Prod>{i<..i+k}) cf n (i+k)) * x^i))"
	+proof (induction k)
	+ case 0
	+ show ?case
	+ by (simp add: hf_int_poly)
	+next
	+ case (Suc k)
	+ define F where "F \<equiv> \<lambda>x. (\<Sum>i = 0..2n - k. real_of_int (int(\<Prod>{i<..i+k}) cf n (i+k)) * x^i)"
	+ have Fd: "F field_differentiable at x" for x
	+ unfolding field_differentiable_def F_def
	+ by (rule derivative_eq_intros exI \| force)+
	+ have [simp]: "prod int {i<..Suc (i + k)} = (1 + int i) * prod int {Suc i<..Suc (i + k)}" for i
	+ by (metis Suc_le_mono atLeastSucAtMost_greaterThanAtMost le_add1 of_nat_Suc prod.head)
	+ have "deriv (\<lambda>x. F x / fact n) x
	+ = (\<Sum>i = 0..2 * n - Suc k. of_int (int(\<Prod>{i<..i+ Suc k}) * cf n (Suc (i+k))) * x^i) / fact n" for x
	+ unfolding deriv_cdivide_right [OF Fd]
	+ by (fastforce simp add: F_def deriv_sum_int cf_def simp flip: of_int_mult intro: sum.cong)
	+ then show ?case
	+ by (simp add: Suc F_def)
	+qed
	+
	+lemma hf_deriv_0: "(deriv^^k) (hf n) 0 \<in> \<int>"
	+proof (cases "n \<le> k")
	+ case True
	+ then obtain j where "(fact k::real) = real_of_int j * fact n"
	+ by (metis fact_dvd dvd_def mult.commute of_int_fact of_int_mult)
	+ moreover have "prod real {0<..k} = fact k"
	+ by (simp add: fact_prod atLeastSucAtMost_greaterThanAtMost)
	+ ultimately show ?thesis
	+ by (simp add: hf_deriv_int_poly dvd_def)
	+next
	+ case False
	+ then show ?thesis
	+ by (simp add: hf_deriv_int_poly cf_def)
	+qed
	+
	+lemma deriv_hf_minus: "deriv (hf n) = (\<lambda>x. - deriv (hf n) (1-x))"
	+proof
	+ fix x
	+ have "hf n = hf n \<circ> (\<lambda>x. (1-x))"
	+ by (simp add: fun_eq_iff hf_def mult.commute)
	+ then have "deriv (hf n) x = deriv (hf n \<circ> (\<lambda>x. (1-x))) x"
	+ by fastforce
	+ also have "\<dots> = deriv (hf n) (1-x) * deriv ((-) 1) x"
	+ by (intro real_derivative_chain) auto
	+ finally show "deriv (hf n) x = - deriv (hf n) (1-x)"
	+ by simp
	+qed
	+
	+lemma deriv_n_hf_diffr [iff]: "(deriv^^k) (hf n) field_differentiable at x"
	+ unfolding field_differentiable_def hf_deriv_int_poly
	+ by (rule derivative_eq_intros exI \| force)+
	+
	+lemma deriv_n_hf_minus: "(deriv^^k) (hf n) = (\<lambda>x. (-1)^k * (deriv^^k) (hf n) (1-x))"
	+proof (induction k)
	+ case 0
	+ then show ?case
	+ by (simp add: fun_eq_iff hf_def)
	+next
	+ case (Suc k)
	+ have o: "(\<lambda>x. (deriv ^^ k) (hf n) (1-x)) = (deriv ^^ k) (hf n) \<circ> (-) 1"
	+ by auto
	+ show ?case
	+ proof
	+ fix x
	+ have [simp]: "((deriv^^k) (hf n) \<circ> (-) 1) field_differentiable at x"
	+ by (force intro: field_differentiable_compose)
	+ have "(deriv ^^ Suc k) (hf n) x = deriv (\<lambda>x. (-1) ^ k * (deriv ^^ k) (hf n) (1-x)) x"
	+ by simp (metis Suc)
	+ also have "\<dots> = (-1) ^ k * deriv (\<lambda>x. (deriv ^^ k) (hf n) (1-x)) x"
	+ using o by fastforce
	+ also have "\<dots> = (-1) ^ Suc k * (deriv ^^ Suc k) (hf n) (1-x)"
	+ by (subst o, subst deriv_chain, auto)
	+ finally show "(deriv ^^ Suc k) (hf n) x = (-1) ^ Suc k * (deriv ^^ Suc k) (hf n) (1-x)" .
	+ qed
	+qed
	+
	+subsection \<open>Towards the main result\<close>
	+
	+lemma hf_deriv_1: "(deriv^^k) (hf n) 1 \<in> \<int>"
	+ by (smt (verit, best) Ints_1 Ints_minus Ints_mult Ints_power deriv_n_hf_minus hf_deriv_0)
	+
	+lemma hf_deriv_eq_0: "k > 2*n \<Longrightarrow> (deriv^^k) (hf n) = (\<lambda>x. 0)"
	+ by (force simp add: cf_def hf_deriv_int_poly)
	+
	+text \<open>The case for positive integers\<close>
	+lemma exp_nat_irrational:
	+ assumes "s > 0" shows "exp (real_of_int s) \<notin> \<rat>"
	+proof
	+ assume "exp (real_of_int s) \<in> \<rat>"
	+ then obtain a b where ab: "a > 0" "b > 0" "coprime a b" and exp_s: "exp s = of_int a / of_int b"
	+ using Rats_cases' div_0 exp_not_eq_zero of_int_0
	+ by (smt (verit, best) exp_gt_zero of_int_0_less_iff zero_less_divide_iff)
	+ define n where "n \<equiv> nat (max (a^2) (3 * s^3))"
	+ then have ns3: "s^3 \<le> real n / 3"
	+ by linarith
	+ have "n > 0"
	+ using \<open>a > 0\<close> n_def by (smt (verit, best) zero_less_nat_eq zero_less_power)
	+ then have "s ^ (2n+1) \<le> s ^ (3n)"
	+ using \<open>a > 0\<close> assms by (intro power_increasing) auto
	+ also have "\<dots> = real_of_int(s^3) ^ n"
	+ by (simp add: power_mult)
	+ also have "\<dots> \<le> (n / 3) ^ n"
	+ using assms ns3 by (simp add: power_mono)
	+ also have "\<dots> \<le> (n / exp 1) ^ n"
	+ using exp_le \<open>n > 0\<close>
	+ by (auto simp add: divide_simps)
	+ finally have s_le: "s ^ (2*n+1) \<le> (n / exp 1) ^ n"
	+ by presburger
	+ have a_less: "a < sqrt (2pin)"
	+ proof -
	+ have "2*pi > 1"
	+ by (smt (z3) pi_gt_zero sin_gt_zero_02 sin_le_zero)
	+ have "a = sqrt (a^2)"
	+ by (simp add: ab(1) order_less_imp_le)
	+ also have "\<dots> \<le> sqrt n"
	+ unfolding n_def
	+ by (smt (verit, ccfv_SIG) int_nat_eq of_nat_less_of_int_iff real_sqrt_le_mono)
	+ also have "\<dots> < sqrt (2pin)"
	+ by (simp add: \<open>0 < n\<close> \<open>1 < 2 * pi\<close>)
	+ finally show ?thesis .
	+ qed
	+ have "sqrt (2pin) * (n / exp 1) ^ n > a * s ^ (2*n+1)"
	+ using mult_strict_right_mono [OF a_less] mult_left_mono [OF s_le]
	+ by (smt (verit, best) s_le ab(1) assms of_int_1 of_int_le_iff of_int_mult zero_less_power)
	+ then have n: "fact n > a * s ^ (2*n+1)"
	+ using fact_bounds(1) by (smt (verit, best) \<open>0 < n\<close> of_int_fact of_int_less_iff)
	+ define F where "F \<equiv> \<lambda>x. \<Sum>i\<le>2n. (-1)^i s^(2n-i) (deriv^^i) (hf n) x"
	+ have Fder: "(F has_real_derivative -s * F x + s^(2n+1) hf n x) (at x)" for x
	+ proof -
	+ have *: "sum f {..n+n} = sum f {..<n+n}" if "f (n+n) = 0" for f::"nat \<Rightarrow> real"
	+ by (smt (verit, best) lessThan_Suc_atMost sum.lessThan_Suc that)
	+ have [simp]: "(deriv ((deriv ^^ (n+n)) (hf n)) x) = 0"
	+ using hf_deriv_eq_0 [where k= "Suc(n+n)"] by simp
	+ have \<section>: "(\<Sum>k\<le>n+n. (-1) ^ k * ((deriv ^^ Suc k) (hf n) x * of_int s ^ (n+n - k)))
	+ + s * (\<Sum>j=0..n+n. (-1) ^ j * ((deriv ^^ j) (hf n) x * of_int s ^ (n+n - j)))
	+ = s * (hf n x * of_int s ^ (n+n))"
	+ using \<open>n>0\<close>
	+ apply (subst sum_Suc_reindex)
	+ apply (simp add: algebra_simps atLeast0AtMost)
	+ apply (force simp add: * mult.left_commute [of "of_int s"] minus_nat.diff_Suc sum_distrib_left
	+ simp flip: sum.distrib intro: comm_monoid_add_class.sum.neutral split: nat.split_asm)
	+ done
	+ show ?thesis
	+ unfolding F_def
	+ apply (rule derivative_eq_intros field_differentiable_derivI \| simp)+
	+ using \<section> by (simp add: algebra_simps atLeast0AtMost eval_nat_numeral)
	+ qed
	+ have F01_Ints: "F 0 \<in> \<int>" "F 1 \<in> \<int>"
	+ by (simp_all add: F_def hf_deriv_0 hf_deriv_1 Ints_sum)
	+ define sF where "sF \<equiv> \<lambda>x. exp (of_int s * x) * F x"
	+ define sF' where "sF' \<equiv> \<lambda>x. of_int s ^ Suc(2n) (exp (of_int s * x) * hf n x)"
	+ have sF_der: "(sF has_real_derivative sF' x) (at x)" for x
	+ unfolding sF_def sF'_def
	+ by (rule refl Fder derivative_eq_intros \| force simp: algebra_simps)+
	+ let ?N = "b * integral {0..1} sF'"
	+ have sF'_integral: "(sF' has_integral sF 1 - sF 0) {0..1}"
	+ by (smt (verit) fundamental_theorem_of_calculus has_field_derivative_iff_has_vector_derivative
	+ has_vector_derivative_at_within sF_der)
	+ then have "?N = a * F 1 - b * F 0"
	+ using \<open>b > 0\<close> by (simp add: integral_unique exp_s sF_def algebra_simps)
	+ also have "\<dots> \<in> \<int>"
	+ using hf_deriv_1 by (simp add: F01_Ints)
	+ finally have N_Ints: "?N \<in> \<int>" .
	+ have "sF' (1/2) > 0" and ge0: "\<And>x. x \<in> {0..1} \<Longrightarrow> 0 \<le> sF' x"
	+ using assms by (auto simp add: sF'_def hf_def)
	+ moreover have "continuous_on {0..1} sF'"
	+ unfolding sF'_def hf_def by (intro continuous_intros) auto
	+ ultimately have False if "(sF' has_integral 0) {0..1}"
	+ using has_integral_0_cbox_imp_0 [of 0 1 sF' "1/2"] that by auto
	+ then have "integral {0..1} sF' > 0"
	+ by (metis ge0 has_integral_nonneg integral_unique order_le_less sF'_integral)
	+ then have "0 < ?N"
	+ by (simp add: \<open>b > 0\<close>)
	+ have "integral {0..1} sF' = of_int s ^ Suc(2n) integral {0..1} (\<lambda>x. exp (sx) hf n x)"
	+ unfolding sF'_def by force
	+ also have "\<dots> \<le> of_int s ^ Suc(2n) (exp s * (1 / fact n))"
	+ proof (rule mult_left_mono)
	+ have "integral {0..1} (\<lambda>x. exp (sx) hf n x) \<le> integral {0..1} (\<lambda>x::real. exp s * (1/fact n))"
	+ proof (intro mult_mono integral_le)
	+ show "(\<lambda>x. exp (sx) hf n x) integrable_on {0..1}"
	+ using \<open>0 < ?N\<close> not_integrable_integral sF'_def by fastforce
	+ qed (use assms hf_nonneg hf_le_inverse_fact in auto)
	+ also have "\<dots> = exp s * (1 / fact n)"
	+ by simp
	+ finally show "integral {0..1} (\<lambda>x. exp (sx) hf n x) \<le> exp s * (1 / fact n)" .
	+ qed (use assms in auto)
	+ finally have "?N \<le> b * of_int s ^ Suc(2n) exp s * (1 / fact n)"
	+ using \<open>b > 0\<close> by (simp add: sF'_def mult_ac divide_simps)
	+ also have "\<dots> < 1"
	+ using n apply (simp add: field_simps exp_s)
	+ by (metis of_int_fact of_int_less_iff of_int_mult of_int_power)
	+ finally show False
	+ using \<open>0 < ?N\<close> Ints_cases N_Ints by force
	+qed
	+
	+theorem exp_irrational:
	+ fixes q::real assumes "q \<in> \<rat>" "q \<noteq> 0" shows "exp q \<notin> \<rat>"
	+proof
	+ assume q: "exp q \<in> \<rat>"
	+ obtain s t where "s \<noteq> 0" "t > 0" "q = of_int s / of_int t"
	+ by (metis Rats_cases' assms div_0 of_int_0)
	+ then have "(exp q) ^ (nat t) = exp s"
	+ by (smt (verit, best) exp_divide_power_eq of_nat_nat zero_less_nat_eq)
	+ moreover have "exp q ^ (nat t) \<in> \<rat>"
	+ by (simp add: q)
	+ ultimately show False
	+ by (smt (verit, del_insts) Rats_inverse \<open>s \<noteq> 0\<close> exp_minus exp_nat_irrational of_int_of_nat)
	+qed
	+
	+corollary ln_irrational:
	+ fixes q::real assumes "q \<in> \<rat>" "q > 0" "q \<noteq> 1" shows "ln q \<notin> \<rat>"
	+ using assms exp_irrational [of "ln q"] exp_ln_iff [of q] by force
	+
	+end
	diff --git a/thys/Irrationals_From_THEBOOK/ROOT b/thys/Irrationals_From_THEBOOK/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Irrationals_From_THEBOOK/ROOT
	@@ -0,0 +1,10 @@
	+chapter AFP
	+
	+session Irrationals_From_THEBOOK (AFP) = Stirling_Formula +
	+ description "Exponentials are irrational, as proved by Aigner and Ziegler"
	+ options [timeout = 600]
	+ theories
	+ Irrationals_From_THEBOOK
	+ document_files
	+ "root.bib"
	+ "root.tex"
	diff --git a/thys/Irrationals_From_THEBOOK/document/root.bib b/thys/Irrationals_From_THEBOOK/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Irrationals_From_THEBOOK/document/root.bib
	@@ -0,0 +1,42 @@
	+%% This BibTeX bibliography file was created using BibDesk.
	+%% http://bibdesk.sourceforge.net/
	+
	+
	+%% Created for Larry Paulson at 2022-01-06 13:07:25 +0000
	+
	+
	+%% Saved with string encoding Unicode (UTF-8)
	+
	+
	+
	+@article{Hermite_Lindemann-AFP,
	+ author = {Manuel Eberl},
	+ date-added = {2022-01-06 13:05:35 +0000},
	+ date-modified = {2022-01-06 13:07:13 +0000},
	+ issn = {2150-914x},
	+ journal = {Archive of Formal Proofs},
	+ month = mar,
	+ note = {\url{https://isa-afp.org/entries/Hermite_Lindemann.html}, Formal proof development},
	+ title = {The {Hermite}--{Lindemann}--{Weierstra{\ss}} Transcendence Theorem},
	+ year = 2021}
	+
	+@article{Stirling_Formula-AFP,
	+ author = {Manuel Eberl},
	+ date-added = {2022-01-06 12:03:13 +0000},
	+ date-modified = {2022-01-06 12:03:13 +0000},
	+ issn = {2150-914x},
	+ journal = {Archive of Formal Proofs},
	+ month = sep,
	+ note = {\url{https://isa-afp.org/entries/Stirling_Formula.html}, Formal proof development},
	+ title = {Stirling's formula},
	+ year = 2016}
	+
	+@book{aigner-proofs,
	+ author = {M. Aigner and G. M. Ziegler},
	+ booktitle = {Proofs from THE BOOK},
	+ date-added = {2022-01-06 11:42:58 +0000},
	+ date-modified = {2022-01-06 13:07:25 +0000},
	+ edition = {6th},
	+ publisher = {Springer},
	+ title = {Proofs from THE BOOK},
	+ year = {2018}}
	diff --git a/thys/Irrationals_From_THEBOOK/document/root.tex b/thys/Irrationals_From_THEBOOK/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Irrationals_From_THEBOOK/document/root.tex
	@@ -0,0 +1,41 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{amsmath}
	+\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{Irrational numbers from THE BOOK}
	+\author{Lawrence C. Paulson}
	+\maketitle
	+
	+\begin{abstract}
	+An elementary proof is formalised: that $\exp r$ is irrational for every nonzero rational number~$r$. The mathematical development comes from the well-known volume \emph{Proofs from THE BOOK}~\cite[pp.\thinspace51--2]{aigner-proofs}, by Aigner and Ziegler, who credit the idea to Hermite. The development illustrates a number of basic Isabelle techniques: the manipulation of summations, the calculation of quite complicated derivatives and the estimation of integrals.
	+We also see how to import another AFP entry (Stirling's formula)~\cite{Stirling_Formula-AFP}.
	+
	+As for the theorem itself, note that a much stronger and more general result (the Hermite--Lindemann--Weierstra\ss{} transcendence theorem) is already available in the AFP~\cite{Hermite_Lindemann-AFP}.
	+\end{abstract}
	+
	+\newpage
	+\tableofcontents
	+
	+\paragraph*{Acknowledgements}
	+The author was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178) funded by the European Research Council.
	+
	+\newpage
	+
	+% include generated text of all theories
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/Isabelle_C/C11-FrontEnd/C_Appendices.thy b/thys/Isabelle_C/C11-FrontEnd/appendices/C_Appendices.thy
	rename from thys/Isabelle_C/C11-FrontEnd/C_Appendices.thy
	rename to thys/Isabelle_C/C11-FrontEnd/appendices/C_Appendices.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/C_Appendices.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/appendices/C_Appendices.thy
	@@ -1,905 +1,905 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	chapter \<open>A Resume on Isabelle/C: Commands, Control Attributes and Programming Infrastructure\<close>

	theory C_Appendices
	- imports "examples/C1"
	+ imports "../examples/C2"
	Isar_Ref.Base
	begin

	(<)
	ML \<comment> \<open>\<^file>\<open>~~/src/Doc/antiquote_setup.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Doc/antiquote_setup.ML
	Author: Makarius

	Auxiliary antiquotations for the Isabelle manuals.
	-*)
	+))
	\<open>
	structure C_Antiquote_Setup =
	struct

	(* misc utils *)

	fun translate f = Symbol.explode #> map f #> implode;

	val clean_string = translate
	(fn "_" => "\\_"
	\| "#" => "\\#"
	\| "$" => "\\$"
	\| "%" => "\\%"
	\| "<" => "$<$"
	\| ">" => "$>$"
	\| "{" => "\\{"
	\| "\|" => "$\\mid$"
	\| "}" => "\\}"
	\| "\<hyphen>" => "-"
	\| c => c);

	fun clean_name "\<dots>" = "dots"
	\| clean_name ".." = "ddot"
	\| clean_name "." = "dot"
	\| clean_name "_" = "underscore"
	\| clean_name "{" = "braceleft"
	\| clean_name "}" = "braceright"
	\| clean_name s = s \|> translate (fn "_" => "-"
	\| "\<hyphen>" => "-"
	\| "#" => "symbol-hash"
	\| "\<approx>" => "symbol-lower-approx"
	\| "\<Down>" => "symbol-upper-down"
	\| c => c);


	(* Isabelle/Isar entities (with index) *)

	local

	val arg = enclose "{" "}" o clean_string;

	fun entity check markup binding index =
	Document_Output.antiquotation_raw
	(binding \|> Binding.map_name (fn name => name ^
	(case index of NONE => "" \| SOME true => "_def" \| SOME false => "_ref")))
	(Scan.lift (Scan.optional (Args.parens Args.name) "" -- Parse.position Args.name))
	(fn ctxt => fn (logic, (name, pos)) =>
	let
	val kind = translate (fn "_" => " " \| c => c) (Binding.name_of binding);
	val hyper_name =
	"{" ^ Long_Name.append kind (Long_Name.append logic (clean_name name)) ^ "}";
	val hyper =
	enclose ("\\hyperlink" ^ hyper_name ^ "{") "}" #>
	index = SOME true ? enclose ("\\hypertarget" ^ hyper_name ^ "{") "}";
	val idx =
	(case index of
	NONE => ""
	\| SOME is_def =>
	"\\index" ^ (if is_def then "def" else "ref") ^ arg logic ^ arg kind ^ arg name);
	val _ =
	if Context_Position.is_reported ctxt pos then ignore (check ctxt (name, pos)) else ();
	val latex =
	idx ^
	(Output.output name
	\|> (if markup = "" then I else enclose ("\\" ^ markup ^ "{") "}")
	\|> hyper o enclose "\\mbox{\\isa{" "}}");
	in Latex.string latex end);

	fun entity_antiqs check markup kind =
	entity check markup kind NONE #>
	entity check markup kind (SOME true) #>
	entity check markup kind (SOME false);

	in

	val _ =
	Theory.setup
	(entity_antiqs C_Annotation.check_command "isacommand" \<^binding>\<open>annotation\<close>);

	end;

	end;

	\<close>
	(>)

	section \<open>Syntax Commands for Isabelle/C\<close>

	subsection \<open>Toplevel Commands and Control Attributes\<close>

	(* @{attribute_def C\<^sub>e\<^sub>n\<^sub>v\<^sub>0} cases LaTeX error *)
	text \<open>
	\begin{matharray}{rcl}
	@{command_def "C_file"} & : & \<open>local_theory \<rightarrow> local_theory\<close> \\
	@{command_def "C"} & : & \<open>local_theory \<rightarrow> local_theory\<close> \\
	@{command_def "C_export_boot"} & : & \<open>local_theory \<rightarrow> local_theory\<close> \\
	@{command_def "C_prf"} & : & \<open>proof \<rightarrow> proof\<close> \\
	@{command_def "C_val"} & : & \<open>any \<rightarrow>\<close> \\
	@{command_def "C_export_file"} & : & \<open>any \<rightarrow>\<close> \\
	\end{matharray}
	\begin{tabular}{rcll}
	@{attribute_def C_lexer_trace} & : & \<open>attribute\<close> & default \<open>false\<close> \\
	@{attribute_def C_parser_trace} & : & \<open>attribute\<close> & default \<open>false\<close> \\
	@{attribute_def C_ML_verbose} & : & \<open>attribute\<close> & default \<open>true\<close> \\
	\<open>C\<^sub>e\<^sub>n\<^sub>v\<^sub>0\<close> & : & \<open>attribute\<close> & default \<open>empty\<close> \\
	\<open>C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0\<close> & : & \<open>attribute\<close> & default \<open>translation_unit\<close> \\
	\end{tabular}

	\<^rail>\<open>
	@@{command C_file} @{syntax name} ';'?
	;
	(@@{command C} \| @@{command C_export_boot} \| @@{command C_prf} \|
	@@{command C_val}) @{syntax text}
	;
	@@{command C_export_file}
	;
	\<close>

	\<^descr> \<^theory_text>\<open>C_file name\<close> reads the given C file, and let any attached
	semantic back-ends to proceed for further subsequent evaluation. Top-level C bindings are stored
	within the (global or local) theory context; the initial environment is set by default to be an
	empty one, or the one returned by a previous \<^theory_text>\<open>C_file\<close> (depending on attribute
	\<open>C\<^sub>e\<^sub>n\<^sub>v\<^sub>0\<close>). The entry-point of the grammar taken as initial starting point of the parser
	is read from attribute \<open>C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0\<close> (see
	\<^url>\<open>https://www.haskell.org/happy/doc/html/sec-directives.html#sec-parser-name\<close>).
	Multiple \<^theory_text>\<open>C_file\<close> commands may be used to build larger C projects if
	they are all written in a single theory file (existing parent theories are ignored, and not
	affecting the current working theory).

	\<^descr> \<^theory_text>\<open>C\<close> is similar to
	\<^theory_text>\<open>C_file\<close>, but evaluates directly the
	given \<open>text\<close>. Top-level resulting bindings are stored
	within the (global or local) theory context.

	\<^descr> \<^theory_text>\<open>C_export_boot\<close> is similar to
	\<^theory_text>\<open>ML_export\<close>, except that the code in
	input is understood as being processed by
	\<^theory_text>\<open>C\<close> instead of \<^theory_text>\<open>ML\<close>.

	\<^descr> \<^theory_text>\<open>C_prf\<close> is similar to
	\<^theory_text>\<open>ML_prf\<close>, except that the code in input
	is understood as being processed by
	\<^theory_text>\<open>C\<close> instead of \<^theory_text>\<open>ML\<close>.

	\<^descr> \<^theory_text>\<open>C_val\<close> is similar to
	\<^theory_text>\<open>ML_val\<close>, except that the code in input
	is understood as being processed by
	\<^theory_text>\<open>C\<close> instead of \<^theory_text>\<open>ML\<close>.

	\<^descr> \<^theory_text>\<open>C_export_file\<close> is similar to
	\<^theory_text>\<open>generate_file fic = \<open>code\<close>
	export_generated_files fic\<close>, except that
	\<^item> \<open>code\<close> refers to the dump of all existing previous C code in the current
	theory (parent theories are ignored),
	\<^item> and any ML antiquotations in \<open>code\<close> are not analyzed by
	\<^theory_text>\<open>generate_file\<close> (in contrast with its default behavior). \<close>

	(* again, @{attribute C\<^sub>e\<^sub>n\<^sub>v\<^sub>0} and @{attribute C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0} cause LaTeX errors... *)
	text \<open>

	\<^descr> @{attribute C_lexer_trace} indicates whether the list of C
	tokens associated to the source text should be output (that list is
	computed during the lexing phase).

	\<^descr> @{attribute C_parser_trace} indicates whether the stack
	forest of Shift-Reduce node should be output (it is the final stack
	which is printed, i.e., the one taken as soon as the parsing
	terminates).

	\<^descr> @{attribute C_ML_verbose} indicates whether nested
	\<^theory_text>\<open>ML\<close> commands are acting similarly as
	their default verbose configuration in top-level.

	\<^descr> \<open>C\<^sub>e\<^sub>n\<^sub>v\<^sub>0\<close> makes the start of a C
	command (e.g., \<^theory_text>\<open>C_file\<close>,
	\<^theory_text>\<open>C\<close>) initialized with the environment of
	the previous C command if existing.

	\<^descr> \<open>C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0\<close> sets the root syntactic category in which the parser starts.
	C commands (e.g., \<^theory_text>\<open>C_file\<close>, \<^theory_text>\<open>C\<close>). Possible values are:
	\<^descr> \<open>"expression"\<close>,
	\<^descr> \<open>"statement"\<close>,
	\<^descr> \<open>"external_declaration"\<close> and
	\<^descr> \<open>"translation_unit"\<close> (the default)
	\<close>

	subsection \<open>Predefined Annotation Commands inside the C context (C Annotation commands)\<close>

	text \<open>
	\<^rail>\<open>
	(@@{annotation "#ML_file"} \| @@{annotation ML_file} \| @@{annotation "ML_file\<Down>"} \|
	@@{annotation "#C_file"} \| @@{annotation C_file} \| @@{annotation "C_file\<Down>"}) @{syntax name} ';'?
	;
	(@@{annotation "#ML"} \| @@{annotation ML} \| @@{annotation "ML\<Down>"} \|
	@@{annotation "#setup"} \| @@{annotation setup} \| @@{annotation "setup\<Down>"} \|
	@@{annotation "\<approx>setup"} \| @@{annotation "\<approx>setup\<Down>"} \|
	@@{annotation "#C"} \| @@{annotation C} \| @@{annotation "C\<Down>"} \|
	@@{annotation "#C_export_boot"} \| @@{annotation C_export_boot} \| @@{annotation "C_export_boot\<Down>"}) @{syntax text}
	;
	(@@{annotation "#C_export_file"} \| @@{annotation C_export_file} \| @@{annotation "C_export_file\<Down>"} \|
	@@{annotation highlight} \| @@{annotation "highlight\<Down>"})
	;
	\<close>

	\<^descr> \<^C_theory_text>\<open>ML_file\<close>, \<^C_theory_text>\<open>C_file\<close>,
	\<^C_theory_text>\<open>ML\<close>, \<^C_theory_text>\<open>setup\<close>,
	\<^C_theory_text>\<open>C\<close>, \<^C_theory_text>\<open>C_export_boot\<close>, and
	\<^C_theory_text>\<open>C_export_file\<close> behave similarly as the respective outer commands
	\<^theory_text>\<open>ML_file\<close>, \<^theory_text>\<open>C_file\<close>,
	\<^theory_text>\<open>ML\<close>, \<^theory_text>\<open>setup\<close>,
	\<^theory_text>\<open>C\<close>, \<^theory_text>\<open>C_export_boot\<close>,
	\<^theory_text>\<open>C_export_file\<close>.

	\<^descr> \<^C_theory_text>\<open>\<approx>setup \<open>f'\<close>\<close> has the same semantics
	as \<^C_theory_text>\<open>setup \<open>f\<close>\<close> whenever \<^term>\<open>\<And> stack top
	env. f' stack top env = f\<close>. In particular, depending on where the annotation
	\<^C_theory_text>\<open>\<approx>setup \<open>f'\<close>\<close> is located in the C code, the
	additional values \<open>stack\<close>, \<open>top\<close> and \<open>env\<close> can drastically
	vary, and then can be possibly used in the body of \<open>f'\<close> for implementing new
	interactive features (e.g., in contrast to \<open>f\<close>, which by default does not have the
	possibility to directly use the information provided by \<open>stack\<close>, \<open>top\<close>
	and \<open>env\<close>).

	\<^descr> \<^C_theory_text>\<open>highlight\<close> changes the background color of the C tokens pointed by the command.

	\<^descr> \<^C_theory_text>\<open>#ML_file\<close>,
	\<^C_theory_text>\<open>#C_file\<close>, \<^C_theory_text>\<open>#ML\<close>,
	\<^C_theory_text>\<open>#setup\<close>,
	\<^C_theory_text>\<open>#C\<close>,
	\<^C_theory_text>\<open>#C_export_boot\<close>, and
	\<^C_theory_text>\<open>#C_export_file\<close>
	behave similarly as the respective (above inner) commands
	\<^C_theory_text>\<open>ML_file\<close>,
	\<^C_theory_text>\<open>C_file\<close>, \<^C_theory_text>\<open>ML\<close>,
	\<^C_theory_text>\<open>setup\<close>,
	\<^C_theory_text>\<open>C\<close>,
	\<^C_theory_text>\<open>C_export_boot\<close>, and
	\<^C_theory_text>\<open>C_export_file\<close>
	except that their evaluations happen as earliest as possible.

	\<^descr> \<^C_theory_text>\<open>ML_file\<Down>\<close>,
	\<^C_theory_text>\<open>C_file\<Down>\<close>, \<^C_theory_text>\<open>ML\<Down>\<close>,
	\<^C_theory_text>\<open>setup\<Down>\<close>,
	\<^C_theory_text>\<open>\<approx>setup\<Down>\<close>, \<^C_theory_text>\<open>C\<Down>\<close>,
	\<^C_theory_text>\<open>C_export_boot\<Down>\<close>,
	\<^C_theory_text>\<open>C_export_file\<Down>\<close>, and
	\<^C_theory_text>\<open>highlight\<Down>\<close>
	behave similarly as the respective (above inner) commands
	\<^C_theory_text>\<open>ML_file\<close>, \<^C_theory_text>\<open>C_file\<close>,
	\<^C_theory_text>\<open>ML\<close>, \<^C_theory_text>\<open>setup\<close>,
	\<^C_theory_text>\<open>\<approx>setup\<close>, \<^C_theory_text>\<open>C\<close>,
	\<^C_theory_text>\<open>C_export_boot\<close>,
	\<^C_theory_text>\<open>C_export_file\<close>, and
	\<^C_theory_text>\<open>highlight\<close>
	except that their evaluations happen as latest as possible.
	\<close>

	subsection \<open>Inner Directive Commands\<close>

	text \<open>
	\<^descr> Among the directives provided as predefined in Isabelle/C, we currently have:
	\<^C>\<open>#define _\<close> and \<^C>\<open>#undef _\<close>. In particular, for the case of
	\<^C>\<open>#define _\<close>, rewrites are restricted to variable-form macros: support of
	functional macros is not yet provided.
	\<^descr> In Isabelle/C, not-yet-defined directives (such as \<^C>\<open>#include _\<close> or
	\<^C>\<open>#if
	#endif\<close>, etc.) do not make the parsing fail, but are treated as ``free variable commands''.
	\<close>

	section \<open>Quick Start (for People More Familiar with C than Isabelle)\<close>

	text \<open>
	-\<^item> Assuming we are working with Isabelle 2019
	-\<^url>\<open>http://isabelle.in.tum.de/dist/Isabelle2019_app.tar.gz\<close>, the shortest way to
	+\<^item> Assuming we are working with Isabelle 2021
	+\<^url>\<open>https://isabelle.in.tum.de/website-Isabelle2021/dist/Isabelle2021_linux.tar.gz\<close>, the shortest way to
	start programming in C is to open a new theory file with the shell-command:

	\<^verbatim>\<open>$ISABELLE_HOME/bin/isabelle jedit -d $AFP_HOME/thys Scratch.thy\<close>

	where \<^verbatim>\<open>$ISABELLE_HOME\<close> is the path of the above extracted Isabelle source,
	and \<^verbatim>\<open>$AFP_HOME\<close> is the downloaded content of
	-\<^url>\<open>https://bitbucket.org/isa-afp/afp-2019\<close>.\<^footnote>\<open>This folder
	+\<^url>\<open>https://foss.heptapod.net/isa-afp/afp-2021\<close>.\<^footnote>\<open>This folder
	particularly contains the Isabelle/C project, located in
	-\<^url>\<open>https://bitbucket.org/isa-afp/afp-2019/src/default/thys/Isabelle_C\<close>. To inspect
	+\<^url>\<open>https://foss.heptapod.net/isa-afp/afp-2021/-/tree/branch/default/thys/Isabelle_C\<close>. To inspect
	the latest developper version, one can also replace \<^verbatim>\<open>$AFP_HOME/thys\<close> by the
	-content downloaded from \<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c\<close>.\<close>
	+content downloaded from \<^url>\<open>https://gitlab.lisn.upsaclay.fr/burkhart.wolff/Isabelle_C\<close>.\<close>
	\<^item> The next step is to copy this minimal content inside the newly opened window:
	\<^verbatim>\<open>theory Scratch imports Isabelle_C.C_Main begin C \<open>
	// C code
	\<close> end\<close>
	\<^item> \<^emph>\<open>Quod Erat Demonstrandum!\<close> This already enables the support of C code inside the special
	brackets ``\<^verbatim>\<open>\<open>\<close>\<close>'', now depicted as
	``\<open>\<open>\<close>\<close>'' for readability reasons. \<close>

	text_raw \<open>
	\begin{figure}
	\centering
	\includegraphics[width=\textwidth]{figures/C-export-example}
	\caption{Making the File Browser Pointing to the Virtual File System}
	\label{fig:file-bro}
	\end{figure}
	\<close>

	text \<open> Additionally, Isabelle/C comes with several functionalities that can be alternatively
	explored:
	\<^item> To write theorems and proofs along with C code, the special C comment
	\<^C>\<open>/@ ( Isabelle content ) /\<close> can be used at any position where C comments are
	usually regularly allowed. At the time of writing, not yet all Isabelle commands can be written in C
	comments, and certain proof-solving-command combinations are also not yet implemented --- manual
	registration of commands to retrieve some more or less native user-experience remains possible
	though. Generally, the kind of content one can write in C comments should be arbitrary. The
	exhaustive list of Isabelle commands is provided in the accompanying above archive, for example in
	\<^dir>\<open>$ISABELLE_HOME/src/Doc/Isar_Ref\<close> or
	\<^url>\<open>https://isabelle.in.tum.de/doc/isar-ref.pdf\<close>.

	\<^item> Instead of starting from scratch, any existing C files can also be opened with Isabelle/C,
	it suffices to replace:

	\begin{tabular}{c}
	\<^verbatim>\<open>C\<close> \<^theory_text>\<open>\<open> /* C */ \<close>\<close> \\
	by \\
	\<^verbatim>\<open>C_file\<close> \<^theory_text>\<open>\<open>~/file.c\<close>\<close>
	\end{tabular}

	Once done, one can press a CTRL-like key while hovering the mouse over the file name, then followed
	by a click on it to open a new window loading that file.

	\<^item> After a \<^verbatim>\<open>C\<close> \<^theory_text>\<open>\<open> /* C */ \<close>\<close>
	command, one has either the possibility to keep the content as such in the theory file, or use
	\<^verbatim>\<open>C_export_file\<close> to export all previous C content into a ``real'' C file.

	Note that since Isabelle2019, Isabelle/C uses a virtual file-system. This has the consequence, that
	some extra operations are needed to export a file generated into the virtual file-system of Isabelle
	into the ``real'' file-system. First, the \<^verbatim>\<open>C_export_file\<close> command needs to
	be activated, by putting the cursor on the command. This leads to the following message in the
	output window: \<^verbatim>\<open>See theory exports "C//.c"\<close> (see
	\autoref{fig:file-bro}). By clicking on \<open>theory exports\<close> in
	this message, Isabelle opens a \<open>File Browser\<close> showing the content of the virtual
	file-system in the left window. Selecting and opening a generated file in the latter lets jEdit
	display it in a new buffer, which gives the possibility to export this file via ``\<open>File
	\<rightarrow> Save As\<dots>\<close>'' into the real file-system. \<close>

	section \<open>Case Study: Mapping on the Parsed AST via C99 ASTs\<close>

	text \<open> In this section, we give a concrete example of a situation where one is interested to
	do some automated transformations on the parsed AST, such as changing the type of every encountered
	variables from \<^C>\<open>int _;\<close> to \<^C>\<open>int _ [];\<close>. The main theory of
	interest here is \<^theory>\<open>Isabelle_C.C_Parser_Language\<close>, where the C grammar is
	loaded, in contrast to \<^theory>\<open>Isabelle_C.C_Lexer_Language\<close> which is only dedicated
	to build a list of C tokens. As another example,
	\<^theory>\<open>Isabelle_C.C_Parser_Language\<close> also contains the portion of the code
	implementing the report to the user of various characteristics of encountered variables during
	parsing: if a variable is bound or free, or if the declaration of a variable is made in the global
	topmost space or locally declared in a function. \<close>

	subsection \<open>Prerequisites\<close>

	-text \<open> Even if \<^file>\<open>generated/c_grammar_fun.grm.sig\<close> and
	-\<^file>\<open>generated/c_grammar_fun.grm.sml\<close> are files written in ML syntax, we have
	-actually modified \<^dir>\<open>../src_ext/mlton/lib/mlyacc-lib\<close> in such a way that at run
	-time, the overall loading and execution of
	-\<^theory>\<open>Isabelle_C.C_Parser_Language\<close> will mimic all necessary features of the
	-Haskell parser generator Happy
	+text \<open> Even if \<^file>\<open>../generated/c_grammar_fun.grm.sig\<close> and
	+\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close> are files written in ML syntax, we have
	+actually modified \<^dir>\<open>../../src_ext/mlton/lib/mlyacc-lib\<close> in such a way that at run
	+time, the overall loading and execution of \<^theory>\<open>Isabelle_C.C_Parser_Language\<close>
	+will mimic all necessary features of the Haskell parser generator Happy
	\<^footnote>\<open>\<^url>\<open>https://www.haskell.org/happy/doc/html/index.html\<close>\<close>,
	including any monadic interactions between the lexing
	(\<^theory>\<open>Isabelle_C.C_Lexer_Language\<close>) and parsing part
	(\<^theory>\<open>Isabelle_C.C_Parser_Language\<close>).

	This is why in the remaining part, we will at least assume a mandatory familiarity with Happy (e.g.,
	the reading of ML-Yacc's manual can happen later if wished
	\<^footnote>\<open>\<^url>\<open>https://www.cs.princeton.edu/~appel/modern/ml/ml-yacc/manual.html\<close>\<close>). In
	particular, we will use the term \<^emph>\<open>rule code\<close> to designate \<^emph>\<open>a
	Haskell expression enclosed in braces\<close>
	\<^footnote>\<open>\<^url>\<open>https://www.haskell.org/happy/doc/html/sec-grammar.html\<close>\<close>.
	\<close>

	subsection \<open>Structure of \<^theory>\<open>Isabelle_C.C_Parser_Language\<close>\<close>

	text \<open> In more detail, \<^theory>\<open>Isabelle_C.C_Parser_Language\<close> can be seen as being
	principally divided into two parts:
	\<^item> a first part containing the implementation of
	\<^ML_structure>\<open>C_Grammar_Rule_Lib\<close>, which provides the ML implementation library
	used by any rule code written in the C grammar
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Parser/Parser.y\<close>
	- (\<^file>\<open>generated/c_grammar_fun.grm.sml\<close>).
	+ (\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>).
	\<^item> a second part implementing \<^ML_structure>\<open>C_Grammar_Rule_Wrap\<close>, providing
	one wrapping function for each rule code, for potentially complementing the rule code with an
	additional action to be executed after its call. The use of wrapping functions is very optional:
	by default, they are all assigned as identity functions.

	The difference between \<^ML_structure>\<open>C_Grammar_Rule_Lib\<close> and
	\<^ML_structure>\<open>C_Grammar_Rule_Wrap\<close> relies in how often functions in the two
	structures are called: while building subtree pieces of the final AST, grammar rules are free to
	call any functions in \<^ML_structure>\<open>C_Grammar_Rule_Lib\<close> for completing their
	respective tasks, but also free to not use \<^ML_structure>\<open>C_Grammar_Rule_Lib\<close> at
	all. On the other hand, irrespective of the actions done by a rule code, the function associated to
	the rule code in \<^ML_structure>\<open>C_Grammar_Rule_Wrap\<close> is retrieved and always executed
	(but a visible side-effect will likely mostly happen whenever one has provided an implementation far
	different from \<^ML>\<open>I\<close>). \<close>

	text \<open> Because the grammar
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Parser/Parser.y\<close>
	-(\<^file>\<open>generated/c_grammar_fun.grm.sml\<close>) has been defined in such a way that
	+(\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>) has been defined in such a way that
	computation of variable scopes are completely handled by functions in
	\<^ML_structure>\<open>C_Grammar_Rule_Lib\<close> and not in rule code (which are just calling
	functions in \<^ML_structure>\<open>C_Grammar_Rule_Lib\<close>), it is enough to overload functions
	in \<^ML_structure>\<open>C_Grammar_Rule_Lib\<close> whenever it is wished to perform new actions
	depending on variable scopes, for example to do a specific PIDE report at the first time when a C
	variable is being declared. In particular, functions in
	\<^ML_structure>\<open>C_Grammar_Rule_Lib\<close> are implemented in monadic style, making a
	subsequent modification on the parsing environment \<^theory>\<open>Isabelle_C.C_Environment\<close> possible
	(whenever appropriate) as this last is carried in the monadic state.

	Fundamentally, this is feasible because the monadic environment fulfills the property of being
	always properly enriched with declared variable information at any time, because we assume
	\<^item> working with a language where a used variable must be at most declared or redeclared
	somewhere before its actual usage,
	\<^item> and using a parser scanning tokens uniquely, from left to right, in the same order as
	the execution of rule code actions. \<close>

	subsubsection \<open>Example\<close>

	text \<open> As illustration, \<^ML>\<open>C_Grammar_Rule_Lib.markup_var o C_Ast.Left\<close> is
	(implicitly) called by a rule code while a variable being declared is encountered. Later, a call to
	\<^ML>\<open>C_Grammar_Rule_Lib.markup_var o C_Ast.Right\<close> in
	\<^ML_structure>\<open>C_Grammar_Rule_Wrap\<close> (actually, in
	\<^ML_structure>\<open>C_Grammar_Rule_Wrap_Overloading\<close>) is made after the execution of
	another rule code to signal the position of a variable in use, together with the information
	retrieved from the environment of the position of where it is declared. \<close>

	text \<open> In more detail, the second argument of
	\<^ML>\<open>C_Grammar_Rule_Lib.markup_var\<close> is among other of the form:
	\<^ML_type>\<open>Position.T * {global: bool}\<close>, where particularly the field
	\<^ML>\<open>#global : C_Env.markup_ident -> bool\<close> of the record is informing
	\<^ML>\<open>C_Grammar_Rule_Lib.markup_var\<close> if the variable being reported (at either first
	declaration time, or first use time) is global or local (inside a function for instance). Because
	once declared, the property \<^ML>\<open>#global : C_Env.markup_ident -> bool\<close> of a variable
	does not change afterwards, it is enough to store that information in the monadic environment:
	\<^item> \<^bold>\<open>Storing the information at declaration time\<close> The part deciding if a
	variable being declared is global or not is implemented in
	\<^ML>\<open>C_Grammar_Rule_Lib.doDeclIdent\<close> and
	\<^ML>\<open>C_Grammar_Rule_Lib.doFuncParamDeclIdent\<close>. The two functions come from
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Parser/Parser.y\<close>
	(so do any functions in \<^ML_structure>\<open>C_Grammar_Rule_Lib\<close>). Ultimately, they are
	both calling \<^ML>\<open>C_Grammar_Rule_Lib.markup_var o C_Ast.Left\<close> at some point.
	\<^item> \<^bold>\<open>Retrieving the information at use time\<close>
	\<^ML>\<open>C_Grammar_Rule_Lib.markup_var o C_Ast.Right\<close> is only called by
	\<^ML>\<open>C_Grammar_Rule_Wrap.primary_expression1\<close>, while treating a variable being
	already declared. In particular the second argument of
	\<^ML>\<open>C_Grammar_Rule_Lib.markup_var\<close> is just provided by what has been computed by the
	above point when the variable was declared (e.g., the globality versus locality
	information). \<close>

	subsection \<open>Rewriting of AST node\<close>

	text \<open> For the case of rewriting a specific AST node, from subtree \<open>T1\<close> to
	subtree \<open>T2\<close>, it is useful to zoom on the different parsing evaluation stages, as well
	as make precise when the evaluation of semantic back-ends are starting.

	\<^enum> Whereas annotations in Isabelle/C code have the potential of carrying arbitrary ML code (as
	-in \<^theory>\<open>Isabelle_C.C1\<close>), the moment when they are effectively evaluated
	+in \<^theory>\<open>Isabelle_C.C2\<close>), the moment when they are effectively evaluated
	will not be discussed here, because to closely follow the semantics of the language in embedding (so
	C), we suppose comments --- comprising annotations --- may not affect any parsed tokens living
	outside comments. So no matter when annotations are scheduled to be future evaluated in Isabelle/C,
	the design decision of Isabelle/C is to not let a code do directive-like side-effects in
	annotations, such as changing \<open>T1\<close> to \<open>T2\<close> inside annotations.

	\<^enum> To our knowledge, the sole category of code having the capacity to affect incoming stream
	of tokens are directives, which are processed and evaluated before the ``major'' parsing step
	occurs. Since in Isabelle/C, directives are relying on ML code, changing an AST node from
	\<open>T1\<close> to \<open>T2\<close> can then be perfectly implemented in directives.

	\<^enum> After the directive (pre)processing step, the main parsing happens. But since what are
	driving the parsing engine are principally rule code, this step means to execute
	\<^ML_structure>\<open>C_Grammar_Rule_Lib\<close> and
	\<^ML_structure>\<open>C_Grammar_Rule_Wrap\<close>, i.e., rules in
	-\<^file>\<open>generated/c_grammar_fun.grm.sml\<close>.
	+\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>.

	\<^enum> Once the parsing finishes, we have a final AST value, which topmost root type entry-point
	constitutes the last node built before the grammar parser
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Parser/Parser.y\<close>
	ever entered in a stop state. For the case of a stop acceptance state, that moment happens when we
	reach the first rule code building the type \<^ML_type>\<open>C_Ast.CTranslUnit\<close>, since there
	is only one possible node making the parsing stop, according to what is currently written in the C
	grammar. (For the case of a state stopped due to an error, it is the last successfully built value
	that is returned, but to simplify the discussion, we will assume in the rest of the document the
	parser is taking in input a fully well-parsed C code.)

	\<^enum> By \<^emph>\<open>semantic back-ends\<close>, we denote any kind of ``relatively
	efficient'' compiled code generating Isabelle/HOL theorems, proofs, definitions, and so with the
	potential of generally generating Isabelle packages. In our case, the input of semantic back-ends
	will be the type \<^ML_type>\<open>C_Ast.CTranslUnit\<close> (actually, whatever value provided by
	the above parser). But since our parser is written in monadic style, it is as well possible to give
	slightly more information to semantic back-ends, such as the last monadic computed state, so
	including the last state of the parsing environment. \<close>

	text \<open> Generally, semantic back-ends can be written in full ML starting from
	\<^ML_type>\<open>C_Ast.CTranslUnit\<close>, but to additionally support formalizing tasks requiring
	to start from an AST defined in Isabelle/HOL, we provide an equivalent AST in HOL in the project,
	such as the one obtained after loading
	-\<^url>\<open>https://gitlri.lri.fr/ftuong/citadelle-devel/blob/master/doc/Meta_C_generated.thy\<close>.
	+\<^url>\<open>https://gitlab.lisn.upsaclay.fr/frederictuong/isabelle_contrib/-/blob/master/Citadelle/doc/Meta_C_generated.thy\<close>.
	(In fact, the ML AST is just generated from the HOL one.) \<close>



	text \<open>
	Based on the above information, there are now several \<^emph>\<open>equivalent\<close> ways to
	proceed for the purpose of having an AST node be mapped from \<open>T1\<close> to
	\<open>T2\<close>. The next bullets providing several possible solutions to follow are particularly
	sorted in increasing action time.

	\<^item> \<^emph>\<open>Before even starting the Isabelle system.\<close> A first approach would be
	to modify the C code in input, by adding a directive \<^C>\<open>#define _ _\<close> performing the
	necessary rewrite.

	\<^item> \<^emph>\<open>Before even starting the Isabelle system.\<close> As an alternative of
	changing the C code, one can modify
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Parser/Parser.y\<close>
	by hand, by explicitly writing \<open>T2\<close> at the specific position of the rule code
	generating \<open>T1\<close>. However, this solution implies to re-generate
	-\<^file>\<open>generated/c_grammar_fun.grm.sml\<close>.
	+\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>.

	\<^item> \<^emph>\<open>At grammar loading time, while the source of Isabelle/C is still being
	processed.\<close> Instead of modifying the grammar, it should be possible to first locate which
	rule code is building \<open>T1\<close>. Then it would remain to retrieve and modify the respective
	function of \<^ML_structure>\<open>C_Grammar_Rule_Wrap\<close> executed after that rule code, by
	providing a replacement function to be put in
	\<^ML_structure>\<open>C_Grammar_Rule_Wrap_Overloading\<close>. However, as a design decision,
	-wrapping functions generated in \<^file>\<open>generated/c_grammar_fun.grm.sml\<close> have only
	+wrapping functions generated in \<^file>\<open>../generated/c_grammar_fun.grm.sml\<close> have only
	been generated to affect monadic states, not AST values. This is to prevent an erroneous replacement
	of an end-user while parsing C code. (It is currently left open about whether this feature will be
	implemented in future versions of the parser...)

	\<^item> \<^emph>\<open>At directive setup time, before executing any
	\<^theory_text>\<open>C\<close> command of interest.\<close> Since the behavior of directives can be
	dynamically modified, this solution amounts to change the semantics of any wished directive,
	appearing enough earlier in the code. (But for the overall code be in the end mostly compatible with
	any other C preprocessors, the implementation change has to be somehow at least consistent with how
	a preprocessor is already expected to treat an initial C un(pre)processed code.) For example, the
	current semantics of \<^C>\<open>#undef _\<close> depends on what has been registered in
	\<^ML>\<open>C_Context.directive_update\<close> (see \<^theory>\<open>Isabelle_C.C_Command\<close>).

	\<^item> \<^emph>\<open>After parsing and obtaining a constructive value.\<close> Another solution
	consists in directly writing a mapping function acting on the full AST, so writing a ML function of
	type \<^ML_type>\<open>C_Ast.CTranslUnit -> C_Ast.CTranslUnit\<close> (or a respective HOL function)
	which has to act on every constructor of the AST (so in the worst case about hundred of constructors
	for the considered AST, i.e., whenever a node has to be not identically returned). However, as we
	have already implemented a conversion function from \<^ML_type>\<open>C_Ast.CTranslUnit\<close>
	(subset of C11) to a subset AST of C99, it might be useful to save some effort by starting from this
	conversion function, locate where \<open>T1\<close> is pattern-matched by the conversion function,
	and generate \<open>T2\<close> instead.

	As example, the conversion function \<^ML>\<open>C_Ast.main\<close> is particularly used to connect
	the C11 front-end to the entry-point of AutoCorres in
	\<^verbatim>\<open>l4v/src/tools/c-parser/StrictCParser.ML\<close>.

	\<^item> \<^emph>\<open>At semantic back-ends execution time.\<close> The above points were dealing
	with the cases where modification actions were all occurring before getting a final
	\<^ML_type>\<open>C_Ast.CTranslUnit\<close> value. But this does not mean it is forbidden to make
	some slight adjustments once that resulting \<^ML_type>\<open>C_Ast.CTranslUnit\<close> value
	obtained. In particular, it is the tasks of semantic back-ends to precisely work with
	\<^ML_type>\<open>C_Ast.CTranslUnit\<close> as starting point, and possibly translate it to another
	different type. So letting a semantic back-end implement the mapping from \<open>T1\<close> to
	\<open>T2\<close> would mean here to first understand the back-end of interest's architecture, to
	see where the necessary minimal modifications must be made.

	By taking l4v as a back-end example, its integration with Isabelle/C first starts with translating
	\<^ML_type>\<open>C_Ast.CTranslUnit\<close> to l4v's default C99 AST. Then various analyses on the
	obtained AST are performed in
	\<^url>\<open>https://github.com/seL4/l4v/tree/master/tools/c-parser\<close> (the reader interested
	in the details can start by further exploring the ML files loaded by
	\<^url>\<open>https://github.com/seL4/l4v/blob/master/tools/c-parser/CTranslation.thy\<close>). In
	short, to implement the mapping from \<open>T1\<close> to \<open>T2\<close> in the back-end part,
	one can either:
	\<^item> modify the translation from \<^ML_type>\<open>C_Ast.CTranslUnit\<close> to C99,
	\<^item> or modify the necessary ML files of interests in the l4v project.
	\<close>

	text \<open> More generally, to better inspect the list of rule code really executed when a C code
	-is parsed, it might be helpful to proceed as in \<^theory>\<open>Isabelle_C.C1\<close>, by activating
	+is parsed, it might be helpful to proceed as in \<^theory>\<open>Isabelle_C.C2\<close>, by activating
	\<^theory_text>\<open>declare[[C_parser_trace]]\<close>. Then, the output window will display the
	sequence of Shift Reduce actions associated to the \<^theory_text>\<open>C\<close> command of
	interest.
	\<close>

	text\<open>\<^bold>\<open>NOTE\<close> :the C99 library is part of the configuration with AutoCorres, which is
	currently only available for Isabelle2019.\<close>

	section \<open>Case Study: Mapping on the Parsed AST via the \<^ML_structure>\<open>C11_Ast_Lib\<close>\<close>

	ML\<open>open C11_Ast_Lib\<close>
	text\<open>A simpler alternative for connecting Isabelle/C to a semantic backend is the use of the
	\<^ML_structure>\<open>C11_Ast_Lib\<close>, an API for the C11 abstract syntax. Among a number of utilities,
	it provides a family of iterators (or: hylomorphisms, generalized fold operators, or whatever
	terminology you prefer). There is a fold-operator for each C11 Ast-category :
	\<^enum> \<^ML>\<open>fold_cArraySize: 'a -> (node_content->'a->'b->'b) -> 'a C_Ast.cArraySize -> 'b -> 'b\<close>
	\<^enum> \<^ML>\<open>fold_cCompoundBlockItem: (node_content->'a->'b->'b) -> 'a C_Ast.cCompoundBlockItem->'b->'b\<close>
	\<^enum> \<^ML>\<open>fold_cArraySize: 'a -> (node_content->'a->'b->'b) -> 'a C_Ast.cArraySize -> 'b -> 'b\<close>
	\<^enum> \<^ML>\<open>fold_cDeclaration: (node_content->'a->'b->'b) -> 'a C_Ast.cDeclaration -> 'b -> 'b\<close>
	\<^enum> \<^ML>\<open>fold_cExpression: (node_content->'a->'b->'b) -> 'a C_Ast.cExpression -> 'b -> 'b\<close>
	\<^enum> \<^ML>\<open>fold_cStatement: (node_content->'a->'b->'b) -> 'a C_Ast.cStatement -> 'b -> 'b\<close>
	\<^enum> \<^ML>\<open>fold_cExternalDeclaration: (node_content->'a->'b->'b) -> 'a C_Ast.cExternalDeclaration->'b->'b\<close>
	\<^enum> \<^ML>\<open>fold_cTranslationUnit: (node_content->'a->'b->'b) -> 'a C_Ast.cTranslationUnit -> 'b -> 'b\<close>
	\<^enum> etc.
	\<close>
	text\<open>Here, \<^ML_type>\<open>node_content\<close> is a data-structure providing untyped and uniform
	information on which rule has been applied, and what kind of particular decoration appears in the
	C11-Ast. \<close>

	text\<open> This allows for a simple programming of queries like "get the list of identifiers"
	directly on the C11-Ast. Moreover, it is pretty straight-forward to program a compiler to
	\<open>\<lambda>\<close>-terms for a specific semantic interpretation in Isabelle/HOL. A simple example is here:\<close>

	text\<open>
	@{theory_text [display]
	\<open>declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]
	C\<open>a + b * c - a / b\<close>
	ML\<open>val ast_expr = @{C11_CExpr}\<close>\<close>}

	@{verbatim [display]\<open>
	fun selectIdent0Binary (a as { tag, sub_tag, args }:C11_Ast_Lib.node_content)
	(b: C_Ast.nodeInfo )
	(c : term list)=
	case tag of
	"Ident0" => (node_content_2_free a)::c
	\|"CBinary0" => (case (drop_dark_matter sub_tag, c) of
	("CAddOp0",b::a::R) => (Const("Groups.plus_class.plus",dummyT) $ a $ b :: R)
	\| ("CMulOp0",b::a::R) => (Const("Groups.times_class.times",dummyT) $ a $ b :: R)
	\| ("CDivOp0",b::a::R) => (Const("Rings.divide_class.divide",dummyT) $ a $ b :: R)
	\| ("CSubOp0",b::a::R) => (Const("Groups.minus_class.minus",dummyT) $ a $ b :: R)
	\| _ => (writeln ("sub_tag all " ^sub_tag^" :>> "^ @{make_string} c);c ))
	\| _ => c;


	val S = (C11_Ast_Lib.fold_cExpression selectIdent0Binary ast_expr []);
	(* gives the (untyped) equivalent of : *)
	val S' = @{term "a + b * c - a / b"};
	\<close>}
	\<close>

	text\<open>This snippet is drawn from the C11-Example shown in Appendix III.\<close>

	section \<open>Known Limitations, Troubleshooting\<close>
	-subsection \<open>The Document Model of the Isabelle/PIDE\<close>
	+subsection \<open>The Document Model of the Isabelle/PIDE (applying since at least Isabelle 2019)\<close>
	subsubsection \<open>Introduction\<close>

	text \<open> Embedding C directives in C code is an act of common practice in numerous applications,
	as well as largely highlighted in the C standard. As an example of frequently encountered
	directives, \<open>#include <some_file.c>\<close> is used to insert the content of
	\<open>some_file.c\<close> at the place where it is written. In Isabelle/C, we can also write a C
	code containing directives like \<open>#include\<close>, and generally the PIDE reporting of
	directives is supported to a certain extent. Yet, the dynamic inclusion of arbitrary file with
	\<open>#include\<close> is hurting a certain technological barrier. This is related to how the
	document model of Isabelle 2019 is functioning, but also to the design decisions behind the
	implementation of \<^theory_text>\<open>C\<open> .. \<close>\<close>. Thus, providing a complete
	semantic implementation of \<open>#include\<close> might be not as evident as usual, if not more
	dangerous, i.e. ``something requiring a manual intervention in the source of Isabelle 2019''. In the
	next part, we show why in our current implementation of Isabelle/C there is no way for user
	programmed extensions to exploit implicit dependencies between sub-documents in pure ML: a
	sub-document referred to via \<open>#include <some_file>\<close> will not lead to a reevaluation of
	a \<^theory_text>\<open>C\<open> .. \<close>\<close> command whenever modified.\<close>

	subsubsection \<open>Embedding a language in Isabelle/PIDE\<close>

	text \<open>
	To clarify why the way a language being embedded in Isabelle is influencing the interaction between
	a future parser of the language with the Isabelle's document model, we recall the two ``different''
	ways of embedding a language in Isabelle/PIDE.

	At its most basic form, the general syntactic scope of an Isabelle/Isar document can be seen as
	being composed of two syntactic alternations of editing space: fragments of the inner syntax
	language, themselves part of the more general outer syntax (the inner syntax is implemented as an
	atomic entity of the outer language); see
	\<^file>\<open>~~/src/Doc/Isar_Ref/Outer_Syntax.thy\<close>. So strictly speaking, when attempting
	to support a new language \<open>L\<close> in Isabelle, there is always the question of fine-grain
	estimating which subsets of \<open>L\<close> will be represented in the outer syntax part, and if it
	possibly remains any left subsets to be represented on the more inner (syntactic) part.

	Generally, to answer this question, there are several criteria to consider:
	\<^item> Are there any escaping symbols conflicting between \<open>L\<close> and the outer
	(syntax) language, including for example the ASCII \<^verbatim>\<open>"\<close> or
	\<^verbatim>\<open>`\<close>?
	\<^item> Is \<open>L\<close> a realistic language, i.e. more complex than any combinations of
	outer named tokens that can be ever covered in terms of expressivity power (where the list of
	outer named tokens is provided in \<^file>\<open>~~/src/Doc/Isar_Ref/Outer_Syntax.thy\<close>)?
	\<^item> Is it preferable of not altering the outer syntax language with too specific and
	challenging features of \<open>L\<close>? This is particularly true since in Isabelle 2019, there
	is no way of modifying the outer syntax without making the modifications irremediably happen on
	its source code.

	For the above reasons, we have come up in Isabelle/C with the choice of making the full C language
	be supported inside the inner syntax allocated space. In particular, this has become all the more
	syntactically easy with the introduction of cartouches since Isabelle
	2014.\<^footnote>\<open>Fortunately, parsing tokens of C do not strongly conflict with cartouche
	delimiter symbols. For example, it should not be ethically wrong in C to write an opening cartouche
	symbol (possibly in a C comment) without writing any closing cartouche symbol afterwards. However,
	we have not encountered such C code in our tested codebase, and it is a functionality implicitly
	rejected by the current parser of Isabelle/C, as it is relying on Isabelle 2019's parser combinator
	library for the lexing part.\<close> However, for the case of the C language, certain C directives
	like \<open>#include\<close> are meant to heavily interact with external files. In particular,
	resources would be best utilized if we were taking advantage of the Isabelle's asynchronous document
	model for such interaction task. Unfortunately, the inner syntax space only has a minimum
	interaction with the document model, compared to the outer syntax one. Otherwise said, be it for
	experimenting the inner syntax layer and see how far it can deal with the document layer, or
	otherwise reimplementing parts of Isabelle/C in the outer syntax layer, the two solutions are
	conducting to do modifications in the Isabelle 2019 source code. \<close>

	text \<open> Note that the language embedding space of \<^theory_text>\<open>C\<close> closely
	resembles to how ML sources are delimited within a \<^theory_text>\<open>ML\<close>
	command. Additionally, in ML, one can use antiquotations to also refer to external files
	(particularly in formal comments). Still, the problem is still present in ML: referred files are not
	loaded in the document model. \<close>

	subsubsection \<open>Examples\<close>

	text \<open>
	\<^item> Commands declared as of type \<open>thy_decl\<close> in the theory header are scheduled
	to be executed once. Additionally, they are not tracking the content of file names provided in
	argument, so a change there will not trigger a reevaluation of the associated command. For
	example, even if the type of \<^theory_text>\<open>ML_file\<close> is not \<open>thy_decl\<close>,
	nothing prevents one to set it with \<open>thy_decl\<close> as type. In particular, by doing so,
	it is no more possible to CTRL-hover-click on the file name written after
	\<^theory_text>\<open>ML_file\<close>.
	\<^item> To make a command \<open>C\<close> track the content of \<open>file\<close>, whenever the
	file is changing, setting \<open>C\<close> to be of type \<open>thy_load\<close> in the theory
	header is a first step, but not enough. To be effective, \<open>file\<close> must also be loaded,
	by either explicitly opening it, or clicking on its name after the command. Examples of commands
	in this situation requiring a preliminary one-time-click include:
	\<^theory_text>\<open>external_file\<close>, \<^theory_text>\<open>bibtex_file\<close>,
	\<^theory_text>\<open>ML_file\<close>.
	Internally, the click is bound to a Scala code invoking a request to make an asynchronous
	dependency to the newly opened document at ML side.
	\<^item> In terms of recursivity, for the case of a chain of sub-documents of the form
	(a theory file containing: \<^theory_text>\<open>C_file \<open>file0.c\<close>\<close>)
	\<open>\<Longrightarrow>\<close>
	(C file \<^verbatim>\<open>file0.c\<close> containing: \<^C>\<open>#include <file1.c>\<close>)
	\<open>\<Longrightarrow>\<close>
	(C file \<^verbatim>\<open>file1.c\<close> containing: \<^C>\<open>#include <file2.c>\<close>)
	\<open>\<Longrightarrow>\<close>
	(C file \<^verbatim>\<open>file2.c\<close> containing: \<^C>\<open>#include <file3.c>\<close>), we
	ideally expect a modification in \<^verbatim>\<open>file3.c\<close> be taken into account in all
	ancestor files including the initial theory, provoking the associated command of the theory be
	reevaluated. However in C, directives resolving might be close to Turing-complete. For instance,
	one can also include files based on particular conditional situations: \<^C>\<open>#if _
	#include <file1>
	#else
	#include <file2>
	#include <file3>
	#endif\<close>
	\<^item> When a theory is depending on other theories (such as
	\<^theory>\<open>Isabelle_C.C_Eval\<close> depending on
	\<^theory>\<open>Isabelle_C.C_Parser_Language\<close> and
	\<^theory>\<open>Isabelle_C.C_Parser_Annotation\<close>), modifying the list of theories in
	importation automatically triggers what the user is expecting: for example, the newly added
	theories are dynamically imported, any change by another external editor makes everything
	consequently propagated.

	Following the internal implementation of the document model engine, we basically distinguish two
	phases of document importation: either at start-up time, or dynamically on user requests. Although
	the case of start-up time can be handled in pure ML side, the language dedicated to express which
	Isabelle theory files to import is less powerful than the close-to-Turing-completeness
	expressivity of C directives. On the other hand, the dynamic importation of files on user requests
	seems to be performed (at the time of writing) through a too high level ML protocol, mostly called
	from Scala side. Due to the fact that Isabelle/C is currently implemented in pure ML, a solution
	also in pure ML would thus sound more natural (although we are not excluding solutions interacting
	with Scala, as long as the resulting can be implemented in Isabelle, preferably outside of its own
	source).\<close>

	subsection \<open>Parsing Error versus Parsing Correctness\<close>

	text \<open> When trying to decide if the next parsing action is a Shift or Reduce action to
	perform, the grammar simulator \<^ML>\<open>LALR_Parser_Eval.parse\<close> can actually decide to do
	another action: ignore everything and immediately stop the simulation.

	If the parser ever decides to stop, this can only be for two reasons:
	\<^item> The parser is supposed to have correctly finished its parsing task, making it be in an
	acceptance state. As acceptance states are encoded in the grammar, it is easy to find if this
	information is correct, or if it has to be adjusted in more detail by inspecting
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Parser/Parser.y\<close>
	-(\<^file>\<open>generated/c_grammar_fun.grm.sml\<close>).
	+(\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>).
	\<^item> The parser seems to be unable to correctly finish its parsing task. In this case, the user
	will see an error be explicitly raised by the prover IDE. However raising an error is just the
	default behavior of Isabelle/C: the decision to whether raise interruptive errors ultimately depends
	on how front-end commands are implemented (such as \<^theory_text>\<open>C\<close>,
	\<^theory_text>\<open>C_file\<close>, etc.). For instance, similarly as to how outer syntax commands
	are implemented, we can imagine a tool implementing a kind of partial parsing, analyzing the longest
	sequence of well-formed input, and discarding some strategic next set of faulty tokens with a well
	suited informative message, so that the parsing process could be maximally repeated on what is
	coming afterwards.

	Currently, the default behavior of Isabelle/C is to raise the error defined in
	\<^ML>\<open>C_Module.err\<close> at the very first opportunity \<^footnote>\<open>At the time of
	writing it is: \<^emph>\<open>No matching grammar rule\<close>.\<close>. The possible solutions to
	make the error disappear at the position the error is indicated can be detailed as follows:
	\<^item> Modifying the C code in input would be a first solution whenever we suspect something is
	making it erroneous (and when we have a reason to believe that the grammar is behaving as it
	should).

	\<^item> However, we could still get the above error in front of an input where one is usually
	expecting to see not causing a failure. In particular, there are several C features (such as C
	directives) explicitly left for semantic back-ends (pre-) processing, so in general not fully
	semantically processed at parsing time.

	For example, whereas the code \<^C>\<open>#define i int
	i a;\<close> succeeds, replacing its first line with the directive
	\<^C>\<open>#include <file.c>\<close> will not initially work, even if \<open>file.c\<close>
	contains \<^C>\<open>#define i int\<close>, as the former directive has been left for semantic
	back-end treatment. One way of solving this would be to modify the C code in input for it to be
	already preprocessed (without directives, for example the C example of
	- \<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/blob/C/C11-BackEnds/AutoCorres_wrapper/examples/TestSEL4.thy\<close> is already provided as
	+ \<^url>\<open>https://gitlab.lisn.upsaclay.fr/burkhart.wolff/Isabelle_C/-/blob/C/C11-BackEnds/AutoCorres_wrapper/examples/TestSEL4.thy\<close> is already provided as
	preprocessed). Another way would be adding a specific new semantic back-end implementing the
	automation of the preprocessing task (as done in
	- \<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/blob/C/C11-BackEnds/AutoCorres_wrapper/examples/IsPrime_TEC.thy\<close>, where the
	+ \<^url>\<open>https://gitlab.lisn.upsaclay.fr/burkhart.wolff/Isabelle_C/-/blob/C/C11-BackEnds/AutoCorres_wrapper/examples/IsPrime_linear_CCT.thy\<close>, where the
	back-end explicitly makes a call to \<open>cpp\<close> at run-time).

	\<^item> Ultimately, modifying the grammar with new rules cancelling the exception would only work
	if the problem really relies on the grammar, as it was mentioned for the acceptance state.
	\<close>

	text \<open> In terms of parsing correctness, Isabelle/C provides at least two different parsers:
	-\<^item> a parser limited to C99/C11 code provided in \<^dir>\<open>../C11-FrontEnd\<close> that can
	+\<^item> a parser limited to C99/C11 code provided in \<^dir>\<open>../../C11-FrontEnd\<close> that can
	parse certain liberal extensions out of the C
	standard~\<^footnote>\<open>\<^url>\<open>http://hackage.haskell.org/package/language-c\<close>\<close>;
	-\<^item> and another parser accepting C99/C11/C18 code in \<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/tree/C/C18-FrontEnd\<close> that
	+\<^item> and another parser accepting C99/C11/C18 code in \<^url>\<open>https://gitlab.lisn.upsaclay.fr/burkhart.wolff/Isabelle_C/-/tree/C/C18-FrontEnd\<close> that
	is close to the C standard while focusing on resolving ambiguities of the
	standard~\<^footnote>\<open>\<^url>\<open>https://github.com/jhjourdan/C11parser\<close>\<close>~\cite{DBLP:journals/toplas/JourdanP17}. \<close>

	text \<open> Note that the two parsers are not accepting/rejecting the same range of arbitrary C
	code. We have actually already encountered situations where an error is raised by one parser, while
	a success is happening with the other parser (and vice-versa). Consequently, in front of a C code,
	it can be a good recommendation to try out the parsing with all possible parsers of Isabelle/C. In
	any cases, a failure in one or several activated parsers might not be necessarily harmful: it might
	also indicate that a wrong parser has been selected, or a semantic back-end not yet supporting
	aspects of the C code being parsed. \<close>

	subsection \<open>Exporting C Files to the File-System\<close>

	text \<open> From the Isabelle/C side, the task is easy, just type:\<close>

	C_export_file

	text \<open> ... which does the trick and generates a file
	\<^verbatim>\<open>C_Appendices.c\<close>. But hold on --- where is it? Well, Isabelle/C uses since
	version Isabelle2019 a virtual file-system. Exporting from it to the real file-system requires a few
	mouse-clicks (unfortunately).

	So activating the command \<^theory_text>\<open>C_export_file\<close> leads to the output
	\<^verbatim>\<open>See theory exports "C/*/C_Appendices.c"\<close> (see
	\autoref{fig:file-bro}), and clicking on the highlighted
	\<^verbatim>\<open>theory exports\<close> lets Isabelle display a part of the virtual file-system
	(see subwidget left). Activating it in the subwidget lets jEdit open it as an editable file, which
	can be exported via ``\<open>File \<rightarrow> Save As\<dots>\<close>'' into the real
	file-system. \<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/document/root.tex b/thys/Isabelle_C/C11-FrontEnd/document/root.tex
	--- a/thys/Isabelle_C/C11-FrontEnd/document/root.tex
	+++ b/thys/Isabelle_C/C11-FrontEnd/document/root.tex
	@@ -1,140 +1,138 @@
	%% Copyright (c) 2019 University of Exeter
	%% 2018-2019 University of Paris-Saclay
	%% 2018-2019 The University of Sheffield
	%%
	%% License:
	%% This program can be redistributed and/or modified under the terms
	%% of the LaTeX Project Public License Distributed from CTAN
	%% archives in directory macros/latex/base/lppl.txt; either
	%% version 1.3c of the License, or (at your option) any later version.
	%% OR
	%% The 2-clause BSD-style license.
	%%
	%% SPDX-License-Identifier: LPPL-1.3c+ OR BSD-2-Clause

	%% 2019/09/21 Unreleased/Isabelle2019

	%% Warning: Do Not Edit!
	%% =====================
	%% This is the root file for the Isabelle/DOF using the scrreprt class.
	%%
	%% All customization and/or additional packages should be added to the file
	%% preamble.tex.

	\RequirePackage{ifvtex}
	\documentclass[fontsize=11pt,paper=a4,open=right,twoside,abstract=true]{scrreprt}
	\usepackage[T1]{fontenc}
	\usepackage{textcomp}
	\bibliographystyle{abbrvnat}
	\usepackage[english]{babel}
	\RequirePackage[caption]{subfig}
	\usepackage{isabelle}
	\usepackage{isabellesym}
	\usepackage{ifthen}
	\usepackage{railsetup}

	\input{ontologies}
	\input{preamble.tex}
	\usepackage{amsmath}
	\usepackage{amssymb}
	\usepackage[numbers, sort&compress, sectionbib]{natbib}
	\usepackage{graphicx}
	\usepackage{hyperref}
	\setcounter{tocdepth}{2}
	\hypersetup{%
	bookmarksdepth=3
	,pdfpagelabels
	,pageanchor=true
	,bookmarksnumbered
	,plainpages=false
	} % more detailed digital TOC (aka bookmarks)
	\sloppy
	\allowdisplaybreaks[4]
	\urlstyle{rm}
	\isabellestyle{it}
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	%%% Overrides the (rightfully issued) warning by Koma Script that \rm
	%%% etc. should not be used (they are deprecated since more than a
	%%% decade)
	\DeclareOldFontCommand{\rm}{\normalfont\rmfamily}{\mathrm}
	\DeclareOldFontCommand{\sf}{\normalfont\sffamily}{\mathsf}
	\DeclareOldFontCommand{\tt}{\normalfont\ttfamily}{\mathtt}
	\DeclareOldFontCommand{\bf}{\normalfont\bfseries}{\mathbf}
	\DeclareOldFontCommand{\it}{\normalfont\itshape}{\mathit}
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\newenvironment{frontmatter}{}{}

	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	% command

	\newenvironment{matharray}[1]{\[\begin{array}{#1}}{\end{array}\]} % from 'iman.sty'
	\newcommand{\indexdef}[3]%
	{\ifthenelse{\equal{}{#1}}{\index{#3 (#2)\|bold}}{\index{#3 (#1\ #2)\|bold}}} % from 'isar.sty'
	\newcommand{\isactrlurl}{$\oplus$}
	\newcommand{\isactrlC}{{\isacommand C}}

	%

	\renewcommand{\chapterautorefname}{Chapter}
	\renewcommand{\sectionautorefname}{Section}
	\renewcommand{\subsectionautorefname}{Section}
	\renewcommand{\subsubsectionautorefname}{Section}
	\newcommand{\subtableautorefname}{\tableautorefname}
	\newcommand{\subfigureautorefname}{\figureautorefname}

	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	\begin{document}
	\title{Isabelle/C}
	\begin{frontmatter}
	\vspace{-2cm}
	\publishers{%
	\mbox{LRI, CNRS, CentraleSup\'elec, Universit\'e Paris-Saclay} \\
	b\^at. 650 Ada Lovelace, 91405 Orsay, France \texorpdfstring{\\}{}
	\href{mailto:"Frederic Tuong"
	<frederic.tuong@lri.fr>}{frederic.tuong@lri.fr} \hspace{4.5em}
	\href{mailto:"Burkhart Wolff"
	<burkhart.wolff@lri.fr>}{burkhart.wolff@lri.fr}
	\vspace{3cm}
	\begin{center}
	\textbf{In case that you consider citing Isabelle/C, \\ please refer to \cite{Tuong-IsabelleC:2019}.}
	\end{center}
	}
	\maketitle

	\tableofcontents
	\end{frontmatter}

	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	\chapter{A Conceptual Description of the Isabelle/C Package}
	\input{paper.tex}

	\input{C_Appendices.tex}

	\input{C_Ast.tex}
	\input{C_Lexer_Language.tex}
	\input{C_Environment.tex}
	\input{C_Parser_Language.tex}
	\input{C_Lexer_Annotation.tex}
	\input{C_Parser_Annotation.tex}
	\input{C_Eval.tex}
	\input{C_Command.tex}
	\input{C_Document.tex}
	\input{C_Main.tex}

	\input{C0.tex} % not included by default
	\input{C1.tex}
	\input{C2.tex}
	-\input{C3.tex}
	-\input{C4.tex}
	\input{C_paper.tex}


	\bibliography{root}
	\end{document}

	%%% Local Variables:
	%%% mode: latex
	%%% TeX-master: t
	%%% End:
	diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C0.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C0.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/examples/C0.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/examples/C0.thy
	@@ -1,228 +1,228 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	chapter \<open>Appendix II: Examples for C11 Lexis and Syntax; and Isabelle/C User-Interaction\<close>

	theory C0
	- imports "../C_Main"
	+ imports "../main/C_Main"
	begin

	declare[[C_lexer_trace]]

	section \<open>Regular C Code\<close>

	subsection \<open>Comments, Keywords and Pragmas\<close>

	C \<comment> \<open>Nesting of comments following the example suite of
	\<^url>\<open>https://gcc.gnu.org/onlinedocs/cpp/Initial-processing.html\<close>\<close> \<open>
	/* inside /* inside */ int a = "outside";
	// inside // inside until end of line
	int a = "outside";
	/* inside
	// inside
	inside
	*/ int a = "outside";
	// inside /* inside until end of line
	int a = "outside";
	\<close>

	C \<comment> \<open>Backslash newline\<close> \<open>
	i\
	n\
	t a = "/* // /\
	*\
	fff */\
	";
	\<close>

	C \<comment> \<open>Backslash newline, Directive \<^url>\<open>https://gcc.gnu.org/onlinedocs/cpp/Initial-processing.html\<close>\<close> \<open>
	/\
	*
	/ # /
	*/ defi\
	ne FO\
	O 10\
	20\<close>

	C \<comment> \<open>Directive: conditional\<close> \<open>
	#ifdef a
	#elif
	#else
	#if
	#endif
	#endif
	\<close>
	(*
	C \<comment> \<open>Directive: pragma\<close> \<open># f # "/**/"
	/**/
	# /**/ // #

	_Pragma /\
	**/("a")
	\<close>
	*)
	C \<comment> \<open>Directive: macro\<close> \<open>
	#define a zz
	#define a(x1,x2) z erz(( zz
	#define a (x1,x2) z erz(( zz
	#undef z
	#if
	#define a zz
	#define a(x1,x2) z erz(( zz
	#define a (x1,x2) z erz(( zz
	#endif
	\<close>

	subsection \<open>Scala/jEdit Latency on Multiple Bindings\<close>

	C \<comment> \<open>Example of obfuscated code \<^url>\<open>https://en.wikipedia.org/wiki/International_Obfuscated_C_Code_Contest\<close>\<close> \<open>
	#define _ -F<00\|\|--F-OO--;
	int F=00,OO=00;main(){F_OO();printf("%1.3f\n",4.*-F/OO/OO);}F_OO()
	{
	_-_-_-_
	_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_-_-_-_-_
	_-_-_-_-_-_-_-_
	_-_-_-_
	}
	\<close>

	text \<open> Select inside the ball, experience the latency.
	A special keyboard combination ``Ctrl-like key\<^footnote>\<open>on Apple: Cmd\<close> + Shift +
	Enter'' lets Isabelle/Scala/jEdit enter in a mode where the selected bound occurrences can be all
	simultaneously replaced by new input characters typed on the keyboard. (The ``select-entity'' action
	exists since Isabelle2016-1, see the respective section ``Prover IDE -- Isabelle/Scala/jEdit'' in
	the NEWS.)\<close>

	subsection \<open>Lexing and Parsing Obfuscated Sources\<close>

	text \<open>Another lexer/parser - stress test: parsing an obfuscated C source.\<close>

	C \<comment> \<open>Example of obfuscated code \<^url>\<open>https://www.ioccc.org/2018/endoh1/prog.c\<close>\<close> \<open>
	#define/__Int3rn^ti[]n/l_()I3fusc^t3\|]_C_C<>I7E_C[]nt3st__/L/__MMXVIII__/for
	#include/!"'()+,-./12357:;<=>?CEFGHIJKLMNSTUVWXYZ[]^_`cfhijklmnrstuvwxyz{\|}*/<stdio.h>
	char*r,F[1<<21]="~T/}3(\|+G{>/zUhy;Jx+5wG<v>>u55t.?sIZrC]n.;m+:l+Hk]WjNJi/Sh+2f1>c2H`)(_2(^L\
	-]=([1/Z<2Y7/X12W:.VFFU1,T77S+;N?;M/>L..K1+JCCI<<H:(G5F--E11C=5?.(>+(=3)Z-;(:.Y/5(-=)2-U,\
	/+-?5'(,+++***''EE>T,215IEUF:N`2`:?GK;+^`+?>)5?>U>_)5GxG).2K.2};}_235(]:5,S7E1(vTSS,-SSTvU(<-HG\
	-2E2/2L2/EE->E:?EE,2XMMMM1Hy`)5rHK;+.T+?[n2/_2{LKN2/_\|cK2+.2`;}:?{KL57?\|cK:2{NrHKtMMMK2nrH;rH[n"
	"CkM_E21-E,-1->E(_:mSE/LhLE/mm:2Ul;2M>,2KW-+.-u).5Lm?fM`2`2nZXjj?[n<YcK?2}yC}H[^7N7LX^7N7UN</:-\
	ZWXI<^I2K?>T+?KH~-?f<;G_x2;;2XT7LXIuuVF2X(G(GVV-:-:KjJ]HKLyN7UjJ3.WXjNI2KN<l\|cKt2~[IsHfI2w{[<VV"
	"GIfZG>x#&#&&$#$;ZXIc###$&$$#>7[LMv{&&&&#&##L,l2TY.&$#$#&&$,(iiii,#&&&#$#$?TY2.$#$1(x###;2EE[t,\
	SSEz.SW-k,T&&jC?E-.$## &#&57+$$# &&&W1-&$$7W -J$#$kEN&#& $##C^+$##W,h###n/+L2YE"
	"2nJk/H;YNs#$[,:TU(#$ ,: &&~H>&# Y; &&G_x ,mT&$YE-#& 5G $#VVF$#&zNs$$&Ej]HELy\
	CN/U^Jk71<(#&:G7E+^&# l\|?1 $$Y.2$$ 7lzs WzZw>&$E -<V-wE(2$$ G>x; 2zsW/$$#HKt&$$v>+t1(>"
	"7>S7S,;TT,&$;S7S>7&#>E_::U $$'",op ,G= F,I=957+F ;int*t,k,O, i, j,T[+060<<+020];int M(
	int m,int nop){;;;return+ m%(0+nop );;} int*tOo,w, h,z,W;void(C) (int n){n=putchar(n);}int
	f,c,H=11,Y=64<<2,Z,pq,X ;void(E/d /)( int/RP/n ){L(Z=k+00; Z; Z/=+2+000)G[000]=G!!f
	\|M(n,2)<<f,pq=2,f=+06 <f?++pq,++pq ,G++ ,z:f+001,n /=2;;}void (V)( int/opqrstabd/n){C(n
	%Y);;C(n/Y+00);;}void J(){L(pq--,pq =j =O=-1+0;++ j<240;I[6+ (h +6+j/12/22+M(j/2,2))
	W+M(j/2/2,+06)2+w014 +00+M(00+ 000+j,002 +00)]=000 +00+k)k=M(G[j/2/2+(*r-+
	32)*"<nopqabdeg"],/4649&96#/3);/&oaogoqo/;}/xD%P$Q#Rq/int/dbqpdbqpxyzzyboo3570OQ*/main()
	{L(X=Y-1;i<213;i++,I++)L(r=G,G+=2;G++;)G>=133?G-r?I++=G:(I++=r[1],I++=r[2]):1;L(j=12,r
	=I;(I=i=getchar())>-1;I++)i-7-3?I-=i<32\|\|127<=i,j+=12:(H+=17+3,W=W<j?j:W,j=12);L(;r>-1;r++)*r-
	7-3?J(),w++:(w=z,h+=17+3);C(71);C(73);V('''1'7);C(57);C(323+1);V(W);V(H);C(122*2);L(V(i=z);i
	<323;)C(i++/3X/31);C(33);C(X);C(11);L(G="SJYXHFUJ735";G;)C(G++-5);C(3);V(1);L(V(j=z);j<21*3;
	j++){k=257;V(63777);V(k<<2);V(M(j,32)?11:511);V(z);C(22*2);V(i=f=z);V(z);V(W);V(H);V(1<<11);r=
	G=I+WH;L(t=T;i<1<<21;i++)T[i]=i<Y?i:-1;E(Y);L(i=-1;++i<WH;t=T+ZY+Y)c=I[i]?I[i]31-31:(31<
	j?j-31:31-j),Z=c[t[c]<z?E(Z),k<(1<<12)-2?t[c]=++k,T:T:t];E(Z);E(257);L(G++;k=G-r>X?X:G-r
	,C(k),k;)L(;k--;C(r++/---#$%&04689@ABDOPQRabdegopq---*/));}C(53+6);return(z);}
	\<close>

	section \<open>Experiments with \<^dir>\<open>../../src_ext/parser_menhir\<close>\<close>

	declare[[C_lexer_trace = false]]

	subsection \<open>Expecting to succeed\<close>

	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/aligned_struct_c18.c\<close>\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/argument_scope.c\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/atomic.c\<close>\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/atomic_parenthesis.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/bitfield_declaration_ambiguity.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/bitfield_declaration_ambiguity.ok.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/block_scope.c\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/c11-noreturn.c\<close>\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/c1x-alignas.c\<close>\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/char-literal-printing.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/c-namespace.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/control-scope.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/dangling_else.c\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/dangling_else_lookahead.c\<close>\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/dangling_else_lookahead.if.c\<close>\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/declaration_ambiguity.c\<close>\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/declarators.c\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/declarator_visibility.c\<close>\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/designator.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/enum.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/enum_constant_visibility.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/enum_shadows_typedef.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/enum-trick.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/expressions.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/function-decls.c\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/function_parameter_scope.c\<close>\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/function_parameter_scope_extends.c\<close>\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/if_scopes.c\<close>\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/local_scope.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/local_typedef.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/long-long-struct.c\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/loop_scopes.c\<close>\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/namespaces.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/no_local_scope.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/parameter_declaration_ambiguity.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/parameter_declaration_ambiguity.test.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/statements.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/struct-recursion.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/typedef_star.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/types.c\<close>
	C_file \<open>../../src_ext/parser_menhir/tests/variable_star.c\<close>

	subsection \<open>Expecting to fail\<close>

	C_file \<open>../../src_ext/parser_menhir/tests/bitfield_declaration_ambiguity.fail.c\<close>
	\<^cancel>\<open>C_file \<open>../../src_ext/parser_menhir/tests/dangling_else_misleading.fail.c\<close>\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy
	@@ -1,647 +1,649 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	chapter \<open>Appendix III: Examples for the SML Interfaces to Generic and Specific C11 ASTs\<close>

	theory C1
	- imports "../C_Main"
	+ imports "../main/C_Main"
	begin

	section\<open>Access to Main C11 AST Categories via the Standard Interface \<close>

	text\<open>For the parsing root key's, c.f. ~ \<^verbatim>\<open>C_Command.thy\<close>\<close>

	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]
	C\<open>a + b * c - a / b\<close>
	ML\<open>val ast_expr = @{C11_CExpr}\<close>

	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "statement"]]
	C\<open>a = a + b;\<close>
	ML\<open>val ast_stmt = @{C11_CStat}\<close>


	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "external_declaration"]]
	C\<open>int m ();\<close>
	ML\<open>val ast_ext_decl = @{C11_CExtDecl}\<close>

	declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]
	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "translation_unit"]]
	C\<open>int b; int a = a + b;\<close>
	ML\<open>val ast_unit = @{C11_CTranslUnit}
	val env_unit = @{C\<^sub>e\<^sub>n\<^sub>v}
	\<close>



	text\<open>... and completely low-level in ML:\<close>
	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]
	ML\<open>
	val src = \<open>a + d\<close>;
	val ctxt = (Context.Theory @{theory});
	-val ctxt' = C_Module.C' @{C\<^sub>e\<^sub>n\<^sub>v} src ctxt;
	+val ctxt' = C_Module.C' (SOME @{C\<^sub>e\<^sub>n\<^sub>v}) src ctxt;
	val tt = Context.the_theory ctxt';
	\<close>

	subsection\<open>Queries on C11-Asts via the iterator\<close>

	ML\<open>

	fun selectIdent0 (a:C11_Ast_Lib.node_content) b c= if #tag a = "Ident0" then a::c else c;

	(* and here comes the hic >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> *)

	val S = (C11_Ast_Lib.fold_cTranslationUnit selectIdent0 ast_unit []);

	(* ... end of hic *)

	fun print ({args = (C11_Ast_Lib.data_string S)::_::C11_Ast_Lib.data_string S'::[],
	sub_tag = STAG, tag = TAG}
	:C11_Ast_Lib.node_content)
	= let fun dark_matter (x:bstring) = XML.content_of (YXML.parse_body x)
	in writeln (":>"^dark_matter(S)^"<:>"^(S')^"<:>"^STAG^"<:>"^TAG^"<:") end;

	app print S; (* these strings are representations for C_Ast.abr_string,
	where the main constructor is C_Ast.SS_base. *)
	map (YXML.parse_body o (fn {args = (C11_Ast_Lib.data_string S)::_::C11_Ast_Lib.data_string S'::[],
	sub_tag = _, tag = _} =>S)) S ;
	\<close>

	subsection\<open>A small compiler to Isabelle term's.\<close>

	ML\<open>

	fun drop_dark_matter x = (XML.content_of o YXML.parse_body) x


	fun node_content_2_free (x : C11_Ast_Lib.node_content) =
	let val C11_Ast_Lib.data_string a_markup = hd(#args(x));
	val id = hd(tl(String.tokens (fn x => x = #"\"")(drop_dark_matter a_markup)))
	in Free(id,dummyT) end (* no type inference *);



	fun selectIdent0Binary (a as { tag, sub_tag, args }:C11_Ast_Lib.node_content)
	(b: C_Ast.nodeInfo )
	(c : term list)=
	case tag of
	"Ident0" => (node_content_2_free a)::c
	\|"CBinary0" => (case (drop_dark_matter sub_tag, c) of
	("CAddOp0",b::a::R) => (Const("Groups.plus_class.plus",dummyT) $ a $ b :: R)
	\| ("CMulOp0",b::a::R) => (Const("Groups.times_class.times",dummyT) $ a $ b :: R)
	\| ("CDivOp0",b::a::R) => (Const("Rings.divide_class.divide",dummyT) $ a $ b :: R)
	\| ("CSubOp0",b::a::R) => (Const("Groups.minus_class.minus",dummyT) $ a $ b :: R)
	\| _ => (writeln ("sub_tag all " ^sub_tag^" :>> "^ @{make_string} c);c ))
	\| _ => c;


	\<close>

	text\<open>
	And here comes the ultra-hic: direct compilation of C11 expressions into (untyped) \<open>\<lambda>\<close>-terms in Isabelle.
	The term-list of the @{ML \<open>C11_Ast_Lib.fold_cExpression\<close>} - iterator serves as term-stack in which
	sub-expressions were stored in reversed polish notation. The example shows that the resulting term is
	structurally equivalent.
	\<close>
	ML\<open>
	val S = (C11_Ast_Lib.fold_cExpression selectIdent0Binary ast_expr []);
	val S' = @{term "a + b * c - a / b"};
	\<close>

	section \<open>Late-binding a Simplistic Post-Processor for ASTs and ENVs\<close>

	subsection\<open>Definition of Core Data Structures\<close>
	text\<open>The following setup just stores the result of the parsed values in the environment.\<close>

	ML\<open>
	structure Data_Out = Generic_Data
	- (type T = (C_Grammar_Rule.ast_generic * C_Antiquote.antiq C_Env.stream) list
	- val empty = []
	- val merge = K empty)
	+(
	+ type T = (C_Grammar_Rule.ast_generic * C_Antiquote.antiq C_Env.stream) list
	+ val empty = []
	+ val merge = K empty
	+)

	fun get_CTranslUnit thy =
	let val context = Context.Theory thy
	in (Data_Out.get context
	\|> map (apfst (C_Grammar_Rule.get_CTranslUnit #> the)), C_Module.Data_In_Env.get context)
	end

	fun get_CExpr thy =
	let val context = Context.Theory thy
	in (Data_Out.get context
	\|> map (apfst (C_Grammar_Rule.get_CExpr #> the)), C_Module.Data_In_Env.get context)
	end

	\<close>

	text\<open>... this gives :\<close>

	ML\<open> Data_Out.map: ( (C_Grammar_Rule.ast_generic * C_Antiquote.antiq C_Env.stream) list
	-> (C_Grammar_Rule.ast_generic * C_Antiquote.antiq C_Env.stream) list)
	-> Context.generic -> Context.generic \<close>

	subsection\<open>Registering A Store-Function in \<^ML>\<open>C_Module.Data_Accept.put\<close>\<close>

	text\<open>... as C-method call-back. \<close>
	setup \<open>Context.theory_map (C_Module.Data_Accept.put
	(fn ast => fn env_lang =>
	Data_Out.map (cons (ast, #stream_ignored env_lang \|> rev))))\<close>


	subsection\<open>Registering an ML-Antiquotation with an Access-Function \<close>
	ML\<open>
	val _ = Theory.setup(
	ML_Antiquotation.value_embedded \<^binding>\<open>C11_AST_CTranslUnit\<close>
	(Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	(warning"arg variant not implemented";"get_CTranslUnit (Context.the_global_context())"))
	\|\| Scan.succeed "get_CTranslUnit (Context.the_global_context())"))

	\<close>

	subsection\<open>Accessing the underlying C11-AST's via the ML Interface.\<close>

	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "translation_unit"]]
	C\<open>
	void swap(int x,int y)
	{
	int temp;

	temp = *x;
	x = y;
	*y = temp;
	}
	\<close>

	ML\<open>
	local open C_Ast in
	val _ = CTranslUnit0
	val (A::R, _) = @{C11_AST_CTranslUnit};
	val (CTranslUnit0 (t,u), v) = A
	fun rule_trans (CTranslUnit0 (t,u), v) = case C_Grammar_Rule_Lib.decode u of
	Left (p1,p2) => writeln (Position.here p1 ^ " " ^ Position.here p2)
	\| Right S => warning ("Not expecting that value:"^S)
	val bb = rule_trans A
	end

	val (R, env_final) = @{C11_AST_CTranslUnit};
	val rules = map rule_trans R;
	@{C\<^sub>e\<^sub>n\<^sub>v}
	\<close>


	section \<open>Example: A Possible Semantics for \<open>#include\<close>\<close>

	subsubsection \<open>Implementation\<close>

	text \<open> The CPP directive \<^C>\<open>#include _\<close> is used to import signatures of
	modules in C. This has the effect that imported identifiers are included in the C environment and,
	as a consequence, appear as constant symbols and not as free variables in the output. \<close>

	text \<open> The following structure is an extra mechanism to define the effect of \<^C>\<open>#include _\<close> wrt. to
	its definition in its environment. \<close>

	ML \<open>
	structure Directive_include = Generic_Data
	- (type T = (Input.source * C_Env.markup_ident) list Symtab.table
	- val empty = Symtab.empty
	- val merge = K empty)
	+(
	+ type T = (Input.source * C_Env.markup_ident) list Symtab.table
	+ val empty = Symtab.empty
	+ val merge = K empty
	+)
	\<close>

	ML \<comment> \<open>\<^theory>\<open>Pure\<close>\<close> \<open>
	local
	fun return f (env_cond, env) = ([], (env_cond, f env))

	val _ =
	Theory.setup
	(Context.theory_map
	(C_Context0.Directives.map
	(C_Context.directive_update ("include", \<^here>)
	( (return o K I)
	, fn C_Lex.Include (C_Lex.Group2 (toks_bl, _, tok :: _)) =>
	let
	fun exec file =
	if exists (fn C_Scan.Left _ => false \| C_Scan.Right _ => true) file then
	K (error ("Unsupported character"
	^ Position.here
	(Position.range_position
	(C_Lex.pos_of tok, C_Lex.end_pos_of (List.last toks_bl)))))
	else
	fn (env_lang, env_tree) =>
	fold
	(fn (src, data) => fn (env_lang, env_tree) =>
	let val (name, pos) = Input.source_content src
	in C_Grammar_Rule_Lib.shadowTypedef0''''
	name
	[pos]
	data
	env_lang
	env_tree
	end)
	(these (Symtab.lookup (Directive_include.get (#context env_tree))
	(String.concat
	- (maps (fn C_Scan.Left s => [s] \| _ => []) file))))
	+ (maps (fn C_Scan.Left (s, _) => [s] \| _ => []) file))))
	(env_lang, env_tree)
	in
	case tok of
	C_Lex.Token (_, (C_Lex.String (_, file), _)) => exec file
	\| C_Lex.Token (_, (C_Lex.File (_, file), _)) => exec file
	\| _ => tap (fn _ => (* not yet implemented *)
	warning ("Ignored directive"
	^ Position.here
	(Position.range_position
	( C_Lex.pos_of tok
	, C_Lex.end_pos_of (List.last toks_bl)))))
	end \|> K \|> K
	\| _ => K (K I)))))
	in end
	\<close>

	ML \<open>
	structure Include =
	struct
	fun init name vars =
	Context.theory_map
	(Directive_include.map
	(Symtab.update
	(name, map (rpair {global = true, params = [], ret = C_Env.Previous_in_stack}) vars)))

	fun append name vars =
	Context.theory_map
	(Directive_include.map
	(Symtab.map_default
	(name, [])
	(rev o fold (cons o rpair {global = true, params = [], ret = C_Env.Previous_in_stack}) vars
	o rev)))

	val show =
	Context.theory_map
	(Directive_include.map
	(tap
	(Symtab.dest
	#>
	app (fn (fic, vars) =>
	writeln ("Content of \"" ^ fic ^ "\": "
	^ String.concat (map (fn (i, _) => let val (name, pos) = Input.source_content i
	in name ^ Position.here pos ^ " " end)
	vars))))))
	end
	\<close>

	setup \<open>Include.append "stdio.h" [\<open>printf\<close>, \<open>scanf\<close>]\<close>

	subsubsection \<open>Tests\<close>

	C \<open>
	//@ setup \<open>Include.append "tmp" [\<open>b\<close>]\<close>
	#include "tmp"
	int a = b;

	\<close>

	C \<open>
	int b = 0;
	//@ setup \<open>Include.init "tmp" [\<open>b\<close>]\<close>
	#include "tmp"
	int a = b;
	\<close>

	C \<open>
	int c = 0;
	//@ setup \<open>Include.append "tmp" [\<open>c\<close>]\<close>
	//@ setup \<open>Include.append "tmp" [\<open>c\<close>]\<close>
	#include "tmp"
	int a = b + c;
	//@ setup \<open>Include.show\<close>
	\<close>

	C\<open>

	#include <stdio.h>
	#include /sdfsdf / <stdlib.h>
	#define a B
	#define b(C)
	#pragma /* just exists syntaxically */
	\<close>


	text\<open>In the following, we retrieve the C11 AST parsed above. \<close>
	ML\<open> val ((C_Ast.CTranslUnit0 (t,u), v)::R, env) = @{C11_AST_CTranslUnit};
	val u = C_Grammar_Rule_Lib.decode u;
	C_Ast.CTypeSpec0; \<close>



	section \<open>Defining a C-Annotation Commands Language \<close>

	ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Command\<close>\<close> \<open>
	\<comment> \<open>setup for a dummy ensures : the "Hello World" of Annotation Commands\<close>
	local
	datatype antiq_hol = Term of string (* term *)

	val scan_opt_colon = Scan.option (C_Parse.$$$ ":")

	fun msg cmd_name call_pos cmd_pos =
	tap (fn _ =>
	tracing ("\<open>Hello World\<close> reported by \"" ^ cmd_name ^ "\" here" ^ call_pos cmd_pos))

	fun command (cmd as (cmd_name, _)) scan0 scan f =
	C_Annotation.command'
	cmd
	""
	(fn (_, (cmd_pos, _)) =>
	(scan0 -- (scan >> f) >> (fn _ => C_Env.Never \|> msg cmd_name Position.here cmd_pos)))
	in
	val _ = Theory.setup ( C_Inner_Syntax.command_no_range
	(C_Inner_Toplevel.generic_theory oo C_Inner_Isar_Cmd.setup \<open>K (K (K I))\<close>)
	("loop", \<^here>, \<^here>)
	#> command ("ensures", \<^here>) scan_opt_colon C_Parse.term Term
	#> command ("invariant", \<^here>) scan_opt_colon C_Parse.term Term
	#> command ("assigns", \<^here>) scan_opt_colon C_Parse.term Term
	#> command ("requires", \<^here>) scan_opt_colon C_Parse.term Term
	#> command ("variant", \<^here>) scan_opt_colon C_Parse.term Term)
	end
	\<close>

	C\<open>
	/*@ ensures "result >= x && result >= y"
	*/

	int max(int x, int y) {
	if (x > y) return x; else return y;
	}
	\<close>

	text\<open>What happens on C11 AST level:\<close>
	ML\<open>
	val ((C_Ast.CTranslUnit0 (t,u), v)::R, env) = get_CTranslUnit @{theory};
	val u = C_Grammar_Rule_Lib.decode u
	\<close>


	subsection \<open>C Code: Various Annotated Examples\<close>

	text\<open>This example suite is drawn from Frama-C and used in our GLA - TPs. \<close>

	C\<open>
	int sqrt(int a) {
	int i = 0;
	int tm = 1;
	int sum = 1;

	/*@ loop invariant "1 <= sum <= a+tm"
	loop invariant "(i+1)*(i+1) == sum"
	loop invariant "tm+(i*i) == sum"
	loop invariant "1<=tm<=sum"
	loop assigns "i, tm, sum"
	loop variant "a-sum"
	*/
	while (sum <= a) {
	i++;
	tm = tm + 2;
	sum = sum + tm;
	}

	return i;
	}
	\<close>

	C\<open>
	/*@ requires "n >= 0"
	requires "valid(t+(0..n-1))"
	ensures "exists integer i; (0<=i<n && t[i] != 0) <==> result == 0"
	ensures "(forall integer i; 0<=i<n ==> t[i] == 0) <==> result == 1"
	assigns nothing
	*/

	int allzeros(int t[], int n) {
	int k = 0;

	/*@ loop invariant "0 <= k <= n"
	loop invariant "forall integer i; 0<=i<k ==> t[i] == 0"
	loop assigns k
	loop variant "n-k"
	*/
	while(k < n) {
	if (t[k]) return 0;
	k = k + 1;
	}
	return 1;
	}

	\<close>

	C\<open>

	/*@ requires "n >= 0"
	requires "valid(t+(0..n-1))"
	ensures "(forall integer i; 0<=i<n ==> t[i] != v) <==> result == -1"
	ensures "(exists integer i; 0<=i<n && t[i] == v) <==> result == v"
	assigns nothing
	*/

	int binarysearch(int t[], int n, int v) {
	int l = 0;
	int u = n-1;

	/*@ loop invariant false
	*/
	while (l <= u) {
	int m = (l + u) / 2;
	if (t[m] < v) {
	l = m + 1;
	} else if (t[m] > v) {
	u = m - 1;
	}
	else return m;
	}
	return -1;
	}
	\<close>


	C\<open>
	/*@ requires "n >= 0"
	requires "valid(t+(0..n-1))"
	requires "(forall integer i,j; 0<=i<=j<n ==> t[i] <= t[j])"
	ensures "exists integer i; (0<=i<n && t[i] == x) <==> result == 1"
	ensures "(forall integer i; 0<=i<n ==> t[i] != x) <==> result == 0"
	assigns nothing
	*/

	int linearsearch(int x, int t[], int n) {
	int i = 0;

	/*@ loop invariant "0<=i<=n"
	loop invariant "forall integer j; 0<=j<i ==> (t[j] != x)"
	loop assigns i
	loop variant "n-i"
	*/
	while (i < n) {
	if (t[i] < x) {
	i++;
	} else {
	return (t[i] == x);
	}
	}

	return 0;
	}
	\<close>


	subsection \<open>Example: An Annotated Sorting Algorithm\<close>

	C\<open>
	#include <stdio.h>

	int main()
	{
	int array[100], n, c, d, position, swap;

	printf("Enter number of elements\n");
	scanf("%d", &n);

	printf("Enter %d integers\n", n);

	for (c = 0; c < n; c++) scanf("%d", &array[c]);

	for (c = 0; c < (n - 1); c++)
	{
	position = c;

	for (d = c + 1; d < n; d++)
	{
	if (array[position] > array[d])
	position = d;
	}
	if (position != c)
	{
	swap = array[c];
	array[c] = array[position];
	array[position] = swap;
	}
	}

	printf("Sorted list in ascending order:\n");

	for (c = 0; c < n; c++)
	printf("%d\n", array[c]);

	return 0;
	}
	\<close>

	text\<open>A better example implementation:\<close>

	C\<open>
	#include <stdio.h>
	#include <stdlib.h>

	#define SIZE 10

	void swap(int x,int y);
	void selection_sort(int* a, const int n);
	void display(int a[],int size);

	void main()
	{

	int a[SIZE] = {8,5,2,3,1,6,9,4,0,7};

	int i;
	printf("The array before sorting:\n");
	display(a,SIZE);

	selection_sort(a,SIZE);

	printf("The array after sorting:\n");
	display(a,SIZE);
	}

	/*
	swap two integers
	*/
	void swap(int x,int y)
	{
	int temp;

	temp = *x;
	x = y;
	*y = temp;
	}
	/*
	perform selection sort
	*/
	void selection_sort(int* a,const int size)
	{
	int i, j, min;

	for (i = 0; i < size - 1; i++)
	{
	min = i;
	for (j = i + 1; j < size; j++)
	{
	if (a[j] < a[min])
	{
	min = j;
	}
	}
	swap(&a[i], &a[min]);
	}
	}
	/*
	display array content
	*/
	void display(int a[],const int size)
	{
	int i;
	for(i=0; i<size; i++)
	printf("%d ",a[i]);
	printf("\n");
	}
	\<close>



	section \<open>C Code: Floats Exist\<close>

	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "translation_unit"]]
	-
	C\<open>
	int a;
	float b;
	int m() {return 0;}
	\<close>

	-end
	\ No newline at end of file
	+end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy
	@@ -1,896 +1,931 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	chapter \<open>Appendix IV : Examples for Annotation Navigation and Context Serialization\<close>

	theory C2
	- imports "../C_Main"
	+ imports "../main/C_Main"
	"HOL-ex.Cartouche_Examples"
	begin

	text \<open> Operationally, the \<^theory_text>\<open>C\<close> command can be thought of as behaving as the \<^theory_text>\<open>ML\<close> command,
	where it is for example possible to recursively nest C code in C. Generally, the present
	chapter assumes a familiarity with all advance concepts of ML as described in
	\<^file>\<open>~~/src/HOL/Examples/ML.thy\<close>, as well as the concept of ML antiquotations
	(\<^file>\<open>~~/src/Doc/Implementation/ML.thy\<close>). However, even if\<^theory_text>\<open>C\<close> might resemble to \<^theory_text>\<open>ML\<close>,
	we will now see in detail that there are actually subtle differences between the two commands.\<close>

	section \<open>Setup of ML Antiquotations Displaying the Environment (For Debugging) \<close>

	ML\<open>
	fun print_top make_string f _ (_, (value, _, _)) _ = tap (fn _ => writeln (make_string value)) o f

	fun print_top' _ f _ _ env = tap (fn _ => writeln ("ENV " ^ C_Env.string_of env)) o f

	fun print_stack s make_string stack _ _ thy =
	let
	val () = Output.information ("SHIFT " ^ (case s of NONE => "" \| SOME s => "\"" ^ s ^ "\" ")
	^ Int.toString (length stack - 1) ^ " +1 ")
	val () = stack
	\|> split_list
	\|> #2
	\|> map_index I
	\|> app (fn (i, (value, pos1, pos2)) =>
	writeln (" " ^ Int.toString (length stack - i) ^ " " ^ make_string value
	^ " " ^ Position.here pos1 ^ " " ^ Position.here pos2))
	in thy end

	fun print_stack' s _ stack _ env thy =
	let
	val () = Output.information ("SHIFT " ^ (case s of NONE => "" \| SOME s => "\"" ^ s ^ "\" ")
	^ Int.toString (length stack - 1) ^ " +1 ")
	val () = writeln ("ENV " ^ C_Env.string_of env)
	in thy end
	\<close>

	setup \<open>ML_Antiquotation.inline @{binding print_top}
	(Args.context
	>> K ("print_top " ^ ML_Pretty.make_string_fn ^ " I"))\<close>
	setup \<open>ML_Antiquotation.inline @{binding print_top'}
	(Args.context
	>> K ("print_top' " ^ ML_Pretty.make_string_fn ^ " I"))\<close>
	setup \<open>ML_Antiquotation.inline @{binding print_stack}
	(Scan.peek (fn _ => Scan.option Parse.embedded)
	>> (fn name => ("print_stack "
	^ (case name of NONE => "NONE"
	\| SOME s => "(SOME \"" ^ s ^ "\")")
	^ " " ^ ML_Pretty.make_string_fn)))\<close>
	setup \<open>ML_Antiquotation.inline @{binding print_stack'}
	(Scan.peek (fn _ => Scan.option Parse.embedded)
	>> (fn name => ("print_stack' "
	^ (case name of NONE => "NONE"
	\| SOME s => "(SOME \"" ^ s ^ "\")")
	^ " " ^ ML_Pretty.make_string_fn)))\<close>

	declare[[C_lexer_trace]]

	section \<open>Introduction to C Annotations: Navigating in the Parsing Stack\<close>

	subsection \<open>Basics\<close>

	text \<open> Since the present theory \<^file>\<open>C1.thy\<close> is depending on
	\<^theory>\<open>Isabelle_C.C_Lexer_Language\<close> and
	\<^theory>\<open>Isabelle_C.C_Parser_Language\<close>, the syntax one is writing in the
	\<^theory_text>\<open>C\<close> command is C11. Additionally, \<^file>\<open>C1.thy\<close> also
	depends on \<^theory>\<open>Isabelle_C.C_Parser_Annotation\<close>, making it possible to write
	commands in C comments, called annotation commands, such as
	\<^theory_text>\<open>\<approx>setup\<close>. \<close>

	C \<comment> \<open>Nesting ML code in C comments\<close> \<open>
	int a = (((0))); /@ highlight /
	/@ \<approx>setup \<open>@{print_stack}\<close> /
	/@ \<approx>setup \<open>@{print_top}\<close> /
	\<close>

	text \<open> In terms of execution order, nested annotation commands are not pre-filtered out of the
	C code, but executed when the C code is still being parsed. Since the parser implemented is a LALR
	parser \<^footnote>\<open>\<^url>\<open>https://en.wikipedia.org/wiki/LALR\<close>\<close>, C tokens
	are uniquely read and treated from left to right. Thus, each nested command is (supposed by default
	to be) executed when the parser has already read all C tokens before the comment associated to the
	nested command, so when the parser is in a particular intermediate parsing step (not necessarily
	final)
	\<^footnote>\<open>\<^url>\<open>https://en.wikipedia.org/wiki/Shift-reduce_parser\<close>\<close>. \<close>

	text \<open>The command \<^theory_text>\<open>\<approx>setup\<close> is similar to the command
	\<^theory_text>\<open>setup\<close> except that the former takes a function with additional
	arguments. These arguments are precisely depending on the current parsing state. To better examine
	these arguments, it is convenient to use ML antiquotations (be it for printing, or for doing any
	regular ML actions like PIDE reporting).

	Note that, in contrast with \<^theory_text>\<open>setup\<close>, the return type of the
	\<^theory_text>\<open>\<approx>setup\<close> function is not
	\<^ML_type>\<open>theory -> theory\<close> but
	\<^ML_type>\<open>Context.generic -> Context.generic\<close>. \<close>

	C \<comment> \<open>Positional navigation: referring to any previous parsed sub-tree in the stack\<close> \<open>
	int a = (((0
	+ 5))) /*@@ \<approx>setup \<open>print_top @{make_string} I\<close>
	@ highlight
	*/
	* 4;
	float b = 7 / 3;
	\<close>

	text \<open>The special \<open>@\<close> symbol makes the command be executed whenever the first element \<open>E\<close>
	in the stack is about to be irremediably replaced by a more structured parent element (having \<open>E\<close>
	as one of its direct children). It is the parent element which is provided to the ML code.

	Instead of always referring to the first element of the stack,
	\<open>N\<close> consecutive occurrences of \<open>@\<close> will make the ML code getting as argument the direct parent
	of the \<open>N\<close>-th element.\<close>

	C \<comment> \<open>Positional navigation: referring to any previous parsed sub-tree in the stack\<close> \<open>
	int a = (((0 + 5))) /@@ highlight /
	* 4;

	int a = (((0 + 5))) /@& highlight /
	* 4;

	int a = (((0 + 5))) /@@@@@ highlight /
	* 4;

	int a = (((0 + 5))) /@&&&& highlight /
	* 4;
	\<close>

	text \<open>\<open>&\<close> behaves as \<open>@\<close>, but instead of always giving the designated direct parent to the ML code,
	it finds the first parent ancestor making non-trivial changes in the respective grammar rule
	(a non-trivial change can be for example the registration of the position of the current AST node
	being built).\<close>

	C \<comment> \<open>Positional navigation: moving the comment after a number of C token\<close> \<open>
	int b = 7 / (3) * 50;
	/@+++@@ highlight /
	long long f (int a) {
	while (0) { return 0; }
	}
	int b = 7 / (3) * 50;
	\<close>

	text \<open>\<open>N\<close> consecutive occurrences of \<open>+\<close> will delay the interpretation of the comment,
	which is ignored at the place it is written. The comment is only really considered after the
	C parser has treated \<open>N\<close> more tokens.\<close>

	C \<comment> \<open>Closing C comments \<open>*/\<close> must close anything, even when editing ML code\<close> \<open>
	int a = (((0 //@ (* inline ) \<approx>setup \<open>fn _ => fn _ => fn _ => fn context => let in ( / ) context end\<close>
	/@ \<approx>setup \<open>(K o K o K) I\<close> ( * / ) /
	)));
	\<close>

	C \<comment> \<open>Inline comments with antiquotations\<close> \<open>
	/*@ \<approx>setup\<open>(K o K o K) (fn x => K x @{con\
	text (*)})\<close> / // break of line activated everywhere (also in antiquotations)
	int a = 0; //\
	@ \<approx>setup\<open>(K o K o K) (fn x => K x @{term \<open>a \
	+ b\<close> (* (*) \
	\
	)})\<close>
	\<close>

	subsection \<open>Erroneous Annotations Treated as Regular C Comments\<close>

	C \<comment> \<open>Permissive Types of Antiquotations\<close> \<open>
	int a = 0;
	/@ \<approx>setup ( Errors: Explicit warning + Explicit markup reporting *)
	*/
	/** \<approx>setup (* Errors: Turned into tracing report information *)
	*/

	/** \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close> (* An example of correct syntax accepted as usual *)
	*/
	\<close>

	C \<comment> \<open>Permissive Types of Antiquotations\<close> \<open>
	int a = 0;
	/*@ \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	\<approx>setup (* Parsing error of a single command does not propagate to other commands *)
	\<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	context
	*/
	/** \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	\<approx>setup (* Parsing error of a single command does not propagate to other commands *)
	\<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	context
	*/

	/@ \<approx>setup ( Errors in all commands are all rendered *)
	\<approx>setup (* Errors in all commands are all rendered *)
	\<approx>setup (* Errors in all commands are all rendered *)
	*/
	/** \<approx>setup (* Errors in all commands makes the whole comment considered as an usual comment *)
	\<approx>setup (* Errors in all commands makes the whole comment considered as an usual comment *)
	\<approx>setup (* Errors in all commands makes the whole comment considered as an usual comment *)
	*/
	\<close>

	subsection \<open>Bottom-Up vs. Top-Down Evaluation\<close>

	ML\<open>
	-structure Example_Data = Generic_Data(type T = string list val empty = [] val merge = K empty)
	+structure Example_Data = Generic_Data
	+(
	+ type T = string list
	+ val empty = []
	+ val merge = K empty
	+)

	fun add_ex s1 s2 =
	Example_Data.map (cons s2)
	#> (fn context => let val () = Output.information (s1 ^ s2)
	val () = app (fn s => writeln (" Data content: " ^ s))
	(Example_Data.get context)
	in context end)
	\<close>

	setup \<open>Context.theory_map (Example_Data.put [])\<close>

	declare[[ML_source_trace]]
	declare[[C_parser_trace]]

	C \<comment> \<open>Arbitrary interleaving of effects: \<open>\<approx>setup\<close> vs \<open>\<approx>setup\<Down>\<close>\<close> \<open>
	int b,c,d/*@@ \<approx>setup \<open>fn s => fn x => fn env => @{print_top} s x env
	#> add_ex "evaluation of " "3_print_top"\<close>
	/,e = 0; /@@
	\<approx>setup \<open>fn s => fn x => fn env => @{print_top} s x env
	#> add_ex "evaluation of " "4_print_top"\<close> */

	int b,c,d/*@@ \<approx>setup\<Down> \<open>fn s => fn x => fn env => @{print_top} s x env
	#> add_ex "evaluation of " "6_print_top"\<close>
	/,e = 0; /@@
	\<approx>setup\<Down> \<open>fn s => fn x => fn env => @{print_top} s x env
	#> add_ex "evaluation of " "5_print_top"\<close> */
	\<close>

	+subsection \<open>Out of Bound Evaluation for Annotations\<close>
	+
	+C \<comment> \<open>Bottom-up and top-down + internal initial value\<close> \<open>
	+int a = 0 ;
	+int /*@ @ ML \<open>writeln "2"\<close>
	+ @@@ ML \<open>writeln "4"\<close>
	+ +@ ML \<open>writeln "3"\<close>
	+(* +++@ ML \<open>writeln "6"\<close>*)
	+ ML\<Down>\<open>writeln "1"\<close> */
	+// a d /@ @ ML \<open>writeln "5"\<close> /;
	+int a;
	+\<close>
	+
	+C \<comment> \<open>Ordering of consecutive commands\<close> \<open>
	+int a = 0 /@ ML\<open>writeln "1"\<close> /;
	+int /@ @@@@@ML\<open>writeln "5" \<close> @@@ML\<open>writeln "4" \<close> @@ML\<open>writeln "2" \<close> /
	+ /@ @@@@@ML\<open>writeln "5'"\<close> @@@ML\<open>writeln "4'"\<close> @@ML\<open>writeln "2'"\<close> /
	+ a = 0;
	+int d = 0; /@ ML\<open>writeln "3"\<close> /
	+\<close>
	+
	+C \<comment> \<open>Maximum depth reached\<close> \<open>
	+int a = 0 /*@ ++@@@@ML\<open>writeln "2"\<close>
	+ ++@@@ ML\<open>writeln "1"\<close> */;
	+\<close>
	+
	section \<open>Reporting of Positions and Contextual Update of Environment\<close>

	text \<open>
	To show the content of the parsing environment, the ML antiquotations \<open>print_top'\<close> and \<open>print_stack'\<close>
	will respectively be used instead of \<open>print_top\<close> and \<open>print_stack\<close>.
	This example suite allows to explore the bindings represented in the C environment
	and made accessible in PIDE for hovering. \<close>

	subsection \<open>Reporting: \<open>typedef\<close>, \<open>enum\<close>\<close> (\<open>struct\<close>)

	declare [[ML_source_trace = false]]
	declare [[C_lexer_trace = false]]

	C \<comment> \<open>Reporting of Positions\<close> \<open>
	typedef int i, j;
	/@@ \<approx>setup \<open>@{print_top'}\<close> @highlight / //@ +++++@ \<approx>setup \<open>@{print_top'}\<close> +++++@highlight
	int j = 0;
	typedef int i, j;
	j jj1 = 0;
	j jj = jj1;
	j j = jj1 + jj;
	typedef i j;
	typedef i j;
	typedef i j;
	i jj = jj;
	j j = jj;
	\<close>

	C \<comment> \<open>Nesting type definitions\<close> \<open>
	typedef int j;
	j a = 0;
	typedef int k;
	int main (int c) {
	j b = 0;
	typedef int k;
	typedef k l;
	k a = c;
	l a = 0;
	}
	k a = a;
	\<close>

	C \<comment> \<open>Reporting \<open>enum\<close>\<close> \<open>
	enum a b; // bound case: undeclared
	enum a {aaa}; // define case
	enum a {aaa}; // define case: redefined
	enum a _; // bound case

	__thread (f ( enum a, enum a vv));

	enum a /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.function_definition4\<close>\<close>*/ f (enum a a) {
	}

	__thread enum a /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.declaration_specifier2\<close>\<close>*/ f (enum a a) {
	enum c {ccc}; // define case
	__thread enum c f (enum c a) {
	return 0;
	}
	enum c /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.nested_function_definition2\<close>\<close>*/ f (enum c a) {
	return 0;
	}
	return 0;
	}

	enum z {zz}; // define case
	int main (enum z x) / \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.parameter_type_list2\<close>\<close>*/ {
	return zz; }
	int main (enum a x, ...) / \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.parameter_type_list3\<close>\<close>*/ {
	return zz; }
	\<close>

	subsection \<open>Continuation Calculus with the C Environment: Presentation in ML\<close>

	declare [[C_parser_trace = false]]

	ML\<open>
	-val C = C_Module.C
	-val C' = C_Module.C'
	+val C = C_Module.C' NONE
	+val C' = C_Module.C' o SOME
	\<close>

	C \<comment> \<open>Nesting C code without propagating the C environment\<close> \<open>
	int a = 0;
	int b = 7 / (3) * 50
	/*@@@@@ \<approx>setup \<open>fn _ => fn _ => fn _ =>
	C \<open>int b = a + a + a + a + a + a + a
	;\<close> \<close> */;
	\<close>

	C \<comment> \<open>Nesting C code and propagating the C environment\<close> \<open>
	int a = 0;
	int b = 7 / (3) * 50
	/*@@@@@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	C' env \<open>int b = a + a + a + a + a + a + a
	;\<close> \<close> */;
	\<close>

	subsection \<open>Continuation Calculus with the C Environment: Presentation with Outer Commands\<close>

	ML\<open>
	val _ = Theory.setup
	(C_Inner_Syntax.command0
	(fn src => fn context => C' (C_Stack.Data_Lang.get' context \|> #2) src context)
	C_Parse.C_source
	("C'", \<^here>, \<^here>, \<^here>))
	\<close>

	C \<comment> \<open>Nesting C code without propagating the C environment\<close> \<open>
	int f (int a) {
	int b = 7 / (3) * 50 /@ C \<open>int b = a + a + a + a + a + a + a;\<close> /;
	int c = b + a + a + a + a + a + a;
	} \<close>

	C \<comment> \<open>Nesting C code and propagating the C environment\<close> \<open>
	int f (int a) {
	int b = 7 / (3) * 50 /@ C' \<open>int b = a + a + a + a + a + a + a;\<close> /;
	int c = b + b + b + b + a + a + a + a + a + a;
	} \<close>

	C \<comment> \<open>Miscellaneous\<close> \<open>
	int f (int a) {
	int b = 7 / (3) * 50 /@ C \<open>int b = a + a + a + a + a; //@ C' \<open>int c = b + b + b + b + a;\<close> \<close> /;
	int b = 7 / (3) * 50 /@ C' \<open>int b = a + a + a + a + a; //@ C' \<open>int c = b + b + b + b + a;\<close> \<close> /;
	int c = b + b + b + b + a + a + a + a + a + a;
	} \<close>

	subsection \<open>Continuation Calculus with the C Environment: Deep-First Nesting vs Breadth-First Folding: Propagation of \<^ML_type>\<open>C_Env.env_lang\<close>\<close>

	C \<comment> \<open>Propagation of report environment while manually composing at ML level (with \<open>#>\<close>)\<close>
	\<comment> \<open>In \<open>c1 #> c2\<close>, \<open>c1\<close> and \<open>c2\<close> should not interfere each other.\<close> \<open>
	//@ ML \<open>fun C_env src _ _ env = C' env src\<close>
	int a;
	int f (int b) {
	int c = 0; /*@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	#> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	#> C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	#> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	\<close> */
	int e = a + b + c + d;
	}\<close>

	C \<comment> \<open>Propagation of directive environment (evaluated before parsing)
	to any other annotations (evaluated at parsing time)\<close> \<open>
	#undef int
	#define int(a,b) int
	#define int int
	int a;
	int f (int b) {
	int c = 0; /*@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	#> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	#> C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	#> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	\<close> */
	#undef int
	int e = a + b + c + d;
	}
	\<close>

	subsection \<open>Continuation Calculus with the C Environment: Deep-First Nesting vs Breadth-First Folding: Propagation of \<^ML_type>\<open>C_Env.env_tree\<close>\<close>

	ML\<open>
	structure Data_Out = Generic_Data
	- (type T = int
	- val empty = 0
	- val merge = K empty)
	+(
	+ type T = int
	+ val empty = 0
	+ val merge = K empty
	+)

	fun show_env0 make_string f msg context =
	Output.information ("(" ^ msg ^ ") " ^ make_string (f (Data_Out.get context)))

	val show_env = tap o show_env0 @{make_string} I
	\<close>

	setup \<open>Context.theory_map (C_Module.Data_Accept.put (fn _ => fn _ => Data_Out.map (fn x => x + 1)))\<close>

	C \<comment> \<open>Propagation of Updates\<close> \<open>
	typedef int i, j;
	int j = 0;
	typedef int i, j;
	j jj1 = 0;
	j jj = jj1; /@@ \<approx>setup \<open>fn _ => fn _ => fn _ => show_env "POSITION 0"\<close> @\<approx>setup \<open>@{print_top'}\<close> /
	typedef int k; /*@@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	C' env \<open>k jj = jj; //@@ \<approx>setup \<open>@{print_top'}\<close>
	k jj = jj + jj1;
	typedef k l; //@@ \<approx>setup \<open>@{print_top'}\<close>\<close>
	#> show_env "POSITION 1"\<close> */
	j j = jj1 + jj; //@@ \<approx>setup \<open>@{print_top'}\<close>
	typedef i j; /@@ \<approx>setup \<open>fn _ => fn _ => fn _ => show_env "POSITION 2"\<close> /
	typedef i j;
	typedef i j;
	i jj = jj;
	j j = jj;
	\<close>

	ML\<open>show_env "POSITION 3" (Context.Theory @{theory})\<close>

	setup \<open>Context.theory_map (C_Module.Data_Accept.put (fn _ => fn _ => I))\<close>

	subsection \<open>Reporting: Scope of Recursive Functions\<close>

	declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]

	C \<comment> \<open>Propagation of Updates\<close> \<open>
	int a = 0;
	int b = a * a + 0;
	int jjj = b;
	int main (void main(int x,int y),int *jjj) {
	return a + jjj + main(); }
	int main2 () {
	int main3 () { main2() + main(); }
	int main () { main2() + main(); }
	return a + jjj + main3() + main(); }
	\<close>

	C \<open>
	int main3 () { main2 (); }
	\<close>

	declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = empty]]

	subsection \<open>Reporting: Extensions to Function Types, Array Types\<close>

	C \<open>int f (int z);\<close>
	C \<open>int * f (int z);\<close>
	C \<open>int (* f) (int z /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.declarator1\<close>\<close>*/);\<close>
	C \<open>typedef int (* f) (int z);\<close>
	C \<open>int f (int z) {}\<close>
	C \<open>int * f (int z) {return z;}\<close>
	C \<open>int ((* f) (int z1, int z2)) {return z1 + z2;}\<close>
	C \<open>int (* (* f) (int z1, int z2)) {return z1 + z2;}\<close>
	C \<open>typedef int (* f) (int z); f uuu (int b) {return b;};\<close>
	C \<open>typedef int (* (* f) (int z, int z)) (int a); f uuu (int b) {return b;};\<close>
	C \<open>struct z { int (* f) (int z); int (* (* ff) (int z)) (int a); };\<close>
	C \<open>double (* (* f (int a /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.declarator1\<close>\<close>*/)) (int a, double d)) (char a);\<close>
	C \<open>double (* (((* f) []) (int a)) (int b, double c)) (char d) {int a = b + c + d;}\<close>
	C \<open>double ((((f) (int a))) (int a / \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Lib.doFuncParamDeclIdent\<close>\<close>*/, double)) (char c) {int a = 0;}\<close>

	C \<comment> \<open>Nesting functions\<close> \<open>
	double (* (* f (int a)) (int a, double)) (char c) {
	double (* (* f (int a)) (double a, int a)) (char) {
	return a;
	}
	}
	\<close>

	C \<comment> \<open>Old function syntax\<close> \<open>
	f (x) int x; {return x;}
	\<close>

	section \<open>General Isar Commands\<close>

	locale zz begin definition "z' = ()"
	end

	C \<comment> \<open>Mixing arbitrary commands\<close> \<open>
	int a = 0;
	int b = a * a + 0;
	int jjj = b;
	/*@
	@@@ ML \<open>@{lemma \<open>A \<and> B \<longrightarrow> B \<and> A\<close> by (ml_tactic \<open>blast_tac ctxt 1\<close>)}\<close>
	definition "a' = ()"
	declare [[ML_source_trace]]
	lemma (in zz) \<open>A \<and> B \<longrightarrow> B \<and> A\<close> by (ml_tactic \<open>blast_tac ctxt 1\<close>)
	definition (in zz) "z = ()"
	corollary "zz.z' = ()"
	apply (unfold zz.z'_def)
	by blast
	theorem "True &&& True" by (auto, presburger?)
	*/
	\<close>

	declare [[ML_source_trace = false]]

	C \<comment> \<open>Backslash newlines must be supported by \<^ML>\<open>C_Token.syntax'\<close> (in particular in keywords)\<close> \<open>
	//@ lem\
	ma (i\
	n z\
	z) \
	\<open>\
	AA \<and> B\
	\<longrightarrow>\
	B \<and> A\
	\
	A\<close> b\
	y (ml_t\
	actic \<open>\
	bla\
	st_tac c\
	txt\
	0\
	001\<close>)
	\<close>

	section \<open>Starting Parsing Rule\<close>

	subsection \<open>Basics\<close>

	C \<comment> \<open>Parameterizing starting rule\<close> \<open>
	/*@
	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "statement"]]
	C \<open>while (a) {}\<close>
	C \<open>a = 2;\<close>
	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]
	C \<open>2 + 3\<close>
	C \<open>a = 2\<close>
	C \<open>a[1]\<close>
	C \<open>&a\<close>
	C \<open>a\<close>
	*/
	\<close>

	subsection \<open>Embedding in Inner Terms\<close>

	term \<open>\<^C> \<comment> \<open>default behavior of parsing depending on the activated option\<close> \<open>0\<close>\<close>
	term \<open>\<^C>\<^sub>u\<^sub>n\<^sub>i\<^sub>t \<comment> \<open>force the explicit parsing\<close> \<open>f () {while (a) {}; return 0;} int a = 0;\<close>\<close>
	term \<open>\<^C>\<^sub>d\<^sub>e\<^sub>c\<^sub>l \<comment> \<open>force the explicit parsing\<close> \<open>int a = 0; \<close>\<close>
	term \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r \<comment> \<open>force the explicit parsing\<close> \<open>a\<close>\<close>
	term \<open>\<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t \<comment> \<open>force the explicit parsing\<close> \<open>while (a) {}\<close>\<close>

	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "translation_unit"]]

	term \<open>\<^C> \<comment> \<open>default behavior of parsing depending on the current option\<close> \<open>int a = 0;\<close>\<close>

	subsection \<open>User Defined Setup of Syntax\<close>

	setup \<open>C_Module.C_Term.map_expression (fn _ => fn _ => fn _ => @{term "10 :: nat"})\<close>
	setup \<open>C_Module.C_Term.map_statement (fn _ => fn _ => fn _ => @{term "20 :: nat"})\<close>
	value \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>1\<close> + \<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t\<open>for (;;);\<close>\<close>

	setup \<comment> \<open>redefinition\<close> \<open>C_Module.C_Term.map_expression
	(fn _ => fn _ => fn _ => @{term "1000 :: nat"})\<close>
	value \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>1\<close> + \<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t\<open>for (;;);\<close>\<close>

	setup \<open>C_Module.C_Term.map_default (fn _ => fn _ => fn _ => @{term "True"})\<close>

	subsection \<open>Validity of Context for Annotations\<close>

	ML \<open>fun fac x = if x = 0 then 1 else x * fac (x - 1)\<close>

	-ML \<comment> \<open>Execution of annotations in term possible in (the outermost) \<^theory_text>\<open>ML\<close>\<close>
	-\<open>
	+ML \<comment> \<open>Execution of annotations in term possible in (the outermost) \<^theory_text>\<open>ML\<close>\<close> \<open>
	\<^term>\<open> \<^C> \<open>int c = 0; /@ ML \<open>fac 100\<close> /\<close> \<close>
	\<close>

	-definition \<comment> \<open>Execution of annotations in term possible in \<^ML_type>\<open>local_theory\<close>
	- commands (such as \<^theory_text>\<open>definition\<close>)\<close>
	-\<open>
	+definition \<comment> \<open>Execution of annotations in term possible in \<^ML_type>\<open>local_theory\<close> commands (such as \<^theory_text>\<open>definition\<close>)\<close> \<open>
	term = \<^C> \<open>int c = 0; /@ ML \<open>fac 100\<close> /\<close>
	\<close>

	section \<open>Scopes of Inner and Outer Terms\<close>

	ML \<open>
	local
	fun bind scan ((stack1, (to_delay, stack2)), _) =
	C_Parse.range scan
	>> (fn (src, range) =>
	C_Env.Parsing
	( (stack1, stack2)
	, ( range
	, C_Inner_Syntax.bottom_up
	(fn _ => fn context =>
	ML_Context.exec
	(tap (fn _ => Syntax.read_term (Context.proof_of context)
	(Token.inner_syntax_of src)))
	context)
	, Symtab.empty
	, to_delay)))
	in
	val _ =
	Theory.setup
	( C_Annotation.command'
	("term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r", \<^here>)
	""
	(bind (C_Token.syntax' (Parse.token Parse.cartouche)))
	#> C_Inner_Syntax.command0
	(C_Inner_Toplevel.keep'' o C_Inner_Isar_Cmd.print_term)
	(C_Token.syntax' (Scan.succeed [] -- Parse.term))
	("term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r", \<^here>, \<^here>, \<^here>))
	end
	\<close>

	-
	C \<open>
	int z = z;
	/*@ C \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	C' \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	C \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	C' \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close> */\<close>
	term(outer) \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>

	C \<open>
	int z = z;
	/*@ C \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	C' \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	C \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	C' \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close> */\<close>
	term(outer) \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>

	declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]

	C \<open>
	int z = z;
	/*@ C \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	C' \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	C \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	C' \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close> */\<close>
	term(outer) \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>

	declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = empty]]

	C \<comment> \<open>Propagation of report environment while manually composing at ML level\<close> \<open>
	int a;
	int f (int b) {
	int c = 0;
	/*@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	C' env \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	#> C \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	#> C' env \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	#> C \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	\<close>
	term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>
	term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> */
	int e = a + b + c + d;
	}\<close>

	section \<open>Calculation in Directives\<close>

	subsection \<open>Annotation Command Classification\<close>

	C \<comment> \<open>Lexing category vs. parsing category\<close> \<open>
	int a = 0;

	// \<comment> \<open>Category 2: only parsing\<close>

	//@ \<approx>setup \<open>K (K (K I))\<close> (* evaluation at parsing *)
	//@@ \<approx>setup\<Down> \<open>K (K (K I))\<close> (* evaluation at parsing *)

	//@ highlight (* evaluation at parsing *)
	//@@ highlight\<Down> (* evaluation at parsing *)

	// \<comment> \<open>Category 3: with lexing\<close>

	//@ #setup I (* evaluation at lexing (and directives resolving) *)
	//@ setup I (* evaluation at parsing *)
	//@@ setup\<Down> I (* evaluation at parsing *)

	//@ #ML I (* evaluation at lexing (and directives resolving) *)
	//@ ML I (* evaluation at parsing *)
	//@@ ML\<Down> I (* evaluation at parsing *)

	//@ #C \<open>\<close> (* evaluation at lexing (and directives resolving) *)
	//@ C \<open>\<close> (* evaluation at parsing *)
	//@@ C\<Down> \<open>\<close> (* evaluation at parsing *)
	\<close>

	C \<comment> \<open>Scheduling example\<close> \<open>
	//@+++++ ML \<open>writeln "2"\<close>
	int a = 0;
	//@@ ML\<Down> \<open>writeln "3"\<close>
	//@ #ML \<open>writeln "1"\<close>
	\<close>

	C \<comment> \<open>Scheduling example\<close> \<open>
	//* lemma True by simp
	//* #lemma True #by simp
	//* #lemma True by simp
	//* lemma True #by simp
	\<close>

	C \<comment> \<open>Scheduling example\<close> \<open> /*@
	lemma \<open>1 = one\<close>
	\<open>2 = two\<close>
	\<open>two + one = three\<close>
	by auto

	#definition [simp]: \<open>three = 3\<close>
	#definition [simp]: \<open>two = 2\<close>
	#definition [simp]: \<open>one = 1\<close>
	*/ \<close>

	subsection \<open>Generalizing ML Antiquotations with C Directives\<close>

	ML \<open>
	structure Directive_setup_define = Generic_Data
	- (type T = int
	- val empty = 0
	- val merge = K empty)
	+(
	+ type T = int
	+ val empty = 0
	+ val merge = K empty
	+)

	fun setup_define1 pos f =
	C_Directive.setup_define
	pos
	(fn toks => fn (name, (pos1, _)) =>
	tap (fn _ => writeln ("Executing " ^ name ^ Position.here pos1 ^ " (only once)"))
	#> pair (f toks))
	(K I)

	fun setup_define2 pos = C_Directive.setup_define pos (K o pair)
	\<close>

	C \<comment> \<open>General scheme of C antiquotations\<close> \<open>
	/*@
	#setup \<comment> \<open>Overloading \<open>#define\<close>\<close> \<open>
	setup_define2
	\<^here>
	(fn (name, (pos1, _)) =>
	op ` Directive_setup_define.get
	#>> (case name of "f3" => curry op * 152263 \| _ => curry op + 1)
	#> tap (fn (nb, _) =>
	tracing ("Executing antiquotation " ^ name ^ Position.here pos1
	^ " (number = " ^ Int.toString nb ^ ")"))
	#> uncurry Directive_setup_define.put)
	\<close>
	*/
	#define f1
	#define f2 int a = 0;
	#define f3
	f1
	f2
	f1
	f3

	//@ #setup \<comment> \<open>Resetting \<open>#define\<close>\<close> \<open>setup_define2 \<^here> (K I)\<close>
	f3
	#define f3
	f3
	\<close>

	C \<comment> \<open>Dynamic token computing in \<open>#define\<close>\<close> \<open>

	//@ #setup \<open>setup_define1 \<^here> (K [])\<close>
	#define f int a = 0;
	f f f f

	//@ #setup \<open>setup_define1 \<^here> (fn toks => toks @ toks)\<close>
	#define f int b = a;
	f f

	//@ #setup \<open>setup_define1 \<^here> I\<close>
	#define f int a = 0;
	f f
	\<close>

	section \<open>Miscellaneous\<close>

	C \<comment> \<open>Antiquotations acting on a parsed-subtree\<close> \<open>
	# /**/ include <a\b\\c> // backslash rendered unescaped
	f(){0 + 0;} /**/ // val _ : theory => 'a => theory
	# /* context */ if if elif
	#include <stdio.h>
	if then else ;
	# /* zzz / elif /*/
	#else\

	#define FOO 00 0 "" ((
	FOO(FOO(a,b,c))
	#endif\<close>

	C \<comment> \<open>Header-names in directives\<close> \<open>
	#define F <stdio.h>
	#define G "stdio\h" // expecting an error whenever expanded
	#define H "stdio_h" // can be used anywhere without errors
	int f = /F/ "";
	int g = /G/ "";
	int h = H "";

	#include F
	\<close>

	C \<comment> \<open>Parsing tokens as directives only when detecting space symbols before \<open>#\<close>\<close> \<open>/*
	*/ \
	\

	//
	# /*
	/ define /*/ \
	a
	a a /#include <>/ // must not be considered as a directive
	\<close>

	C \<comment> \<open>Universal character names in identifiers and Isabelle symbols\<close> \<open>
	#include <stdio.h>
	int main () {
	+ char * _ = "\x00001";
	+ char * _ = " ";
	char * ó\<^url>ò = "ó\<^url>ò";
	- printf ("%s", ó\<^url>ò);
	+ printf ("%s %s", ó\<^url>ò, _ );
	}
	\<close>

	\<comment>\<open>The core lexer ...\<close>
	ML\<open> C_Parse.ML_source \<close>

	declare[[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]
	ML\<open>@{C\<^sub>e\<^sub>n\<^sub>v}\<close>


	ML\<open>C_Stack.Data_Lang.get' :
	Context.generic ->
	(LALR_Table.state, C_Grammar_Rule.svalue0, Position.T) C_Env.stack_elem0 list * C_Env.env_lang;
	C_Parse.C_source: Input.source C_Parse.parser ;
	C_Inner_Syntax.command0 ;
	C';
	C;

	\<close>

	declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]

	ML\<open>
	val src = \<open>a + b\<close>;
	val ctxt = (Context.Proof @{context});
	val ctxt' = C' @{C\<^sub>e\<^sub>n\<^sub>v} src ctxt;
	C_Module.Data_In_Env.get ctxt'
	\<close>

	ML\<open>val _ = @{term \<open>3::nat\<close>}\<close>
	ML\<open> ML_Antiquotation.inline_embedded;
	\<close>
	(* and from where do I get the result ? *)

	+declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "translation_unit"]]
	+
	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C3.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C3.thy
	deleted file mode 100644
	--- a/thys/Isabelle_C/C11-FrontEnd/examples/C3.thy
	+++ /dev/null
	@@ -1,862 +0,0 @@
	-(******************************************************************************
	- * Isabelle/C
	- *
	- * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	- *
	- * All rights reserved.
	- *
	- * Redistribution and use in source and binary forms, with or without
	- * modification, are permitted provided that the following conditions are
	- * met:
	- *
	- * * Redistributions of source code must retain the above copyright
	- * notice, this list of conditions and the following disclaimer.
	- *
	- * * Redistributions in binary form must reproduce the above
	- * copyright notice, this list of conditions and the following
	- * disclaimer in the documentation and/or other materials provided
	- * with the distribution.
	- *
	- * * Neither the name of the copyright holders nor the names of its
	- * contributors may be used to endorse or promote products derived
	- * from this software without specific prior written permission.
	- *
	- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	- * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	- * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	- * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	- * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	- * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	- * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	- ******************************************************************************)
	-
	-chapter \<open>Annnex IV : Examples for Annotation Navigation and Context Serialization\<close>
	-
	-theory C3
	- imports "../C_Main"
	- "HOL-ex.Cartouche_Examples" (* This dependency should be erliminated.*)
	-begin
	-
	-text \<open> Operationally, the \<^theory_text>\<open>C\<close> command can be thought of as
	-behaving as \<^theory_text>\<open>ML\<close>, where it is for example possible to recursively nest C
	-code in C. Generally, the present chapter assumes a familiarity with all advance concepts of ML as
	-described in \<^file>\<open>~~/src/HOL/Examples/ML.thy\<close>, as well as the concept of ML
	-antiquotations (\<^file>\<open>~~/src/Doc/Implementation/ML.thy\<close>). However, even if
	-\<^theory_text>\<open>C\<close> might resemble to \<^theory_text>\<open>ML\<close>, we will now see
	-in detail that there are actually subtle differences between the two commands.\<close>
	-
	-section \<open>Setup of ML Antiquotations Displaying the Environment (For Debugging) \<close>
	-
	-ML\<open>
	-fun print_top make_string f _ (_, (value, _, _)) _ = tap (fn _ => writeln (make_string value)) o f
	-
	-fun print_top' _ f _ _ env = tap (fn _ => writeln ("ENV " ^ C_Env.string_of env)) o f
	-
	-fun print_stack s make_string stack _ _ thy =
	- let
	- val () = Output.information ("SHIFT " ^ (case s of NONE => "" \| SOME s => "\"" ^ s ^ "\" ")
	- ^ Int.toString (length stack - 1) ^ " +1 ")
	- val () = stack
	- \|> split_list
	- \|> #2
	- \|> map_index I
	- \|> app (fn (i, (value, pos1, pos2)) =>
	- writeln (" " ^ Int.toString (length stack - i) ^ " " ^ make_string value
	- ^ " " ^ Position.here pos1 ^ " " ^ Position.here pos2))
	- in thy end
	-
	-fun print_stack' s _ stack _ env thy =
	- let
	- val () = Output.information ("SHIFT " ^ (case s of NONE => "" \| SOME s => "\"" ^ s ^ "\" ")
	- ^ Int.toString (length stack - 1) ^ " +1 ")
	- val () = writeln ("ENV " ^ C_Env.string_of env)
	- in thy end
	-\<close>
	-
	-setup \<open>ML_Antiquotation.inline @{binding print_top}
	- (Args.context
	- >> K ("print_top " ^ ML_Pretty.make_string_fn ^ " I"))\<close>
	-setup \<open>ML_Antiquotation.inline @{binding print_top'}
	- (Args.context
	- >> K ("print_top' " ^ ML_Pretty.make_string_fn ^ " I"))\<close>
	-setup \<open>ML_Antiquotation.inline @{binding print_stack}
	- (Scan.peek (fn _ => Scan.option Parse.embedded)
	- >> (fn name => ("print_stack "
	- ^ (case name of NONE => "NONE"
	- \| SOME s => "(SOME \"" ^ s ^ "\")")
	- ^ " " ^ ML_Pretty.make_string_fn)))\<close>
	-setup \<open>ML_Antiquotation.inline @{binding print_stack'}
	- (Scan.peek (fn _ => Scan.option Parse.embedded)
	- >> (fn name => ("print_stack' "
	- ^ (case name of NONE => "NONE"
	- \| SOME s => "(SOME \"" ^ s ^ "\")")
	- ^ " " ^ ML_Pretty.make_string_fn)))\<close>
	-
	-declare[[C_lexer_trace]]
	-
	-section \<open>Introduction to C Annotations: Navigating in the Parsing Stack\<close>
	-
	-subsection \<open>Basics\<close>
	-
	-text \<open> Since the present theory \<^file>\<open>C1.thy\<close> is depending on
	-\<^theory>\<open>Isabelle_C.C_Lexer_Language\<close> and
	-\<^theory>\<open>Isabelle_C.C_Parser_Language\<close>, the syntax one is writing in the
	-\<^theory_text>\<open>C\<close> command is C11. Additionally, \<^file>\<open>C1.thy\<close> also
	-depends on \<^theory>\<open>Isabelle_C.C_Parser_Annotation\<close>, making it possible to write
	-commands in C comments, called annotation commands, such as
	-\<^theory_text>\<open>\<approx>setup\<close>. \<close>
	-
	-C \<comment> \<open>Nesting ML code in C comments\<close> \<open>
	-int a = (((0))); /@ highlight /
	- /@ \<approx>setup \<open>@{print_stack}\<close> /
	- /@ \<approx>setup \<open>@{print_top}\<close> /
	-\<close>
	-
	-text \<open> In terms of execution order, nested annotation commands are not pre-filtered out of the
	-C code, but executed when the C code is still being parsed. Since the parser implemented is a LALR
	-parser \<^footnote>\<open>\<^url>\<open>https://en.wikipedia.org/wiki/LALR\<close>\<close>, C tokens
	-are uniquely read and treated from left to right. Thus, each nested command is (supposed by default
	-to be) executed when the parser has already read all C tokens before the comment associated to the
	-nested command, so when the parser is in a particular intermediate parsing step (not necessarily
	-final)
	-\<^footnote>\<open>\<^url>\<open>https://en.wikipedia.org/wiki/Shift-reduce_parser\<close>\<close>. \<close>
	-
	-text \<open>The command \<^theory_text>\<open>\<approx>setup\<close> is similar to the command
	-\<^theory_text>\<open>setup\<close> except that the former takes a function with additional
	-arguments. These arguments are precisely depending on the current parsing state. To better examine
	-these arguments, it is convenient to use ML antiquotations (be it for printing, or for doing any
	-regular ML actions like PIDE reporting).
	-
	-Note that, in contrast with \<^theory_text>\<open>setup\<close>, the return type of the
	-\<^theory_text>\<open>\<approx>setup\<close> function is not
	-\<^ML_type>\<open>theory -> theory\<close> but
	-\<^ML_type>\<open>Context.generic -> Context.generic\<close>. \<close>
	-
	-C \<comment> \<open>Positional navigation: referring to any previous parsed sub-tree in the stack\<close> \<open>
	-int a = (((0
	- + 5))) /*@@ \<approx>setup \<open>print_top @{make_string} I\<close>
	- @ highlight
	- */
	- * 4;
	-float b = 7 / 3;
	-\<close>
	-
	-text \<open>The special \<open>@\<close> symbol makes the command be executed whenever the first element \<open>E\<close>
	- in the stack is about to be irremediably replaced by a more structured parent element (having \<open>E\<close>
	-as one of its direct children). It is the parent element which is provided to the ML code.
	-
	-Instead of always referring to the first element of the stack,
	-\<open>N\<close> consecutive occurrences of \<open>@\<close> will make the ML code getting as argument the direct parent
	-of the \<open>N\<close>-th element.\<close>
	-
	-C \<comment> \<open>Positional navigation: referring to any previous parsed sub-tree in the stack\<close> \<open>
	-int a = (((0 + 5))) /@@ highlight /
	- * 4;
	-
	-int a = (((0 + 5))) /@& highlight /
	- * 4;
	-
	-int a = (((0 + 5))) /@@@@@ highlight /
	- * 4;
	-
	-int a = (((0 + 5))) /@&&&& highlight /
	- * 4;
	-\<close>
	-
	-text \<open>\<open>&\<close> behaves as \<open>@\<close>, but instead of always giving the designated direct parent to the ML code,
	-it finds the first parent ancestor making non-trivial changes in the respective grammar rule
	-(a non-trivial change can be for example the registration of the position of the current AST node
	-being built).\<close>
	-
	-C \<comment> \<open>Positional navigation: moving the comment after a number of C token\<close> \<open>
	-int b = 7 / (3) * 50;
	-/@+++@@ highlight /
	-long long f (int a) {
	- while (0) { return 0; }
	-}
	-int b = 7 / (3) * 50;
	-\<close>
	-
	-text \<open>\<open>N\<close> consecutive occurrences of \<open>+\<close> will delay the interpretation of the comment,
	-which is ignored at the place it is written. The comment is only really considered after the
	-C parser has treated \<open>N\<close> more tokens.\<close>
	-
	-C \<comment> \<open>Closing C comments \<open>*/\<close> must close anything, even when editing ML code\<close> \<open>
	-int a = (((0 //@ (* inline ) \<approx>setup \<open>fn _ => fn _ => fn _ => fn context => let in ( / ) context end\<close>
	- /@ \<approx>setup \<open>(K o K o K) I\<close> ( * / ) /
	- )));
	-\<close>
	-
	-C \<comment> \<open>Inline comments with antiquotations\<close> \<open>
	- /*@ \<approx>setup\<open>(K o K o K) (fn x => K x @{con\
	-text (*)})\<close> / // break of line activated everywhere (also in antiquotations)
	-int a = 0; //\
	-@ \<approx>setup\<open>(K o K o K) (fn x => K x @{term \<open>a \
	- + b\<close> (* (*) \
	-\
	-)})\<close>
	-\<close>
	-
	-subsection \<open>Erroneous Annotations Treated as Regular C Comments\<close>
	-
	-C \<comment> \<open>Permissive Types of Antiquotations\<close> \<open>
	-int a = 0;
	- /@ \<approx>setup ( Errors: Explicit warning + Explicit markup reporting *)
	- */
	- /** \<approx>setup (* Errors: Turned into tracing report information *)
	- */
	-
	- /** \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close> (* An example of correct syntax accepted as usual *)
	- */
	-\<close>
	-
	-C \<comment> \<open>Permissive Types of Antiquotations\<close> \<open>
	-int a = 0;
	- /*@ \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	- \<approx>setup (* Parsing error of a single command does not propagate to other commands *)
	- \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	- context
	- */
	- /** \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	- \<approx>setup (* Parsing error of a single command does not propagate to other commands *)
	- \<approx>setup \<open>fn _ => fn _ => fn _ => I\<close>
	- context
	- */
	-
	- /@ \<approx>setup ( Errors in all commands are all rendered *)
	- \<approx>setup (* Errors in all commands are all rendered *)
	- \<approx>setup (* Errors in all commands are all rendered *)
	- */
	- /** \<approx>setup (* Errors in all commands makes the whole comment considered as an usual comment *)
	- \<approx>setup (* Errors in all commands makes the whole comment considered as an usual comment *)
	- \<approx>setup (* Errors in all commands makes the whole comment considered as an usual comment *)
	- */
	-\<close>
	-
	-subsection \<open>Bottom-Up vs. Top-Down Evaluation\<close>
	-
	-ML\<open>
	-structure Example_Data = Generic_Data (type T = string list val empty = [] val merge = K empty)
	-fun add_ex s1 s2 =
	- Example_Data.map (cons s2)
	- #> (fn context => let val () = Output.information (s1 ^ s2)
	- val () = app (fn s => writeln (" Data content: " ^ s))
	- (Example_Data.get context)
	- in context end)
	-\<close>
	-
	-setup \<open>Context.theory_map (Example_Data.put [])\<close>
	-
	-declare[[ML_source_trace]]
	-declare[[C_parser_trace]]
	-
	-C \<comment> \<open>Arbitrary interleaving of effects: \<open>\<approx>setup\<close> vs \<open>\<approx>setup\<Down>\<close>\<close> \<open>
	-int b,c,d/*@@ \<approx>setup \<open>fn s => fn x => fn env => @{print_top} s x env
	- #> add_ex "evaluation of " "3_print_top"\<close>
	- /,e = 0; /@@
	- \<approx>setup \<open>fn s => fn x => fn env => @{print_top} s x env
	- #> add_ex "evaluation of " "4_print_top"\<close> */
	-
	-int b,c,d/*@@ \<approx>setup\<Down> \<open>fn s => fn x => fn env => @{print_top} s x env
	- #> add_ex "evaluation of " "6_print_top"\<close>
	- /,e = 0; /@@
	- \<approx>setup\<Down> \<open>fn s => fn x => fn env => @{print_top} s x env
	- #> add_ex "evaluation of " "5_print_top"\<close> */
	-\<close>
	-
	-section \<open>Reporting of Positions and Contextual Update of Environment\<close>
	-
	-text \<open>
	-To show the content of the parsing environment, the ML antiquotations \<open>print_top'\<close> and \<open>print_stack'\<close>
	-will respectively be used instead of \<open>print_top\<close> and \<open>print_stack\<close>.
	-This example suite allows to explore the bindings represented in the C environment
	-and made accessible in PIDE for hovering. \<close>
	-
	-subsection \<open>Reporting: \<open>typedef\<close>, \<open>enum\<close>\<close> (\<open>struct\<close>)
	-
	-declare [[ML_source_trace = false]]
	-declare [[C_lexer_trace = false]]
	-
	-C \<comment> \<open>Reporting of Positions\<close> \<open>
	-typedef int i, j;
	- /@@ \<approx>setup \<open>@{print_top'}\<close> @highlight / //@ +++++@ \<approx>setup \<open>@{print_top'}\<close> +++++@highlight
	-int j = 0;
	-typedef int i, j;
	-j jj1 = 0;
	-j jj = jj1;
	-j j = jj1 + jj;
	-typedef i j;
	-typedef i j;
	-typedef i j;
	-i jj = jj;
	-j j = jj;
	-\<close>
	-
	-C \<comment> \<open>Nesting type definitions\<close> \<open>
	-typedef int j;
	-j a = 0;
	-typedef int k;
	-int main (int c) {
	- j b = 0;
	- typedef int k;
	- typedef k l;
	- k a = c;
	- l a = 0;
	-}
	-k a = a;
	-\<close>
	-
	-C \<comment> \<open>Reporting \<open>enum\<close>\<close> \<open>
	-enum a b; // bound case: undeclared
	-enum a {aaa}; // define case
	-enum a {aaa}; // define case: redefined
	-enum a _; // bound case
	-
	-__thread (f ( enum a, enum a vv));
	-
	-enum a /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.function_definition4\<close>\<close>*/ f (enum a a) {
	-}
	-
	-__thread enum a /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.declaration_specifier2\<close>\<close>*/ f (enum a a) {
	- enum c {ccc}; // define case
	- __thread enum c f (enum c a) {
	- return 0;
	- }
	- enum c /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.nested_function_definition2\<close>\<close>*/ f (enum c a) {
	- return 0;
	- }
	- return 0;
	-}
	-
	-enum z {zz}; // define case
	-int main (enum z x) / \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.parameter_type_list2\<close>\<close>*/ {
	- return zz; }
	-int main (enum a x, ...) / \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.parameter_type_list3\<close>\<close>*/ {
	- return zz; }
	-\<close>
	-
	-subsection \<open>Continuation Calculus with the C Environment: Presentation in ML\<close>
	-
	-declare [[C_parser_trace = false]]
	-
	-ML\<open>
	-val C = tap o C_Module.C
	-val C' = C_Module.C'
	-\<close>
	-
	-C \<comment> \<open>Nesting C code without propagating the C environment\<close> \<open>
	-int a = 0;
	-int b = 7 / (3) * 50
	- /*@@@@@ \<approx>setup \<open>fn _ => fn _ => fn _ =>
	- C \<open>int b = a + a + a + a + a + a + a
	- ;\<close> \<close> */;
	-\<close>
	-
	-C \<comment> \<open>Nesting C code and propagating the C environment\<close> \<open>
	-int a = 0;
	-int b = 7 / (3) * 50
	- /*@@@@@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	- C' env \<open>int b = a + a + a + a + a + a + a
	- ;\<close> \<close> */;
	-\<close>
	-
	-subsection \<open>Continuation Calculus with the C Environment: Presentation with Outer Commands\<close>
	-
	-ML\<open>
	-val _ = Theory.setup
	- (C_Inner_Syntax.command0
	- (fn src => fn context => C' (C_Stack.Data_Lang.get' context \|> #2) src context)
	- C_Parse.C_source
	- ("C'", \<^here>, \<^here>, \<^here>))
	-\<close>
	-
	-C \<comment> \<open>Nesting C code without propagating the C environment\<close> \<open>
	-int f (int a) {
	- int b = 7 / (3) * 50 /@ C \<open>int b = a + a + a + a + a + a + a;\<close> /;
	- int c = b + a + a + a + a + a + a;
	-} \<close>
	-
	-C \<comment> \<open>Nesting C code and propagating the C environment\<close> \<open>
	-int f (int a) {
	- int b = 7 / (3) * 50 /@ C' \<open>int b = a + a + a + a + a + a + a;\<close> /;
	- int c = b + b + b + b + a + a + a + a + a + a;
	-} \<close>
	-
	-C \<comment> \<open>Miscellaneous\<close> \<open>
	-int f (int a) {
	- int b = 7 / (3) * 50 /@ C \<open>int b = a + a + a + a + a; //@ C' \<open>int c = b + b + b + b + a;\<close> \<close> /;
	- int b = 7 / (3) * 50 /@ C' \<open>int b = a + a + a + a + a; //@ C' \<open>int c = b + b + b + b + a;\<close> \<close> /;
	- int c = b + b + b + b + a + a + a + a + a + a;
	-} \<close>
	-
	-subsection \<open>Continuation Calculus with the C Environment: Deep-First Nesting vs Breadth-First Folding: Propagation of \<^ML_type>\<open>C_Env.env_lang\<close>\<close>
	-
	-C \<comment> \<open>Propagation of report environment while manually composing at ML level (with \<open>#>\<close>)\<close>
	- \<comment> \<open>In \<open>c1 #> c2\<close>, \<open>c1\<close> and \<open>c2\<close> should not interfere each other.\<close> \<open>
	-//@ ML \<open>fun C_env src _ _ env = C' env src\<close>
	-int a;
	-int f (int b) {
	-int c = 0; /*@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	- C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	- #> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	- #> C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	- #> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	-\<close> */
	-int e = a + b + c + d;
	-}\<close>
	-
	-C \<comment> \<open>Propagation of directive environment (evaluated before parsing)
	- to any other annotations (evaluated at parsing time)\<close> \<open>
	-#undef int
	-#define int(a,b) int
	-#define int int
	-int a;
	-int f (int b) {
	-int c = 0; /*@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	- C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	- #> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	- #> C' env \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	- #> C \<open>int d = a + b + c + d; //@ \<approx>setup \<open>C_env \<open>int e = a + b + c + d;\<close>\<close>\<close>
	-\<close> */
	-#undef int
	-int e = a + b + c + d;
	-}
	-\<close>
	-
	-subsection \<open>Continuation Calculus with the C Environment: Deep-First Nesting vs Breadth-First Folding: Propagation of \<^ML_type>\<open>C_Env.env_tree\<close>\<close>
	-
	-ML\<open>
	-structure Data_Out = Generic_Data
	- (type T = int
	- val empty = 0
	- val merge = K empty)
	-
	-fun show_env0 make_string f msg context =
	- Output.information ("(" ^ msg ^ ") " ^ make_string (f (Data_Out.get context)))
	-
	-val show_env = tap o show_env0 @{make_string} I
	-\<close>
	-
	-setup \<open>Context.theory_map (C_Module.Data_Accept.put (fn _ => fn _ => Data_Out.map (fn x => x + 1)))\<close>
	-
	-C \<comment> \<open>Propagation of Updates\<close> \<open>
	-typedef int i, j;
	-int j = 0;
	-typedef int i, j;
	-j jj1 = 0;
	-j jj = jj1; /@@ \<approx>setup \<open>fn _ => fn _ => fn _ => show_env "POSITION 0"\<close> @\<approx>setup \<open>@{print_top'}\<close> /
	-typedef int k; /*@@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	- C' env \<open>k jj = jj; //@@ \<approx>setup \<open>@{print_top'}\<close>
	- k jj = jj + jj1;
	- typedef k l; //@@ \<approx>setup \<open>@{print_top'}\<close>\<close>
	- #> show_env "POSITION 1"\<close> */
	-j j = jj1 + jj; //@@ \<approx>setup \<open>@{print_top'}\<close>
	-typedef i j; /@@ \<approx>setup \<open>fn _ => fn _ => fn _ => show_env "POSITION 2"\<close> /
	-typedef i j;
	-typedef i j;
	-i jj = jj;
	-j j = jj;
	-\<close>
	-
	-ML\<open>show_env "POSITION 3" (Context.Theory @{theory})\<close>
	-
	-setup \<open>Context.theory_map (C_Module.Data_Accept.put (fn _ => fn _ => I))\<close>
	-
	-subsection \<open>Reporting: Scope of Recursive Functions\<close>
	-
	-declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]
	-
	-C \<comment> \<open>Propagation of Updates\<close> \<open>
	-int a = 0;
	-int b = a * a + 0;
	-int jjj = b;
	-int main (void main(int x,int y),int *jjj) {
	- return a + jjj + main(); }
	-int main2 () {
	- int main3 () { main2() + main(); }
	- int main () { main2() + main(); }
	- return a + jjj + main3() + main(); }
	-\<close>
	-
	-C \<open>
	-int main3 () { main2 (); }
	-\<close>
	-
	-declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = empty]]
	-
	-subsection \<open>Reporting: Extensions to Function Types, Array Types\<close>
	-
	-C \<open>int f (int z);\<close>
	-C \<open>int * f (int z);\<close>
	-C \<open>int (* f) (int z /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.declarator1\<close>\<close>*/);\<close>
	-C \<open>typedef int (* f) (int z);\<close>
	-C \<open>int f (int z) {}\<close>
	-C \<open>int * f (int z) {return z;}\<close>
	-C \<open>int ((* f) (int z1, int z2)) {return z1 + z2;}\<close>
	-C \<open>int (* (* f) (int z1, int z2)) {return z1 + z2;}\<close>
	-C \<open>typedef int (* f) (int z); f uuu (int b) {return b;};\<close>
	-C \<open>typedef int (* (* f) (int z, int z)) (int a); f uuu (int b) {return b;};\<close>
	-C \<open>struct z { int (* f) (int z); int (* (* ff) (int z)) (int a); };\<close>
	-C \<open>double (* (* f (int a /* \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Wrap_Overloading.declarator1\<close>\<close>*/)) (int a, double d)) (char a);\<close>
	-C \<open>double (* (((* f) []) (int a)) (int b, double c)) (char d) {int a = b + c + d;}\<close>
	-C \<open>double ((((f) (int a))) (int a / \<leftarrow>\<comment> \<open>\<^ML>\<open>C_Grammar_Rule_Lib.doFuncParamDeclIdent\<close>\<close>*/, double)) (char c) {int a = 0;}\<close>
	-
	-C \<comment> \<open>Nesting functions\<close> \<open>
	-double (* (* f (int a)) (int a, double)) (char c) {
	-double (* (* f (int a)) (double a, int a)) (char) {
	- return a;
	-}
	-}
	-\<close>
	-
	-C \<comment> \<open>Old function syntax\<close> \<open>
	-f (x) int x; {return x;}
	-\<close>
	-
	-section \<open>General Isar Commands\<close>
	-
	-locale zz begin definition "z' = ()"
	- end
	-
	-C \<comment> \<open>Mixing arbitrary commands\<close> \<open>
	-int a = 0;
	-int b = a * a + 0;
	-int jjj = b;
	-/*@
	- @@@ ML \<open>@{lemma \<open>A \<and> B \<longrightarrow> B \<and> A\<close> by (ml_tactic \<open>blast_tac ctxt 1\<close>)}\<close>
	- definition "a' = ()"
	- declare [[ML_source_trace]]
	- lemma (in zz) \<open>A \<and> B \<longrightarrow> B \<and> A\<close> by (ml_tactic \<open>blast_tac ctxt 1\<close>)
	- definition (in zz) "z = ()"
	- corollary "zz.z' = ()"
	- apply (unfold zz.z'_def)
	- by blast
	- theorem "True &&& True" by (auto, presburger?)
	-*/
	-\<close>
	-
	-declare [[ML_source_trace = false]]
	-
	-C \<comment> \<open>Backslash newlines must be supported by \<^ML>\<open>C_Token.syntax'\<close> (in particular in keywords)\<close> \<open>
	-//@ lem\
	-ma (i\
	-n z\
	-z) \
	-\<open>\
	-AA \<and> B\
	- \<longrightarrow>\
	- B \<and> A\
	-\
	-A\<close> b\
	-y (ml_t\
	-actic \<open>\
	-bla\
	-st_tac c\
	-txt\
	- 0\
	-001\<close>)
	-\<close>
	-
	-section \<open>Starting Parsing Rule\<close>
	-
	-subsection \<open>Basics\<close>
	-
	-C \<comment> \<open>Parameterizing starting rule\<close> \<open>
	-/*@
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "statement"]]
	-C \<open>while (a) {}\<close>
	-C \<open>a = 2;\<close>
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]
	-C \<open>2 + 3\<close>
	-C \<open>a = 2\<close>
	-C \<open>a[1]\<close>
	-C \<open>&a\<close>
	-C \<open>a\<close>
	-*/
	-\<close>
	-
	-subsection \<open>Embedding in Inner Terms\<close>
	-
	-term \<open>\<^C> \<comment> \<open>default behavior of parsing depending on the activated option\<close> \<open>0\<close>\<close>
	-term \<open>\<^C>\<^sub>u\<^sub>n\<^sub>i\<^sub>t \<comment> \<open>force the explicit parsing\<close> \<open>f () {while (a) {}; return 0;} int a = 0;\<close>\<close>
	-term \<open>\<^C>\<^sub>d\<^sub>e\<^sub>c\<^sub>l \<comment> \<open>force the explicit parsing\<close> \<open>int a = 0; \<close>\<close>
	-term \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r \<comment> \<open>force the explicit parsing\<close> \<open>a\<close>\<close>
	-term \<open>\<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t \<comment> \<open>force the explicit parsing\<close> \<open>while (a) {}\<close>\<close>
	-
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "translation_unit"]]
	-
	-term \<open>\<^C> \<comment> \<open>default behavior of parsing depending on the current option\<close> \<open>int a = 0;\<close>\<close>
	-
	-subsection \<open>User Defined Setup of Syntax\<close>
	-
	-setup \<open>C_Module.C_Term.map_expression (fn _ => fn _ => fn _ => @{term "10 :: nat"})\<close>
	-setup \<open>C_Module.C_Term.map_statement (fn _ => fn _ => fn _ => @{term "20 :: nat"})\<close>
	-value \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>1\<close> + \<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t\<open>for (;;);\<close>\<close>
	-
	-setup \<comment> \<open>redefinition\<close> \<open>C_Module.C_Term.map_expression
	- (fn _ => fn _ => fn _ => @{term "1000 :: nat"})\<close>
	-value \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>1\<close> + \<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t\<open>for (;;);\<close>\<close>
	-
	-setup \<open>C_Module.C_Term.map_default (fn _ => fn _ => fn _ => @{term "True"})\<close>
	-
	-subsection \<open>Validity of Context for Annotations\<close>
	-
	-ML \<open>fun fac x = if x = 0 then 1 else x * fac (x - 1)\<close>
	-
	-ML \<comment> \<open>Execution of annotations in term possible in (the outermost) \<^theory_text>\<open>ML\<close>\<close> \<open>
	-\<^term>\<open> \<^C> \<open>int c = 0; /@ ML \<open>fac 100\<close> /\<close> \<close>
	-\<close>
	-
	-definition \<comment> \<open>Execution of annotations in term possible in \<^ML_type>\<open>local_theory\<close> commands (such as \<^theory_text>\<open>definition\<close>)\<close> \<open>
	-term = \<^C> \<open>int c = 0; /@ ML \<open>fac 100\<close> /\<close>
	-\<close>
	-
	-section \<open>Scopes of Inner and Outer Terms\<close>
	-
	-ML \<open>
	-local
	-fun bind scan ((stack1, (to_delay, stack2)), _) =
	- C_Parse.range scan
	- >> (fn (src, range) =>
	- C_Env.Parsing
	- ( (stack1, stack2)
	- , ( range
	- , C_Inner_Syntax.bottom_up
	- (fn _ => fn context =>
	- ML_Context.exec
	- (tap (fn _ => Syntax.read_term (Context.proof_of context)
	- (Token.inner_syntax_of src)))
	- context)
	- , Symtab.empty
	- , to_delay)))
	-in
	-val _ =
	- Theory.setup
	- ( C_Annotation.command'
	- ("term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r", \<^here>)
	- ""
	- (bind (C_Token.syntax' (Parse.token Parse.cartouche)))
	- #> C_Inner_Syntax.command0
	- (C_Inner_Toplevel.keep'' o C_Inner_Isar_Cmd.print_term)
	- (C_Token.syntax' (Scan.succeed [] -- Parse.term))
	- ("term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r", \<^here>, \<^here>, \<^here>))
	-end
	-\<close>
	-
	-C \<open>
	-int z = z;
	- /*@ C \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- C' \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	- C \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- C' \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close> */\<close>
	-term(outer) \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	-
	-C \<open>
	-int z = z;
	- /*@ C \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- C' \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	- C \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- C' \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close> */\<close>
	-term(outer) \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	-
	-declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]
	-
	-C \<open>
	-int z = z;
	- /*@ C \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- C' \<open>//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	- C \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- C' \<open>//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>\<close>
	- term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close> */\<close>
	-term(outer) \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>z\<close>\<close>
	-
	-declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = empty]]
	-
	-C \<comment> \<open>Propagation of report environment while manually composing at ML level\<close> \<open>
	-int a;
	-int f (int b) {
	-int c = 0;
	-/*@ \<approx>setup \<open>fn _ => fn _ => fn env =>
	- C' env \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	- #> C \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	- #> C' env \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	- #> C \<open>int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>\<close>
	-\<close>
	- term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close>
	- term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \<open>\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>c\<close> + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<open>d\<close>\<close> */
	-int e = a + b + c + d;
	-}\<close>
	-
	-section \<open>Calculation in Directives\<close>
	-
	-subsection \<open>Annotation Command Classification\<close>
	-
	-C \<comment> \<open>Lexing category vs. parsing category\<close> \<open>
	-int a = 0;
	-
	-// \<comment> \<open>Category 2: only parsing\<close>
	-
	-//@ \<approx>setup \<open>K (K (K I))\<close> (* evaluation at parsing *)
	-//@@ \<approx>setup\<Down> \<open>K (K (K I))\<close> (* evaluation at parsing *)
	-
	-//@ highlight (* evaluation at parsing *)
	-//@@ highlight\<Down> (* evaluation at parsing *)
	-
	-// \<comment> \<open>Category 3: with lexing\<close>
	-
	-//@ #setup I (* evaluation at lexing (and directives resolving) *)
	-//@ setup I (* evaluation at parsing *)
	-//@@ setup\<Down> I (* evaluation at parsing *)
	-
	-//@ #ML I (* evaluation at lexing (and directives resolving) *)
	-//@ ML I (* evaluation at parsing *)
	-//@@ ML\<Down> I (* evaluation at parsing *)
	-
	-//@ #C \<open>\<close> (* evaluation at lexing (and directives resolving) *)
	-//@ C \<open>\<close> (* evaluation at parsing *)
	-//@@ C\<Down> \<open>\<close> (* evaluation at parsing *)
	-\<close>
	-
	-C \<comment> \<open>Scheduling example\<close> \<open>
	-//@+++++ ML \<open>writeln "2"\<close>
	-int a = 0;
	-//@@ ML\<Down> \<open>writeln "3"\<close>
	-//@ #ML \<open>writeln "1"\<close>
	-\<close>
	-
	-C \<comment> \<open>Scheduling example\<close> \<open>
	-//* lemma True by simp
	-//* #lemma True #by simp
	-//* #lemma True by simp
	-//* lemma True #by simp
	-\<close>
	-
	-C \<comment> \<open>Scheduling example\<close> \<open> /*@
	-lemma \<open>1 = one\<close>
	- \<open>2 = two\<close>
	- \<open>two + one = three\<close>
	-by auto
	-
	-#definition [simp]: \<open>three = 3\<close>
	-#definition [simp]: \<open>two = 2\<close>
	-#definition [simp]: \<open>one = 1\<close>
	-*/ \<close>
	-
	-subsection \<open>Generalizing ML Antiquotations with C Directives\<close>
	-
	-ML \<open>
	-structure Directive_setup_define = Generic_Data
	- (type T = int
	- val empty = 0
	- val merge = K empty)
	-
	-fun setup_define1 pos f =
	- C_Directive.setup_define
	- pos
	- (fn toks => fn (name, (pos1, _)) =>
	- tap (fn _ => writeln ("Executing " ^ name ^ Position.here pos1 ^ " (only once)"))
	- #> pair (f toks))
	- (K I)
	-
	-fun setup_define2 pos = C_Directive.setup_define pos (K o pair)
	-\<close>
	-
	-C \<comment> \<open>General scheme of C antiquotations\<close> \<open>
	-/*@
	- #setup \<comment> \<open>Overloading \<open>#define\<close>\<close> \<open>
	- setup_define2
	- \<^here>
	- (fn (name, (pos1, _)) =>
	- op ` Directive_setup_define.get
	- #>> (case name of "f3" => curry op * 152263 \| _ => curry op + 1)
	- #> tap (fn (nb, _) =>
	- tracing ("Executing antiquotation " ^ name ^ Position.here pos1
	- ^ " (number = " ^ Int.toString nb ^ ")"))
	- #> uncurry Directive_setup_define.put)
	- \<close>
	-*/
	-#define f1
	-#define f2 int a = 0;
	-#define f3
	- f1
	- f2
	- f1
	- f3
	-
	-//@ #setup \<comment> \<open>Resetting \<open>#define\<close>\<close> \<open>setup_define2 \<^here> (K I)\<close>
	- f3
	-#define f3
	- f3
	-\<close>
	-
	-C \<comment> \<open>Dynamic token computing in \<open>#define\<close>\<close> \<open>
	-
	-//@ #setup \<open>setup_define1 \<^here> (K [])\<close>
	-#define f int a = 0;
	- f f f f
	-
	-//@ #setup \<open>setup_define1 \<^here> (fn toks => toks @ toks)\<close>
	-#define f int b = a;
	- f f
	-
	-//@ #setup \<open>setup_define1 \<^here> I\<close>
	-#define f int a = 0;
	- f f
	-\<close>
	-
	-section \<open>Miscellaneous\<close>
	-
	-C \<comment> \<open>Antiquotations acting on a parsed-subtree\<close> \<open>
	-# /**/ include <a\b\\c> // backslash rendered unescaped
	-f(){0 + 0;} /**/ // val _ : theory => 'a => theory
	-# /* context */ if if elif
	-#include <stdio.h>
	-if then else ;
	-# /* zzz / elif /*/
	-#else\
	-
	-#define FOO 00 0 "" ((
	-FOO(FOO(a,b,c))
	-#endif\<close>
	-
	-C \<comment> \<open>Header-names in directives\<close> \<open>
	-#define F <stdio.h>
	-#define G "stdio\h" // expecting an error whenever expanded
	-#define H "stdio_h" // can be used anywhere without errors
	-int f = /F/ "";
	-int g = /G/ "";
	-int h = H "";
	-
	-#include F
	-\<close>
	-
	-C \<comment> \<open>Parsing tokens as directives only when detecting space symbols before \<open>#\<close>\<close> \<open>/*
	- */ \
	- \
	-
	- //
	- # /*
	-/ define /*/ \
	- a
	-a a /#include <>/ // must not be considered as a directive
	-\<close>
	-
	-C \<comment> \<open>Universal character names in identifiers and Isabelle symbols\<close> \<open>
	-#include <stdio.h>
	-int main () {
	- char * ó\<^url>ò = "ó\<^url>ò";
	- printf ("%s", ó\<^url>ò);
	-}
	-\<close>
	-
	-
	-end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C4.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C4.thy
	deleted file mode 100644
	--- a/thys/Isabelle_C/C11-FrontEnd/examples/C4.thy
	+++ /dev/null
	@@ -1,628 +0,0 @@
	-(******************************************************************************
	- * Isabelle/C
	- *
	- * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	- *
	- * All rights reserved.
	- *
	- * Redistribution and use in source and binary forms, with or without
	- * modification, are permitted provided that the following conditions are
	- * met:
	- *
	- * * Redistributions of source code must retain the above copyright
	- * notice, this list of conditions and the following disclaimer.
	- *
	- * * Redistributions in binary form must reproduce the above
	- * copyright notice, this list of conditions and the following
	- * disclaimer in the documentation and/or other materials provided
	- * with the distribution.
	- *
	- * * Neither the name of the copyright holders nor the names of its
	- * contributors may be used to endorse or promote products derived
	- * from this software without specific prior written permission.
	- *
	- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	- * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	- * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	- * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	- * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	- * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	- * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	- ******************************************************************************)
	-
	-chapter \<open>Annex V: Examples for A Simple C Program with Directives and Annotations\<close>
	-
	-theory C4
	- imports "../C_Main"
	-begin
	-
	-section \<open>A Simplistic Setup: Parse and Store\<close>
	-
	-text\<open>The following setup just stores the result of the parsed values in the environment.\<close>
	-
	-ML\<open>
	-structure Data_Out = Generic_Data
	- (type T = (C_Grammar_Rule.ast_generic * C_Antiquote.antiq C_Env.stream) list
	- val empty = []
	- val merge = K empty)
	-
	-fun get_CTranslUnit thy =
	- let val context = Context.Theory thy
	- in (Data_Out.get context
	- \|> map (apfst (C_Grammar_Rule.get_CTranslUnit #> the)), C_Module.Data_In_Env.get context)
	- end
	-
	-fun get_CExpr thy =
	- let val context = Context.Theory thy
	- in (Data_Out.get context
	- \|> map (apfst (C_Grammar_Rule.get_CExpr #> the)), C_Module.Data_In_Env.get context)
	- end
	-
	-\<close>
	-
	-text\<open>Und hier setzen wir per callback die Petze:\<close>
	-
	-ML\<open> Data_Out.map: ( (C_Grammar_Rule.ast_generic * C_Antiquote.antiq C_Env.stream) list
	- -> (C_Grammar_Rule.ast_generic * C_Antiquote.antiq C_Env.stream) list)
	- -> Context.generic -> Context.generic \<close>
	-
	-ML\<open>val SPY = Unsynchronized.ref([]:C_Grammar_Rule.ast_generic list)\<close>
	-setup \<open>Context.theory_map (C_Module.Data_Accept.put
	- (fn ast => fn env_lang => let val _ = (SPY:= ast:: !SPY) in
	- Data_Out.map (cons (ast, #stream_ignored env_lang \|> rev))
	- end))\<close>
	-
	-ML\<open>
	-val _ = Theory.setup(
	- ML_Antiquotation.value_embedded \<^binding>\<open>C11_AST_CTranslUnit\<close>
	- (Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	- (warning"arg variant not implemented";"get_CTranslUnit (Context.the_global_context())"))
	- \|\| Scan.succeed "get_CTranslUnit (Context.the_global_context())"))
	-
	-\<close>
	-
	-
	-section \<open>Example: A Possible Semantics for \<open>#include\<close>\<close>
	-
	-subsection \<open>Implementation\<close>
	-
	-text \<open> The CPP directive \<^C>\<open>#include _\<close> is used to import signatures of
	-modules in C. This has the effect that imported identifiers are included in the C environment and,
	-as a consequence, appear as constant symbols and not as free variables in the output. \<close>
	-
	-text \<open> The following structure is an extra mechanism to define the effect of \<^C>\<open>#include _\<close> wrt. to
	-its definition in its environment. \<close>
	-
	-ML \<open>
	-structure Directive_include = Generic_Data
	- (type T = (Input.source * C_Env.markup_ident) list Symtab.table
	- val empty = Symtab.empty
	- val merge = K empty)
	-\<close>
	-
	-ML \<comment> \<open>\<^theory>\<open>Pure\<close>\<close> \<open>
	-local
	-fun return f (env_cond, env) = ([], (env_cond, f env))
	-
	-val _ =
	- Theory.setup
	- (Context.theory_map
	- (C_Context0.Directives.map
	- (C_Context.directive_update ("include", \<^here>)
	- ( (return o K I)
	- , fn C_Lex.Include (C_Lex.Group2 (toks_bl, _, tok :: _)) =>
	- let
	- fun exec file =
	- if exists (fn C_Scan.Left _ => false \| C_Scan.Right _ => true) file then
	- K (error ("Unsupported character"
	- ^ Position.here
	- (Position.range_position
	- (C_Lex.pos_of tok, C_Lex.end_pos_of (List.last toks_bl)))))
	- else
	- fn (env_lang, env_tree) =>
	- fold
	- (fn (src, data) => fn (env_lang, env_tree) =>
	- let val (name, pos) = Input.source_content src
	- in C_Grammar_Rule_Lib.shadowTypedef0''''
	- name
	- [pos]
	- data
	- env_lang
	- env_tree
	- end)
	- (these (Symtab.lookup (Directive_include.get (#context env_tree))
	- (String.concat
	- (maps (fn C_Scan.Left s => [s] \| _ => []) file))))
	- (env_lang, env_tree)
	- in
	- case tok of
	- C_Lex.Token (_, (C_Lex.String (_, file), _)) => exec file
	- \| C_Lex.Token (_, (C_Lex.File (_, file), _)) => exec file
	- \| _ => tap (fn _ => (* not yet implemented *)
	- warning ("Ignored directive"
	- ^ Position.here
	- (Position.range_position
	- ( C_Lex.pos_of tok
	- , C_Lex.end_pos_of (List.last toks_bl)))))
	- end \|> K \|> K
	- \| _ => K (K I)))))
	-in end
	-\<close>
	-
	-ML \<open>
	-structure Include =
	-struct
	-fun init name vars =
	- Context.theory_map
	- (Directive_include.map
	- (Symtab.update
	- (name, map (rpair {global = true, params = [], ret = C_Env.Previous_in_stack}) vars)))
	-
	-fun append name vars =
	- Context.theory_map
	- (Directive_include.map
	- (Symtab.map_default
	- (name, [])
	- (rev o fold (cons o rpair {global = true, params = [], ret = C_Env.Previous_in_stack}) vars
	- o rev)))
	-
	-val show =
	- Context.theory_map
	- (Directive_include.map
	- (tap
	- (Symtab.dest
	- #>
	- app (fn (fic, vars) =>
	- writeln ("Content of \"" ^ fic ^ "\": "
	- ^ String.concat (map (fn (i, _) => let val (name, pos) = Input.source_content i
	- in name ^ Position.here pos ^ " " end)
	- vars))))))
	-end
	-\<close>
	-
	-setup \<open>Include.append "stdio.h" [\<open>printf\<close>, \<open>scanf\<close>]\<close>
	-
	-subsection \<open>Tests\<close>
	-
	-C \<open>
	-//@ setup \<open>Include.append "tmp" [\<open>b\<close>]\<close>
	-#include "tmp"
	-int a = b;
	-
	-\<close>
	-
	-C \<open>
	-int b = 0;
	-//@ setup \<open>Include.init "tmp" [\<open>b\<close>]\<close>
	-#include "tmp"
	-int a = b;
	-\<close>
	-
	-C \<open>
	-int c = 0;
	-//@ setup \<open>Include.append "tmp" [\<open>c\<close>]\<close>
	-//@ setup \<open>Include.append "tmp" [\<open>c\<close>]\<close>
	-#include "tmp"
	-int a = b + c;
	-//@ setup \<open>Include.show\<close>
	-\<close>
	-
	-section \<open>Working with Pragmas\<close>
	-C\<open>
	-
	-#include <stdio.h>
	-#include /sdfsdf / <stdlib.h>
	-#define a B
	-#define b(C)
	-#pragma /* just exists syntaxically */
	-\<close>
	-
	-
	-text\<open>In the following, we retrieve the C11 AST parsed above. \<close>
	-ML\<open> val ((C_Ast.CTranslUnit0 (t,u), v)::R, env) = @{C11_AST_CTranslUnit};
	- val u = C_Grammar_Rule_Lib.decode u;
	- C_Ast.CTypeSpec0; \<close>
	-
	-
	-
	-section \<open>Working with Annotation Commands\<close>
	-
	-ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Command\<close>\<close> \<open>
	-\<comment> \<open>setup for a dummy ensures : the "Hello World" of Annotation Commands\<close>
	-local
	-datatype antiq_hol = Term of string (* term *)
	-
	-val scan_opt_colon = Scan.option (C_Parse.$$$ ":")
	-
	-fun msg cmd_name call_pos cmd_pos =
	- tap (fn _ =>
	- tracing ("\<open>Hello World\<close> reported by \"" ^ cmd_name ^ "\" here" ^ call_pos cmd_pos))
	-
	-fun command (cmd as (cmd_name, _)) scan0 scan f =
	- C_Annotation.command'
	- cmd
	- ""
	- (fn (_, (cmd_pos, _)) =>
	- (scan0 -- (scan >> f) >> (fn _ => C_Env.Never \|> msg cmd_name Position.here cmd_pos)))
	-in
	-val _ = Theory.setup ( C_Inner_Syntax.command_no_range
	- (C_Inner_Toplevel.generic_theory oo C_Inner_Isar_Cmd.setup \<open>K (K (K I))\<close>)
	- ("loop", \<^here>, \<^here>)
	- #> command ("ensures", \<^here>) scan_opt_colon C_Parse.term Term
	- #> command ("invariant", \<^here>) scan_opt_colon C_Parse.term Term
	- #> command ("assigns", \<^here>) scan_opt_colon C_Parse.term Term
	- #> command ("requires", \<^here>) scan_opt_colon C_Parse.term Term
	- #> command ("variant", \<^here>) scan_opt_colon C_Parse.term Term)
	-end
	-\<close>
	-
	-C\<open>
	-/*@ ensures "result >= x && result >= y"
	- */
	-
	-int max(int x, int y) {
	- if (x > y) return x; else return y;
	-}
	-\<close>
	-
	-ML\<open>
	-val ((C_Ast.CTranslUnit0 (t,u), v)::R, env) = get_CTranslUnit @{theory};
	-val u = C_Grammar_Rule_Lib.decode u
	-\<close>
	-
	-
	-section \<open>C Code: Various Examples\<close>
	-
	-text\<open>This example suite is drawn from Frama-C and used in our GLA - TPs. \<close>
	-
	-C\<open>
	-int sqrt(int a) {
	- int i = 0;
	- int tm = 1;
	- int sum = 1;
	-
	- /*@ loop invariant "1 <= sum <= a+tm"
	- loop invariant "(i+1)*(i+1) == sum"
	- loop invariant "tm+(i*i) == sum"
	- loop invariant "1<=tm<=sum"
	- loop assigns "i, tm, sum"
	- loop variant "a-sum"
	- */
	- while (sum <= a) {
	- i++;
	- tm = tm + 2;
	- sum = sum + tm;
	- }
	-
	- return i;
	-}
	-\<close>
	-
	-C\<open>
	-/*@ requires "n >= 0"
	- requires "valid(t+(0..n-1))"
	- ensures "exists integer i; (0<=i<n && t[i] != 0) <==> result == 0"
	- ensures "(forall integer i; 0<=i<n ==> t[i] == 0) <==> result == 1"
	- assigns nothing
	- */
	-
	-int allzeros(int t[], int n) {
	- int k = 0;
	-
	- /*@ loop invariant "0 <= k <= n"
	- loop invariant "forall integer i; 0<=i<k ==> t[i] == 0"
	- loop assigns k
	- loop variant "n-k"
	- */
	- while(k < n) {
	- if (t[k]) return 0;
	- k = k + 1;
	- }
	- return 1;
	-}
	-
	-\<close>
	-
	-C\<open>
	-
	-/*@ requires "n >= 0"
	- requires "valid(t+(0..n-1))"
	- ensures "(forall integer i; 0<=i<n ==> t[i] != v) <==> result == -1"
	- ensures "(exists integer i; 0<=i<n && t[i] == v) <==> result == v"
	- assigns nothing
	- */
	-
	-int binarysearch(int t[], int n, int v) {
	- int l = 0;
	- int u = n-1;
	-
	- /*@ loop invariant false
	- */
	- while (l <= u) {
	- int m = (l + u) / 2;
	- if (t[m] < v) {
	- l = m + 1;
	- } else if (t[m] > v) {
	- u = m - 1;
	- }
	- else return m;
	- }
	- return -1;
	-}
	-\<close>
	-
	-
	-C\<open>
	-/*@ requires "n >= 0"
	- requires "valid(t+(0..n-1))"
	- requires "(forall integer i,j; 0<=i<=j<n ==> t[i] <= t[j])"
	- ensures "exists integer i; (0<=i<n && t[i] == x) <==> result == 1"
	- ensures "(forall integer i; 0<=i<n ==> t[i] != x) <==> result == 0"
	- assigns nothing
	- */
	-
	-int linearsearch(int x, int t[], int n) {
	- int i = 0;
	-
	- /*@ loop invariant "0<=i<=n"
	- loop invariant "forall integer j; 0<=j<i ==> (t[j] != x)"
	- loop assigns i
	- loop variant "n-i"
	- */
	- while (i < n) {
	- if (t[i] < x) {
	- i++;
	- } else {
	- return (t[i] == x);
	- }
	- }
	-
	- return 0;
	-}
	-\<close>
	-
	-
	-section \<open>C Code: A Sorting Algorithm\<close>
	-
	-C\<open>
	-#include <stdio.h>
	-
	-int main()
	-{
	- int array[100], n, c, d, position, swap;
	-
	- printf("Enter number of elements\n");
	- scanf("%d", &n);
	-
	- printf("Enter %d integers\n", n);
	-
	- for (c = 0; c < n; c++) scanf("%d", &array[c]);
	-
	- for (c = 0; c < (n - 1); c++)
	- {
	- position = c;
	-
	- for (d = c + 1; d < n; d++)
	- {
	- if (array[position] > array[d])
	- position = d;
	- }
	- if (position != c)
	- {
	- swap = array[c];
	- array[c] = array[position];
	- array[position] = swap;
	- }
	- }
	-
	-printf("Sorted list in ascending order:\n");
	-
	- for (c = 0; c < n; c++)
	- printf("%d\n", array[c]);
	-
	- return 0;
	-}
	-\<close>
	-
	-text\<open>A better example implementation:\<close>
	-
	-C\<open>
	-#include <stdio.h>
	-#include <stdlib.h>
	-
	-#define SIZE 10
	-
	-void swap(int x,int y);
	-void selection_sort(int* a, const int n);
	-void display(int a[],int size);
	-
	-void main()
	-{
	-
	- int a[SIZE] = {8,5,2,3,1,6,9,4,0,7};
	-
	- int i;
	- printf("The array before sorting:\n");
	- display(a,SIZE);
	-
	- selection_sort(a,SIZE);
	-
	- printf("The array after sorting:\n");
	- display(a,SIZE);
	-}
	-
	-/*
	- swap two integers
	-*/
	-void swap(int x,int y)
	-{
	- int temp;
	-
	- temp = *x;
	- x = y;
	- *y = temp;
	-}
	-/*
	- perform selection sort
	-*/
	-void selection_sort(int* a,const int size)
	-{
	- int i, j, min;
	-
	- for (i = 0; i < size - 1; i++)
	- {
	- min = i;
	- for (j = i + 1; j < size; j++)
	- {
	- if (a[j] < a[min])
	- {
	- min = j;
	- }
	- }
	- swap(&a[i], &a[min]);
	- }
	-}
	-/*
	- display array content
	-*/
	-void display(int a[],const int size)
	-{
	- int i;
	- for(i=0; i<size; i++)
	- printf("%d ",a[i]);
	- printf("\n");
	-}
	-\<close>
	-
	-text\<open>Accessing the underlying C11-AST's via the ML Interface.\<close>
	-
	-ML\<open>
	-local open C_Ast in
	-val _ = CTranslUnit0
	-val (A::R, _) = @{C11_AST_CTranslUnit};
	-val (CTranslUnit0 (t,u), v) = A
	-fun rule_trans (CTranslUnit0 (t,u), v) = case C_Grammar_Rule_Lib.decode u of
	- Left (p1,p2) => writeln (Position.here p1 ^ " " ^ Position.here p2)
	- \| Right S => warning ("Not expecting that value:"^S)
	-val bb = rule_trans A
	-val CDeclExt0(x1)::_ = t;
	-val _ = CDecl0
	-end
	-\<close>
	-
	-ML\<open>
	-get_CTranslUnit;
	-val (R, env_final) = @{C11_AST_CTranslUnit};
	-val rules = map rule_trans R;
	-@{C\<^sub>e\<^sub>n\<^sub>v}
	-\<close>
	-
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]
	-
	-ML\<open>
	-val src = \<open>a + d\<close>;
	-val ctxt = (Context.Theory @{theory});
	-val ctxt' = C_Module.C' @{C\<^sub>e\<^sub>n\<^sub>v} src ctxt;
	-val tt = Context.the_theory ctxt';
	-(*get_CExpr (Context.the_theory ctxt');
	-C_Module.Data_In_Env.get ctxt' *)
	-\<close>
	-ML\<open>val Expr = hd(map_filter C_Grammar_Rule.get_CExpr (!SPY));\<close>
	-
	-ML\<open>Symtab.map_entry\<close>
	-
	-ML\<open> Context.theory_long_name @{theory}\<close>
	-ML\<open> fun insert_K_ast key ast = Symtab.map_default (key,[]) (cons ast)
	- \<close>
	-
	-ML\<open>
	-structure Root_Ast_Store = Generic_Data
	- (type T = C_Grammar_Rule.ast_generic list Symtab.table
	- val empty = Symtab.empty
	- val merge = K empty);
	-
	-
	-Root_Ast_Store.map: ( C_Grammar_Rule.ast_generic list Symtab.table
	- -> C_Grammar_Rule.ast_generic list Symtab.table)
	- -> Context.generic -> Context.generic;
	-
	-
	-fun update_Root_Ast filter ast _ ctxt =
	- let val theory_id = Context.theory_long_name(Context.theory_of ctxt)
	- val insert_K_ast = Symtab.map_default (theory_id,[]) (cons ast)
	- in case filter ast of
	- NONE => (warning "No appropriate c11 ast found - store unchanged."; ctxt)
	- \|SOME _ => (Root_Ast_Store.map insert_K_ast) ctxt
	- end;
	-
	-
	-fun get_Root_Ast filter thy =
	- let val ctxt = Context.Theory thy
	- val thid = Context.theory_long_name(Context.theory_of ctxt)
	- val ast = case Symtab.lookup (Root_Ast_Store.get ctxt) (thid) of
	- SOME (a::_) => (case filter a of
	- NONE => error "Last C command is not of appropriate AST-class."
	- \| SOME x => x)
	- \| _ => error"No C command in the current theory."
	- in ast
	- end
	-
	-val get_CExpr = get_Root_Ast C_Grammar_Rule.get_CExpr;
	-val get_CStat = get_Root_Ast C_Grammar_Rule.get_CStat;
	-val get_CExtDecl = get_Root_Ast C_Grammar_Rule.get_CExtDecl;
	-val get_CTranslUnit = get_Root_Ast C_Grammar_Rule.get_CTranslUnit;
	-\<close>
	-
	-setup \<open>Context.theory_map (C_Module.Data_Accept.put (update_Root_Ast SOME))\<close>
	-
	-
	-ML\<open>
	-val _ = Theory.setup(
	- ML_Antiquotation.value_embedded \<^binding>\<open>C11_CTranslUnit\<close>
	- (Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	- (warning"arg variant not implemented";"get_CTranslUnit (Context.the_global_context())"))
	- \|\| Scan.succeed "get_CTranslUnit (Context.the_global_context())")
	- #>
	- ML_Antiquotation.value_embedded \<^binding>\<open>C11_CExtDecl\<close>
	- (Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	- (warning"arg variant not implemented";"get_CExtDecl (Context.the_global_context())"))
	- \|\| Scan.succeed "get_CExtDecl (Context.the_global_context())")
	- #>
	- ML_Antiquotation.value_embedded \<^binding>\<open>C11_CStat\<close>
	- (Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	- (warning"arg variant not implemented";"get_CStat (Context.the_global_context())"))
	- \|\| Scan.succeed "get_CStat (Context.the_global_context())")
	- #>
	- ML_Antiquotation.value_embedded \<^binding>\<open>C11_CExpr\<close>
	- (Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	- (warning"arg variant not implemented";"get_CExpr (Context.the_global_context())"))
	- \|\| Scan.succeed "get_CExpr (Context.the_global_context())")
	- )
	-\<close>
	-
	-text\<open>For the parsing root key's, c.f. ~ \<^verbatim>\<open>C_Command.thy\<close>\<close>
	-
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "expression"]]
	-C\<open>a + b\<close>
	-ML\<open>val ast = @{C11_CExpr}\<close>
	-
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "statement"]]
	-C\<open>a = a + b;\<close>
	-ML\<open>val ast = @{C11_CStat}\<close>
	-
	-
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "external_declaration"]]
	-C\<open>int m ();\<close>
	-ML\<open>val ast = @{C11_CExtDecl}\<close>
	-
	-declare [[C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0 = "translation_unit"]]
	-C\<open>int a = a + b;\<close>
	-ML\<open>val ast = @{C11_CTranslUnit}\<close>
	-
	-
	-
	-end
	\ No newline at end of file
	diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C_paper.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C_paper.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/examples/C_paper.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/examples/C_paper.thy
	@@ -1,199 +1,196 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	chapter \<open>Examples from the F-IDE Paper\<close>

	theory C_paper
	- imports "../C_Main"
	+ imports "../main/C_Main"
	begin

	text \<open> This theory contains the examples presented in F-IDE 2019 paper~\cite{Tuong-IsabelleC:2019}. \<close>

	section \<open>Setup\<close>

	ML\<open>
	\<comment> \<open>Annotation Commands Mimicking the \<^theory_text>\<open>setup\<close> command\<close>
	val _ = Theory.setup
	(C_Inner_Syntax.command C_Inner_Isar_Cmd.setup' C_Parse.ML_source ("\<simeq>setup", \<^here>, \<^here>))

	-val C' = C_Module.C'
	-
	-fun C opt = case opt of NONE => C' (C_Module.env (Context.the_generic_context ()))
	- \| SOME env => C' env
	+val C = C_Module.C'

	fun C_def dir name _ _ =
	Context.map_theory
	(C_Inner_Syntax.command'
	(C_Inner_Syntax.drop1
	(C_Scan.Right ( (fn src => fn context =>
	- C' (C_Stack.Data_Lang.get' context \|> #2) src context)
	+ C_Module.C' (SOME (C_Stack.Data_Lang.get' context \|> #2)) src context)
	, dir)))
	C_Parse.C_source
	name)

	\<comment> \<open>Defining the ML Antiquotation \<open>C_def\<close> to define on the fly new C annotation commands\<close>
	local
	in
	val _ = Theory.setup
	(ML_Antiquotation.declaration
	@{binding "C_def"}
	(Scan.lift (Parse.sym_ident -- Parse.position Parse.name))
	(fn _ => fn (top_down, (name, pos)) =>
	tap (fn ctxt => Context_Position.reports ctxt [(pos, Markup.keyword1)]) #>
	C_Context.fun_decl
	"cmd" "x" ( "C_def "
	^ (case top_down of "\<Up>" => "C_Inner_Syntax.bottom_up"
	\| "\<Down>" => "C_Env.Top_down"
	\| _ => error "Illegal symbol")
	^ " (\"" ^ name ^ "\", " ^ ML_Syntax.print_position pos ^ ")")))
	end
	\<close>

	text \<open> The next command is predefined here, so that the example below can later refer to the
	constant. \<close>
	definition [simplified]: "UINT_MAX \<equiv> (2 :: nat) ^ 32 - 1"

	section \<open>Defining Annotation Commands\<close>

	ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Command\<close>\<close> \<open>
	local
	datatype antiq_hol = Invariant of string (* term *)
	val scan_colon = C_Parse.$$$ ":" >> SOME
	fun command cmd scan0 scan f =
	C_Annotation.command' cmd "" (K (scan0 -- (scan >> f)
	>> K C_Env.Never))
	in
	val _ = Theory.setup ((* 1 '@' *)
	command ("INVARIANT", \<^here>) scan_colon C_Parse.term Invariant
	#> command ("INV", \<^here>) scan_colon C_Parse.term Invariant)
	end
	\<close>

	text\<open>Demonstrating the Effect of Annotation Command Context Navigation \<close>


	C \<open>
	int sum1(int a)
	{
	while (a < 10)
	/*@ @ INV: \<open>\<dots>\<close>
	@ highlight */
	{ a = a + 1; }
	return a;
	}\<close>



	C \<open>
	int sum2(int a)
	/*@ ++@ INV: \<open>\<dots>\<close>
	++@ highlight */
	{
	while (a < 10)
	{ a = a + 1; }
	return a;
	}\<close>




	C (NONE) \<comment> \<open>starting environment = empty\<close> \<open>
	int a (int b) { return &a + b + c; }
	/*@ \<simeq>setup \<open>fn stack_top => fn env =>
	C (SOME env) \<open>int c = &a + b + c;\<close>\<close>
	\<simeq>setup \<open>fn stack_top => fn env =>
	C NONE \<open>int c = &a + b + c;\<close>\<close>
	declare [[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]
	C (SOME) \<open>int c = &a + b + c;\<close>
	*/\<close>

	section \<open>Proofs inside C-Annotations\<close>

	-\<comment> \<open>See also: \<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/blob/C/C11-BackEnds/AutoCorres_wrapper/examples/IsPrime_TEC.thy\<close>\<close>
	+\<comment> \<open>See also: \<^url>\<open>https://gitlab.lisn.upsaclay.fr/burkhart.wolff/Isabelle_C/-/blob/C/C11-BackEnds/AutoCorres_wrapper/examples/IsPrime_linear_CCT.thy\<close>\<close>

	C \<open>
	#define SQRT_UINT_MAX 65536
	/*@ lemma uint_max_factor [simp]:
	"UINT_MAX = SQRT_UINT_MAX * SQRT_UINT_MAX - 1"
	by (clarsimp simp: UINT_MAX_def SQRT_UINT_MAX_def)
	*/\<close>

	term SQRT_UINT_MAX

	section \<open>Scheduling the Effects on the Logical Context\<close>

	C \<open>int _;
	/*@ @ C \<open>//@ C1 \<open>int _; //@ @ \<simeq>setup\<Down> \<open>@{C_def \<Up> C2}\<close> \
	@ C1 \<open>//* C2 \<open>int _;\<close>\<close> \
	@ C1\<Down> \<open>//* C2 \<open>int _;\<close>\<close> \<close>\<close>
	@ C \<open>//* C2 \<open>int _;\<close> \<close>
	\<simeq>setup \<open>@{C_def \<Up> (* bottom-up *) C1 }\<close>
	\<simeq>setup \<open>@{C_def \<Down> (* top-down *) "C1\<Down>"}\<close>
	*/\<close>

	section \<open>As Summary: A Spaghetti Language --- Bon Appétit!\<close>

	text\<open>... with the Bonus of a local C-inside-ML-inside-C-inside-Isar ...\<close>

	ML\<open>
	fun highlight (_, (_, pos1, pos2)) =
	tap (fn _ => Position.reports_text [((Position.range (pos1, pos2)
	\|> Position.range_position, Markup.intensify), "")])
	\<close>

	C (NONE) \<comment> \<open> the command starts with a default empty environment \<close>
	\<open>int f (int a)
	//@ ++& \<simeq>setup \<open>fn stack_top => fn env => highlight stack_top\<close>
	{ /*@ @ \<simeq>setup \<open>fn stack_top => fn env =>
	C (SOME env) (* the command starts with some provided environment *)
	\<open>int b = a + b; //@ C1' \<open>int c; //@ @ \<simeq>setup\<Down> \<open>@{C_def \<Up> C2'}\<close> \
	@ C1' \<open>//* C2' \<open>int d;\<close>\<close> \
	@ C1'\<Down> \<open>//* C2' \<open>int d;\<close>\<close> \<close>
	int b = a + b + c + d;\<close>\<close>
	@ \<simeq>setup \<open>fn stack_top => fn env => C NONE \<open>#define int int
	int b = a + b; //* C2' \<open>int c = b;\<close>\<close>\<close>
	\<simeq>setup \<open>@{C_def \<Up> (* bottom-up *) C1' }\<close>
	\<simeq>setup \<open>@{C_def \<Down> (* top-down *) "C1'\<Down>"}\<close>
	*/
	return a + b + c + d; /* explicit highlighting */ }\<close>

	text \<open> Note that in the current design-implementation of Isabelle/C, C directives have a
	propagation side-effect to any occurring subsequent C annotations, even if C directives are supposed
	to be all evaluated before any C code. (Making such effect inexistent would be equally easier to
	implement though, this is what was the default behavior of directives in previous versions of
	Isabelle/C.)\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/generated/c_grammar_fun.grm.sig b/thys/Isabelle_C/C11-FrontEnd/generated/c_grammar_fun.grm.sig
	--- a/thys/Isabelle_C/C11-FrontEnd/generated/c_grammar_fun.grm.sig
	+++ b/thys/Isabelle_C/C11-FrontEnd/generated/c_grammar_fun.grm.sig
	@@ -1,1425 +1,1416 @@
	structure C_Grammar_Rule =
	struct
	(#line 1.2 "c_grammar_fun.grm")open C_Ast open C_Grammar_Rule_Lib

	-(* ast_generic is an untyped universe of (some) ast's with the specific lenses put ... get ... *)
	-
	-type ast_generic = (CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either) either
	-(* name was: init_happy ,start_happy *)
	+type start_happy = (CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either) either

	-fun get_CExpr (x : ast_generic) = case x of Right (Right (Right (Left x))) => SOME x \| _ => NONE
	-fun get_CStat (x : ast_generic) = case x of Right (Right (Left x)) => SOME x \| _ => NONE
	-fun get_CExtDecl (x : ast_generic) = case x of Right (Left x) => SOME x \| _ => NONE
	-fun get_CTranslUnit (x : ast_generic) = case x of Left x => SOME x \| _ => NONE
	-
	-fun put_CExpr (x : C_Grammar_Rule_Lib.CExpr) = Right (Right (Right (Left x))) : ast_generic
	-fun put_CStat (x : C_Grammar_Rule_Lib.CStat) = Right (Right (Left x)) : ast_generic
	-fun put_CExtDecl (x : C_Grammar_Rule_Lib.CExtDecl) = Right (Left x) : ast_generic
	-fun put_CTranslUnit (x : C_Grammar_Rule_Lib.CTranslUnit) = Left x : ast_generic
	-
	+fun start_happy4 (x : start_happy) = case x of Right (Right (Right (Left x))) => SOME x \| _ => NONE
	+fun start_happy3 (x : start_happy) = case x of Right (Right (Left x)) => SOME x \| _ => NONE
	+fun start_happy2 (x : start_happy) = case x of Right (Left x) => SOME x \| _ => NONE
	+fun start_happy1 (x : start_happy) = case x of Left x => SOME x \| _ => NONE


	(#line 8775.1 "c_grammar_fun.grm.sml")
	datatype svalue0 = VOID \| ntVOID of unit \| clangcversion of (C_Ast.ClangCVersion) \| x5f_x5f_builtin_types_compatible_p of (string) \| x5f_x5f_builtin_offsetof of (string) \| x5f_x5f_builtin_va_arg of (string) \| x5f_x5f_imag_x5f_x5f of (string) \| x5f_x5f_real_x5f_x5f of (string) \| x5f_x5f_extension_x5f_x5f of (string) \| x5f_x5f_attribute_x5f_x5f of (string) \| tyident of (C_Ast.ident) \| ident of (C_Ast.ident) \| cstr of (C_Ast.cString) \| cfloat of (C_Ast.cFloat) \| cint of (C_Ast.cInteger) \| cchar of (C_Ast.cChar) \| while0 of (string) \| volatile of (string) \| void of (string) \| unsigned of (string) \| union of (string) \| x5f_x5f_thread of (string) \| typeof of (string) \| typedef of (string) \| switch of (string) \| struct0 of (string) \| x5f_Static_assert of (string) \| static of (string) \| sizeof of (string) \| signed of (string) \| short of (string) \| return0 of (string) \| restrict of (string) \| register of (string) \| x5f_Nonnull of (string) \| x5f_Nullable of (string) \| x5f_Noreturn of (string) \| x5f_x5f_label_x5f_x5f of (string) \| long of (string) \| x5f_x5f_int_x31_x32_x38 of (string) \| int of (string) \| inline of (string) \| if0 of (string) \| goto of (string) \| x5f_Generic of (string) \| for0 of (string) \| float of (string) \| extern of (string) \| enum of (string) \| else0 of (string) \| double of (string) \| do0 of (string) \| default of (string) \| x5f_Complex of (string) \| continue of (string) \| const of (string) \| char of (string) \| case0 of (string) \| x5f_Bool of (string) \| break of (string) \| auto of (string) \| asm of (string) \| x5f_Atomic of (string) \| alignas of (string) \| alignof of (string) \| x2e_x2e_x2e of (string) \| x7d of (string) \| x7b of (string) \| x3b of (string) \| x2c of (string) \| x3e_x3e_x3d of (string) \| x3c_x3c_x3d of (string) \| x7c_x3d of (string) \| x5e_x3d of (string) \| x26_x3d of (string) \| x25_x3d of (string) \| x2f_x3d of (string) \| x2a_x3d of (string) \| x2d_x3d of (string) \| x2b_x3d of (string) \| x3d of (string) \| x3a of (string) \| x3f of (string) \| x7c_x7c of (string) \| x26_x26 of (string) \| x7c of (string) \| x5e of (string) \| x21_x3d of (string) \| x3d_x3d of (string) \| x3e_x3d of (string) \| x3e of (string) \| x3c_x3d of (string) \| x3c of (string) \| x3e_x3e of (string) \| x3c_x3c of (string) \| x26 of (string) \| x25 of (string) \| x2f of (string) \| x2a of (string) \| x2d of (string) \| x2b of (string) \| x2d_x2d of (string) \| x2b_x2b of (string) \| x7e of (string) \| x21 of (string) \| x2e of (string) \| x2d_x3e of (string) \| x5d of (string) \| x5b of (string) \| x29 of (string) \| x28 of (string) \| attribute_params of ( ( CExpr list ) Reversed) \| attribute of (CAttr Maybe) \| attribute_list of ( ( CAttr list ) Reversed) \| attr of (CAttr list) \| attrs of (CAttr list) \| attrs_opt of (CAttr list) \| identifier of (Ident) \| clang_version_literal of (ClangCVersion) \| string_literal_list of ( ( CString list ) Reversed) \| string_literal of (CStrLit) \| constant of (CConst) \| constant_expression of (CExpr) \| assignment_expression_opt of (CExpr Maybe) \| expression_opt of (CExpr Maybe) \| comma_expression of ( ( CExpr list ) Reversed) \| expression of (CExpr) \| assignment_operator of (CAssignOp Located) \| assignment_expression of (CExpr) \| conditional_expression of (CExpr) \| logical_or_expression of (CExpr) \| logical_and_expression of (CExpr) \| inclusive_or_expression of (CExpr) \| exclusive_or_expression of (CExpr) \| and_expression of (CExpr) \| equality_expression of (CExpr) \| relational_expression of (CExpr) \| shift_expression of (CExpr) \| additive_expression of (CExpr) \| multiplicative_expression of (CExpr) \| cast_expression of (CExpr) \| unary_operator of (CUnaryOp Located) \| unary_expression of (CExpr) \| argument_expression_list of ( ( CExpr list ) Reversed) \| postfix_expression of (CExpr) \| offsetof_member_designator of ( ( CDesignator list ) Reversed) \| generic_assoc of ( ( CDecl Maybe * CExpr ) ) \| generic_assoc_list of ( ( ((CDecl Maybe * CExpr)) list ) Reversed) \| primary_expression of (CExpr) \| array_designator of (CDesignator) \| designator of (CDesignator) \| designator_list of ( ( CDesignator list ) Reversed) \| designation of (CDesignator list) \| initializer_list of (CInitList Reversed) \| initializer_opt of (CInit Maybe) \| initializer of (CInit) \| postfix_abstract_declarator of (CDeclrR) \| unary_abstract_declarator of (CDeclrR) \| postfix_array_abstract_declarator of ( ( CDeclrR -> CDeclrR ) ) \| array_abstract_declarator of ( ( CDeclrR -> CDeclrR ) ) \| postfixing_abstract_declarator of ( ( CDeclrR -> CDeclrR ) ) \| abstract_declarator of (CDeclrR) \| type_name of (CDecl) \| identifier_list of ( ( Ident list ) Reversed) \| parameter_declaration of (CDecl) \| parameter_list of ( ( CDecl list ) Reversed) \| parameter_type_list of ( ( CDecl list * Bool ) ) \| postfix_old_function_declarator of (CDeclrR) \| old_function_declarator of (CDeclrR) \| function_declarator_old of (CDeclr) \| paren_identifier_declarator of (CDeclrR) \| postfix_identifier_declarator of (CDeclrR) \| unary_identifier_declarator of (CDeclrR) \| identifier_declarator of (CDeclrR) \| simple_paren_typedef_declarator of (CDeclrR) \| paren_postfix_typedef_declarator of (CDeclrR) \| paren_typedef_declarator of (CDeclrR) \| clean_postfix_typedef_declarator of (CDeclrR) \| clean_typedef_declarator of (CDeclrR) \| parameter_typedef_declarator of (CDeclrR) \| typedef_declarator of (CDeclrR) \| asm_opt of (CStrLit Maybe) \| declarator of (CDeclrR) \| type_qualifier_list of ( ( CTypeQual list ) Reversed) \| type_qualifier of (CTypeQual) \| enumerator of ( ( Ident * CExpr Maybe ) ) \| enumerator_list of ( ( ((Ident * CExpr Maybe)) list ) Reversed) \| enum_specifier of (CEnum) \| struct_identifier_declarator of ( ( CDeclr Maybe * CExpr Maybe ) ) \| struct_declarator of ( ( CDeclr Maybe * CExpr Maybe ) ) \| struct_declaring_list of (CDecl) \| struct_default_declaring_list of (CDecl) \| struct_declaration of (CDecl) \| struct_declaration_list of ( ( CDecl list ) Reversed) \| struct_or_union of (CStructTag Located) \| struct_or_union_specifier of (CStructUnion) \| elaborated_type_name of (CTypeSpec) \| typedef_type_specifier of ( ( CDeclSpec list ) Reversed) \| typedef_declaration_specifier of ( ( CDeclSpec list ) Reversed) \| sue_type_specifier of ( ( CDeclSpec list ) Reversed) \| sue_declaration_specifier of ( ( CDeclSpec list ) Reversed) \| basic_type_specifier of ( ( CDeclSpec list ) Reversed) \| basic_declaration_specifier of ( ( CDeclSpec list ) Reversed) \| basic_type_name of (CTypeSpec) \| type_specifier of (CDeclSpec list) \| alignment_specifier of (CAlignSpec) \| function_specifier of (CFunSpec) \| storage_class of (CStorageSpec) \| declaration_qualifier_without_types of (CDeclSpec) \| declaration_qualifier of (CDeclSpec) \| declaration_qualifier_list of ( ( CDeclSpec list ) Reversed) \| declaration_specifier of (CDeclSpec list) \| declaring_list of (CDecl) \| asm_attrs_opt of ( ( CStrLit Maybe * CAttr list ) ) \| default_declaring_list of (CDecl) \| declaration_list of ( ( CDecl list ) Reversed) \| declaration of (CDecl) \| asm_clobbers of ( ( CStrLit list ) Reversed) \| asm_operand of (CAsmOperand) \| nonnull_asm_operands of ( ( CAsmOperand list ) Reversed) \| asm_operands of (CAsmOperand list) \| maybe_type_qualifier of (CTypeQual Maybe) \| asm_statement of (CAsmStmt) \| jump_statement of (CStat) \| iteration_statement of (CStat) \| selection_statement of (CStat) \| expression_statement of (CStat) \| label_declarations of ( ( Ident list ) Reversed) \| nested_function_definition of (CFunDef) \| nested_declaration of (CBlockItem) \| block_item of (CBlockItem) \| block_item_list of ( ( CBlockItem list ) Reversed) \| leave_scope of (unit) \| enter_scope of (unit) \| compound_statement of (CStat) \| labeled_statement of (CStat) \| statement of (CStat) \| function_declarator of (CDeclr) \| function_definition of (CFunDef) \| external_declaration of (CExtDecl) \| ext_decl_list of ( ( CExtDecl list ) Reversed) \| translation_unit of (CTranslUnit) \| start_happy of ( ( CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either ) either)
	fun find_list msg mk_name l =
	let val tab =
	fold (fn (name, occ) =>
	fold (fn name => fn (tab, nb) => (Inttab.update (nb, name) tab, nb + 1))
	(if occ = 1 then [name]
	else map_range (mk_name name) occ))
	l
	(Inttab.empty, 0)
	\|> #1
	in
	fn i => case Inttab.lookup tab i of NONE => error msg \| SOME name => name
	end
	val type_reduce = find_list "reduce type not found" K [
	(" ( ( CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either ) either)", 4),
	(" (CTranslUnit)", 1),
	(" ( ( CExtDecl list ) Reversed)", 3),
	(" (CExtDecl)", 4),
	(" (CFunDef)", 14),
	(" (CDeclr)", 1),
	(" (CStat)", 7),
	(" (CStat)", 4),
	(" (CStat)", 2),
	(" (unit)", 1),
	(" (unit)", 1),
	(" ( ( CBlockItem list ) Reversed)", 2),
	(" (CBlockItem)", 2),
	(" (CBlockItem)", 3),
	(" (CFunDef)", 5),
	(" ( ( Ident list ) Reversed)", 2),
	(" (CStat)", 2),
	(" (CStat)", 3),
	(" (CStat)", 4),
	(" (CStat)", 5),
	(" (CAsmStmt)", 4),
	(" (CTypeQual Maybe)", 2),
	(" (CAsmOperand list)", 2),
	(" ( ( CAsmOperand list ) Reversed)", 2),
	(" (CAsmOperand)", 3),
	(" ( ( CStrLit list ) Reversed)", 2),
	(" (CDecl)", 5),
	(" ( ( CDecl list ) Reversed)", 2),
	(" (CDecl)", 5),
	(" ( ( CStrLit Maybe * CAttr list ) )", 1),
	(" (CDecl)", 3),
	(" (CDeclSpec list)", 3),
	(" ( ( CDeclSpec list ) Reversed)", 6),
	(" (CDeclSpec)", 4),
	(" (CDeclSpec)", 3),
	(" (CStorageSpec)", 6),
	(" (CFunSpec)", 2),
	(" (CAlignSpec)", 2),
	(" (CDeclSpec list)", 3),
	(" (CTypeSpec)", 12),
	(" ( ( CDeclSpec list ) Reversed)", 5),
	(" ( ( CDeclSpec list ) Reversed)", 7),
	(" ( ( CDeclSpec list ) Reversed)", 4),
	(" ( ( CDeclSpec list ) Reversed)", 6),
	(" ( ( CDeclSpec list ) Reversed)", 6),
	(" ( ( CDeclSpec list ) Reversed)", 14),
	(" (CTypeSpec)", 2),
	(" (CStructUnion)", 3),
	(" (CStructTag Located)", 2),
	(" ( ( CDecl list ) Reversed)", 3),
	(" (CDecl)", 3),
	(" (CDecl)", 3),
	(" (CDecl)", 3),
	(" ( ( CDeclr Maybe * CExpr Maybe ) )", 3),
	(" ( ( CDeclr Maybe * CExpr Maybe ) )", 4),
	(" (CEnum)", 5),
	(" ( ( ((Ident * CExpr Maybe)) list ) Reversed)", 2),
	(" ( ( Ident * CExpr Maybe ) )", 4),
	(" (CTypeQual)", 6),
	(" ( ( CTypeQual list ) Reversed)", 3),
	(" (CDeclrR)", 2),
	(" (CStrLit Maybe)", 2),
	(" (CDeclrR)", 2),
	(" (CDeclrR)", 3),
	(" (CDeclrR)", 5),
	(" (CDeclrR)", 4),
	(" (CDeclrR)", 7),
	(" (CDeclrR)", 3),
	(" (CDeclrR)", 2),
	(" (CDeclrR)", 2),
	(" (CDeclrR)", 5),
	(" (CDeclrR)", 5),
	(" (CDeclrR)", 3),
	(" (CDeclr)", 1),
	(" (CDeclrR)", 3),
	(" (CDeclrR)", 3),
	(" ( ( CDecl list * Bool ) )", 3),
	(" ( ( CDecl list ) Reversed)", 2),
	(" (CDecl)", 15),
	(" ( ( Ident list ) Reversed)", 2),
	(" (CDecl)", 4),
	(" (CDeclrR)", 3),
	(" ( ( CDeclrR -> CDeclrR ) )", 2),
	(" ( ( CDeclrR -> CDeclrR ) )", 2),
	(" ( ( CDeclrR -> CDeclrR ) )", 11),
	(" (CDeclrR)", 6),
	(" (CDeclrR)", 9),
	(" (CInit)", 3),
	(" (CInit Maybe)", 2),
	(" (CInitList Reversed)", 5),
	(" (CDesignator list)", 3),
	(" ( ( CDesignator list ) Reversed)", 2),
	(" (CDesignator)", 3),
	(" (CDesignator)", 1),
	(" (CExpr)", 9),
	(" ( ( ((CDecl Maybe * CExpr)) list ) Reversed)", 2),
	(" ( ( CDecl Maybe * CExpr ) )", 2),
	(" ( ( CDesignator list ) Reversed)", 3),
	(" (CExpr)", 10),
	(" ( ( CExpr list ) Reversed)", 2),
	(" (CExpr)", 12),
	(" (CUnaryOp Located)", 6),
	(" (CExpr)", 2),
	(" (CExpr)", 4),
	(" (CExpr)", 3),
	(" (CExpr)", 3),
	(" (CExpr)", 5),
	(" (CExpr)", 3),
	(" (CExpr)", 2),
	(" (CExpr)", 2),
	(" (CExpr)", 2),
	(" (CExpr)", 2),
	(" (CExpr)", 2),
	(" (CExpr)", 3),
	(" (CExpr)", 2),
	(" (CAssignOp Located)", 11),
	(" (CExpr)", 2),
	(" ( ( CExpr list ) Reversed)", 2),
	(" (CExpr Maybe)", 2),
	(" (CExpr Maybe)", 2),
	(" (CExpr)", 1),
	(" (CConst)", 3),
	(" (CStrLit)", 2),
	(" ( ( CString list ) Reversed)", 2),
	(" (ClangCVersion)", 1),
	(" (Ident)", 2),
	(" (CAttr list)", 2),
	(" (CAttr list)", 2),
	(" (CAttr list)", 1),
	(" ( ( CAttr list ) Reversed)", 2),
	(" (CAttr Maybe)", 5),
	(" ( ( CExpr list ) Reversed)", 6),
	("", 0)]
	val string_reduce = find_list "reduce type not found" (fn name => fn occ => name ^ Int.toString (occ + 1)) [
	("start_happy", 4),
	("translation_unit", 1),
	("ext_decl_list", 3),
	("external_declaration", 4),
	("function_definition", 14),
	("function_declarator", 1),
	("statement", 7),
	("labeled_statement", 4),
	("compound_statement", 2),
	("enter_scope", 1),
	("leave_scope", 1),
	("block_item_list", 2),
	("block_item", 2),
	("nested_declaration", 3),
	("nested_function_definition", 5),
	("label_declarations", 2),
	("expression_statement", 2),
	("selection_statement", 3),
	("iteration_statement", 4),
	("jump_statement", 5),
	("asm_statement", 4),
	("maybe_type_qualifier", 2),
	("asm_operands", 2),
	("nonnull_asm_operands", 2),
	("asm_operand", 3),
	("asm_clobbers", 2),
	("declaration", 5),
	("declaration_list", 2),
	("default_declaring_list", 5),
	("asm_attrs_opt", 1),
	("declaring_list", 3),
	("declaration_specifier", 3),
	("declaration_qualifier_list", 6),
	("declaration_qualifier", 4),
	("declaration_qualifier_without_types", 3),
	("storage_class", 6),
	("function_specifier", 2),
	("alignment_specifier", 2),
	("type_specifier", 3),
	("basic_type_name", 12),
	("basic_declaration_specifier", 5),
	("basic_type_specifier", 7),
	("sue_declaration_specifier", 4),
	("sue_type_specifier", 6),
	("typedef_declaration_specifier", 6),
	("typedef_type_specifier", 14),
	("elaborated_type_name", 2),
	("struct_or_union_specifier", 3),
	("struct_or_union", 2),
	("struct_declaration_list", 3),
	("struct_declaration", 3),
	("struct_default_declaring_list", 3),
	("struct_declaring_list", 3),
	("struct_declarator", 3),
	("struct_identifier_declarator", 4),
	("enum_specifier", 5),
	("enumerator_list", 2),
	("enumerator", 4),
	("type_qualifier", 6),
	("type_qualifier_list", 3),
	("declarator", 2),
	("asm_opt", 2),
	("typedef_declarator", 2),
	("parameter_typedef_declarator", 3),
	("clean_typedef_declarator", 5),
	("clean_postfix_typedef_declarator", 4),
	("paren_typedef_declarator", 7),
	("paren_postfix_typedef_declarator", 3),
	("simple_paren_typedef_declarator", 2),
	("identifier_declarator", 2),
	("unary_identifier_declarator", 5),
	("postfix_identifier_declarator", 5),
	("paren_identifier_declarator", 3),
	("function_declarator_old", 1),
	("old_function_declarator", 3),
	("postfix_old_function_declarator", 3),
	("parameter_type_list", 3),
	("parameter_list", 2),
	("parameter_declaration", 15),
	("identifier_list", 2),
	("type_name", 4),
	("abstract_declarator", 3),
	("postfixing_abstract_declarator", 2),
	("array_abstract_declarator", 2),
	("postfix_array_abstract_declarator", 11),
	("unary_abstract_declarator", 6),
	("postfix_abstract_declarator", 9),
	("initializer", 3),
	("initializer_opt", 2),
	("initializer_list", 5),
	("designation", 3),
	("designator_list", 2),
	("designator", 3),
	("array_designator", 1),
	("primary_expression", 9),
	("generic_assoc_list", 2),
	("generic_assoc", 2),
	("offsetof_member_designator", 3),
	("postfix_expression", 10),
	("argument_expression_list", 2),
	("unary_expression", 12),
	("unary_operator", 6),
	("cast_expression", 2),
	("multiplicative_expression", 4),
	("additive_expression", 3),
	("shift_expression", 3),
	("relational_expression", 5),
	("equality_expression", 3),
	("and_expression", 2),
	("exclusive_or_expression", 2),
	("inclusive_or_expression", 2),
	("logical_and_expression", 2),
	("logical_or_expression", 2),
	("conditional_expression", 3),
	("assignment_expression", 2),
	("assignment_operator", 11),
	("expression", 2),
	("comma_expression", 2),
	("expression_opt", 2),
	("assignment_expression_opt", 2),
	("constant_expression", 1),
	("constant", 3),
	("string_literal", 2),
	("string_literal_list", 2),
	("clang_version_literal", 1),
	("identifier", 2),
	("attrs_opt", 2),
	("attrs", 2),
	("attr", 1),
	("attribute_list", 2),
	("attribute", 5),
	("attribute_params", 6),
	("", 0)]
	val reduce0 = fn start_happy x => x \| _ => error "Only expecting start_happy"
	val reduce1 = fn start_happy x => x \| _ => error "Only expecting start_happy"
	val reduce2 = fn start_happy x => x \| _ => error "Only expecting start_happy"
	val reduce3 = fn start_happy x => x \| _ => error "Only expecting start_happy"
	val reduce4 = fn translation_unit x => x \| _ => error "Only expecting translation_unit"
	val reduce5 = fn ext_decl_list x => x \| _ => error "Only expecting ext_decl_list"
	val reduce6 = fn ext_decl_list x => x \| _ => error "Only expecting ext_decl_list"
	val reduce7 = fn ext_decl_list x => x \| _ => error "Only expecting ext_decl_list"
	val reduce8 = fn external_declaration x => x \| _ => error "Only expecting external_declaration"
	val reduce9 = fn external_declaration x => x \| _ => error "Only expecting external_declaration"
	val reduce10 = fn external_declaration x => x \| _ => error "Only expecting external_declaration"
	val reduce11 = fn external_declaration x => x \| _ => error "Only expecting external_declaration"
	val reduce12 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce13 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce14 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce15 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce16 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce17 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce18 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce19 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce20 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce21 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce22 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce23 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce24 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce25 = fn function_definition x => x \| _ => error "Only expecting function_definition"
	val reduce26 = fn function_declarator x => x \| _ => error "Only expecting function_declarator"
	val reduce27 = fn statement x => x \| _ => error "Only expecting statement"
	val reduce28 = fn statement x => x \| _ => error "Only expecting statement"
	val reduce29 = fn statement x => x \| _ => error "Only expecting statement"
	val reduce30 = fn statement x => x \| _ => error "Only expecting statement"
	val reduce31 = fn statement x => x \| _ => error "Only expecting statement"
	val reduce32 = fn statement x => x \| _ => error "Only expecting statement"
	val reduce33 = fn statement x => x \| _ => error "Only expecting statement"
	val reduce34 = fn labeled_statement x => x \| _ => error "Only expecting labeled_statement"
	val reduce35 = fn labeled_statement x => x \| _ => error "Only expecting labeled_statement"
	val reduce36 = fn labeled_statement x => x \| _ => error "Only expecting labeled_statement"
	val reduce37 = fn labeled_statement x => x \| _ => error "Only expecting labeled_statement"
	val reduce38 = fn compound_statement x => x \| _ => error "Only expecting compound_statement"
	val reduce39 = fn compound_statement x => x \| _ => error "Only expecting compound_statement"
	val reduce40 = fn enter_scope x => x \| _ => error "Only expecting enter_scope"
	val reduce41 = fn leave_scope x => x \| _ => error "Only expecting leave_scope"
	val reduce42 = fn block_item_list x => x \| _ => error "Only expecting block_item_list"
	val reduce43 = fn block_item_list x => x \| _ => error "Only expecting block_item_list"
	val reduce44 = fn block_item x => x \| _ => error "Only expecting block_item"
	val reduce45 = fn block_item x => x \| _ => error "Only expecting block_item"
	val reduce46 = fn nested_declaration x => x \| _ => error "Only expecting nested_declaration"
	val reduce47 = fn nested_declaration x => x \| _ => error "Only expecting nested_declaration"
	val reduce48 = fn nested_declaration x => x \| _ => error "Only expecting nested_declaration"
	val reduce49 = fn nested_function_definition x => x \| _ => error "Only expecting nested_function_definition"
	val reduce50 = fn nested_function_definition x => x \| _ => error "Only expecting nested_function_definition"
	val reduce51 = fn nested_function_definition x => x \| _ => error "Only expecting nested_function_definition"
	val reduce52 = fn nested_function_definition x => x \| _ => error "Only expecting nested_function_definition"
	val reduce53 = fn nested_function_definition x => x \| _ => error "Only expecting nested_function_definition"
	val reduce54 = fn label_declarations x => x \| _ => error "Only expecting label_declarations"
	val reduce55 = fn label_declarations x => x \| _ => error "Only expecting label_declarations"
	val reduce56 = fn expression_statement x => x \| _ => error "Only expecting expression_statement"
	val reduce57 = fn expression_statement x => x \| _ => error "Only expecting expression_statement"
	val reduce58 = fn selection_statement x => x \| _ => error "Only expecting selection_statement"
	val reduce59 = fn selection_statement x => x \| _ => error "Only expecting selection_statement"
	val reduce60 = fn selection_statement x => x \| _ => error "Only expecting selection_statement"
	val reduce61 = fn iteration_statement x => x \| _ => error "Only expecting iteration_statement"
	val reduce62 = fn iteration_statement x => x \| _ => error "Only expecting iteration_statement"
	val reduce63 = fn iteration_statement x => x \| _ => error "Only expecting iteration_statement"
	val reduce64 = fn iteration_statement x => x \| _ => error "Only expecting iteration_statement"
	val reduce65 = fn jump_statement x => x \| _ => error "Only expecting jump_statement"
	val reduce66 = fn jump_statement x => x \| _ => error "Only expecting jump_statement"
	val reduce67 = fn jump_statement x => x \| _ => error "Only expecting jump_statement"
	val reduce68 = fn jump_statement x => x \| _ => error "Only expecting jump_statement"
	val reduce69 = fn jump_statement x => x \| _ => error "Only expecting jump_statement"
	val reduce70 = fn asm_statement x => x \| _ => error "Only expecting asm_statement"
	val reduce71 = fn asm_statement x => x \| _ => error "Only expecting asm_statement"
	val reduce72 = fn asm_statement x => x \| _ => error "Only expecting asm_statement"
	val reduce73 = fn asm_statement x => x \| _ => error "Only expecting asm_statement"
	val reduce74 = fn maybe_type_qualifier x => x \| _ => error "Only expecting maybe_type_qualifier"
	val reduce75 = fn maybe_type_qualifier x => x \| _ => error "Only expecting maybe_type_qualifier"
	val reduce76 = fn asm_operands x => x \| _ => error "Only expecting asm_operands"
	val reduce77 = fn asm_operands x => x \| _ => error "Only expecting asm_operands"
	val reduce78 = fn nonnull_asm_operands x => x \| _ => error "Only expecting nonnull_asm_operands"
	val reduce79 = fn nonnull_asm_operands x => x \| _ => error "Only expecting nonnull_asm_operands"
	val reduce80 = fn asm_operand x => x \| _ => error "Only expecting asm_operand"
	val reduce81 = fn asm_operand x => x \| _ => error "Only expecting asm_operand"
	val reduce82 = fn asm_operand x => x \| _ => error "Only expecting asm_operand"
	val reduce83 = fn asm_clobbers x => x \| _ => error "Only expecting asm_clobbers"
	val reduce84 = fn asm_clobbers x => x \| _ => error "Only expecting asm_clobbers"
	val reduce85 = fn declaration x => x \| _ => error "Only expecting declaration"
	val reduce86 = fn declaration x => x \| _ => error "Only expecting declaration"
	val reduce87 = fn declaration x => x \| _ => error "Only expecting declaration"
	val reduce88 = fn declaration x => x \| _ => error "Only expecting declaration"
	val reduce89 = fn declaration x => x \| _ => error "Only expecting declaration"
	val reduce90 = fn declaration_list x => x \| _ => error "Only expecting declaration_list"
	val reduce91 = fn declaration_list x => x \| _ => error "Only expecting declaration_list"
	val reduce92 = fn default_declaring_list x => x \| _ => error "Only expecting default_declaring_list"
	val reduce93 = fn default_declaring_list x => x \| _ => error "Only expecting default_declaring_list"
	val reduce94 = fn default_declaring_list x => x \| _ => error "Only expecting default_declaring_list"
	val reduce95 = fn default_declaring_list x => x \| _ => error "Only expecting default_declaring_list"
	val reduce96 = fn default_declaring_list x => x \| _ => error "Only expecting default_declaring_list"
	val reduce97 = fn asm_attrs_opt x => x \| _ => error "Only expecting asm_attrs_opt"
	val reduce98 = fn declaring_list x => x \| _ => error "Only expecting declaring_list"
	val reduce99 = fn declaring_list x => x \| _ => error "Only expecting declaring_list"
	val reduce100 = fn declaring_list x => x \| _ => error "Only expecting declaring_list"
	val reduce101 = fn declaration_specifier x => x \| _ => error "Only expecting declaration_specifier"
	val reduce102 = fn declaration_specifier x => x \| _ => error "Only expecting declaration_specifier"
	val reduce103 = fn declaration_specifier x => x \| _ => error "Only expecting declaration_specifier"
	val reduce104 = fn declaration_qualifier_list x => x \| _ => error "Only expecting declaration_qualifier_list"
	val reduce105 = fn declaration_qualifier_list x => x \| _ => error "Only expecting declaration_qualifier_list"
	val reduce106 = fn declaration_qualifier_list x => x \| _ => error "Only expecting declaration_qualifier_list"
	val reduce107 = fn declaration_qualifier_list x => x \| _ => error "Only expecting declaration_qualifier_list"
	val reduce108 = fn declaration_qualifier_list x => x \| _ => error "Only expecting declaration_qualifier_list"
	val reduce109 = fn declaration_qualifier_list x => x \| _ => error "Only expecting declaration_qualifier_list"
	val reduce110 = fn declaration_qualifier x => x \| _ => error "Only expecting declaration_qualifier"
	val reduce111 = fn declaration_qualifier x => x \| _ => error "Only expecting declaration_qualifier"
	val reduce112 = fn declaration_qualifier x => x \| _ => error "Only expecting declaration_qualifier"
	val reduce113 = fn declaration_qualifier x => x \| _ => error "Only expecting declaration_qualifier"
	val reduce114 = fn declaration_qualifier_without_types x => x \| _ => error "Only expecting declaration_qualifier_without_types"
	val reduce115 = fn declaration_qualifier_without_types x => x \| _ => error "Only expecting declaration_qualifier_without_types"
	val reduce116 = fn declaration_qualifier_without_types x => x \| _ => error "Only expecting declaration_qualifier_without_types"
	val reduce117 = fn storage_class x => x \| _ => error "Only expecting storage_class"
	val reduce118 = fn storage_class x => x \| _ => error "Only expecting storage_class"
	val reduce119 = fn storage_class x => x \| _ => error "Only expecting storage_class"
	val reduce120 = fn storage_class x => x \| _ => error "Only expecting storage_class"
	val reduce121 = fn storage_class x => x \| _ => error "Only expecting storage_class"
	val reduce122 = fn storage_class x => x \| _ => error "Only expecting storage_class"
	val reduce123 = fn function_specifier x => x \| _ => error "Only expecting function_specifier"
	val reduce124 = fn function_specifier x => x \| _ => error "Only expecting function_specifier"
	val reduce125 = fn alignment_specifier x => x \| _ => error "Only expecting alignment_specifier"
	val reduce126 = fn alignment_specifier x => x \| _ => error "Only expecting alignment_specifier"
	val reduce127 = fn type_specifier x => x \| _ => error "Only expecting type_specifier"
	val reduce128 = fn type_specifier x => x \| _ => error "Only expecting type_specifier"
	val reduce129 = fn type_specifier x => x \| _ => error "Only expecting type_specifier"
	val reduce130 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce131 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce132 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce133 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce134 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce135 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce136 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce137 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce138 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce139 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce140 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce141 = fn basic_type_name x => x \| _ => error "Only expecting basic_type_name"
	val reduce142 = fn basic_declaration_specifier x => x \| _ => error "Only expecting basic_declaration_specifier"
	val reduce143 = fn basic_declaration_specifier x => x \| _ => error "Only expecting basic_declaration_specifier"
	val reduce144 = fn basic_declaration_specifier x => x \| _ => error "Only expecting basic_declaration_specifier"
	val reduce145 = fn basic_declaration_specifier x => x \| _ => error "Only expecting basic_declaration_specifier"
	val reduce146 = fn basic_declaration_specifier x => x \| _ => error "Only expecting basic_declaration_specifier"
	val reduce147 = fn basic_type_specifier x => x \| _ => error "Only expecting basic_type_specifier"
	val reduce148 = fn basic_type_specifier x => x \| _ => error "Only expecting basic_type_specifier"
	val reduce149 = fn basic_type_specifier x => x \| _ => error "Only expecting basic_type_specifier"
	val reduce150 = fn basic_type_specifier x => x \| _ => error "Only expecting basic_type_specifier"
	val reduce151 = fn basic_type_specifier x => x \| _ => error "Only expecting basic_type_specifier"
	val reduce152 = fn basic_type_specifier x => x \| _ => error "Only expecting basic_type_specifier"
	val reduce153 = fn basic_type_specifier x => x \| _ => error "Only expecting basic_type_specifier"
	val reduce154 = fn sue_declaration_specifier x => x \| _ => error "Only expecting sue_declaration_specifier"
	val reduce155 = fn sue_declaration_specifier x => x \| _ => error "Only expecting sue_declaration_specifier"
	val reduce156 = fn sue_declaration_specifier x => x \| _ => error "Only expecting sue_declaration_specifier"
	val reduce157 = fn sue_declaration_specifier x => x \| _ => error "Only expecting sue_declaration_specifier"
	val reduce158 = fn sue_type_specifier x => x \| _ => error "Only expecting sue_type_specifier"
	val reduce159 = fn sue_type_specifier x => x \| _ => error "Only expecting sue_type_specifier"
	val reduce160 = fn sue_type_specifier x => x \| _ => error "Only expecting sue_type_specifier"
	val reduce161 = fn sue_type_specifier x => x \| _ => error "Only expecting sue_type_specifier"
	val reduce162 = fn sue_type_specifier x => x \| _ => error "Only expecting sue_type_specifier"
	val reduce163 = fn sue_type_specifier x => x \| _ => error "Only expecting sue_type_specifier"
	val reduce164 = fn typedef_declaration_specifier x => x \| _ => error "Only expecting typedef_declaration_specifier"
	val reduce165 = fn typedef_declaration_specifier x => x \| _ => error "Only expecting typedef_declaration_specifier"
	val reduce166 = fn typedef_declaration_specifier x => x \| _ => error "Only expecting typedef_declaration_specifier"
	val reduce167 = fn typedef_declaration_specifier x => x \| _ => error "Only expecting typedef_declaration_specifier"
	val reduce168 = fn typedef_declaration_specifier x => x \| _ => error "Only expecting typedef_declaration_specifier"
	val reduce169 = fn typedef_declaration_specifier x => x \| _ => error "Only expecting typedef_declaration_specifier"
	val reduce170 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce171 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce172 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce173 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce174 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce175 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce176 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce177 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce178 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce179 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce180 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce181 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce182 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce183 = fn typedef_type_specifier x => x \| _ => error "Only expecting typedef_type_specifier"
	val reduce184 = fn elaborated_type_name x => x \| _ => error "Only expecting elaborated_type_name"
	val reduce185 = fn elaborated_type_name x => x \| _ => error "Only expecting elaborated_type_name"
	val reduce186 = fn struct_or_union_specifier x => x \| _ => error "Only expecting struct_or_union_specifier"
	val reduce187 = fn struct_or_union_specifier x => x \| _ => error "Only expecting struct_or_union_specifier"
	val reduce188 = fn struct_or_union_specifier x => x \| _ => error "Only expecting struct_or_union_specifier"
	val reduce189 = fn struct_or_union x => x \| _ => error "Only expecting struct_or_union"
	val reduce190 = fn struct_or_union x => x \| _ => error "Only expecting struct_or_union"
	val reduce191 = fn struct_declaration_list x => x \| _ => error "Only expecting struct_declaration_list"
	val reduce192 = fn struct_declaration_list x => x \| _ => error "Only expecting struct_declaration_list"
	val reduce193 = fn struct_declaration_list x => x \| _ => error "Only expecting struct_declaration_list"
	val reduce194 = fn struct_declaration x => x \| _ => error "Only expecting struct_declaration"
	val reduce195 = fn struct_declaration x => x \| _ => error "Only expecting struct_declaration"
	val reduce196 = fn struct_declaration x => x \| _ => error "Only expecting struct_declaration"
	val reduce197 = fn struct_default_declaring_list x => x \| _ => error "Only expecting struct_default_declaring_list"
	val reduce198 = fn struct_default_declaring_list x => x \| _ => error "Only expecting struct_default_declaring_list"
	val reduce199 = fn struct_default_declaring_list x => x \| _ => error "Only expecting struct_default_declaring_list"
	val reduce200 = fn struct_declaring_list x => x \| _ => error "Only expecting struct_declaring_list"
	val reduce201 = fn struct_declaring_list x => x \| _ => error "Only expecting struct_declaring_list"
	val reduce202 = fn struct_declaring_list x => x \| _ => error "Only expecting struct_declaring_list"
	val reduce203 = fn struct_declarator x => x \| _ => error "Only expecting struct_declarator"
	val reduce204 = fn struct_declarator x => x \| _ => error "Only expecting struct_declarator"
	val reduce205 = fn struct_declarator x => x \| _ => error "Only expecting struct_declarator"
	val reduce206 = fn struct_identifier_declarator x => x \| _ => error "Only expecting struct_identifier_declarator"
	val reduce207 = fn struct_identifier_declarator x => x \| _ => error "Only expecting struct_identifier_declarator"
	val reduce208 = fn struct_identifier_declarator x => x \| _ => error "Only expecting struct_identifier_declarator"
	val reduce209 = fn struct_identifier_declarator x => x \| _ => error "Only expecting struct_identifier_declarator"
	val reduce210 = fn enum_specifier x => x \| _ => error "Only expecting enum_specifier"
	val reduce211 = fn enum_specifier x => x \| _ => error "Only expecting enum_specifier"
	val reduce212 = fn enum_specifier x => x \| _ => error "Only expecting enum_specifier"
	val reduce213 = fn enum_specifier x => x \| _ => error "Only expecting enum_specifier"
	val reduce214 = fn enum_specifier x => x \| _ => error "Only expecting enum_specifier"
	val reduce215 = fn enumerator_list x => x \| _ => error "Only expecting enumerator_list"
	val reduce216 = fn enumerator_list x => x \| _ => error "Only expecting enumerator_list"
	val reduce217 = fn enumerator x => x \| _ => error "Only expecting enumerator"
	val reduce218 = fn enumerator x => x \| _ => error "Only expecting enumerator"
	val reduce219 = fn enumerator x => x \| _ => error "Only expecting enumerator"
	val reduce220 = fn enumerator x => x \| _ => error "Only expecting enumerator"
	val reduce221 = fn type_qualifier x => x \| _ => error "Only expecting type_qualifier"
	val reduce222 = fn type_qualifier x => x \| _ => error "Only expecting type_qualifier"
	val reduce223 = fn type_qualifier x => x \| _ => error "Only expecting type_qualifier"
	val reduce224 = fn type_qualifier x => x \| _ => error "Only expecting type_qualifier"
	val reduce225 = fn type_qualifier x => x \| _ => error "Only expecting type_qualifier"
	val reduce226 = fn type_qualifier x => x \| _ => error "Only expecting type_qualifier"
	val reduce227 = fn type_qualifier_list x => x \| _ => error "Only expecting type_qualifier_list"
	val reduce228 = fn type_qualifier_list x => x \| _ => error "Only expecting type_qualifier_list"
	val reduce229 = fn type_qualifier_list x => x \| _ => error "Only expecting type_qualifier_list"
	val reduce230 = fn declarator x => x \| _ => error "Only expecting declarator"
	val reduce231 = fn declarator x => x \| _ => error "Only expecting declarator"
	val reduce232 = fn asm_opt x => x \| _ => error "Only expecting asm_opt"
	val reduce233 = fn asm_opt x => x \| _ => error "Only expecting asm_opt"
	val reduce234 = fn typedef_declarator x => x \| _ => error "Only expecting typedef_declarator"
	val reduce235 = fn typedef_declarator x => x \| _ => error "Only expecting typedef_declarator"
	val reduce236 = fn parameter_typedef_declarator x => x \| _ => error "Only expecting parameter_typedef_declarator"
	val reduce237 = fn parameter_typedef_declarator x => x \| _ => error "Only expecting parameter_typedef_declarator"
	val reduce238 = fn parameter_typedef_declarator x => x \| _ => error "Only expecting parameter_typedef_declarator"
	val reduce239 = fn clean_typedef_declarator x => x \| _ => error "Only expecting clean_typedef_declarator"
	val reduce240 = fn clean_typedef_declarator x => x \| _ => error "Only expecting clean_typedef_declarator"
	val reduce241 = fn clean_typedef_declarator x => x \| _ => error "Only expecting clean_typedef_declarator"
	val reduce242 = fn clean_typedef_declarator x => x \| _ => error "Only expecting clean_typedef_declarator"
	val reduce243 = fn clean_typedef_declarator x => x \| _ => error "Only expecting clean_typedef_declarator"
	val reduce244 = fn clean_postfix_typedef_declarator x => x \| _ => error "Only expecting clean_postfix_typedef_declarator"
	val reduce245 = fn clean_postfix_typedef_declarator x => x \| _ => error "Only expecting clean_postfix_typedef_declarator"
	val reduce246 = fn clean_postfix_typedef_declarator x => x \| _ => error "Only expecting clean_postfix_typedef_declarator"
	val reduce247 = fn clean_postfix_typedef_declarator x => x \| _ => error "Only expecting clean_postfix_typedef_declarator"
	val reduce248 = fn paren_typedef_declarator x => x \| _ => error "Only expecting paren_typedef_declarator"
	val reduce249 = fn paren_typedef_declarator x => x \| _ => error "Only expecting paren_typedef_declarator"
	val reduce250 = fn paren_typedef_declarator x => x \| _ => error "Only expecting paren_typedef_declarator"
	val reduce251 = fn paren_typedef_declarator x => x \| _ => error "Only expecting paren_typedef_declarator"
	val reduce252 = fn paren_typedef_declarator x => x \| _ => error "Only expecting paren_typedef_declarator"
	val reduce253 = fn paren_typedef_declarator x => x \| _ => error "Only expecting paren_typedef_declarator"
	val reduce254 = fn paren_typedef_declarator x => x \| _ => error "Only expecting paren_typedef_declarator"
	val reduce255 = fn paren_postfix_typedef_declarator x => x \| _ => error "Only expecting paren_postfix_typedef_declarator"
	val reduce256 = fn paren_postfix_typedef_declarator x => x \| _ => error "Only expecting paren_postfix_typedef_declarator"
	val reduce257 = fn paren_postfix_typedef_declarator x => x \| _ => error "Only expecting paren_postfix_typedef_declarator"
	val reduce258 = fn simple_paren_typedef_declarator x => x \| _ => error "Only expecting simple_paren_typedef_declarator"
	val reduce259 = fn simple_paren_typedef_declarator x => x \| _ => error "Only expecting simple_paren_typedef_declarator"
	val reduce260 = fn identifier_declarator x => x \| _ => error "Only expecting identifier_declarator"
	val reduce261 = fn identifier_declarator x => x \| _ => error "Only expecting identifier_declarator"
	val reduce262 = fn unary_identifier_declarator x => x \| _ => error "Only expecting unary_identifier_declarator"
	val reduce263 = fn unary_identifier_declarator x => x \| _ => error "Only expecting unary_identifier_declarator"
	val reduce264 = fn unary_identifier_declarator x => x \| _ => error "Only expecting unary_identifier_declarator"
	val reduce265 = fn unary_identifier_declarator x => x \| _ => error "Only expecting unary_identifier_declarator"
	val reduce266 = fn unary_identifier_declarator x => x \| _ => error "Only expecting unary_identifier_declarator"
	val reduce267 = fn postfix_identifier_declarator x => x \| _ => error "Only expecting postfix_identifier_declarator"
	val reduce268 = fn postfix_identifier_declarator x => x \| _ => error "Only expecting postfix_identifier_declarator"
	val reduce269 = fn postfix_identifier_declarator x => x \| _ => error "Only expecting postfix_identifier_declarator"
	val reduce270 = fn postfix_identifier_declarator x => x \| _ => error "Only expecting postfix_identifier_declarator"
	val reduce271 = fn postfix_identifier_declarator x => x \| _ => error "Only expecting postfix_identifier_declarator"
	val reduce272 = fn paren_identifier_declarator x => x \| _ => error "Only expecting paren_identifier_declarator"
	val reduce273 = fn paren_identifier_declarator x => x \| _ => error "Only expecting paren_identifier_declarator"
	val reduce274 = fn paren_identifier_declarator x => x \| _ => error "Only expecting paren_identifier_declarator"
	val reduce275 = fn function_declarator_old x => x \| _ => error "Only expecting function_declarator_old"
	val reduce276 = fn old_function_declarator x => x \| _ => error "Only expecting old_function_declarator"
	val reduce277 = fn old_function_declarator x => x \| _ => error "Only expecting old_function_declarator"
	val reduce278 = fn old_function_declarator x => x \| _ => error "Only expecting old_function_declarator"
	val reduce279 = fn postfix_old_function_declarator x => x \| _ => error "Only expecting postfix_old_function_declarator"
	val reduce280 = fn postfix_old_function_declarator x => x \| _ => error "Only expecting postfix_old_function_declarator"
	val reduce281 = fn postfix_old_function_declarator x => x \| _ => error "Only expecting postfix_old_function_declarator"
	val reduce282 = fn parameter_type_list x => x \| _ => error "Only expecting parameter_type_list"
	val reduce283 = fn parameter_type_list x => x \| _ => error "Only expecting parameter_type_list"
	val reduce284 = fn parameter_type_list x => x \| _ => error "Only expecting parameter_type_list"
	val reduce285 = fn parameter_list x => x \| _ => error "Only expecting parameter_list"
	val reduce286 = fn parameter_list x => x \| _ => error "Only expecting parameter_list"
	val reduce287 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce288 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce289 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce290 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce291 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce292 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce293 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce294 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce295 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce296 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce297 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce298 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce299 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce300 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce301 = fn parameter_declaration x => x \| _ => error "Only expecting parameter_declaration"
	val reduce302 = fn identifier_list x => x \| _ => error "Only expecting identifier_list"
	val reduce303 = fn identifier_list x => x \| _ => error "Only expecting identifier_list"
	val reduce304 = fn type_name x => x \| _ => error "Only expecting type_name"
	val reduce305 = fn type_name x => x \| _ => error "Only expecting type_name"
	val reduce306 = fn type_name x => x \| _ => error "Only expecting type_name"
	val reduce307 = fn type_name x => x \| _ => error "Only expecting type_name"
	val reduce308 = fn abstract_declarator x => x \| _ => error "Only expecting abstract_declarator"
	val reduce309 = fn abstract_declarator x => x \| _ => error "Only expecting abstract_declarator"
	val reduce310 = fn abstract_declarator x => x \| _ => error "Only expecting abstract_declarator"
	val reduce311 = fn postfixing_abstract_declarator x => x \| _ => error "Only expecting postfixing_abstract_declarator"
	val reduce312 = fn postfixing_abstract_declarator x => x \| _ => error "Only expecting postfixing_abstract_declarator"
	val reduce313 = fn array_abstract_declarator x => x \| _ => error "Only expecting array_abstract_declarator"
	val reduce314 = fn array_abstract_declarator x => x \| _ => error "Only expecting array_abstract_declarator"
	val reduce315 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce316 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce317 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce318 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce319 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce320 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce321 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce322 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce323 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce324 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce325 = fn postfix_array_abstract_declarator x => x \| _ => error "Only expecting postfix_array_abstract_declarator"
	val reduce326 = fn unary_abstract_declarator x => x \| _ => error "Only expecting unary_abstract_declarator"
	val reduce327 = fn unary_abstract_declarator x => x \| _ => error "Only expecting unary_abstract_declarator"
	val reduce328 = fn unary_abstract_declarator x => x \| _ => error "Only expecting unary_abstract_declarator"
	val reduce329 = fn unary_abstract_declarator x => x \| _ => error "Only expecting unary_abstract_declarator"
	val reduce330 = fn unary_abstract_declarator x => x \| _ => error "Only expecting unary_abstract_declarator"
	val reduce331 = fn unary_abstract_declarator x => x \| _ => error "Only expecting unary_abstract_declarator"
	val reduce332 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce333 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce334 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce335 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce336 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce337 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce338 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce339 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce340 = fn postfix_abstract_declarator x => x \| _ => error "Only expecting postfix_abstract_declarator"
	val reduce341 = fn initializer x => x \| _ => error "Only expecting initializer"
	val reduce342 = fn initializer x => x \| _ => error "Only expecting initializer"
	val reduce343 = fn initializer x => x \| _ => error "Only expecting initializer"
	val reduce344 = fn initializer_opt x => x \| _ => error "Only expecting initializer_opt"
	val reduce345 = fn initializer_opt x => x \| _ => error "Only expecting initializer_opt"
	val reduce346 = fn initializer_list x => x \| _ => error "Only expecting initializer_list"
	val reduce347 = fn initializer_list x => x \| _ => error "Only expecting initializer_list"
	val reduce348 = fn initializer_list x => x \| _ => error "Only expecting initializer_list"
	val reduce349 = fn initializer_list x => x \| _ => error "Only expecting initializer_list"
	val reduce350 = fn initializer_list x => x \| _ => error "Only expecting initializer_list"
	val reduce351 = fn designation x => x \| _ => error "Only expecting designation"
	val reduce352 = fn designation x => x \| _ => error "Only expecting designation"
	val reduce353 = fn designation x => x \| _ => error "Only expecting designation"
	val reduce354 = fn designator_list x => x \| _ => error "Only expecting designator_list"
	val reduce355 = fn designator_list x => x \| _ => error "Only expecting designator_list"
	val reduce356 = fn designator x => x \| _ => error "Only expecting designator"
	val reduce357 = fn designator x => x \| _ => error "Only expecting designator"
	val reduce358 = fn designator x => x \| _ => error "Only expecting designator"
	val reduce359 = fn array_designator x => x \| _ => error "Only expecting array_designator"
	val reduce360 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce361 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce362 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce363 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce364 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce365 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce366 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce367 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce368 = fn primary_expression x => x \| _ => error "Only expecting primary_expression"
	val reduce369 = fn generic_assoc_list x => x \| _ => error "Only expecting generic_assoc_list"
	val reduce370 = fn generic_assoc_list x => x \| _ => error "Only expecting generic_assoc_list"
	val reduce371 = fn generic_assoc x => x \| _ => error "Only expecting generic_assoc"
	val reduce372 = fn generic_assoc x => x \| _ => error "Only expecting generic_assoc"
	val reduce373 = fn offsetof_member_designator x => x \| _ => error "Only expecting offsetof_member_designator"
	val reduce374 = fn offsetof_member_designator x => x \| _ => error "Only expecting offsetof_member_designator"
	val reduce375 = fn offsetof_member_designator x => x \| _ => error "Only expecting offsetof_member_designator"
	val reduce376 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce377 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce378 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce379 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce380 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce381 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce382 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce383 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce384 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce385 = fn postfix_expression x => x \| _ => error "Only expecting postfix_expression"
	val reduce386 = fn argument_expression_list x => x \| _ => error "Only expecting argument_expression_list"
	val reduce387 = fn argument_expression_list x => x \| _ => error "Only expecting argument_expression_list"
	val reduce388 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce389 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce390 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce391 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce392 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce393 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce394 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce395 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce396 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce397 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce398 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce399 = fn unary_expression x => x \| _ => error "Only expecting unary_expression"
	val reduce400 = fn unary_operator x => x \| _ => error "Only expecting unary_operator"
	val reduce401 = fn unary_operator x => x \| _ => error "Only expecting unary_operator"
	val reduce402 = fn unary_operator x => x \| _ => error "Only expecting unary_operator"
	val reduce403 = fn unary_operator x => x \| _ => error "Only expecting unary_operator"
	val reduce404 = fn unary_operator x => x \| _ => error "Only expecting unary_operator"
	val reduce405 = fn unary_operator x => x \| _ => error "Only expecting unary_operator"
	val reduce406 = fn cast_expression x => x \| _ => error "Only expecting cast_expression"
	val reduce407 = fn cast_expression x => x \| _ => error "Only expecting cast_expression"
	val reduce408 = fn multiplicative_expression x => x \| _ => error "Only expecting multiplicative_expression"
	val reduce409 = fn multiplicative_expression x => x \| _ => error "Only expecting multiplicative_expression"
	val reduce410 = fn multiplicative_expression x => x \| _ => error "Only expecting multiplicative_expression"
	val reduce411 = fn multiplicative_expression x => x \| _ => error "Only expecting multiplicative_expression"
	val reduce412 = fn additive_expression x => x \| _ => error "Only expecting additive_expression"
	val reduce413 = fn additive_expression x => x \| _ => error "Only expecting additive_expression"
	val reduce414 = fn additive_expression x => x \| _ => error "Only expecting additive_expression"
	val reduce415 = fn shift_expression x => x \| _ => error "Only expecting shift_expression"
	val reduce416 = fn shift_expression x => x \| _ => error "Only expecting shift_expression"
	val reduce417 = fn shift_expression x => x \| _ => error "Only expecting shift_expression"
	val reduce418 = fn relational_expression x => x \| _ => error "Only expecting relational_expression"
	val reduce419 = fn relational_expression x => x \| _ => error "Only expecting relational_expression"
	val reduce420 = fn relational_expression x => x \| _ => error "Only expecting relational_expression"
	val reduce421 = fn relational_expression x => x \| _ => error "Only expecting relational_expression"
	val reduce422 = fn relational_expression x => x \| _ => error "Only expecting relational_expression"
	val reduce423 = fn equality_expression x => x \| _ => error "Only expecting equality_expression"
	val reduce424 = fn equality_expression x => x \| _ => error "Only expecting equality_expression"
	val reduce425 = fn equality_expression x => x \| _ => error "Only expecting equality_expression"
	val reduce426 = fn and_expression x => x \| _ => error "Only expecting and_expression"
	val reduce427 = fn and_expression x => x \| _ => error "Only expecting and_expression"
	val reduce428 = fn exclusive_or_expression x => x \| _ => error "Only expecting exclusive_or_expression"
	val reduce429 = fn exclusive_or_expression x => x \| _ => error "Only expecting exclusive_or_expression"
	val reduce430 = fn inclusive_or_expression x => x \| _ => error "Only expecting inclusive_or_expression"
	val reduce431 = fn inclusive_or_expression x => x \| _ => error "Only expecting inclusive_or_expression"
	val reduce432 = fn logical_and_expression x => x \| _ => error "Only expecting logical_and_expression"
	val reduce433 = fn logical_and_expression x => x \| _ => error "Only expecting logical_and_expression"
	val reduce434 = fn logical_or_expression x => x \| _ => error "Only expecting logical_or_expression"
	val reduce435 = fn logical_or_expression x => x \| _ => error "Only expecting logical_or_expression"
	val reduce436 = fn conditional_expression x => x \| _ => error "Only expecting conditional_expression"
	val reduce437 = fn conditional_expression x => x \| _ => error "Only expecting conditional_expression"
	val reduce438 = fn conditional_expression x => x \| _ => error "Only expecting conditional_expression"
	val reduce439 = fn assignment_expression x => x \| _ => error "Only expecting assignment_expression"
	val reduce440 = fn assignment_expression x => x \| _ => error "Only expecting assignment_expression"
	val reduce441 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce442 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce443 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce444 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce445 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce446 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce447 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce448 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce449 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce450 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce451 = fn assignment_operator x => x \| _ => error "Only expecting assignment_operator"
	val reduce452 = fn expression x => x \| _ => error "Only expecting expression"
	val reduce453 = fn expression x => x \| _ => error "Only expecting expression"
	val reduce454 = fn comma_expression x => x \| _ => error "Only expecting comma_expression"
	val reduce455 = fn comma_expression x => x \| _ => error "Only expecting comma_expression"
	val reduce456 = fn expression_opt x => x \| _ => error "Only expecting expression_opt"
	val reduce457 = fn expression_opt x => x \| _ => error "Only expecting expression_opt"
	val reduce458 = fn assignment_expression_opt x => x \| _ => error "Only expecting assignment_expression_opt"
	val reduce459 = fn assignment_expression_opt x => x \| _ => error "Only expecting assignment_expression_opt"
	val reduce460 = fn constant_expression x => x \| _ => error "Only expecting constant_expression"
	val reduce461 = fn constant x => x \| _ => error "Only expecting constant"
	val reduce462 = fn constant x => x \| _ => error "Only expecting constant"
	val reduce463 = fn constant x => x \| _ => error "Only expecting constant"
	val reduce464 = fn string_literal x => x \| _ => error "Only expecting string_literal"
	val reduce465 = fn string_literal x => x \| _ => error "Only expecting string_literal"
	val reduce466 = fn string_literal_list x => x \| _ => error "Only expecting string_literal_list"
	val reduce467 = fn string_literal_list x => x \| _ => error "Only expecting string_literal_list"
	val reduce468 = fn clang_version_literal x => x \| _ => error "Only expecting clang_version_literal"
	val reduce469 = fn identifier x => x \| _ => error "Only expecting identifier"
	val reduce470 = fn identifier x => x \| _ => error "Only expecting identifier"
	val reduce471 = fn attrs_opt x => x \| _ => error "Only expecting attrs_opt"
	val reduce472 = fn attrs_opt x => x \| _ => error "Only expecting attrs_opt"
	val reduce473 = fn attrs x => x \| _ => error "Only expecting attrs"
	val reduce474 = fn attrs x => x \| _ => error "Only expecting attrs"
	val reduce475 = fn attr x => x \| _ => error "Only expecting attr"
	val reduce476 = fn attribute_list x => x \| _ => error "Only expecting attribute_list"
	val reduce477 = fn attribute_list x => x \| _ => error "Only expecting attribute_list"
	val reduce478 = fn attribute x => x \| _ => error "Only expecting attribute"
	val reduce479 = fn attribute x => x \| _ => error "Only expecting attribute"
	val reduce480 = fn attribute x => x \| _ => error "Only expecting attribute"
	val reduce481 = fn attribute x => x \| _ => error "Only expecting attribute"
	val reduce482 = fn attribute x => x \| _ => error "Only expecting attribute"
	val reduce483 = fn attribute_params x => x \| _ => error "Only expecting attribute_params"
	val reduce484 = fn attribute_params x => x \| _ => error "Only expecting attribute_params"
	val reduce485 = fn attribute_params x => x \| _ => error "Only expecting attribute_params"
	val reduce486 = fn attribute_params x => x \| _ => error "Only expecting attribute_params"
	val reduce487 = fn attribute_params x => x \| _ => error "Only expecting attribute_params"
	val reduce488 = fn attribute_params x => x \| _ => error "Only expecting attribute_params"
	end
	structure C_Grammar_Rule_Wrap =
	struct
	(#line 1.2 "c_grammar_fun.grm")open C_Ast open C_Grammar_Rule_Lib

	type start_happy = (CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either) either

	fun start_happy4 (x : start_happy) = case x of Right (Right (Right (Left x))) => SOME x \| _ => NONE
	fun start_happy3 (x : start_happy) = case x of Right (Right (Left x)) => SOME x \| _ => NONE
	fun start_happy2 (x : start_happy) = case x of Right (Left x) => SOME x \| _ => NONE
	fun start_happy1 (x : start_happy) = case x of Left x => SOME x \| _ => NONE


	(#line 8775.1 "c_grammar_fun.grm.sml")
	fun update_env _ = K (return ())
	val start_happy1 : ( ( CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either ) either) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val start_happy2 : ( ( CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either ) either) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val start_happy3 : ( ( CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either ) either) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val start_happy4 : ( ( CTranslUnit, (CExtDecl, (CStat, (CExpr, unit) either) either) either ) either) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val translation_unit : (CTranslUnit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val ext_decl_list1 : ( ( CExtDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val ext_decl_list2 : ( ( CExtDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val ext_decl_list3 : ( ( CExtDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val external_declaration1 : (CExtDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val external_declaration2 : (CExtDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val external_declaration3 : (CExtDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val external_declaration4 : (CExtDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition1 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition2 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition3 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition4 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition5 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition6 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition7 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition8 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition9 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition10 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition11 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition12 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition13 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_definition14 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_declarator : (CDeclr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val statement1 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val statement2 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val statement3 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val statement4 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val statement5 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val statement6 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val statement7 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val labeled_statement1 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val labeled_statement2 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val labeled_statement3 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val labeled_statement4 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val compound_statement1 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val compound_statement2 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enter_scope : (unit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val leave_scope : (unit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val block_item_list1 : ( ( CBlockItem list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val block_item_list2 : ( ( CBlockItem list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val block_item1 : (CBlockItem) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val block_item2 : (CBlockItem) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_declaration1 : (CBlockItem) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_declaration2 : (CBlockItem) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_declaration3 : (CBlockItem) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_function_definition1 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_function_definition2 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_function_definition3 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_function_definition4 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nested_function_definition5 : (CFunDef) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val label_declarations1 : ( ( Ident list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val label_declarations2 : ( ( Ident list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val expression_statement1 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val expression_statement2 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val selection_statement1 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val selection_statement2 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val selection_statement3 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val iteration_statement1 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val iteration_statement2 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val iteration_statement3 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val iteration_statement4 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val jump_statement1 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val jump_statement2 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val jump_statement3 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val jump_statement4 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val jump_statement5 : (CStat) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_statement1 : (CAsmStmt) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_statement2 : (CAsmStmt) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_statement3 : (CAsmStmt) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_statement4 : (CAsmStmt) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val maybe_type_qualifier1 : (CTypeQual Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val maybe_type_qualifier2 : (CTypeQual Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_operands1 : (CAsmOperand list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_operands2 : (CAsmOperand list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nonnull_asm_operands1 : ( ( CAsmOperand list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val nonnull_asm_operands2 : ( ( CAsmOperand list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_operand1 : (CAsmOperand) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_operand2 : (CAsmOperand) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_operand3 : (CAsmOperand) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_clobbers1 : ( ( CStrLit list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_clobbers2 : ( ( CStrLit list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration4 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration5 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_list1 : ( ( CDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_list2 : ( ( CDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val default_declaring_list1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val default_declaring_list2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val default_declaring_list3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val default_declaring_list4 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val default_declaring_list5 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_attrs_opt : ( ( CStrLit Maybe * CAttr list ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaring_list1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaring_list2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaring_list3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_specifier1 : (CDeclSpec list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_specifier2 : (CDeclSpec list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_specifier3 : (CDeclSpec list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_list1 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_list2 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_list3 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_list4 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_list5 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_list6 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier1 : (CDeclSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier2 : (CDeclSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier3 : (CDeclSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier4 : (CDeclSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_without_types1 : (CDeclSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_without_types2 : (CDeclSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declaration_qualifier_without_types3 : (CDeclSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val storage_class1 : (CStorageSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val storage_class2 : (CStorageSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val storage_class3 : (CStorageSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val storage_class4 : (CStorageSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val storage_class5 : (CStorageSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val storage_class6 : (CStorageSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_specifier1 : (CFunSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_specifier2 : (CFunSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val alignment_specifier1 : (CAlignSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val alignment_specifier2 : (CAlignSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_specifier1 : (CDeclSpec list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_specifier2 : (CDeclSpec list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_specifier3 : (CDeclSpec list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name1 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name2 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name3 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name4 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name5 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name6 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name7 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name8 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name9 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name10 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name11 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_name12 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_declaration_specifier1 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_declaration_specifier2 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_declaration_specifier3 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_declaration_specifier4 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_declaration_specifier5 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_specifier1 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_specifier2 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_specifier3 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_specifier4 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_specifier5 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_specifier6 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val basic_type_specifier7 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_declaration_specifier1 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_declaration_specifier2 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_declaration_specifier3 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_declaration_specifier4 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_type_specifier1 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_type_specifier2 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_type_specifier3 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_type_specifier4 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_type_specifier5 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val sue_type_specifier6 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declaration_specifier1 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declaration_specifier2 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declaration_specifier3 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declaration_specifier4 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declaration_specifier5 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declaration_specifier6 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier1 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier2 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier3 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier4 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier5 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier6 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier7 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier8 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier9 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier10 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier11 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier12 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier13 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_type_specifier14 : ( ( CDeclSpec list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val elaborated_type_name1 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val elaborated_type_name2 : (CTypeSpec) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_or_union_specifier1 : (CStructUnion) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_or_union_specifier2 : (CStructUnion) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_or_union_specifier3 : (CStructUnion) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_or_union1 : (CStructTag Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_or_union2 : (CStructTag Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaration_list1 : ( ( CDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaration_list2 : ( ( CDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaration_list3 : ( ( CDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaration1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaration2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaration3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_default_declaring_list1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_default_declaring_list2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_default_declaring_list3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaring_list1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaring_list2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declaring_list3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declarator1 : ( ( CDeclr Maybe * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declarator2 : ( ( CDeclr Maybe * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_declarator3 : ( ( CDeclr Maybe * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_identifier_declarator1 : ( ( CDeclr Maybe * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_identifier_declarator2 : ( ( CDeclr Maybe * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_identifier_declarator3 : ( ( CDeclr Maybe * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val struct_identifier_declarator4 : ( ( CDeclr Maybe * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enum_specifier1 : (CEnum) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enum_specifier2 : (CEnum) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enum_specifier3 : (CEnum) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enum_specifier4 : (CEnum) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enum_specifier5 : (CEnum) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enumerator_list1 : ( ( ((Ident * CExpr Maybe)) list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enumerator_list2 : ( ( ((Ident * CExpr Maybe)) list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enumerator1 : ( ( Ident * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enumerator2 : ( ( Ident * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enumerator3 : ( ( Ident * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val enumerator4 : ( ( Ident * CExpr Maybe ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier1 : (CTypeQual) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier2 : (CTypeQual) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier3 : (CTypeQual) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier4 : (CTypeQual) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier5 : (CTypeQual) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier6 : (CTypeQual) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier_list1 : ( ( CTypeQual list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier_list2 : ( ( CTypeQual list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_qualifier_list3 : ( ( CTypeQual list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_opt1 : (CStrLit Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val asm_opt2 : (CStrLit Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val typedef_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_typedef_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_typedef_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_typedef_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_typedef_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_typedef_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_typedef_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_typedef_declarator4 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_typedef_declarator5 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_postfix_typedef_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_postfix_typedef_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_postfix_typedef_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clean_postfix_typedef_declarator4 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_typedef_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_typedef_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_typedef_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_typedef_declarator4 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_typedef_declarator5 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_typedef_declarator6 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_typedef_declarator7 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_postfix_typedef_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_postfix_typedef_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_postfix_typedef_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val simple_paren_typedef_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val simple_paren_typedef_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val identifier_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val identifier_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_identifier_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_identifier_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_identifier_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_identifier_declarator4 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_identifier_declarator5 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_identifier_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_identifier_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_identifier_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_identifier_declarator4 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_identifier_declarator5 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_identifier_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_identifier_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val paren_identifier_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val function_declarator_old : (CDeclr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val old_function_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val old_function_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val old_function_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_old_function_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_old_function_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_old_function_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_type_list1 : ( ( CDecl list * Bool ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_type_list2 : ( ( CDecl list * Bool ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_type_list3 : ( ( CDecl list * Bool ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_list1 : ( ( CDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_list2 : ( ( CDecl list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration4 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration5 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration6 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration7 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration8 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration9 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration10 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration11 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration12 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration13 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration14 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val parameter_declaration15 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val identifier_list1 : ( ( Ident list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val identifier_list2 : ( ( Ident list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_name1 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_name2 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_name3 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val type_name4 : (CDecl) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val abstract_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val abstract_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val abstract_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfixing_abstract_declarator1 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfixing_abstract_declarator2 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val array_abstract_declarator1 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val array_abstract_declarator2 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator1 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator2 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator3 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator4 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator5 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator6 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator7 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator8 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator9 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator10 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_array_abstract_declarator11 : ( ( CDeclrR -> CDeclrR ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_abstract_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_abstract_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_abstract_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_abstract_declarator4 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_abstract_declarator5 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_abstract_declarator6 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator1 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator2 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator3 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator4 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator5 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator6 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator7 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator8 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_abstract_declarator9 : (CDeclrR) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer1 : (CInit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer2 : (CInit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer3 : (CInit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer_opt1 : (CInit Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer_opt2 : (CInit Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer_list1 : (CInitList Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer_list2 : (CInitList Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer_list3 : (CInitList Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer_list4 : (CInitList Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val initializer_list5 : (CInitList Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designation1 : (CDesignator list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designation2 : (CDesignator list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designation3 : (CDesignator list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designator_list1 : ( ( CDesignator list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designator_list2 : ( ( CDesignator list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designator1 : (CDesignator) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designator2 : (CDesignator) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val designator3 : (CDesignator) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val array_designator : (CDesignator) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression4 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression5 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression6 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression7 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression8 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val primary_expression9 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val generic_assoc_list1 : ( ( ((CDecl Maybe * CExpr)) list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val generic_assoc_list2 : ( ( ((CDecl Maybe * CExpr)) list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val generic_assoc1 : ( ( CDecl Maybe * CExpr ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val generic_assoc2 : ( ( CDecl Maybe * CExpr ) ) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val offsetof_member_designator1 : ( ( CDesignator list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val offsetof_member_designator2 : ( ( CDesignator list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val offsetof_member_designator3 : ( ( CDesignator list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression4 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression5 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression6 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression7 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression8 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression9 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val postfix_expression10 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val argument_expression_list1 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val argument_expression_list2 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression4 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression5 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression6 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression7 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression8 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression9 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression10 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression11 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_expression12 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_operator1 : (CUnaryOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_operator2 : (CUnaryOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_operator3 : (CUnaryOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_operator4 : (CUnaryOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_operator5 : (CUnaryOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val unary_operator6 : (CUnaryOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val cast_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val cast_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val multiplicative_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val multiplicative_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val multiplicative_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val multiplicative_expression4 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val additive_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val additive_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val additive_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val shift_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val shift_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val shift_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val relational_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val relational_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val relational_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val relational_expression4 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val relational_expression5 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val equality_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val equality_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val equality_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val and_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val and_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val exclusive_or_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val exclusive_or_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val inclusive_or_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val inclusive_or_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val logical_and_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val logical_and_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val logical_or_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val logical_or_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val conditional_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val conditional_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val conditional_expression3 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator1 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator2 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator3 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator4 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator5 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator6 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator7 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator8 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator9 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator10 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_operator11 : (CAssignOp Located) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val expression1 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val expression2 : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val comma_expression1 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val comma_expression2 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val expression_opt1 : (CExpr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val expression_opt2 : (CExpr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_expression_opt1 : (CExpr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val assignment_expression_opt2 : (CExpr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val constant_expression : (CExpr) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val constant1 : (CConst) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val constant2 : (CConst) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val constant3 : (CConst) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val string_literal1 : (CStrLit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val string_literal2 : (CStrLit) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val string_literal_list1 : ( ( CString list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val string_literal_list2 : ( ( CString list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val clang_version_literal : (ClangCVersion) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val identifier1 : (Ident) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val identifier2 : (Ident) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attrs_opt1 : (CAttr list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attrs_opt2 : (CAttr list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attrs1 : (CAttr list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attrs2 : (CAttr list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attr : (CAttr list) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_list1 : ( ( CAttr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_list2 : ( ( CAttr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute1 : (CAttr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute2 : (CAttr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute3 : (CAttr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute4 : (CAttr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute5 : (CAttr Maybe) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_params1 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_params2 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_params3 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_params4 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_params5 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	val attribute_params6 : ( ( CExpr list ) Reversed) -> unit monad = update_env (fn _ => fn env => fn context => (env, context))
	end
	signature C_Grammar_TOKENS =
	sig
	type ('a,'b) token
	type arg
	type svalue0
	type svalue = arg -> svalue0 * arg
	val x25_eof: 'a * 'a -> (svalue,'a) token
	val clangcversion: (C_Ast.ClangCVersion) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_builtin_types_compatible_p: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_builtin_offsetof: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_builtin_va_arg: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_imag_x5f_x5f: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_real_x5f_x5f: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_extension_x5f_x5f: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_attribute_x5f_x5f: (string) * 'a * 'a -> (svalue,'a) token
	val tyident: (C_Ast.ident) * 'a * 'a -> (svalue,'a) token
	val ident: (C_Ast.ident) * 'a * 'a -> (svalue,'a) token
	val cstr: (C_Ast.cString) * 'a * 'a -> (svalue,'a) token
	val cfloat: (C_Ast.cFloat) * 'a * 'a -> (svalue,'a) token
	val cint: (C_Ast.cInteger) * 'a * 'a -> (svalue,'a) token
	val cchar: (C_Ast.cChar) * 'a * 'a -> (svalue,'a) token
	val while0: (string) * 'a * 'a -> (svalue,'a) token
	val volatile: (string) * 'a * 'a -> (svalue,'a) token
	val void: (string) * 'a * 'a -> (svalue,'a) token
	val unsigned: (string) * 'a * 'a -> (svalue,'a) token
	val union: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_thread: (string) * 'a * 'a -> (svalue,'a) token
	val typeof: (string) * 'a * 'a -> (svalue,'a) token
	val typedef: (string) * 'a * 'a -> (svalue,'a) token
	val switch: (string) * 'a * 'a -> (svalue,'a) token
	val struct0: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Static_assert: (string) * 'a * 'a -> (svalue,'a) token
	val static: (string) * 'a * 'a -> (svalue,'a) token
	val sizeof: (string) * 'a * 'a -> (svalue,'a) token
	val signed: (string) * 'a * 'a -> (svalue,'a) token
	val short: (string) * 'a * 'a -> (svalue,'a) token
	val return0: (string) * 'a * 'a -> (svalue,'a) token
	val restrict: (string) * 'a * 'a -> (svalue,'a) token
	val register: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Nonnull: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Nullable: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Noreturn: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_label_x5f_x5f: (string) * 'a * 'a -> (svalue,'a) token
	val long: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_x5f_int_x31_x32_x38: (string) * 'a * 'a -> (svalue,'a) token
	val int: (string) * 'a * 'a -> (svalue,'a) token
	val inline: (string) * 'a * 'a -> (svalue,'a) token
	val if0: (string) * 'a * 'a -> (svalue,'a) token
	val goto: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Generic: (string) * 'a * 'a -> (svalue,'a) token
	val for0: (string) * 'a * 'a -> (svalue,'a) token
	val float: (string) * 'a * 'a -> (svalue,'a) token
	val extern: (string) * 'a * 'a -> (svalue,'a) token
	val enum: (string) * 'a * 'a -> (svalue,'a) token
	val else0: (string) * 'a * 'a -> (svalue,'a) token
	val double: (string) * 'a * 'a -> (svalue,'a) token
	val do0: (string) * 'a * 'a -> (svalue,'a) token
	val default: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Complex: (string) * 'a * 'a -> (svalue,'a) token
	val continue: (string) * 'a * 'a -> (svalue,'a) token
	val const: (string) * 'a * 'a -> (svalue,'a) token
	val char: (string) * 'a * 'a -> (svalue,'a) token
	val case0: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Bool: (string) * 'a * 'a -> (svalue,'a) token
	val break: (string) * 'a * 'a -> (svalue,'a) token
	val auto: (string) * 'a * 'a -> (svalue,'a) token
	val asm: (string) * 'a * 'a -> (svalue,'a) token
	val x5f_Atomic: (string) * 'a * 'a -> (svalue,'a) token
	val alignas: (string) * 'a * 'a -> (svalue,'a) token
	val alignof: (string) * 'a * 'a -> (svalue,'a) token
	val x2e_x2e_x2e: (string) * 'a * 'a -> (svalue,'a) token
	val x7d: (string) * 'a * 'a -> (svalue,'a) token
	val x7b: (string) * 'a * 'a -> (svalue,'a) token
	val x3b: (string) * 'a * 'a -> (svalue,'a) token
	val x2c: (string) * 'a * 'a -> (svalue,'a) token
	val x3e_x3e_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x3c_x3c_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x7c_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x5e_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x26_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x25_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x2f_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x2a_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x2d_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x2b_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x3a: (string) * 'a * 'a -> (svalue,'a) token
	val x3f: (string) * 'a * 'a -> (svalue,'a) token
	val x7c_x7c: (string) * 'a * 'a -> (svalue,'a) token
	val x26_x26: (string) * 'a * 'a -> (svalue,'a) token
	val x7c: (string) * 'a * 'a -> (svalue,'a) token
	val x5e: (string) * 'a * 'a -> (svalue,'a) token
	val x21_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x3d_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x3e_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x3e: (string) * 'a * 'a -> (svalue,'a) token
	val x3c_x3d: (string) * 'a * 'a -> (svalue,'a) token
	val x3c: (string) * 'a * 'a -> (svalue,'a) token
	val x3e_x3e: (string) * 'a * 'a -> (svalue,'a) token
	val x3c_x3c: (string) * 'a * 'a -> (svalue,'a) token
	val x26: (string) * 'a * 'a -> (svalue,'a) token
	val x25: (string) * 'a * 'a -> (svalue,'a) token
	val x2f: (string) * 'a * 'a -> (svalue,'a) token
	val x2a: (string) * 'a * 'a -> (svalue,'a) token
	val x2d: (string) * 'a * 'a -> (svalue,'a) token
	val x2b: (string) * 'a * 'a -> (svalue,'a) token
	val x2d_x2d: (string) * 'a * 'a -> (svalue,'a) token
	val x2b_x2b: (string) * 'a * 'a -> (svalue,'a) token
	val x7e: (string) * 'a * 'a -> (svalue,'a) token
	val x21: (string) * 'a * 'a -> (svalue,'a) token
	val x2e: (string) * 'a * 'a -> (svalue,'a) token
	val x2d_x3e: (string) * 'a * 'a -> (svalue,'a) token
	val x5d: (string) * 'a * 'a -> (svalue,'a) token
	val x5b: (string) * 'a * 'a -> (svalue,'a) token
	val x29: (string) * 'a * 'a -> (svalue,'a) token
	val x28: (string) * 'a * 'a -> (svalue,'a) token
	val error: 'a * 'a -> (svalue,'a) token
	val start_expression: 'a * 'a -> (svalue,'a) token
	val start_statement: 'a * 'a -> (svalue,'a) token
	val start_external_declaration: 'a * 'a -> (svalue,'a) token
	val start_translation_unit: 'a * 'a -> (svalue,'a) token
	end
	signature C_Grammar_LRVALS=
	sig
	structure Tokens : C_Grammar_TOKENS
	structure ParserData:PARSER_DATA1
	sharing type ParserData.Token.token = Tokens.token
	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/C_Main.thy b/thys/Isabelle_C/C11-FrontEnd/main/C_Main.thy
	rename from thys/Isabelle_C/C11-FrontEnd/C_Main.thy
	rename to thys/Isabelle_C/C11-FrontEnd/main/C_Main.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/C_Main.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/main/C_Main.thy
	@@ -1,42 +1,42 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	(<)
	theory C_Main
	- imports "src/C_Document"
	+ imports "../src/C_Document"
	begin
	end
	-(>)
	\ No newline at end of file
	+(>)
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Ast.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Ast.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Ast.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Ast.thy
	@@ -1,1058 +1,884 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	chapter \<open>Annex I: The Commented Sources of Isabelle/C\<close>

	section \<open>Core Language: An Abstract Syntax Tree Definition (C Language without Annotations)\<close>

	theory C_Ast
	imports Main
	begin

	subsection \<open>Loading the Generated AST\<close>

	text \<open> The abstract syntax tree of the C language considered in the Isabelle/C project is
	arbitrary, but it must already come with a grammar making the connection with a default AST, so that
	both the grammar and AST can be imported to SML.\<^footnote>\<open>Additionally, the grammar and AST
	must both have a free licence --- compatible with the Isabelle AFP, for them to be publishable
	there.\<close> The Haskell Language.C project fulfills this property: see for instance
	\<^url>\<open>http://hackage.haskell.org/package/language-c\<close> and
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Syntax/AST.hs\<close>,
	where its AST is being imported in the present theory file \<^file>\<open>C_Ast.thy\<close>, whereas
	its grammar will be later in \<^file>\<open>C_Parser_Language.thy\<close>
	(\<^file>\<open>C_Parser_Language.thy\<close> depends on \<^file>\<open>C_Ast.thy\<close>). The AST
	importation is based on a modified version of Haskabelle, which generates the C AST from Haskell to
	an ML file. \<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_ast.ML\<close>\<close> \<open>
	val fresh_ident0 =
	let val i = Synchronized.var "counter for new identifier" 38 in
	fn () => Int.toString (Synchronized.change_result i (fn i => (i, i + 1)))
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_ast.ML\<close>\<close> \<open>
	-\<comment> \<open>\<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/blob/C/Citadelle/src/compiler_generic/meta_isabelle/Printer_init.thy\<close>\<close>
	+\<comment> \<open>\<^url>\<open>https://gitlab.lisn.upsaclay.fr/burkhart.wolff/Isabelle_C/-/blob/C/Citadelle/src/compiler_generic/meta_isabelle/Printer_init.thy\<close>\<close>
	structure CodeType = struct
	type mlInt = string
	type 'a mlMonad = 'a option
	end

	structure CodeConst = struct
	structure Monad = struct
	val bind = fn
	NONE => (fn _ => NONE)
	\| SOME a => fn f => f a
	val return = SOME
	end

	structure Printf = struct
	local
	fun sprintf s l =
	case String.fields (fn #"%" => true \| _ => false) s of
	[] => ""
	\| [x] => x
	\| x :: xs =>
	let fun aux acc l_pat l_s =
	case l_pat of
	[] => rev acc
	\| x :: xs => aux (String.extract (x, 1, NONE) :: hd l_s :: acc) xs (tl l_s) in
	String.concat (x :: aux [] xs l)
	end
	in
	fun sprintf0 s_pat = s_pat
	fun sprintf1 s_pat s1 = sprintf s_pat [s1]
	fun sprintf2 s_pat s1 s2 = sprintf s_pat [s1, s2]
	fun sprintf3 s_pat s1 s2 s3 = sprintf s_pat [s1, s2, s3]
	fun sprintf4 s_pat s1 s2 s3 s4 = sprintf s_pat [s1, s2, s3, s4]
	fun sprintf5 s_pat s1 s2 s3 s4 s5 = sprintf s_pat [s1, s2, s3, s4, s5]
	end
	end

	structure String = struct
	val concat = String.concatWith
	end

	structure Sys = struct
	val isDirectory2 = SOME o File.is_dir o Path.explode handle ERROR _ => K NONE
	end

	structure To = struct
	fun nat f = Int.toString o f
	end

	fun outFile1 _ _ = tap (fn _ => warning "not implemented") NONE
	fun outStand1 f = outFile1 f ""
	end
	\<close>

	ML_file \<open>../generated/c_ast.ML\<close>

	text \<open> Note that the purpose of \<^dir>\<open>../generated\<close> is to host any generated
	files of the Isabelle/C project. It contains among others:

	\<^item> \<^file>\<open>../generated/c_ast.ML\<close> representing the Abstract Syntax Tree of C,
	which has just been loaded.

	\<^item> \<^file>\<open>../generated/c_grammar_fun.grm\<close> is a generated file not used by the
	project, except for further generating \<^file>\<open>../generated/c_grammar_fun.grm.sig\<close>
	and \<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>. Its physical presence in the
	directory is actually not necessary, but has been kept for informative documentation purposes. It
	represents the basis point of our SML grammar file, generated by an initial Haskell grammar file
	(namely
	\<^url>\<open>https://github.com/visq/language-c/blob/master/src/Language/C/Parser/Parser.y\<close>)
	using a modified version of Happy.

	\<^item> \<^file>\<open>../generated/c_grammar_fun.grm.sig\<close> and
	\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close> are the two files generated from
	\<^file>\<open>../generated/c_grammar_fun.grm\<close> with a modified version of ML-Yacc. This
	last comes from MLton source in \<^dir>\<open>../../src_ext/mlton\<close>, see for example
	\<^dir>\<open>../../src_ext/mlton/mlyacc\<close>.
	\<close>

	text \<open> For the case of \<^file>\<open>../generated/c_ast.ML\<close>, it is actually not
	mandatory to have a ``physical'' representation of the file in \<^dir>\<open>../generated\<close>:
	it could be generated ``on-the-fly'' with \<^theory_text>\<open>code_reflect\<close> and immediately
	loaded: Citadelle has an option to choose between the two
	-tasks~\cite{DBLP:journals/afp/TuongW15}.\<^footnote>\<open>\<^url>\<open>https://gitlri.lri.fr/ftuong/citadelle-devel\<close>\<close>\<close>
	+tasks~\cite{DBLP:journals/afp/TuongW15}.\<^footnote>\<open>\<^url>\<open>https://gitlab.lisn.upsaclay.fr/frederictuong/isabelle_contrib/-/tree/master/Citadelle/src/compiler\<close>\<close>\<close>

	text \<open> After loading the AST, it is possible in Citadelle to do various meta-programming
	renaming, such as the one depicted in the next command. Actually, its content is explicitly included
	here by hand since we decided to manually load the AST using the above
	\<^theory_text>\<open>ML_file\<close> command. (Otherwise, one can automatically execute the overall
	generation and renaming tasks in Citadelle without resorting to a manual copying-pasting.)\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_ast.ML\<close>\<close> \<open>
	structure C_Ast =
	struct
	- val Position = C_Ast.position
	- val NoPosition = C_Ast.noPosition
	- val BuiltinPosition = C_Ast.builtinPosition
	- val InternalPosition = C_Ast.internalPosition
	- val Name = C_Ast.name
	- val OnlyPos = C_Ast.onlyPos
	- val NodeInfo = C_Ast.nodeInfo
	- val AnonymousRef = C_Ast.anonymousRef
	- val NamedRef = C_Ast.namedRef
	- val CChar = C_Ast.cChar val CChars = C_Ast.cChars
	- val DecRepr = C_Ast.decRepr val HexRepr = C_Ast.hexRepr
	- val OctalRepr = C_Ast.octalRepr
	- val FlagUnsigned = C_Ast.flagUnsigned
	- val FlagLong = C_Ast.flagLong
	- val FlagLongLong = C_Ast.flagLongLong
	- val FlagImag = C_Ast.flagImag
	- val CFloat = C_Ast.cFloat
	- val Flags = C_Ast.flags
	- val CInteger = C_Ast.cInteger
	- val CAssignOp = C_Ast.cAssignOp
	- val CMulAssOp = C_Ast.cMulAssOp
	- val CDivAssOp = C_Ast.cDivAssOp
	- val CRmdAssOp = C_Ast.cRmdAssOp
	- val CAddAssOp = C_Ast.cAddAssOp
	- val CSubAssOp = C_Ast.cSubAssOp
	- val CShlAssOp = C_Ast.cShlAssOp
	- val CShrAssOp = C_Ast.cShrAssOp
	- val CAndAssOp = C_Ast.cAndAssOp
	- val CXorAssOp = C_Ast.cXorAssOp
	- val COrAssOp = C_Ast.cOrAssOp
	- val CMulOp = C_Ast.cMulOp
	- val CDivOp = C_Ast.cDivOp
	- val CRmdOp = C_Ast.cRmdOp
	- val CAddOp = C_Ast.cAddOp
	- val CSubOp = C_Ast.cSubOp
	- val CShlOp = C_Ast.cShlOp
	- val CShrOp = C_Ast.cShrOp
	- val CLeOp = C_Ast.cLeOp
	- val CGrOp = C_Ast.cGrOp
	- val CLeqOp = C_Ast.cLeqOp
	- val CGeqOp = C_Ast.cGeqOp
	- val CEqOp = C_Ast.cEqOp
	- val CNeqOp = C_Ast.cNeqOp
	- val CAndOp = C_Ast.cAndOp
	- val CXorOp = C_Ast.cXorOp
	- val COrOp = C_Ast.cOrOp
	- val CLndOp = C_Ast.cLndOp
	- val CLorOp = C_Ast.cLorOp
	- val CPreIncOp = C_Ast.cPreIncOp
	- val CPreDecOp = C_Ast.cPreDecOp
	- val CPostIncOp = C_Ast.cPostIncOp
	- val CPostDecOp = C_Ast.cPostDecOp
	- val CAdrOp = C_Ast.cAdrOp
	- val CIndOp = C_Ast.cIndOp
	- val CPlusOp = C_Ast.cPlusOp
	- val CMinOp = C_Ast.cMinOp
	- val CCompOp = C_Ast.cCompOp
	- val CNegOp = C_Ast.cNegOp
	- val CAuto = C_Ast.cAuto
	- val CRegister = C_Ast.cRegister
	- val CStatic = C_Ast.cStatic
	- val CExtern = C_Ast.cExtern
	- val CTypedef = C_Ast.cTypedef
	- val CThread = C_Ast.cThread
	- val CInlineQual = C_Ast.cInlineQual
	- val CNoreturnQual = C_Ast.cNoreturnQual
	- val CStructTag = C_Ast.cStructTag
	- val CUnionTag = C_Ast.cUnionTag
	- val CIntConst = C_Ast.cIntConst
	- val CCharConst = C_Ast.cCharConst
	- val CFloatConst = C_Ast.cFloatConst
	- val CStrConst = C_Ast.cStrConst
	- val CStrLit = C_Ast.cStrLit
	- val CFunDef = C_Ast.cFunDef
	- val CDecl = C_Ast.cDecl
	- val CStaticAssert = C_Ast.cStaticAssert
	- val CDeclr = C_Ast.cDeclr
	- val CPtrDeclr = C_Ast.cPtrDeclr
	- val CArrDeclr = C_Ast.cArrDeclr
	- val CFunDeclr = C_Ast.cFunDeclr
	- val CNoArrSize = C_Ast.cNoArrSize
	- val CArrSize = C_Ast.cArrSize
	- val CLabel = C_Ast.cLabel
	- val CCase = C_Ast.cCase
	- val CCases = C_Ast.cCases
	- val CDefault = C_Ast.cDefault
	- val CExpr = C_Ast.cExpr
	- val CCompound = C_Ast.cCompound
	- val CIf = C_Ast.cIf
	- val CSwitch = C_Ast.cSwitch
	- val CWhile = C_Ast.cWhile
	- val CFor = C_Ast.cFor
	- val CGoto = C_Ast.cGoto
	- val CGotoPtr = C_Ast.cGotoPtr
	- val CCont = C_Ast.cCont
	- val CBreak = C_Ast.cBreak
	- val CReturn = C_Ast.cReturn
	- val CAsm = C_Ast.cAsm
	- val CAsmStmt = C_Ast.cAsmStmt
	- val CAsmOperand = C_Ast.cAsmOperand
	- val CBlockStmt = C_Ast.cBlockStmt
	- val CBlockDecl = C_Ast.cBlockDecl
	- val CNestedFunDef = C_Ast.cNestedFunDef
	- val CStorageSpec = C_Ast.cStorageSpec
	- val CTypeSpec = C_Ast.cTypeSpec
	- val CTypeQual = C_Ast.cTypeQual
	- val CFunSpec = C_Ast.cFunSpec
	- val CAlignSpec = C_Ast.cAlignSpec
	- val CVoidType = C_Ast.cVoidType
	- val CCharType = C_Ast.cCharType
	- val CShortType = C_Ast.cShortType
	- val CIntType = C_Ast.cIntType
	- val CLongType = C_Ast.cLongType
	- val CFloatType = C_Ast.cFloatType
	- val CDoubleType = C_Ast.cDoubleType
	- val CSignedType = C_Ast.cSignedType
	- val CUnsigType = C_Ast.cUnsigType
	- val CBoolType = C_Ast.cBoolType
	- val CComplexType = C_Ast.cComplexType
	- val CInt128Type = C_Ast.cInt128Type
	- val CSUType = C_Ast.cSUType
	- val CEnumType = C_Ast.cEnumType
	- val CTypeDef = C_Ast.cTypeDef
	- val CTypeOfExpr = C_Ast.cTypeOfExpr
	- val CTypeOfType = C_Ast.cTypeOfType
	- val CAtomicType = C_Ast.cAtomicType
	- val CConstQual = C_Ast.cConstQual
	- val CVolatQual = C_Ast.cVolatQual
	- val CRestrQual = C_Ast.cRestrQual
	- val CAtomicQual = C_Ast.cAtomicQual
	- val CAttrQual = C_Ast.cAttrQual
	- val CNullableQual = C_Ast.cNullableQual
	- val CNonnullQual = C_Ast.cNonnullQual
	- val CAlignAsType = C_Ast.cAlignAsType
	- val CAlignAsExpr = C_Ast.cAlignAsExpr
	- val CStruct = C_Ast.cStruct
	- val CEnum = C_Ast.cEnum
	- val CInitExpr = C_Ast.cInitExpr
	- val CInitList = C_Ast.cInitList
	- val CArrDesig = C_Ast.cArrDesig
	- val CMemberDesig = C_Ast.cMemberDesig
	- val CRangeDesig = C_Ast.cRangeDesig
	- val CAttr = C_Ast.cAttr
	- val CComma = C_Ast.cComma
	- val CAssign = C_Ast.cAssign
	- val CCond = C_Ast.cCond
	- val CBinary = C_Ast.cBinary
	- val CCast = C_Ast.cCast
	- val CUnary = C_Ast.cUnary
	- val CSizeofExpr = C_Ast.cSizeofExpr
	- val CSizeofType = C_Ast.cSizeofType
	- val CAlignofExpr = C_Ast.cAlignofExpr
	- val CAlignofType = C_Ast.cAlignofType
	- val CComplexReal = C_Ast.cComplexReal
	- val CComplexImag = C_Ast.cComplexImag
	- val CIndex = C_Ast.cIndex
	- val CCall = C_Ast.cCall
	- val CMember = C_Ast.cMember
	- val CVar = C_Ast.cVar
	- val CConst = C_Ast.cConst
	- val CCompoundLit = C_Ast.cCompoundLit
	- val CGenericSelection = C_Ast.cGenericSelection
	- val CStatExpr = C_Ast.cStatExpr
	- val CLabAddrExpr = C_Ast.cLabAddrExpr
	- val CBuiltinExpr = C_Ast.cBuiltinExpr
	- val CBuiltinVaArg = C_Ast.cBuiltinVaArg
	- val CBuiltinOffsetOf = C_Ast.cBuiltinOffsetOf
	- val CBuiltinTypesCompatible = C_Ast.cBuiltinTypesCompatible
	- val CDeclExt = C_Ast.cDeclExt
	- val CFDefExt = C_Ast.cFDefExt
	- val CAsmExt = C_Ast.cAsmExt
	- val CTranslUnit = C_Ast.cTranslUnit
	+ val Position = C_Ast.position val NoPosition = C_Ast.noPosition val BuiltinPosition = C_Ast.builtinPosition val InternalPosition = C_Ast.internalPosition val Name = C_Ast.name val OnlyPos = C_Ast.onlyPos val NodeInfo = C_Ast.nodeInfo val AnonymousRef = C_Ast.anonymousRef val NamedRef = C_Ast.namedRef val CChar = C_Ast.cChar val CChars = C_Ast.cChars val DecRepr = C_Ast.decRepr val HexRepr = C_Ast.hexRepr val OctalRepr = C_Ast.octalRepr val FlagUnsigned = C_Ast.flagUnsigned val FlagLong = C_Ast.flagLong val FlagLongLong = C_Ast.flagLongLong val FlagImag = C_Ast.flagImag val CFloat = C_Ast.cFloat val Flags = C_Ast.flags val CInteger = C_Ast.cInteger val CAssignOp = C_Ast.cAssignOp val CMulAssOp = C_Ast.cMulAssOp val CDivAssOp = C_Ast.cDivAssOp val CRmdAssOp = C_Ast.cRmdAssOp val CAddAssOp = C_Ast.cAddAssOp val CSubAssOp = C_Ast.cSubAssOp val CShlAssOp = C_Ast.cShlAssOp val CShrAssOp = C_Ast.cShrAssOp val CAndAssOp = C_Ast.cAndAssOp val CXorAssOp = C_Ast.cXorAssOp val COrAssOp = C_Ast.cOrAssOp val CMulOp = C_Ast.cMulOp val CDivOp = C_Ast.cDivOp val CRmdOp = C_Ast.cRmdOp val CAddOp = C_Ast.cAddOp val CSubOp = C_Ast.cSubOp val CShlOp = C_Ast.cShlOp val CShrOp = C_Ast.cShrOp val CLeOp = C_Ast.cLeOp val CGrOp = C_Ast.cGrOp val CLeqOp = C_Ast.cLeqOp val CGeqOp = C_Ast.cGeqOp val CEqOp = C_Ast.cEqOp val CNeqOp = C_Ast.cNeqOp val CAndOp = C_Ast.cAndOp val CXorOp = C_Ast.cXorOp val COrOp = C_Ast.cOrOp val CLndOp = C_Ast.cLndOp val CLorOp = C_Ast.cLorOp val CPreIncOp = C_Ast.cPreIncOp val CPreDecOp = C_Ast.cPreDecOp val CPostIncOp = C_Ast.cPostIncOp val CPostDecOp = C_Ast.cPostDecOp val CAdrOp = C_Ast.cAdrOp val CIndOp = C_Ast.cIndOp val CPlusOp = C_Ast.cPlusOp val CMinOp = C_Ast.cMinOp val CCompOp = C_Ast.cCompOp val CNegOp = C_Ast.cNegOp val CAuto = C_Ast.cAuto val CRegister = C_Ast.cRegister val CStatic = C_Ast.cStatic val CExtern = C_Ast.cExtern val CTypedef = C_Ast.cTypedef val CThread = C_Ast.cThread val CInlineQual = C_Ast.cInlineQual val CNoreturnQual = C_Ast.cNoreturnQual val CStructTag = C_Ast.cStructTag val CUnionTag = C_Ast.cUnionTag val CIntConst = C_Ast.cIntConst val CCharConst = C_Ast.cCharConst val CFloatConst = C_Ast.cFloatConst val CStrConst = C_Ast.cStrConst val CStrLit = C_Ast.cStrLit val CFunDef = C_Ast.cFunDef val CDecl = C_Ast.cDecl val CStaticAssert = C_Ast.cStaticAssert val CDeclr = C_Ast.cDeclr val CPtrDeclr = C_Ast.cPtrDeclr val CArrDeclr = C_Ast.cArrDeclr val CFunDeclr = C_Ast.cFunDeclr val CNoArrSize = C_Ast.cNoArrSize val CArrSize = C_Ast.cArrSize val CLabel = C_Ast.cLabel val CCase = C_Ast.cCase val CCases = C_Ast.cCases val CDefault = C_Ast.cDefault val CExpr = C_Ast.cExpr val CCompound = C_Ast.cCompound val CIf = C_Ast.cIf val CSwitch = C_Ast.cSwitch val CWhile = C_Ast.cWhile val CFor = C_Ast.cFor val CGoto = C_Ast.cGoto val CGotoPtr = C_Ast.cGotoPtr val CCont = C_Ast.cCont val CBreak = C_Ast.cBreak val CReturn = C_Ast.cReturn val CAsm = C_Ast.cAsm val CAsmStmt = C_Ast.cAsmStmt val CAsmOperand = C_Ast.cAsmOperand val CBlockStmt = C_Ast.cBlockStmt val CBlockDecl = C_Ast.cBlockDecl val CNestedFunDef = C_Ast.cNestedFunDef val CStorageSpec = C_Ast.cStorageSpec val CTypeSpec = C_Ast.cTypeSpec val CTypeQual = C_Ast.cTypeQual val CFunSpec = C_Ast.cFunSpec val CAlignSpec = C_Ast.cAlignSpec val CVoidType = C_Ast.cVoidType val CCharType = C_Ast.cCharType val CShortType = C_Ast.cShortType val CIntType = C_Ast.cIntType val CLongType = C_Ast.cLongType val CFloatType = C_Ast.cFloatType val CDoubleType = C_Ast.cDoubleType val CSignedType = C_Ast.cSignedType val CUnsigType = C_Ast.cUnsigType val CBoolType = C_Ast.cBoolType val CComplexType = C_Ast.cComplexType val CInt128Type = C_Ast.cInt128Type val CSUType = C_Ast.cSUType val CEnumType = C_Ast.cEnumType val CTypeDef = C_Ast.cTypeDef val CTypeOfExpr = C_Ast.cTypeOfExpr val CTypeOfType = C_Ast.cTypeOfType val CAtomicType = C_Ast.cAtomicType val CConstQual = C_Ast.cConstQual val CVolatQual = C_Ast.cVolatQual val CRestrQual = C_Ast.cRestrQual val CAtomicQual = C_Ast.cAtomicQual val CAttrQual = C_Ast.cAttrQual val CNullableQual = C_Ast.cNullableQual val CNonnullQual = C_Ast.cNonnullQual val CAlignAsType = C_Ast.cAlignAsType val CAlignAsExpr = C_Ast.cAlignAsExpr val CStruct = C_Ast.cStruct val CEnum = C_Ast.cEnum val CInitExpr = C_Ast.cInitExpr val CInitList = C_Ast.cInitList val CArrDesig = C_Ast.cArrDesig val CMemberDesig = C_Ast.cMemberDesig val CRangeDesig = C_Ast.cRangeDesig val CAttr = C_Ast.cAttr val CComma = C_Ast.cComma val CAssign = C_Ast.cAssign val CCond = C_Ast.cCond val CBinary = C_Ast.cBinary val CCast = C_Ast.cCast val CUnary = C_Ast.cUnary val CSizeofExpr = C_Ast.cSizeofExpr val CSizeofType = C_Ast.cSizeofType val CAlignofExpr = C_Ast.cAlignofExpr val CAlignofType = C_Ast.cAlignofType val CComplexReal = C_Ast.cComplexReal val CComplexImag = C_Ast.cComplexImag val CIndex = C_Ast.cIndex val CCall = C_Ast.cCall val CMember = C_Ast.cMember val CVar = C_Ast.cVar val CConst = C_Ast.cConst val CCompoundLit = C_Ast.cCompoundLit val CGenericSelection = C_Ast.cGenericSelection val CStatExpr = C_Ast.cStatExpr val CLabAddrExpr = C_Ast.cLabAddrExpr val CBuiltinExpr = C_Ast.cBuiltinExpr val CBuiltinVaArg = C_Ast.cBuiltinVaArg val CBuiltinOffsetOf = C_Ast.cBuiltinOffsetOf val CBuiltinTypesCompatible = C_Ast.cBuiltinTypesCompatible val CDeclExt = C_Ast.cDeclExt val CFDefExt = C_Ast.cFDefExt val CAsmExt = C_Ast.cAsmExt val CTranslUnit = C_Ast.cTranslUnit
	open C_Ast
	end
	\<close>

	subsection \<open>Basic Aliases and Initialization of the Haskell Library\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_ast.ML\<close>\<close> \<open>
	structure C_Ast =
	struct
	type class_Pos = Position.T * Position.T
	(**)
	type NodeInfo = C_Ast.nodeInfo
	type CStorageSpec = NodeInfo C_Ast.cStorageSpecifier
	type CFunSpec = NodeInfo C_Ast.cFunctionSpecifier
	type CConst = NodeInfo C_Ast.cConstant
	type 'a CInitializerList = ('a C_Ast.cPartDesignator List.list * 'a C_Ast.cInitializer) List.list
	type CTranslUnit = NodeInfo C_Ast.cTranslationUnit
	type CExtDecl = NodeInfo C_Ast.cExternalDeclaration
	type CFunDef = NodeInfo C_Ast.cFunctionDef
	type CDecl = NodeInfo C_Ast.cDeclaration
	type CDeclr = NodeInfo C_Ast.cDeclarator
	type CDerivedDeclr = NodeInfo C_Ast.cDerivedDeclarator
	type CArrSize = NodeInfo C_Ast.cArraySize
	type CStat = NodeInfo C_Ast.cStatement
	type CAsmStmt = NodeInfo C_Ast.cAssemblyStatement
	type CAsmOperand = NodeInfo C_Ast.cAssemblyOperand
	type CBlockItem = NodeInfo C_Ast.cCompoundBlockItem
	type CDeclSpec = NodeInfo C_Ast.cDeclarationSpecifier
	type CTypeSpec = NodeInfo C_Ast.cTypeSpecifier
	type CTypeQual = NodeInfo C_Ast.cTypeQualifier
	type CAlignSpec = NodeInfo C_Ast.cAlignmentSpecifier
	type CStructUnion = NodeInfo C_Ast.cStructureUnion
	type CEnum = NodeInfo C_Ast.cEnumeration
	type CInit = NodeInfo C_Ast.cInitializer
	type CInitList = NodeInfo CInitializerList
	type CDesignator = NodeInfo C_Ast.cPartDesignator
	type CAttr = NodeInfo C_Ast.cAttribute
	type CExpr = NodeInfo C_Ast.cExpression
	type CBuiltin = NodeInfo C_Ast.cBuiltinThing
	type CStrLit = NodeInfo C_Ast.cStringLiteral
	(**)
	type ClangCVersion = C_Ast.clangCVersion
	type Ident = C_Ast.ident
	type Position = C_Ast.positiona
	type PosLength = Position * int
	type Name = C_Ast.namea
	type Bool = bool
	type CString = C_Ast.cString
	type CChar = C_Ast.cChar
	type CInteger = C_Ast.cInteger
	type CFloat = C_Ast.cFloat
	type CStructTag = C_Ast.cStructTag
	type CUnaryOp = C_Ast.cUnaryOp
	type 'a CStringLiteral = 'a C_Ast.cStringLiteral
	type 'a CConstant = 'a C_Ast.cConstant
	type ('a, 'b) Either = ('a, 'b) C_Ast.either
	type CIntRepr = C_Ast.cIntRepr
	type CIntFlag = C_Ast.cIntFlag
	type CAssignOp = C_Ast.cAssignOp
	type Comment = C_Ast.comment
	(**)
	type 'a Reversed = 'a
	datatype CDeclrR = CDeclrR0 of C_Ast.ident C_Ast.optiona
	* NodeInfo C_Ast.cDerivedDeclarator list Reversed
	* NodeInfo C_Ast.cStringLiteral C_Ast.optiona
	* NodeInfo C_Ast.cAttribute list
	* NodeInfo
	type 'a Maybe = 'a C_Ast.optiona
	datatype 'a Located = Located of 'a * (Position * (Position * int))
	(**)
	fun CDeclrR ide l s a n = CDeclrR0 (ide, l, s, a, n)
	val reverse = rev
	val Nothing = C_Ast.None
	val Just = C_Ast.Some
	val False = false
	val True = true
	val Ident = C_Ast.Ident0
	(**)
	val CDecl_flat = fn l1 => C_Ast.CDecl l1 o map (fn (a, b, c) => ((a, b), c))
	fun flat3 (a, b, c) = ((a, b), c)
	fun maybe def f = fn C_Ast.None => def \| C_Ast.Some x => f x
	val Reversed = I
	(**)
	val From_string =
	C_Ast.SS_base
	o C_Ast.ST
	o implode
	o map (fn s => \<comment> \<open>prevent functions in \<^file>\<open>~~/src/HOL/String.thy\<close> of raising additional errors
	(e.g., see the ML code associated to \<^term>\<open>String.asciis_of_literal\<close>)\<close>
	if Symbol.is_char s then s
	else if Symbol.is_utf8 s then translate_string (fn c => "\\" ^ string_of_int (ord c)) s
	else s)
	o Symbol.explode
	val From_char_hd = hd o C_Ast.explode
	(**)
	val Namea = C_Ast.name
	(**)
	open C_Ast
	fun flip f b a = f a b
	open Basic_Library
	end
	\<close>

	section\<open>A General C11-AST iterator.\<close>

	ML\<open>

	signature C11_AST_LIB =
	sig
	(* some general combinators *)
	val fold_either: ('a -> 'b -> 'c) -> ('d -> 'b -> 'c) -> ('a, 'd) C_Ast.either -> 'b -> 'c
	val fold_optiona: ('a -> 'b -> 'b) -> 'a C_Ast.optiona -> 'b -> 'b

	datatype data = data_bool of bool \| data_int of int
	\| data_string of string \| data_absstring of string

	type node_content = { tag : string,
	sub_tag : string,
	args : data list }

	(* conversions of enumeration types to string codes *)
	val toString_cBinaryOp : C_Ast.cBinaryOp -> string
	val toString_cIntFlag : C_Ast.cIntFlag -> string
	val toString_cIntRepr : C_Ast.cIntRepr -> string
	val toString_cUnaryOp : C_Ast.cUnaryOp -> string
	val toString_cAssignOp : C_Ast.cAssignOp -> string
	val toString_abr_string: C_Ast.abr_string -> string
	val toString_nodeinfo : C_Ast.nodeInfo -> string


	(* a generic iterator collection over the entire C11 - AST. The lexical
	"leaves" of the AST's are parametric ('a). THe collecyot function "g" (see below)
	gets as additional parameter a string-key representing its term key
	(and sometimes local information such as enumeration type keys). *)
	(* Caveat : Assembly is currently not supported *)
	(* currently a special case since idents are not properly abstracted in the src files of the
	AST generation: *)
	val fold_ident: 'a -> (node_content -> 'a -> 'b -> 'c) -> C_Ast.ident -> 'b -> 'c
	(* the "Leaf" has to be delivered from the context, the internal non-parametric nodeinfo
	is currently ignored. HACK. *)

	val fold_cInteger: (node_content -> 'a -> 'b) -> C_Ast.cInteger -> 'a -> 'b
	val fold_cConstant: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cConstant -> 'b -> 'b
	val fold_cStringLiteral: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cStringLiteral -> 'b -> 'b


	val fold_cArraySize: 'a -> (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cArraySize -> 'b -> 'b
	val fold_cAttribute: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cAttribute -> 'b -> 'b
	val fold_cBuiltinThing: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cBuiltinThing -> 'b -> 'b
	val fold_cCompoundBlockItem: (node_content -> 'a -> 'b -> 'b)
	-> 'a C_Ast.cCompoundBlockItem -> 'b -> 'b
	val fold_cDeclaration: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cDeclaration -> 'b -> 'b
	val fold_cDeclarationSpecifier: (node_content -> 'a -> 'b -> 'b)
	-> 'a C_Ast.cDeclarationSpecifier -> 'b -> 'b
	val fold_cDeclarator: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cDeclarator -> 'b -> 'b
	val fold_cDerivedDeclarator: (node_content -> 'a -> 'b -> 'b)
	-> 'a C_Ast.cDerivedDeclarator -> 'b -> 'b
	val fold_cEnumeration: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cEnumeration -> 'b -> 'b
	val fold_cExpression: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cExpression -> 'b -> 'b
	val fold_cInitializer: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cInitializer -> 'b -> 'b
	val fold_cPartDesignator: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cPartDesignator -> 'b -> 'b
	val fold_cStatement: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cStatement -> 'b -> 'b
	val fold_cStructureUnion : (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cStructureUnion -> 'b -> 'b
	val fold_cTypeQualifier: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cTypeQualifier -> 'b -> 'b
	val fold_cTypeSpecifier: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cTypeSpecifier -> 'b -> 'b
	val fold_cExternalDeclaration: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cExternalDeclaration -> 'b -> 'b
	val fold_cTranslationUnit: (node_content -> 'a -> 'b -> 'b) -> 'a C_Ast.cTranslationUnit -> 'b -> 'b

	(* universal sum type : *)

	datatype 'a C11_Ast =
	mk_cInteger of C_Ast.cInteger
	\| mk_cConstant of 'a C_Ast.cConstant
	\| mk_cStringLiteral of 'a C_Ast.cStringLiteral
	\| mk_cArraySize of 'a C_Ast.cArraySize
	\| mk_cAttribute of 'a C_Ast.cAttribute
	\| mk_cBuiltinThing of 'a C_Ast.cBuiltinThing
	\| mk_cCompoundBlockItem of 'a C_Ast.cCompoundBlockItem
	\| mk_cDeclaration of 'a C_Ast.cDeclaration
	\| mk_cDeclarationSpecifier of 'a C_Ast.cDeclarationSpecifier
	\| mk_cDeclarator of 'a C_Ast.cDeclarator
	\| mk_cDerivedDeclarator of 'a C_Ast.cDerivedDeclarator
	\| mk_cEnumeration of 'a C_Ast.cEnumeration
	\| mk_cExpression of 'a C_Ast.cExpression
	\| mk_cInitializer of 'a C_Ast.cInitializer
	\| mk_cPartDesignator of 'a C_Ast.cPartDesignator
	\| mk_cStatement of 'a C_Ast.cStatement
	\| mk_cStructureUnion of 'a C_Ast.cStructureUnion
	\| mk_cTypeQualifier of 'a C_Ast.cTypeQualifier
	\| mk_cTypeSpecifier of 'a C_Ast.cTypeSpecifier
	\| mk_cStructTag of C_Ast.cStructTag
	\| mk_cUnaryOp of C_Ast.cUnaryOp
	\| mk_cAssignOp of C_Ast.cAssignOp
	\| mk_cBinaryOp of C_Ast.cBinaryOp
	\| mk_cIntFlag of C_Ast.cIntFlag
	\| mk_cIntRepr of C_Ast.cIntRepr
	\| mk_cExternalDeclaration of 'a C_Ast.cExternalDeclaration
	\| mk_cTranslationUnit of 'a C_Ast.cTranslationUnit



	end


	structure C11_Ast_Lib : C11_AST_LIB =
	struct
	local open C_Ast in

	datatype data = data_bool of bool \| data_int of int
	\| data_string of string \| data_absstring of string

	type node_content = { tag : string,
	sub_tag : string,
	args : data list }

	fun TT s = { tag = s, sub_tag = "", args = [] }
	fun TTT s t = { tag = s, sub_tag = t, args = [] }
	fun ({ tag,sub_tag,args} #>> S) = { tag = tag, sub_tag = sub_tag, args = args @ S }

	fun fold_optiona _ None st = st \| fold_optiona g (Some a) st = g a st;
	fun fold_either g1 _ (Left a) st = g1 a st
	\|fold_either _ g2 (Right a) st = g2 a st

	fun toString_cStructTag (X:C_Ast.cStructTag) = @{make_string} X

	fun toString_cIntFlag (X:C_Ast.cIntFlag) = @{make_string} X

	fun toString_cIntRepr (X:C_Ast.cIntRepr) = @{make_string} X

	fun toString_cUnaryOp (X:C_Ast.cUnaryOp) = @{make_string} X

	fun toString_cAssignOp (X:C_Ast.cAssignOp) = @{make_string} X

	fun toString_cBinaryOp (X:C_Ast.cBinaryOp) = @{make_string} X

	fun toString_cIntFlag (X:C_Ast.cIntFlag) = @{make_string} X

	fun toString_cIntRepr (X:C_Ast.cIntRepr) = @{make_string} X

	fun dark_matter x = XML.content_of (YXML.parse_body x)


	fun toString_abr_string S = case to_String_b_a_s_e S of
	ST X => dark_matter X
	\| STa S => map (dark_matter o Int.toString) S
	\|> String.concatWith ","
	\|> enclose "[" "]"

	fun toString_nodeinfo (NodeInfo0 (positiona, (positiona', i), namea)) =
	let val Position0 (i1,abrS,i2,i3) = positiona;
	val Position0 (i1',abrS',i2',i3') = positiona';
	val Name0 X = namea;
	in "<"^Int.toString i1^" : "^toString_abr_string abrS^" : "
	^ Int.toString i2 ^" : " ^ Int.toString i3 ^ " : " ^
	Int.toString i1'^" : "^toString_abr_string abrS'^" : "
	^ Int.toString i2' ^" : " ^ Int.toString i3' ^ "\|" ^ Int.toString i ^"::"
	^ Int.toString X ^ ">"
	end
	\|toString_nodeinfo (OnlyPos0 (positiona, (positiona', i))) =
	let val Position0 (i1,abrS,i2,i3) = positiona;
	val Position0 (i1',abrS',i2',i3') = positiona';
	in "<"^Int.toString i1^" : "^toString_abr_string abrS^" : "
	^ Int.toString i2 ^" : " ^ Int.toString i3 ^ " : " ^
	Int.toString i1'^" : "^toString_abr_string abrS'^" : "
	^ Int.toString i2' ^" : " ^ Int.toString i3' ^ "\|" ^ Int.toString i ^ ">"
	end;


	fun toString_Chara (Chara(b1,b2,b3,b4,b5,b6,b7,b8)) =
	let val v1 = (b1 ? (K 0)) (128)
	val v2 = (b2 ? (K 0)) (64)
	val v3 = (b3 ? (K 0)) (32)
	val v4 = (b4 ? (K 0)) (16)
	val v5 = (b5 ? (K 0)) (8)
	val v6 = (b6 ? (K 0)) (4)
	val v7 = (b7 ? (K 0)) (2)
	val v8 = (b8 ? (K 0)) (1)
	in String.implode[Char.chr(v1+v2+v3+v4+v5+v6+v7+v8)] end

	(* could and should be done much more: change this on demand. *)
	fun fold_cInteger g' (CInteger0 (i: int, r: cIntRepr, rfl:cIntFlag flags)) st =
	st \|> g'(TT "CInteger0"
	#>> [data_int i,
	data_string (@{make_string} r),
	data_string (@{make_string} rfl)])
	fun fold_cChar g' (CChar0(c : char, b:bool)) st =
	st \|> g' (TT"CChar0"
	#>> [data_string (toString_Chara c),data_bool (b)])
	\| fold_cChar g' (CChars0(cs : char list, b:bool)) st =
	let val cs' = cs \|> map toString_Chara
	\|> String.concat
	in st \|> g' (TT"CChars0" #>> [data_string cs',data_bool b]) end
	fun fold_cFloat g' (CFloat0 (bstr: abr_string)) st =
	st \|> g' (TT"CChars0"#>> [data_string (@{make_string} bstr)])
	fun fold_cString g' (CString0 (bstr: abr_string, b: bool)) st =
	st \|> g' (TT"CString0"#>> [data_string (@{make_string} bstr), data_bool b])


	fun fold_cConstant g (CIntConst0 (i: cInteger, a)) st = st \|> fold_cInteger (fn x=>g x a) i
	\|> g (TT"CIntConst0") a
	\| fold_cConstant g (CCharConst0 (c : cChar, a)) st = st \|> fold_cChar (fn x=>g x a) c
	\|> g (TT"CCharConst0") a
	\| fold_cConstant g (CFloatConst0 (f : cFloat, a)) st = st \|> fold_cFloat (fn x=>g x a) f
	\|> g (TT"CFloatConst0") a
	\| fold_cConstant g (CStrConst0 (s : cString, a))st = st \|> fold_cString (fn x=>g x a) s
	\|> g (TT"CStrConst0") a

	fun fold_ident a g (Ident0(bstr : abr_string, i : int, ni: nodeInfo (* hack !!! *))) st =
	st \|> g (TT "Ident0"
	#>> [data_string (@{make_string} bstr),
	data_int i,
	data_string (@{make_string} ni)
	]) a
	(* \|> fold_cString (fn x=>g x a) *)
	fun fold_cStringLiteral g (CStrLit0(cs:cString, a)) st = st \|> fold_cString (fn x=>g x a) cs
	\|> g (TT"CStrLit0") a


	fun fold_cTypeSpecifier g (CAtomicType0 (decl : 'a cDeclaration, a)) st =
	st \|> fold_cDeclaration g decl \|> g (TT"CAtomicType0") a
	\| fold_cTypeSpecifier g (CBoolType0 a) st = st \|> g (TT"CBoolType0") a
	\| fold_cTypeSpecifier g (CCharType0 a) st = st \|> g (TT"CCharType0") a
	\| fold_cTypeSpecifier g (CComplexType0 a) st = st \|> g (TT"CComplexType0") a
	\| fold_cTypeSpecifier g (CDoubleType0 a) st = st \|> g (TT"CDoubleType0") a
	\| fold_cTypeSpecifier g (CEnumType0(e: 'a cEnumeration, a)) st =
	st \|> fold_cEnumeration g e
	\|> g (TT"CEnumType0") a
	\| fold_cTypeSpecifier g (CFloatType0 a) st = st \|> g (TT"CFloatType0") a
	\| fold_cTypeSpecifier g (CInt128Type0 a) st = st \|> g (TT"CInt128Type0") a
	\| fold_cTypeSpecifier g (CIntType0 a) st = st \|> g (TT"CIntType0") a
	\| fold_cTypeSpecifier g (CLongType0 a) st = st \|> g (TT"CLongType0") a
	\| fold_cTypeSpecifier g (CSUType0 (su: 'a cStructureUnion, a)) st =
	st \|> fold_cStructureUnion g su
	\|> g (TT"CSUType0") a
	\| fold_cTypeSpecifier g (CShortType0 a) st = st \|> g (TT"CShortType0") a
	\| fold_cTypeSpecifier g (CSignedType0 a) st = st \|> g (TT"CSignedType0") a
	\| fold_cTypeSpecifier g (CTypeDef0 (id:ident, a)) st =
	st \|> fold_ident a g id
	\|> g (TT"CTypeDef0") a
	\| fold_cTypeSpecifier g (CTypeOfExpr0 (ex: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex
	\|> g (TT"CTypeOfExpr0") a
	\| fold_cTypeSpecifier g (CTypeOfType0 (decl: 'a cDeclaration, a)) st =
	st \|> fold_cDeclaration g decl
	\|> g (TT"CTypeOfType0") a
	\| fold_cTypeSpecifier g (CUnsigType0 a) st = st \|> g (TT"CUnsigType0") a
	\| fold_cTypeSpecifier g (CVoidType0 a) st = st \|> g (TT"CVoidType0") a


	and fold_cTypeQualifier g (CAtomicQual0 a) st = g (TT"CAtomicQual0") a st
	\| fold_cTypeQualifier g (CAttrQual0 (CAttr0 (id,eL:'a cExpression list, a))) st =
	st \|> fold_ident a g id
	\|> fold(fold_cExpression g) eL
	\|> g (TT"CAttrQual0") a
	\| fold_cTypeQualifier g (CConstQual0 a) st = st \|> g (TT"CConstQual0") a
	\| fold_cTypeQualifier g (CNonnullQual0 a) st = st \|> g (TT"CNonnullQual0") a
	\| fold_cTypeQualifier g (CNullableQual0 a) st = st \|> g (TT"CNullableQual0") a
	\| fold_cTypeQualifier g (CRestrQual0 a) st = st \|> g (TT"CRestrQual0") a
	\| fold_cTypeQualifier g (CVolatQual0 a) st = st \|> g (TT"CVolatQual0") a

	and fold_cStatement g (CLabel0(id:ident, s:'a cStatement,
	aL: 'a cAttribute list, a)) st=
	st \|> fold_ident a g id
	\|> fold_cStatement g s
	\|> fold(fold_cAttribute g) aL
	\|> g (TT"CLabel0") a
	\| fold_cStatement g (CCase0(ex: 'a cExpression,
	stmt: 'a cStatement, a)) st =
	st \|> fold_cExpression g ex
	\|> fold_cStatement g stmt
	\|> g (TT"CCase0") a
	\| fold_cStatement g (CCases0(ex1: 'a cExpression,
	ex2: 'a cExpression,
	stmt:'a cStatement, a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cExpression g ex2
	\|> fold_cStatement g stmt
	\|> g (TT"CCases0") a
	\| fold_cStatement g (CDefault0(stmt:'a cStatement, a)) st =
	st \|> fold_cStatement g stmt
	\|> g (TT"CDefault0") a
	\| fold_cStatement g (CExpr0(ex_opt:'a cExpression optiona, a)) st =
	st \|> fold_optiona (fold_cExpression g) ex_opt
	\|> g (TT"CExpr0") a
	\| fold_cStatement g (CCompound0(idS : ident list,
	cbiS: 'a cCompoundBlockItem list, a)) st =
	st \|> fold(fold_ident a g) idS
	\|> fold(fold_cCompoundBlockItem g) cbiS
	\|> g (TT"CCompound0") a
	\| fold_cStatement g (CIf0(ex1:'a cExpression,stmt: 'a cStatement,
	stmt_opt: 'a cStatement optiona, a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cStatement g stmt
	\|> fold_optiona (fold_cStatement g) stmt_opt
	\|> g (TT"CIf0") a
	\| fold_cStatement g (CSwitch0(ex1:'a cExpression,
	stmt: 'a cStatement, a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cStatement g stmt
	\|> g (TT"CSwitch0") a
	\| fold_cStatement g (CWhile0(ex1:'a cExpression,
	stmt: 'a cStatement, b: bool, a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cStatement g stmt
	\|> g (TT"CWhile0" #>> [data_bool b]) a
	\| fold_cStatement g (CFor0(ex0:('a cExpression optiona, 'a cDeclaration) either,
	ex1_opt: 'a cExpression optiona,
	ex2_opt: 'a cExpression optiona,
	stmt: 'a cStatement, a)) st =
	st \|> fold_either (fold_optiona (fold_cExpression g))
	(fold_cDeclaration g) ex0
	\|> fold_optiona (fold_cExpression g) ex1_opt
	\|> fold_optiona (fold_cExpression g) ex2_opt
	\|> fold_cStatement g stmt
	\|> g (TT"CFor0") a
	\| fold_cStatement g (CGoto0(id: ident, a)) st =
	st \|> fold_ident a g id
	\|> g (TT"CGoto0") a
	\| fold_cStatement g (CGotoPtr0(ex1:'a cExpression, a)) st =
	st \|> fold_cExpression g ex1 \|> g (TT"CGotoPtr0") a
	\| fold_cStatement g (CCont0 a) st = st \|> g (TT"CCont0") a
	\| fold_cStatement g (CBreak0 a) st = st \|> g (TT"CBreak0") a
	\| fold_cStatement g (CReturn0 (ex:'a cExpression optiona,a)) st =
	st \|> fold_optiona (fold_cExpression g) ex \|> g (TT"CReturn0") a
	\| fold_cStatement g (CAsm0(_: 'a cAssemblyStatement, a)) st =
	(* assembly ignored so far *)
	st \|> g (TT"CAsm0") a

	and fold_cExpression g (CComma0 (eL:'a cExpression list, a)) st =
	st \|> fold(fold_cExpression g) eL \|> g (TT"CComma0") a
	\| fold_cExpression g (CAssign0(aop:cAssignOp,
	ex1:'a cExpression,
	ex2:'a cExpression,a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cExpression g ex2
	\|> g (TTT"CAssign0" (toString_cAssignOp aop)) a
	\| fold_cExpression g (CCond0( ex1:'a cExpression,
	ex2opt: 'a cExpression optiona, (* bescheuert ! Wieso option ?*)
	ex3: 'a cExpression,a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_optiona (fold_cExpression g) ex2opt
	\|> fold_cExpression g ex3 \|> g (TT"CCond0") a
	\| fold_cExpression g (CBinary0(bop: cBinaryOp, ex1: 'a cExpression,ex2: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cExpression g ex2
	\|> g (TTT"CBinary0"(toString_cBinaryOp bop)) a
	\| fold_cExpression g (CCast0(decl:'a cDeclaration, ex: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex
	\|> fold_cDeclaration g decl
	\|> g (TT"CCast0") a
	\| fold_cExpression g (CUnary0(unop:cUnaryOp, ex: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex
	\|> g (TT("CUnary0 "^toString_cUnaryOp unop)) a
	\| fold_cExpression g (CSizeofExpr0(ex:'a cExpression, a)) st =
	st \|> fold_cExpression g ex \|> g (TT"CSizeofExpr0") a
	\| fold_cExpression g (CSizeofType0(decl:'a cDeclaration,a)) st =
	st \|> fold_cDeclaration g decl \|> g (TT"CSizeofType0") a
	\| fold_cExpression g (CAlignofExpr0(ex:'a cExpression, a)) st =
	st \|> fold_cExpression g ex \|> g (TT"CAlignofExpr0") a
	\| fold_cExpression g (CAlignofType0(decl:'a cDeclaration, a)) st =
	st \|> fold_cDeclaration g decl \|> g (TT"CAlignofType0") a
	\| fold_cExpression g (CComplexReal0(ex:'a cExpression, a)) st =
	st \|> fold_cExpression g ex \|> g (TT"CComplexReal0") a
	\| fold_cExpression g (CComplexImag0(ex:'a cExpression, a)) st =
	st \|> fold_cExpression g ex \|> g (TT"CComplexImag0") a
	\| fold_cExpression g (CIndex0(ex1:'a cExpression, ex2: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cExpression g ex2
	\|> g (TT"CIndex0") a
	\| fold_cExpression g (CCall0(ex:'a cExpression, argS: 'a cExpression list, a)) st =
	st \|> fold_cExpression g ex
	\|> fold (fold_cExpression g) argS
	\|> g (TT"CCall0") a
	\| fold_cExpression g (CMember0(ex:'a cExpression, id:ident, b, a)) st =
	st \|> fold_cExpression g ex
	\|> fold_ident a g id
	\|> g (TT"CMember0"#>> [data_bool b]) a
	\| fold_cExpression g (CVar0(id:ident,a)) st = st \|> fold_ident a g id \|> g (TT"CVar0") a
	\| fold_cExpression g (CConst0(cc:'a cConstant)) st = st \|> fold_cConstant g cc
	\| fold_cExpression g (CCompoundLit0(decl:'a cDeclaration,
	eqn: ('a cPartDesignator list * 'a cInitializer) list, a)) st =
	st \|> fold(fn(S,init) =>
	fn st => st \|> fold(fold_cPartDesignator g) S
	\|> fold_cInitializer g init) eqn
	\|> fold_cDeclaration g decl
	\|> g (TT"CCompoundLit0") a
	\| fold_cExpression g (CGenericSelection0(ex:'a cExpression,
	eqn: ('a cDeclaration optiona*'a cExpression)list,a)) st =
	st \|> fold_cExpression g ex
	\|> fold (fn (d,ex) =>
	fn st => st \|> fold_optiona (fold_cDeclaration g) d
	\|> fold_cExpression g ex) eqn
	\|> g (TT"CGenericSelection0") a
	\| fold_cExpression g (CStatExpr0(stmt: 'a cStatement,a)) st =
	st \|> fold_cStatement g stmt \|> g (TT"CStatExpr0") a
	\| fold_cExpression g (CLabAddrExpr0(id:ident,a)) st =
	st \|> fold_ident a g id \|> g (TT"CLabAddrExpr0") a
	\| fold_cExpression g (CBuiltinExpr0(X: 'a cBuiltinThing)) st = st \|> fold_cBuiltinThing g X

	and fold_cDeclaration g (CDecl0(dsS : 'a cDeclarationSpecifier list,
	mkS: (('a cDeclarator optiona
	*'a cInitializer optiona)
	* 'a cExpression optiona) list,
	a)) st =
	st \|> fold(fold_cDeclarationSpecifier g) dsS
	\|> fold(fn ((d_o, init_o),ex_opt) =>
	fn st => st \|> fold_optiona(fold_cDeclarator g) d_o
	\|> fold_optiona(fold_cInitializer g) init_o
	\|> fold_optiona(fold_cExpression g) ex_opt) mkS
	\|> g (TT"CDecl0") a
	\| fold_cDeclaration g (CStaticAssert0(ex:'a cExpression, slit: 'a cStringLiteral, a)) st =
	st \|> fold_cExpression g ex
	\|> fold_cStringLiteral g slit
	\|> g (TT"CStaticAssert0") a

	and fold_cBuiltinThing g (CBuiltinVaArg0(ex:'a cExpression,decl: 'a cDeclaration,a)) st =
	st \|> fold_cExpression g ex
	\|> fold_cDeclaration g decl
	\|> g (TT"CBuiltinVaArg0") a
	\| fold_cBuiltinThing g (CBuiltinOffsetOf0(d: 'a cDeclaration, _: 'a cPartDesignator list, a)) st =
	st \|> fold_cDeclaration g d
	\|> g (TT"CBuiltinOffsetOf0") a
	\| fold_cBuiltinThing g (CBuiltinTypesCompatible0 (d1: 'a cDeclaration, d2: 'a cDeclaration,a)) st=
	st \|> fold_cDeclaration g d1
	\|> fold_cDeclaration g d2
	\|> g (TT"CBuiltinTypesCompatible0") a

	and fold_cInitializer g (CInitExpr0(ex: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex \|> g (TT"CInitExpr0") a
	\| fold_cInitializer g (CInitList0 (mms: ('a cPartDesignator list * 'a cInitializer) list,a)) st =
	st \|> fold(fn (a,b) =>
	fn st => st\|> fold(fold_cPartDesignator g) a
	\|> fold_cInitializer g b) mms
	\|> g (TT"CInitList0") a

	and fold_cPartDesignator g (CArrDesig0(ex: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex \|> g (TT"CArrDesig0") a
	\| fold_cPartDesignator g (CMemberDesig0(id: ident, a)) st =
	st \|> fold_ident a g id \|> g (TT"CMemberDesig0") a
	\| fold_cPartDesignator g (CRangeDesig0(ex1: 'a cExpression, ex2: 'a cExpression, a)) st =
	st \|> fold_cExpression g ex1
	\|> fold_cExpression g ex2
	\|> g (TT"CRangeDesig0") a

	and fold_cAttribute g (CAttr0(id: ident, exS: 'a cExpression list, a)) st =
	st \|> fold_ident a g id
	\|> fold(fold_cExpression g) exS
	\|> g (TT"CAttr0") a

	and fold_cEnumeration g (CEnum0 (ident_opt: ident optiona,
	exS_opt: ((ident * 'a cExpression optiona) list) optiona,
	attrS: 'a cAttribute list, a)) st =
	st \|> fold_optiona(fold_ident a g) ident_opt
	\|> fold_optiona(fold(
	fn (id,ex_o) =>
	fn st => st \|> fold_ident a g id
	\|> fold_optiona (fold_cExpression g) ex_o))
	exS_opt
	\|> fold(fold_cAttribute g) attrS
	\|> g (TT"CEnum0") a



	and fold_cArraySize a g (CNoArrSize0 (b: bool)) st =
	st \|> g (TT "CNoArrSize0" #>> [data_bool b]) a
	\| fold_cArraySize a g (CArrSize0 (b:bool, ex : 'a cExpression)) st =
	st \|> fold_cExpression g ex
	\|> g (TT "CNoArrSize0" #>> [data_bool b]) a


	and fold_cDerivedDeclarator g (CPtrDeclr0 (tqS: 'a cTypeQualifier list , a)) st =
	st \|> fold(fold_cTypeQualifier g) tqS
	\|> g (TT"CPtrDeclr0") a
	\| fold_cDerivedDeclarator g (CArrDeclr0 (tqS:'a cTypeQualifier list, aS: 'a cArraySize,a)) st =
	st \|> fold(fold_cTypeQualifier g) tqS
	\|> fold_cArraySize a g aS
	\|> g (TT"CArrDeclr0") a
	\| fold_cDerivedDeclarator g (CFunDeclr0 (decl_alt: (ident list,
	('a cDeclaration list * bool)) either,
	aS: 'a cAttribute list, a)) st =
	st \|> fold_either
	(fold(fold_ident a g))
	(fn (declS,b) =>
	fn st => st \|> fold (fold_cDeclaration g) declS
	\|> g (TTT "CFunDeclr0""decl_alt-Right"
	#>> [data_bool b]) a) decl_alt
	\|> fold(fold_cAttribute g) aS
	\|> g (TT"CFunDeclr0") a

	and fold_cDeclarationSpecifier g (CStorageSpec0(CAuto0 a)) st =
	st \|> g (TTT"CStorageSpec0" "CAuto0") a
	\|fold_cDeclarationSpecifier g (CStorageSpec0(CRegister0 a)) st =
	st \|> g (TTT"CStorageSpec0" "CRegister0") a
	\|fold_cDeclarationSpecifier g (CStorageSpec0(CStatic0 a)) st =
	st \|> g (TTT"CStorageSpec0" "CStatic0") a
	\|fold_cDeclarationSpecifier g (CStorageSpec0(CExtern0 a)) st =
	st \|> g (TTT"CStorageSpec0" "CExtern0") a
	\|fold_cDeclarationSpecifier g (CStorageSpec0(CTypedef0 a)) st =
	st \|> g (TTT"CStorageSpec0" "CTypedef0") a
	\|fold_cDeclarationSpecifier g (CStorageSpec0(CThread0 a)) st =
	st \|> g (TTT"CStorageSpec0" "CThread0") a

	\|fold_cDeclarationSpecifier g (CTypeSpec0(CVoidType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CVoidType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CCharType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CCharType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CShortType0 a)) st =
	st \|> g (TTT"TCTypeSpec0""CShortType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CIntType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CIntType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CLongType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CLongType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CFloatType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CFloatType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CDoubleType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CDoubleType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CSignedType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CSignedType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CUnsigType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CUnsigType0") a
	\|fold_cDeclarationSpecifier g (CTypeSpec0(CBoolType0 a)) st =
	st \|> g (TTT"CTypeSpec0""CBoolType0") a

	\|fold_cDeclarationSpecifier g (CTypeQual0(x: 'a cTypeQualifier)) st =
	st \|> fold_cTypeQualifier g x

	\|fold_cDeclarationSpecifier g (CFunSpec0(CInlineQual0 a)) st =
	st \|> g (TTT"CFunSpec0""CInlineQual0") a
	\|fold_cDeclarationSpecifier g (CFunSpec0(CNoreturnQual0 a)) st =
	st \|> g (TTT"CFunSpec0""CNoreturnQual0") a

	\|fold_cDeclarationSpecifier g (CAlignSpec0(CAlignAsType0(decl,a))) st =
	st \|> fold_cDeclaration g decl
	\|> g (TTT"CAlignSpec0""CAlignAsType0") a
	\|fold_cDeclarationSpecifier g (CAlignSpec0(CAlignAsExpr0(ex,a))) st =
	st \|> fold_cExpression g ex
	\|> g (TTT"CAlignSpec0""CAlignAsType0") a

	and fold_cDeclarator g (CDeclr0(id_opt: ident optiona,
	declS: 'a cDerivedDeclarator list,
	sl_opt: 'a cStringLiteral optiona,
	attrS: 'a cAttribute list, a)) st =
	st \|> fold_optiona(fold_ident a g) id_opt
	\|> fold (fold_cDerivedDeclarator g) declS
	\|> fold_optiona(fold_cStringLiteral g) sl_opt
	\|> fold(fold_cAttribute g) attrS
	\|> g (TT"CDeclr0") a

	and fold_cFunctionDef g (CFunDef0(dspecS: 'a cDeclarationSpecifier list,
	dclr: 'a cDeclarator,
	declsS: 'a cDeclaration list,
	stmt: 'a cStatement, a)) st =
	st \|> fold(fold_cDeclarationSpecifier g) dspecS
	\|> fold_cDeclarator g dclr
	\|> fold(fold_cDeclaration g) declsS
	\|> fold_cStatement g stmt
	\|> g (TT"CFunDef0") a

	and fold_cCompoundBlockItem g (CBlockStmt0 (stmt: 'a cStatement)) st =
	st \|> fold_cStatement g stmt
	\| fold_cCompoundBlockItem g (CBlockDecl0 (decl : 'a cDeclaration)) st =
	st \|> fold_cDeclaration g decl
	\| fold_cCompoundBlockItem g (CNestedFunDef0(fdef : 'a cFunctionDef)) st =
	st \|> fold_cFunctionDef g fdef

	and fold_cStructureUnion g (CStruct0( ct : cStructTag, id_a: ident optiona,
	declS_opt : ('a cDeclaration list) optiona,
	aS: 'a cAttribute list, a)) st =
	st \|> fold_optiona (fold_ident a g) id_a
	\|> fold_optiona (fold(fold_cDeclaration g)) declS_opt
	\|> fold(fold_cAttribute g) aS
	\|> g (TTT "CStruct0" (toString_cStructTag ct)) a
	and fold_cExternalDeclaration g (CDeclExt0(cd : 'a cDeclaration)) st =
	st \|> fold_cDeclaration g cd
	\| fold_cExternalDeclaration g (CFDefExt0(fd : 'a cFunctionDef)) st =
	st \|> fold_cFunctionDef g fd
	\| fold_cExternalDeclaration _ (CAsmExt0( _ : 'a cStringLiteral, _ : 'a)) _ = error"Inline assembler not supprted"
	and fold_cTranslationUnit g (CTranslUnit0 (ceL : 'a cExternalDeclaration list, a : 'a)) st =
	st \|> fold(fold_cExternalDeclaration g) ceL
	\|> g (TT"CTranslUnit0") a


	(* missing
	datatype 'a cTranslationUnit = CTranslUnit0 of 'a cExternalDeclaration list * 'a
	*)


	datatype 'a C11_Ast =
	mk_cInteger of C_Ast.cInteger
	\| mk_cStructTag of C_Ast.cStructTag
	\| mk_cUnaryOp of C_Ast.cUnaryOp
	\| mk_cAssignOp of C_Ast.cAssignOp
	\| mk_cBinaryOp of C_Ast.cBinaryOp
	\| mk_cIntFlag of C_Ast.cIntFlag
	\| mk_cIntRepr of C_Ast.cIntRepr
	\| mk_cConstant of 'a C_Ast.cConstant
	\| mk_cStringLiteral of 'a C_Ast.cStringLiteral
	\| mk_cArraySize of 'a C_Ast.cArraySize
	\| mk_cAttribute of 'a C_Ast.cAttribute
	\| mk_cBuiltinThing of 'a C_Ast.cBuiltinThing
	\| mk_cCompoundBlockItem of 'a C_Ast.cCompoundBlockItem
	\| mk_cDeclaration of 'a C_Ast.cDeclaration
	\| mk_cDeclarationSpecifier of 'a C_Ast.cDeclarationSpecifier
	\| mk_cDeclarator of 'a C_Ast.cDeclarator
	\| mk_cDerivedDeclarator of 'a C_Ast.cDerivedDeclarator
	\| mk_cEnumeration of 'a C_Ast.cEnumeration
	\| mk_cExpression of 'a C_Ast.cExpression
	\| mk_cInitializer of 'a C_Ast.cInitializer
	\| mk_cPartDesignator of 'a C_Ast.cPartDesignator
	\| mk_cStatement of 'a C_Ast.cStatement
	\| mk_cStructureUnion of 'a C_Ast.cStructureUnion
	\| mk_cTypeQualifier of 'a C_Ast.cTypeQualifier
	\| mk_cTypeSpecifier of 'a C_Ast.cTypeSpecifier
	\| mk_cExternalDeclaration of 'a C_Ast.cExternalDeclaration
	\| mk_cTranslationUnit of 'a C_Ast.cTranslationUnit


	end

	end (struct )
	\<close>

	-
	-ML\<open>open Position\<close>
	-
	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy
	@@ -1,1179 +1,1203 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	- * Author: Frédéric Tuong, Burkhart Wolff, Université Paris-Saclay
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Interface: Inner and Outer Commands\<close>

	theory C_Command
	imports C_Eval
	keywords "C" :: thy_decl % "ML"
	and "C_file" :: thy_load % "ML"
	and "C_export_boot" :: thy_decl % "ML"
	and "C_export_file" :: thy_decl
	and "C_prf" :: prf_decl % "proof" (* FIXME % "ML" ?? *)
	and "C_val" :: diag % "ML"
	begin

	subsection \<open>Parsing Entry-Point: Error and Acceptance Cases\<close>

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/Tools/ghc.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Tools/ghc.ML\<close>\<close>
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	+(* Title: Pure/Tools/ghc.ML
	+ Author: Makarius

	+Support for GHC: Glasgow Haskell Compiler.
	+))
	\<open>
	structure C_Serialize =
	struct

	( string literals )

	fun print_codepoint c =
	(case c of
	10 => "\\n"
	\| 9 => "\\t"
	\| 11 => "\\v"
	\| 8 => "\\b"
	\| 13 => "\\r"
	\| 12 => "\\f"
	\| 7 => "\\a"
	\| 27 => "\\e"
	\| 92 => "\\\\"
	\| 63 => "\\?"
	\| 39 => "\\'"
	\| 34 => "\\\""
	\| c =>
	if c >= 32 andalso c < 127 then chr c
	else error "Not yet implemented");

	fun print_symbol sym =
	- let val ord = SML90.ord; (* copied from ML_init in Isabelle2020. *)
	- in
	- (case Symbol.decode sym of
	- Symbol.Char s => print_codepoint (ord s)
	- \| Symbol.UTF8 s => UTF8.decode_permissive s \|> map print_codepoint \|> implode
	- \| Symbol.Sym s => "\\092<" ^ s ^ ">"
	- \| Symbol.Control s => "\\092<^" ^ s ^ ">"
	- \| _ => translate_string (print_codepoint o ord) sym)
	- end;
	+ (case Symbol.decode sym of
	+ Symbol.Char s => print_codepoint (ord s)
	+ \| Symbol.UTF8 s => UTF8.decode_permissive s \|> map print_codepoint \|> implode
	+ \| Symbol.Sym s => "\\092<" ^ s ^ ">"
	+ \| Symbol.Control s => "\\092<^" ^ s ^ ">"
	+ \| _ => translate_string (print_codepoint o ord) sym);

	val print_string = quote o implode o map print_symbol o Symbol.explode;
	end
	\<close>

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/Tools/generated_files.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Tools/generated_files.ML\<close>\<close>
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	+(* Title: Pure/Tools/generated_files.ML
	+ Author: Makarius

	+Generated source files for other languages: with antiquotations, without Isabelle symbols.
	+))
	\<open>
	structure C_Generated_Files =
	struct

	val c_dir = "C";
	val c_ext = "c";
	val c_make_comment = enclose "/" "/";

	( context data )

	(* file types *)

	fun get_file_type ext =
	if ext = "" then error "Bad file extension"
	else if c_ext = ext then ()
	else error ("Unknown file type for extension " ^ quote ext);



	( Isar commands )

	(* generate_file *)

	fun generate_file (binding, src_content) lthy =
	let
	val (path, pos) = Path.dest_binding binding;
	val () =
	get_file_type (#2 (Path.split_ext path))
	handle ERROR msg => error (msg ^ Position.here pos);
	val header = c_make_comment " generated by Isabelle ";
	val content = header ^ "\n" ^ src_content;
	in lthy \|> (Local_Theory.background_theory o Generated_Files.add_files) (binding, content) end;



	( concrete file types )

	val _ =
	Theory.setup
	(Generated_Files.file_type \<^binding>\<open>C\<close>
	{ext = c_ext,
	make_comment = c_make_comment,
	make_string = C_Serialize.print_string});
	end
	\<close>

	ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Eval\<close>\<close> \<open>

	signature C_MODULE =
	sig
	structure Data_Accept : GENERIC_DATA
	structure Data_In_Env : GENERIC_DATA
	structure Data_In_Source : GENERIC_DATA
	structure Data_Term : GENERIC_DATA

	structure C_Term:
	sig
	val key0_default: string
	val key0_expression: string
	val key0_external_declaration: string
	val key0_statement: string
	val key0_translation_unit: string
	val key_default: Input.source
	val key_expression: Input.source
	val key_external_declaration: Input.source
	val key_statement: Input.source
	val key_translation_unit: Input.source
	val map_default: (C_Grammar_Rule.ast_generic -> C_Env.env_lang -> local_theory -> term) -> theory -> theory
	val map_expression: (C_Grammar_Rule_Lib.CExpr -> C_Env.env_lang -> local_theory -> term) -> theory -> theory
	val map_external_declaration:
	(C_Grammar_Rule_Lib.CExtDecl -> C_Env.env_lang -> local_theory -> term) -> theory -> theory
	val map_statement: (C_Grammar_Rule_Lib.CStat -> C_Env.env_lang -> local_theory -> term) -> theory -> theory
	val map_translation_unit:
	(C_Grammar_Rule_Lib.CTranslUnit -> C_Env.env_lang -> local_theory -> term) -> theory -> theory
	val tok0_expression: string * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tok0_external_declaration: string * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tok0_statement: string * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tok0_translation_unit: string * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tok_expression: Input.source * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tok_external_declaration: Input.source * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tok_statement: Input.source * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tok_translation_unit: Input.source * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)
	val tokens: (string * ('a * 'a -> (C_Grammar.Tokens.svalue, 'a) LALR_Parser_Eval.Token.token)) list
	end
	structure C_Term':
	sig
	val accept:
	local_theory ->
	(Input.source * (Position.range -> (C_Grammar.Tokens.svalue, Position.T) LALR_Parser_Eval.Token.token)) option ->
	(Input.source -> Context.generic -> (C_Grammar.Tokens.svalue, Position.T) LALR_Parser_Eval.Token.token) *
	(Data_In_Env.T ->
	'a * (C_Grammar_Rule.ast_generic * 'b * 'c) ->
	{context: Context.generic, error_lines: 'd, reports_text: 'e} ->
	term * {context: Context.generic, error_lines: 'd, reports_text: 'e})
	val err:
	C_Env.env_lang ->
	(LALR_Table.state * (C_Grammar_Parser.svalue0 * Position.T * Position.T)) list ->
	Position.T ->
	{context: Context.generic, error_lines: string list, reports_text: Position.report_text list} ->
	term * {context: Context.generic, error_lines: string list, reports_text: Position.report_text list}
	val eval_in:
	Input.source ->
	Context.generic ->
	(Context.generic ->
	C_Env.env_lang) ->
	(Input.source * (Position.range -> (C_Grammar.Tokens.svalue, Position.T) LALR_Parser_Eval.Token.token)) option
	-> C_Lex.token list * (C_Env.error_lines -> string list) -> term
	val parse_translation:
	('a * (Input.source * (Position.range -> (C_Grammar.Tokens.svalue, Position.T) LALR_Parser_Eval.Token.token)) option)
	list
	-> ('a * (Proof.context -> term list -> term)) list
	end

	val accept:
	Data_In_Env.T ->
	'a * (C_Grammar_Rule.ast_generic * 'b * 'c) ->
	{context: Context.generic, error_lines: 'd, reports_text: 'e} ->
	unit * {context: Context.generic, error_lines: 'd, reports_text: 'e}
	val accept0:
	(Context.generic -> C_Grammar_Rule.ast_generic -> Data_In_Env.T -> Context.generic -> 'a) ->
	Data_In_Env.T -> C_Grammar_Rule.ast_generic -> Context.generic -> 'a
	val c_enclose: string -> string -> Input.source -> C_Lex.token list * (string list -> string list)
	val env: Context.generic -> Data_In_Env.T
	val env0: Proof.context -> Data_In_Env.T
	val err:
	C_Env.env_lang ->
	(LALR_Table.state * (C_Grammar_Parser.svalue0 * Position.T * Position.T)) list ->
	Position.T ->
	{context: Context.generic, error_lines: string list, reports_text: Position.report_text list} ->
	unit * {context: Context.generic, error_lines: string list, reports_text: Position.report_text list}
	val err0:
	'a ->
	'b ->
	Position.T ->
	{context: 'c, error_lines: string list, reports_text: 'd} ->
	{context: 'c, error_lines: string list, reports_text: 'd}
	val eval_in: Input.source -> Context.generic option -> C_Lex.token list * (C_Env.error_lines -> string list) -> unit
	val eval_source: Input.source -> unit
	val exec_eval: Input.source -> Context.generic -> Context.generic
	val start: Input.source -> Context.generic -> (C_Grammar.Tokens.svalue, Position.T) LALR_Parser_Eval.Token.token


	(* toplevel command semantics of Isabelle_C *)
	val C: Input.source -> Context.generic -> Context.generic
	- val C': C_Env.env_lang -> Input.source -> Context.generic -> Context.generic
	+ val C': C_Env.env_lang option -> Input.source -> Context.generic -> Context.generic
	val C_export_boot: Input.source -> Context.generic -> generic_theory
	val C_export_file: Position.T * 'a -> Proof.context -> Proof.context
	val C_prf: Input.source -> Proof.state -> Proof.state

	end

	structure C_Module : C_MODULE =
	struct

	structure Data_In_Source = Generic_Data
	- (type T = Input.source list
	- val empty = []
	- val merge = K empty)
	+(
	+ type T = Input.source list
	+ val empty = []
	+ val merge = K empty
	+)

	structure Data_In_Env = Generic_Data
	- (type T = C_Env.env_lang
	- val empty = C_Env.empty_env_lang
	- val merge = K empty)
	+(
	+ type T = C_Env.env_lang
	+ val empty = C_Env.empty_env_lang
	+ val merge = K empty
	+)

	structure Data_Accept = Generic_Data
	- (type T = C_Grammar_Rule.ast_generic -> C_Env.env_lang -> Context.generic -> Context.generic
	- fun empty _ _ = I
	- val merge = #2)
	+(
	+ type T = C_Grammar_Rule.ast_generic -> C_Env.env_lang -> Context.generic -> Context.generic
	+ fun empty _ _ = I
	+ val merge = #2
	+)

	structure Data_Term = Generic_Data
	- (type T = (C_Grammar_Rule.ast_generic -> C_Env.env_lang -> local_theory -> term) Symtab.table
	- val empty = Symtab.empty
	- val merge = #2)
	+(
	+ type T = (C_Grammar_Rule.ast_generic -> C_Env.env_lang -> local_theory -> term) Symtab.table
	+ val empty = Symtab.empty
	+ val merge = #2
	+)

	(* keys for major syntactic categories *)
	structure C_Term =
	struct
	- val key_translation_unit = \<open>translation_unit\<close>
	- val key_external_declaration = \<open>external_declaration\<close>
	- val key_statement = \<open>statement\<close>
	- val key_expression = \<open>expression\<close>
	- val key_default = \<open>default\<close>
	+val key_translation_unit = \<open>translation_unit\<close>
	+val key_external_declaration = \<open>external_declaration\<close>
	+val key_statement = \<open>statement\<close>
	+val key_expression = \<open>expression\<close>
	+val key_default = \<open>default\<close>

	local
	- val source_content = Input.source_content #> #1
	+val source_content = Input.source_content #> #1
	in
	- val key0_translation_unit = source_content key_translation_unit
	- val key0_external_declaration = source_content key_external_declaration
	- val key0_statement = source_content key_statement
	- val key0_expression = source_content key_expression
	- val key0_default = source_content key_default
	+val key0_translation_unit = source_content key_translation_unit
	+val key0_external_declaration = source_content key_external_declaration
	+val key0_statement = source_content key_statement
	+val key0_expression = source_content key_expression
	+val key0_default = source_content key_default
	end

	-val tok0_translation_unit = (key0_translation_unit, C_Grammar.Tokens.start_translation_unit)
	+val tok0_translation_unit = (key0_translation_unit, C_Grammar.Tokens.start_translation_unit)
	val tok0_external_declaration = ( key0_external_declaration
	, C_Grammar.Tokens.start_external_declaration)
	-val tok0_statement = (key0_statement, C_Grammar.Tokens.start_statement)
	-val tok0_expression = (key0_expression, C_Grammar.Tokens.start_expression)
	+val tok0_statement = (key0_statement, C_Grammar.Tokens.start_statement)
	+val tok0_expression = (key0_expression, C_Grammar.Tokens.start_expression)

	-val tok_translation_unit = (key_translation_unit, C_Grammar.Tokens.start_translation_unit)
	-val tok_external_declaration = ( key_external_declaration
	- , C_Grammar.Tokens.start_external_declaration)
	-val tok_statement = (key_statement, C_Grammar.Tokens.start_statement)
	-val tok_expression = (key_expression, C_Grammar.Tokens.start_expression)
	+val tok_translation_unit = (key_translation_unit, C_Grammar.Tokens.start_translation_unit)
	+val tok_external_declaration = ( key_external_declaration
	+ , C_Grammar.Tokens.start_external_declaration)
	+val tok_statement = (key_statement, C_Grammar.Tokens.start_statement)
	+val tok_expression = (key_expression, C_Grammar.Tokens.start_expression)

	val tokens = [ tok0_translation_unit
	, tok0_external_declaration
	, tok0_statement
	, tok0_expression ]

	local
	fun map_upd0 key v = Context.theory_map (Data_Term.map (Symtab.update (key, v)))
	fun map_upd key start f = map_upd0 key (f o the o start)
	in
	val map_translation_unit = map_upd key0_translation_unit C_Grammar_Rule.get_CTranslUnit
	val map_external_declaration = map_upd key0_external_declaration C_Grammar_Rule.get_CExtDecl
	val map_statement = map_upd key0_statement C_Grammar_Rule.get_CStat
	val map_expression = map_upd key0_expression C_Grammar_Rule.get_CExpr
	val map_default = map_upd0 key0_default
	end

	end

	fun env0 ctxt =
	case Config.get ctxt C_Options.starting_env of
	"last" => Data_In_Env.get (Context.Proof ctxt)
	\| "empty" => C_Env.empty_env_lang
	\| s => error ("Unknown option: " ^ s ^ Position.here (Config.pos_of C_Options.starting_env))

	val env = env0 o Context.proof_of

	fun start source context =
	Input.range_of source
	\|>
	let val s = Config.get (Context.proof_of context) C_Options.starting_rule
	in case AList.lookup (op =) C_Term.tokens s of
	SOME tok => tok
	\| NONE => error ("Unknown option: " ^ s
	^ Position.here (Config.pos_of C_Options.starting_rule))
	end

	fun err0 _ _ pos =
	C_Env.map_error_lines (cons ("Parser: No matching grammar rule" ^ Position.here pos))

	val err = pair () oooo err0

	-fun accept0 f (env_lang:C_Env.env_lang) ast =
	+fun accept0 f env_lang ast =
	Data_In_Env.put env_lang
	#> (fn context => f context ast env_lang (Data_Accept.get context ast env_lang context))

	-fun accept (env_lang:C_Env.env_lang) (_, (ast, _, _)) =
	+fun accept env_lang (_, (ast, _, _)) =
	pair () o C_Env.map_context (accept0 (K (K (K I))) env_lang ast)

	val eval_source = C_Context.eval_source env start err accept

	fun c_enclose bg en source =
	C_Lex.@@ ( C_Lex.@@ (C_Lex.read bg, C_Lex.read_source source)
	, C_Lex.read en);

	structure C_Term' =
	struct
	val err = pair Term.dummy oooo err0

	fun accept ctxt start_rule =
	let
	val (key, start) =
	case start_rule of NONE => (C_Term.key_default, start)
	\| SOME (key, start_rule) =>
	(key, fn source => fn _ => start_rule (Input.range_of source))
	val (key, pos) = Input.source_content key
	in
	( start
	, fn env_lang => fn (_, (ast, _, _)) =>
	C_Env.map_context'
	(accept0
	(fn context =>
	pair oo (case Symtab.lookup (Data_Term.get context) key of
	NONE => tap (fn _ => warning ("Representation function associated to\
	\ \"" ^ key ^ "\"" ^ Position.here pos
	^ " not found (returning a dummy term)"))
	(fn _ => fn _ => @{term "()"})
	\| SOME f => fn ast => fn env_lang => f ast env_lang ctxt))
	env_lang
	ast))
	end

	fun eval_in text context env start_rule =
	let
	val (start, accept) = accept (Context.proof_of context) start_rule
	in
	C_Context.eval_in (SOME context) env (start text) err accept
	end

	fun parse_translation l = l \|>
	map
	(apsnd
	(fn start_rule => fn ctxt => fn args =>
	let val msg = (case start_rule of NONE => C_Term.key_default
	\| SOME (key, _) => key)
	\|> Input.source_content \|> #1
	fun err () = raise TERM (msg, args)
	in
	case args of
	[(c as Const (\<^syntax_const>\<open>_constrain\<close>, _)) $ Free (s, _) $ p] =>
	(case Term_Position.decode_position p of
	SOME (pos, _) =>
	c
	$ let val src =
	uncurry
	(Input.source false)
	let val s0 = Symbol_Pos.explode (s, pos)
	val s = Symbol_Pos.cartouche_content s0
	in
	( Symbol_Pos.implode s
	, case s of [] => Position.no_range
	\| (_, pos0) :: _ => Position.range (pos0, s0 \|> List.last \|> snd))
	end
	in
	eval_in
	src
	(case Context.get_generic_context () of
	NONE => Context.Proof ctxt
	\| SOME context => Context.mapping I (K ctxt) context)
	(C_Stack.Data_Lang.get #> (fn NONE => env0 ctxt
	\| SOME (_, env_lang) => env_lang))
	start_rule
	(c_enclose "" "" src)
	end
	$ p
	\| NONE => err ())
	\| _ => err ()
	end))
	end

	fun eval_in text ctxt = C_Context.eval_in ctxt env (start text) err accept

	fun exec_eval source =
	Data_In_Source.map (cons source)
	#> ML_Context.exec (fn () => eval_source source)

	fun C_prf source =
	Proof.map_context (Context.proof_map (exec_eval source))
	#> Proof.propagate_ml_env

	fun C_export_boot source context =
	context
	\|> Config.put_generic ML_Env.ML_environment ML_Env.Isabelle
	\|> Config.put_generic ML_Env.ML_write_global true
	\|> exec_eval source
	\|> Config.restore_generic ML_Env.ML_write_global context
	\|> Config.restore_generic ML_Env.ML_environment context
	\|> Local_Theory.propagate_ml_env

	-val C: Input.source -> Context.generic -> Context.generic =
	- fn source =>
	- exec_eval source
	- #> Local_Theory.propagate_ml_env
	+fun C source =
	+ exec_eval source
	+ #> Local_Theory.propagate_ml_env

	-val C': C_Env.env_lang -> Input.source -> Context.generic -> Context.generic =
	- fn env_lang:C_Env.env_lang => fn src:Input.source => fn context:Context.generic =>
	- context
	- \|> C_Env.empty_env_tree
	- \|> C_Context.eval_source'
	- env_lang
	- (fn src => start src context)
	- err
	- accept
	- src
	- \|> (fn (_, {context, reports_text, error_lines}) =>
	- tap (fn _ => case error_lines of [] => () \| l => warning (cat_lines (rev l)))
	- (C_Stack.Data_Tree.map (curry C_Stack.Data_Tree_Args.merge (reports_text, []))
	- context))
	+val C' =
	+ let
	+ fun C env_lang src context =
	+ context
	+ \|> C_Env.empty_env_tree
	+ \|> C_Context.eval_source'
	+ env_lang
	+ (fn src => start src context)
	+ err
	+ accept
	+ src
	+ \|> (fn (_, {context, reports_text, error_lines}) =>
	+ tap (fn _ => case error_lines of [] => () \| l => warning (cat_lines (rev l)))
	+ (C_Stack.Data_Tree.map (curry C_Stack.Data_Tree_Args.merge (reports_text, []))
	+ context))
	+ in
	+ fn NONE => (fn src => C (env (Context.the_generic_context ())) src)
	+ \| SOME env_lang => C env_lang
	+ end

	fun C_export_file (pos, _) lthy =
	let
	val c_sources = Data_In_Source.get (Context.Proof lthy)
	val binding =
	Path.binding
	( Path.appends [ Path.basic C_Generated_Files.c_dir
	, Path.basic (string_of_int (length c_sources))
	, lthy \|> Proof_Context.theory_of \|> Context.theory_name \|> Path.explode
	\|> Path.ext C_Generated_Files.c_ext ]
	, pos)
	in
	lthy
	\|> C_Generated_Files.generate_file (binding, rev c_sources \|> map (Input.source_content #> #1)
	\|> cat_lines)
	\|> tap (Proof_Context.theory_of
	#> (fn thy => let val file = Generated_Files.get_file thy binding
	in Generated_Files.export_file thy file;
	writeln (Export.message thy Path.current);
	writeln (prefix " " (Generated_Files.print_file file))
	end))
	end
	end
	\<close>

	subsection \<open>Definitions of C11 Directives as C-commands\<close>

	subsubsection \<open>Initialization\<close>

	-ML \<comment> \<open>analogous to \<^theory>\<open>Pure\<close>\<close> \<open>
	+ML \<comment> \<open>\<^theory>\<open>Pure\<close>\<close> \<open>
	structure C_Directive :
	sig
	val setup_define:
	Position.T ->
	(C_Lex.token list -> string * Position.range -> Context.generic
	-> C_Lex.token list * Context.generic) ->
	(string * Position.range -> Context.generic -> Context.generic) -> theory -> theory
	end =
	struct
	local
	fun directive_update keyword data = C_Context.directive_update keyword (data, K (K (K I)))
	fun return f (env_cond, env) = ([], (env_cond, f env))
	fun directive_update_define pos f_toks f_antiq =
	directive_update ("define", pos)
	(return
	o
	(fn C_Lex.Define (_, C_Lex.Group1 ([], [tok3]), NONE, C_Lex.Group1 ([], toks)) =>
	let val map_ctxt =
	case (tok3, toks) of
	- (C_Lex.Token ((pos, _), (C_Lex.Ident, ident)),
	+ (C_Lex.Token ((pos, _), (C_Lex.Ident _, ident)),
	[C_Lex.Token (_, (C_Lex.Integer (_, C_Lex.Repr_decimal, []), integer))]) =>
	C_Env.map_context
	(Context.map_theory
	(Named_Target.theory_map
	(Specification.definition_cmd
	(SOME (Binding.make (ident, pos), NONE, NoSyn))
	[]
	[]
	(Binding.empty_atts, ident ^ " \<equiv> " ^ integer)
	true
	#> tap (fn ((_, (_, t)), ctxt) =>
	Output.information
	("Generating "
	^ Pretty.string_of (Syntax.pretty_term ctxt (Thm.prop_of t))
	^ Position.here
	(Position.range_position
	( C_Lex.pos_of tok3
	, C_Lex.end_pos_of (List.last toks)))))
	#> #2)))
	\| _ => I
	in
	fn (env_dir, env_tree) =>
	let val name = C_Lex.content_of tok3
	val pos = [C_Lex.pos_of tok3]
	val data = (pos, serial (), (C_Scan.Left (f_toks toks), f_antiq))
	in
	( Symtab.update (name, data) env_dir
	, env_tree \|> C_Context.markup_directive_define
	false
	(C_Ast.Left (data, C_Env_Ext.list_lookup env_dir name))
	pos
	name
	\|> map_ctxt)
	end
	end
	\| C_Lex.Define (_, C_Lex.Group1 ([], [tok3]), SOME (C_Lex.Group1 (_ :: toks_bl, _)), _)
	=>
	tap (fn _ => (* not yet implemented *)
	warning ("Ignored functional macro directive"
	^ Position.here
	(Position.range_position
	(C_Lex.pos_of tok3, C_Lex.end_pos_of (List.last toks_bl)))))
	\| _ => I))
	in
	val setup_define = Context.theory_map o C_Context0.Directives.map ooo directive_update_define

	val _ =
	Theory.setup
	(Context.theory_map
	(C_Context0.Directives.map
	(directive_update_define \<^here> (K o pair) (K I)
	#>
	directive_update ("undef", \<^here>)
	(return
	o
	(fn C_Lex.Undef (C_Lex.Group2 (_, _, [tok])) =>
	(fn (env_dir, env_tree) =>
	let val name = C_Lex.content_of tok
	val pos1 = [C_Lex.pos_of tok]
	val data = Symtab.lookup env_dir name
	in ( (case data of NONE => env_dir \| SOME _ => Symtab.delete name env_dir)
	, C_Context.markup_directive_define true
	(C_Ast.Right (pos1, data))
	pos1
	name
	env_tree)
	end)
	\| _ => I)))))
	end
	end
	\<close>

	subsection \<open>Definitions of C Annotation Commands\<close>
	subsubsection \<open>Library\<close>

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/Isar/toplevel.ML\<close>\<close> \<open>
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/toplevel.ML\<close>\<close> \<open>
	structure C_Inner_Toplevel =
	struct
	val theory = Context.map_theory
	fun local_theory' target f gthy =
	let
	val (finish, lthy) = Target_Context.switch_named_cmd target gthy;
	val lthy' = lthy
	\|> Local_Theory.new_group
	\|> f false
	\|> Local_Theory.reset_group;
	in finish lthy' end
	val generic_theory = I
	fun keep'' f = tap (f o Context.proof_of)
	end
	\<close>

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/Isar/isar_cmd.ML\<close>\<close> \<open>
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/isar_cmd.ML\<close>\<close> \<open>
	structure C_Inner_Isar_Cmd =
	struct


	( theory declarations )

	(* generic setup *)

	fun setup0 f_typ f_val src =
	fn NONE =>
	let val setup = "setup"
	in C_Context.expression
	"C_Ast"
	(Input.range_of src)
	setup
	(f_typ "C_Stack.stack_data"
	"C_Stack.stack_data_elem -> C_Env.env_lang -> Context.generic -> Context.generic")
	("fn context => \
	\let val (stack, env_lang) = C_Stack.Data_Lang.get' context \
	\in " ^ f_val setup "stack" ^ " (stack \|> hd) env_lang end context")
	(ML_Lex.read_source src) end
	\| SOME rule =>
	let val hook = "hook"
	in C_Context.expression
	"C_Ast"
	(Input.range_of src)
	hook
	(f_typ "C_Stack.stack_data"
	(C_Grammar_Rule.type_reduce rule
	^ " C_Stack.stack_elem -> C_Env.env_lang -> Context.generic -> Context.generic"))
	("fn context => \
	\let val (stack, env_lang) = C_Stack.Data_Lang.get' context \
	\in " ^ f_val hook
	"stack" ^ " "
	^ "(stack \
	\\|> hd \
	\\|> C_Stack.map_svalue0 C_Grammar_Rule.reduce" ^ Int.toString rule ^ ")\
	\env_lang \
	\end \
	\ context")
	(ML_Lex.read_source src)
	end
	val setup = setup0 (fn a => fn b => a ^ " -> " ^ b) (fn a => fn b => a ^ " " ^ b)
	val setup' = setup0 (K I) K


	(* print theorems, terms, types etc. *)

	local

	fun string_of_term ctxt s =
	let
	val t = Syntax.read_term ctxt s;
	val T = Term.type_of t;
	val ctxt' = Proof_Context.augment t ctxt;
	in
	Pretty.string_of
	(Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t), Pretty.fbrk,
	Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' T)])
	end;

	fun print_item string_of (modes, arg) ctxt =
	Print_Mode.with_modes modes (fn () => writeln (string_of ctxt arg)) ();

	in

	val print_term = print_item string_of_term;

	end;

	end
	\<close>

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/Isar/outer_syntax.ML\<close>\<close> \<open>
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/outer_syntax.ML\<close>\<close> \<open>
	structure C_Inner_Syntax =
	struct
	val drop1 = fn C_Scan.Left f => C_Scan.Left (K o f)
	\| C_Scan.Right (f, dir) => C_Scan.Right (K o f, dir)

	val drop2 = fn C_Scan.Left f => C_Scan.Left (K o K o f)
	\| C_Scan.Right (f, dir) => C_Scan.Right (K o K o f, dir)

	val bottom_up = C_Env.Bottom_up o C_Env.Exec_annotation

	(**)

	fun pref_lex name = "#" ^ name
	val pref_bot = I
	fun pref_top name = name ^ "\<Down>"

	(**)

	fun command2' cmd f (pos_bot, pos_top) =
	let fun cmd' dir = cmd (C_Scan.Right (f, dir)) Keyword.thy_decl
	in cmd' bottom_up (pref_bot, pos_bot)
	#> cmd' C_Env.Top_down (pref_top, pos_top)
	end

	fun command3' cmd f (pos_lex, pos_bot, pos_top) =
	cmd (C_Scan.Left f) (pref_lex, pos_lex)
	#> command2' (K o cmd) f (pos_bot, pos_top)

	fun command2 cmd f (name, pos_bot, pos_top) =
	command2' (fn f => fn kind => fn (name_pref, pos) => cmd f kind (name_pref name, pos))
	f
	(pos_bot, pos_top)

	fun command3 cmd f (name, pos_lex, pos_bot, pos_top) =
	command3' (fn f => fn (name_pref, pos) => cmd f (name_pref name, pos))
	f
	(pos_lex, pos_bot, pos_top)

	(**)

	fun command00 f kind scan name =
	C_Annotation.command'' kind name ""
	(case f of
	C_Scan.Left f =>
	(fn _ =>
	C_Parse.range scan >>
	(fn (src, range) =>
	C_Env.Lexing (range, f src range)))
	\| C_Scan.Right (f, dir) =>
	fn ((stack1, (to_delay, stack2)), _) =>
	C_Parse.range scan >>
	(fn (src, range) =>
	C_Env.Parsing ((stack1, stack2), (range, dir (f src range), Symtab.empty, to_delay))))

	fun command00_no_range f kind name =
	C_Annotation.command'' kind name ""
	(case f of
	C_Scan.Left f =>
	(fn (_, range) =>
	Scan.succeed () >>
	K (C_Env.Lexing (range, f range)))
	\| C_Scan.Right (f, dir) =>
	fn ((stack1, (to_delay, stack2)), range) =>
	Scan.succeed () >>
	K (C_Env.Parsing ((stack1, stack2), (range, dir (f range), Symtab.empty, to_delay))))

	(**)

	fun command' f = command00 (drop1 f) Keyword.thy_decl

	fun command f scan = command2 (fn f => fn kind => command00 f kind scan) (K o f)

	fun command_range f = command00_no_range f Keyword.thy_decl

	val command_range' = command3 (command_range o drop1)

	fun command_no_range' f = command00_no_range (drop1 f) Keyword.thy_decl

	fun command_no_range f = command2 command00_no_range (K f)

	fun command0 f scan = command3 (fn f => command' (drop1 f) scan) f

	fun local_command' (name, pos_lex, pos_bot, pos_top) scan f =
	command3' (fn f => fn (name_pref, pos) =>
	command' (drop1 f)
	(C_Token.syntax' (Parse.opt_target -- scan name_pref))
	(name_pref name, pos))
	(fn (target, arg) => C_Inner_Toplevel.local_theory' target (f arg))
	(pos_lex, pos_bot, pos_top)

	fun local_command'' spec = local_command' spec o K

	val command0_no_range = command_no_range' o drop1

	fun command0' f kind scan =
	- command3 (fn f => fn (name, pos) => command00 (drop2 f) kind (scan name) (name, pos)) f
	+ command3 (fn f => command00 (drop2 f) kind scan) f
	end
	\<close>

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/ML/ml_file.ML\<close>\<close> \<open>
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/ML/ml_file.ML\<close>\<close> \<open>
	structure C_Inner_File =
	struct

	fun command_c ({lines, pos, ...}: Token.file) =
	C_Module.C (Input.source true (cat_lines lines) (pos, pos));

	-fun C files gthy =
	- command_c (hd (files (Context.theory_of gthy))) gthy;
	+fun C get_file gthy =
	+ command_c (get_file (Context.theory_of gthy)) gthy;

	-fun command_ml environment debug files gthy =
	+fun command_ml environment debug get_file gthy =
	let
	- val file: Token.file = hd (files (Context.theory_of gthy));
	+ val file = get_file (Context.theory_of gthy);
	val source = Token.file_source file;

	val _ = Document_Output.check_comments (Context.proof_of gthy) (Input.source_explode source);

	val flags: ML_Compiler.flags =
	{environment = environment, redirect = true, verbose = true,
	debug = debug, writeln = writeln, warning = warning};
	in
	gthy
	\|> ML_Context.exec (fn () => ML_Context.eval_source flags source)
	\|> Local_Theory.propagate_ml_env
	end;

	val ML = command_ml "";
	val SML = command_ml ML_Env.SML;
	end;
	\<close>

	subsubsection \<open>Initialization\<close>

	-setup \<comment> \<open>analogous to \<^theory>\<open>Pure\<close>\<close> \<open>
	+setup \<comment> \<open>\<^theory>\<open>Pure\<close>\<close> \<open>
	C_Thy_Header.add_keywords_minor
	(maps (fn ((name, pos_lex, pos_bot, pos_top), ty) =>
	[ ((C_Inner_Syntax.pref_lex name, pos_lex), ty)
	, ((C_Inner_Syntax.pref_bot name, pos_bot), ty)
	, ((C_Inner_Syntax.pref_top name, pos_top), ty) ])
	- [ (("apply", \<^here>, \<^here>, \<^here>), ((Keyword.prf_script, []), ["proof"]))
	- , (("by", \<^here>, \<^here>, \<^here>), ((Keyword.qed, []), ["proof"]))
	- , (("done", \<^here>, \<^here>, \<^here>), ((Keyword.qed_script, []), ["proof"])) ])
	+ [ (("apply", \<^here>, \<^here>, \<^here>), Keyword.command_spec (Keyword.prf_script, ["proof"]))
	+ , (("by", \<^here>, \<^here>, \<^here>), Keyword.command_spec (Keyword.qed, ["proof"]))
	+ , (("done", \<^here>, \<^here>, \<^here>), Keyword.command_spec (Keyword.qed_script, ["proof"])) ])
	\<close>

	-ML \<comment> \<open>analogous to \<^theory>\<open>Pure\<close>\<close> \<open>
	+ML \<comment> \<open>\<^theory>\<open>Pure\<close>\<close> \<open>
	local
	val semi = Scan.option (C_Parse.$$$ ";");

	structure C_Isar_Cmd =
	struct
	fun ML source = ML_Context.exec (fn () =>
	ML_Context.eval_source (ML_Compiler.verbose true ML_Compiler.flags) source) #>
	Local_Theory.propagate_ml_env

	fun theorem schematic ((long, binding, includes, elems, concl), (l_meth, o_meth)) int lthy =
	(if schematic then Specification.schematic_theorem_cmd else Specification.theorem_cmd)
	long Thm.theoremK NONE (K I) binding includes elems concl int lthy
	\|> fold (fn m => tap (fn _ => Method.report m) #> Proof.apply m #> Seq.the_result "") l_meth
	\|> (case o_meth of
	NONE => Proof.global_done_proof
	\| SOME (m1, m2) =>
	tap (fn _ => (Method.report m1; Option.map Method.report m2))
	#> Proof.global_terminal_proof (m1, m2))

	fun definition (((decl, spec), prems), params) =
	#2 oo Specification.definition_cmd decl params prems spec

	fun declare (facts, fixes) =
	#2 oo Specification.theorems_cmd "" [(Binding.empty_atts, flat facts)] fixes
	end

	local
	val long_keyword =
	Parse_Spec.includes >> K "" \|\|
	Parse_Spec.long_statement_keyword;

	val long_statement =
	Scan.optional (Parse_Spec.opt_thm_name ":" --\| Scan.ahead long_keyword) Binding.empty_atts --
	Scan.optional Parse_Spec.includes [] -- Parse_Spec.long_statement
	>> (fn ((binding, includes), (elems, concl)) => (true, binding, includes, elems, concl));

	val short_statement =
	Parse_Spec.statement -- Parse_Spec.if_statement -- Parse.for_fixes
	>> (fn ((shows, assumes), fixes) =>
	(false, Binding.empty_atts, [], [Element.Fixes fixes, Element.Assumes assumes],
	Element.Shows shows));
	in
	fun theorem spec schematic =
	C_Inner_Syntax.local_command'
	spec
	(fn name_pref =>
	(long_statement \|\| short_statement)
	-- let val apply = Parse.$$$ (name_pref "apply") \|-- Method.parse
	in Scan.repeat1 apply -- (Parse.$$$ (name_pref "done") >> K NONE)
	\|\| Scan.repeat apply -- (Parse.$$$ (name_pref "by")
	\|-- Method.parse -- Scan.option Method.parse >> SOME)
	end)
	(C_Isar_Cmd.theorem schematic)
	end

	val opt_modes =
	Scan.optional (\<^keyword>\<open>(\<close> \|-- Parse.!!! (Scan.repeat1 Parse.name --\| \<^keyword>\<open>)\<close>)) [];

	val _ = Theory.setup
	( C_Inner_Syntax.command (C_Inner_Toplevel.generic_theory oo C_Inner_Isar_Cmd.setup)
	C_Parse.ML_source
	("\<approx>setup", \<^here>, \<^here>)
	#> C_Inner_Syntax.command0 (C_Inner_Toplevel.theory o Isar_Cmd.setup)
	C_Parse.ML_source
	("setup", \<^here>, \<^here>, \<^here>)
	#> C_Inner_Syntax.command0 (C_Inner_Toplevel.generic_theory o C_Isar_Cmd.ML)
	C_Parse.ML_source
	("ML", \<^here>, \<^here>, \<^here>)
	#> C_Inner_Syntax.command0 (C_Inner_Toplevel.generic_theory o C_Module.C)
	C_Parse.C_source
	("C", \<^here>, \<^here>, \<^here>)
	#> C_Inner_Syntax.command0' (C_Inner_Toplevel.generic_theory o C_Inner_File.ML NONE)
	Keyword.thy_load
	- (fn name => C_Resources.parse_files name --\| semi)
	+ (C_Resources.parse_file --\| semi)
	("ML_file", \<^here>, \<^here>, \<^here>)
	#> C_Inner_Syntax.command0' (C_Inner_Toplevel.generic_theory o C_Inner_File.C)
	Keyword.thy_load
	- (fn name => C_Resources.parse_files name --\| semi)
	+ (C_Resources.parse_file --\| semi)
	("C_file", \<^here>, \<^here>, \<^here>)
	#> C_Inner_Syntax.command0 (C_Inner_Toplevel.generic_theory o C_Module.C_export_boot)
	C_Parse.C_source
	("C_export_boot", \<^here>, \<^here>, \<^here>)
	#> C_Inner_Syntax.command_range'
	(Context.map_theory o Named_Target.theory_map o C_Module.C_export_file)
	("C_export_file", \<^here>, \<^here>, \<^here>)
	#> C_Inner_Syntax.command_no_range
	(C_Inner_Toplevel.generic_theory oo C_Inner_Isar_Cmd.setup
	\<open>fn ((_, (_, pos1, pos2)) :: _) =>
	(fn _ => fn _ =>
	tap (fn _ =>
	Position.reports_text [((Position.range (pos1, pos2)
	\|> Position.range_position, Markup.intensify), "")]))
	\| _ => fn _ => fn _ => I\<close>)
	("highlight", \<^here>, \<^here>)
	#> theorem ("theorem", \<^here>, \<^here>, \<^here>) false
	#> theorem ("lemma", \<^here>, \<^here>, \<^here>) false
	#> theorem ("corollary", \<^here>, \<^here>, \<^here>) false
	#> theorem ("proposition", \<^here>, \<^here>, \<^here>) false
	#> theorem ("schematic_goal", \<^here>, \<^here>, \<^here>) true
	#> C_Inner_Syntax.local_command''
	("definition", \<^here>, \<^here>, \<^here>)
	(Scan.option Parse_Spec.constdecl -- (Parse_Spec.opt_thm_name ":" -- Parse.prop) --
	Parse_Spec.if_assumes -- Parse.for_fixes)
	C_Isar_Cmd.definition
	#> C_Inner_Syntax.local_command''
	("declare", \<^here>, \<^here>, \<^here>)
	(Parse.and_list1 Parse.thms1 -- Parse.for_fixes)
	C_Isar_Cmd.declare
	#> C_Inner_Syntax.command0
	(C_Inner_Toplevel.keep'' o C_Inner_Isar_Cmd.print_term)
	(C_Token.syntax' (opt_modes -- Parse.term))
	("term", \<^here>, \<^here>, \<^here>))
	in end
	\<close>

	subsection \<open>Definitions of Outer Classical Commands\<close>
	subsubsection \<open>Library\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	+(* Title: Pure/Pure.thy
	+ Author: Makarius

	-ML \<comment> \<open>analogously to \<^file>\<open>~~/src/Pure/Isar/parse.ML\<close>\<close> \<open>
	+The Pure theory, with definitions of Isar commands and some lemmas.
	+))
	+
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/parse.ML\<close>\<close> \<open>
	structure C_Outer_Parse =
	struct
	val C_source = Parse.input (Parse.group (fn () => "C source") Parse.embedded)
	end
	\<close>

	-ML \<comment> \<open>analogously to \<^file>\<open>~~/src/Pure/Isar/outer_syntax.ML\<close>\<close> \<open>
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/outer_syntax.ML\<close>\<close> \<open>
	structure C_Outer_Syntax =
	struct
	val _ =
	Outer_Syntax.command \<^command_keyword>\<open>C\<close> ""
	(C_Outer_Parse.C_source >> (Toplevel.generic_theory o C_Module.C));
	end
	\<close>

	-ML \<comment> \<open>analogously to \<^file>\<open>~~/src/Pure/Isar/isar_cmd.ML\<close>\<close> \<open>
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/isar_cmd.ML\<close>\<close> \<open>
	structure C_Outer_Isar_Cmd =
	struct
	(* diagnostic ML evaluation *)

	structure Diag_State = Proof_Data
	(
	type T = Toplevel.state option;
	fun init _ = NONE;
	);

	fun C_diag source state =
	let
	val opt_ctxt =
	try Toplevel.generic_theory_of state
	\|> Option.map (Context.proof_of #> Diag_State.put (SOME state));
	in Context.setmp_generic_context (Option.map Context.Proof opt_ctxt)
	(fn () => C_Module.eval_source source) () end;

	fun diag_state ctxt =
	(case Diag_State.get ctxt of
	SOME st => st
	\| NONE => Toplevel.init_toplevel ());

	val diag_goal = Proof.goal o Toplevel.proof_of o diag_state;

	val _ = Theory.setup
	(ML_Antiquotation.value (Binding.qualify true "Isar" \<^binding>\<open>C_state\<close>)
	(Scan.succeed "C_Outer_Isar_Cmd.diag_state ML_context") #>
	ML_Antiquotation.value (Binding.qualify true "Isar" \<^binding>\<open>C_goal\<close>)
	(Scan.succeed "C_Outer_Isar_Cmd.diag_goal ML_context"));

	end
	\<close>

	-ML \<comment> \<open>analogously to \<^file>\<open>~~/src/Pure/ML/ml_file.ML\<close>\<close> \<open>
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/ML/ml_file.ML\<close>\<close> \<open>
	structure C_Outer_File =
	struct

	fun command_c ({src_path, lines, digest, pos}: Token.file) =
	let
	val provide = Resources.provide (src_path, digest);
	in I
	#> C_Module.C (Input.source true (cat_lines lines) (pos, pos))
	#> Context.mapping provide (Local_Theory.background_theory provide)
	end;

	-fun C files gthy =
	- command_c (hd (files (Context.theory_of gthy))) gthy;
	+fun C get_file gthy =
	+ command_c (get_file (Context.theory_of gthy)) gthy;

	end;
	\<close>

	subsubsection \<open>Setup for \<^verbatim>\<open>C\<close> and \<^verbatim>\<open>C_file\<close> Command Syntax\<close>

	-ML \<open>
	+ML \<comment> \<open>\<^theory>\<open>Pure\<close>\<close> \<open>
	local

	val semi = Scan.option \<^keyword>\<open>;\<close>;

	val _ =
	Outer_Syntax.command \<^command_keyword>\<open>C_file\<close> "read and evaluate Isabelle/C file"
	- (Resources.parse_files single --\| semi >> (Toplevel.generic_theory o C_Outer_File.C));
	+ (Resources.parse_file --\| semi >> (Toplevel.generic_theory o C_Outer_File.C));

	val _ =
	Outer_Syntax.command \<^command_keyword>\<open>C_export_boot\<close>
	"C text within theory or local theory, and export to bootstrap environment"
	(C_Outer_Parse.C_source >> (Toplevel.generic_theory o C_Module.C_export_boot));

	val _ =
	Outer_Syntax.command \<^command_keyword>\<open>C_prf\<close> "C text within proof"
	(C_Outer_Parse.C_source >> (Toplevel.proof o C_Module.C_prf));

	val _ =
	Outer_Syntax.command \<^command_keyword>\<open>C_val\<close> "diagnostic C text"
	(C_Outer_Parse.C_source >> (Toplevel.keep o C_Outer_Isar_Cmd.C_diag));

	val _ =
	Outer_Syntax.local_theory \<^command_keyword>\<open>C_export_file\<close> "diagnostic C text"
	(Scan.succeed () >> K (C_Module.C_export_file Position.no_range));
	in end\<close>

	subsection \<open>Term-Cartouches for C Syntax\<close>

	syntax "_C_translation_unit" :: \<open>cartouche_position \<Rightarrow> string\<close> ("\<^C>\<^sub>u\<^sub>n\<^sub>i\<^sub>t _")
	syntax "_C_external_declaration" :: \<open>cartouche_position \<Rightarrow> string\<close> ("\<^C>\<^sub>d\<^sub>e\<^sub>c\<^sub>l _")
	syntax "_C_expression" :: \<open>cartouche_position \<Rightarrow> string\<close> ("\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r _")
	syntax "_C_statement" :: \<open>cartouche_position \<Rightarrow> string\<close> ("\<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t _")
	syntax "_C" :: \<open>cartouche_position \<Rightarrow> string\<close> ("\<^C> _")

	parse_translation \<open>
	C_Module.C_Term'.parse_translation
	[ (\<^syntax_const>\<open>_C_translation_unit\<close>, SOME C_Module.C_Term.tok_translation_unit)
	, (\<^syntax_const>\<open>_C_external_declaration\<close>, SOME C_Module.C_Term.tok_external_declaration)
	, (\<^syntax_const>\<open>_C_expression\<close>, SOME C_Module.C_Term.tok_expression)
	, (\<^syntax_const>\<open>_C_statement\<close>, SOME C_Module.C_Term.tok_statement)
	, (\<^syntax_const>\<open>_C\<close>, NONE) ]
	\<close>

	(test)
	ML\<open>C_Module.env (Context.the_generic_context())\<close>

	ML\<open>open Args\<close>
	subsection\<open>C-env related ML-Antiquotations as Programming Support\<close>

	ML\<open>

	(*
	was in Isabelle2020:
	(Args.context -- Scan.lift Args.embedded_position >> (fn (ctxt, (name, pos)) =>

	with:

	val embedded_token = ident \|\| string \|\| cartouche;
	val embedded_inner_syntax = embedded_token >> Token.inner_syntax_of;
	val embedded_input = embedded_token >> Token.input_of;
	val embedded = embedded_token >> Token.content_of;
	val embedded_position = embedded_input >> Input.source_content;

	defined in args.

	Setting it to :

	(Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>

	makes this syntactically more restrictive.
	*)

	val _ = Theory.setup(
	ML_Antiquotation.value_embedded \<^binding>\<open>C\<^sub>e\<^sub>n\<^sub>v\<close>
	(Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	(warning"arg variant not implemented";"C_Module.env (Context.the_generic_context())"))
	\|\| Scan.succeed "C_Module.env (Context.the_generic_context())"))

	\<close>

	text\<open>Note that this anti-quotation is controlled by the \<^verbatim>\<open>C_starting_env\<close> - flag. \<close>

	declare[[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = last]]
	ML\<open>@{C\<^sub>e\<^sub>n\<^sub>v}\<close>

	declare[[C\<^sub>e\<^sub>n\<^sub>v\<^sub>0 = empty]]
	ML\<open>@{C\<^sub>e\<^sub>n\<^sub>v}\<close>

	subsection\<open>The Standard Store C11-AST's generated from C-commands\<close>
	text\<open>Each call of the C command will register the parsed root AST in this theory-name indexed table.\<close>

	ML\<open>
	structure Root_Ast_Store = Generic_Data
	(type T = C_Grammar_Rule.ast_generic list Symtab.table
	val empty = Symtab.empty
	val merge = K empty);


	Root_Ast_Store.map: ( C_Grammar_Rule.ast_generic list Symtab.table
	-> C_Grammar_Rule.ast_generic list Symtab.table)
	-> Context.generic -> Context.generic;


	fun update_Root_Ast filter ast _ ctxt =
	let val theory_id = Context.theory_long_name(Context.theory_of ctxt)
	val insert_K_ast = Symtab.map_default (theory_id,[]) (cons ast)
	in case filter ast of
	NONE => (warning "No appropriate c11 ast found - store unchanged."; ctxt)
	\|SOME _ => (Root_Ast_Store.map insert_K_ast) ctxt
	end;


	fun get_Root_Ast filter thy =
	let val ctxt = Context.Theory thy
	val thid = Context.theory_long_name(Context.theory_of ctxt)
	val ast = case Symtab.lookup (Root_Ast_Store.get ctxt) (thid) of
	SOME (a::_) => (case filter a of
	NONE => error "Last C command is not of appropriate AST-class."
	\| SOME x => x)
	\| _ => error"No C command in the current theory."
	in ast
	end

	val get_CExpr = get_Root_Ast C_Grammar_Rule.get_CExpr;
	val get_CStat = get_Root_Ast C_Grammar_Rule.get_CStat;
	val get_CExtDecl = get_Root_Ast C_Grammar_Rule.get_CExtDecl;
	val get_CTranslUnit = get_Root_Ast C_Grammar_Rule.get_CTranslUnit;
	\<close>

	setup \<open>Context.theory_map (C_Module.Data_Accept.put (update_Root_Ast SOME))\<close>


	ML\<open>
	(* Was : Args.embedded_position changed to : Args.name_position.
	See comment above. *)
	val _ = Theory.setup(
	ML_Antiquotation.value_embedded \<^binding>\<open>C11_CTranslUnit\<close>
	(Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	(warning"arg variant not implemented";"get_CTranslUnit (Context.the_global_context())"))
	\|\| Scan.succeed "get_CTranslUnit (Context.the_global_context())")
	#>
	ML_Antiquotation.value_embedded \<^binding>\<open>C11_CExtDecl\<close>
	(Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	(warning"arg variant not implemented";"get_CExtDecl (Context.the_global_context())"))
	\|\| Scan.succeed "get_CExtDecl (Context.the_global_context())")
	#>
	ML_Antiquotation.value_embedded \<^binding>\<open>C11_CStat\<close>
	(Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	(warning"arg variant not implemented";"get_CStat (Context.the_global_context())"))
	\|\| Scan.succeed "get_CStat (Context.the_global_context())")
	#>
	ML_Antiquotation.value_embedded \<^binding>\<open>C11_CExpr\<close>
	(Args.context -- Scan.lift Args.name_position >> (fn (ctxt, (name, pos)) =>
	(warning"arg variant not implemented";"get_CExpr (Context.the_global_context())"))
	\|\| Scan.succeed "get_CExpr (Context.the_global_context())")
	)
	\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Document.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Document.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Document.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Document.thy
	@@ -1,231 +1,238 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Support for Document Preparation: Text-Antioquotations.\<close>

	theory C_Document
	imports C_Command
	begin

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/Thy/document_output.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	-(* Text Antiquotations and Theory document output. *)
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Thy/document_output.ML\<close>\<close>
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	+(* Title: Pure/Thy/document_output.ML
	+ Author: Makarius
	+
	+Theory document output.
	+))
	\<open>
	structure C_Document_Output =
	struct

	(* output document source *)

	fun output_comment ctxt (kind, syms) =
	(case kind of
	Comment.Comment =>
	Input.cartouche_content syms
	\|> output_document (ctxt \|> Config.put Document_Antiquotation.thy_output_display false)
	{markdown = false}
	\|> XML.enclose "%\n\\isamarkupcmt{" "%\n}"
	\| Comment.Cancel =>
	Symbol_Pos.cartouche_content syms
	\|> Latex.symbols_output
	\|> XML.enclose "%\n\\isamarkupcancel{" "}"
	\| Comment.Latex => Latex.symbols (Symbol_Pos.cartouche_content syms)
	\| Comment.Marker => [])
	and output_comment_document ctxt (comment, syms) =
	(case comment of
	SOME kind => output_comment ctxt (kind, syms)
	\| NONE => Latex.symbols syms)
	and output_document_text ctxt syms =
	Comment.read_body syms \|> maps (output_comment_document ctxt)
	and output_document ctxt {markdown} source =
	let
	val pos = Input.pos_of source;
	val syms = Input.source_explode source;

	val output_antiquotes =
	maps (Document_Antiquotation.evaluate (output_document_text ctxt) ctxt);

	fun output_line line =
	(if Markdown.line_is_item line then Latex.string "\\item " else []) @
	output_antiquotes (Markdown.line_content line);

	fun output_block (Markdown.Par lines) =
	separate (XML.Text "\n") (map (Latex.block o output_line) lines)
	\| output_block (Markdown.List {kind, body, ...}) =
	Latex.environment (Markdown.print_kind kind) (output_blocks body)
	and output_blocks blocks =
	separate (XML.Text "\n\n") (map (Latex.block o output_block) blocks);
	in
	if Toplevel.is_skipped_proof (Toplevel.presentation_state ctxt) then []
	else if markdown andalso exists (Markdown.is_control o Symbol_Pos.symbol) syms
	then
	let
	val ants = Antiquote.parse_comments pos syms;
	val reports = Antiquote.antiq_reports ants;
	val blocks = Markdown.read_antiquotes ants;
	val _ = Context_Position.reports ctxt (reports @ Markdown.reports blocks);
	in output_blocks blocks end
	else
	let
	val ants = Antiquote.parse_comments pos (trim (Symbol.is_blank o Symbol_Pos.symbol) syms);
	val reports = Antiquote.antiq_reports ants;
	val _ = Context_Position.reports ctxt (reports @ Markdown.text_reports ants);
	in output_antiquotes ants end
	end;


	(* output tokens with formal comments *)

	local

	val output_symbols_antiq =
	(fn Antiquote.Text syms => Latex.symbols_output syms
	\| Antiquote.Control {name = (name, _), body, ...} =>
	Latex.string (Latex.output_symbols [Symbol.encode (Symbol.Control name)]) @
	Latex.symbols_output body
	\| Antiquote.Antiq {body, ...} =>
	XML.enclose "%\n\\isaantiq\n" "{}%\n\\endisaantiq\n" (Latex.symbols_output body));

	fun output_comment_symbols ctxt {antiq} (comment, syms) =
	(case (comment, antiq) of
	(NONE, false) => Latex.symbols_output syms
	\| (NONE, true) =>
	Antiquote.parse_comments (#1 (Symbol_Pos.range syms)) syms
	\|> maps output_symbols_antiq
	\| (SOME comment, _) => output_comment ctxt (comment, syms));

	fun output_body ctxt antiq bg en syms =
	Comment.read_body syms
	\|> maps (output_comment_symbols ctxt {antiq = antiq})
	\|> XML.enclose bg en;

	in

	fun output_token ctxt tok =
	let
	fun output antiq bg en =
	output_body ctxt antiq bg en (Input.source_explode (C_Token.input_of tok));
	in
	(case C_Token.kind_of tok of
	Token.Comment NONE => []
	\| Token.Comment (SOME Comment.Marker) => []
	\| Token.Command => output false "\\isacommand{" "}"
	\| Token.Keyword =>
	if Symbol.is_ascii_identifier (C_Token.content_of tok)
	then output false "\\isakeyword{" "}"
	else output false "" ""
	\| Token.String => output false "{\\isachardoublequoteopen}" "{\\isachardoublequoteclose}"
	\| Token.Alt_String => output false "{\\isacharbackquoteopen}" "{\\isacharbackquoteclose}"
	\| Token.Cartouche => output false "{\\isacartoucheopen}" "{\\isacartoucheclose}"
	+ \| Token.Control control => output_body ctxt false "" "" (Antiquote.control_symbols control)
	\| _ => output false "" "")
	end handle ERROR msg => error (msg ^ Position.here (C_Token.pos_of tok));


	end;
	end;
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Thy/document_antiquotations.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/Thy/document_antiquotations.ML
	Author: Makarius

	Miscellaneous document antiquotations.
	-*)
	+))
	\<open>
	structure C_Document_Antiquotations =
	struct

	(* quasi-formal text (unchecked) *)

	local

	fun report_text ctxt text =
	let val pos = Input.pos_of text in
	Context_Position.reports ctxt
	[(pos, Markup.language_text (Input.is_delimited text)),
	(pos, Markup.raw_text)]
	end;

	fun prepare_text ctxt =
	Input.source_content #> #1 #> Document_Antiquotation.prepare_lines ctxt;

	val theory_text_antiquotation =
	Document_Output.antiquotation_raw_embedded \<^binding>\<open>C_theory_text\<close> (Scan.lift Parse.embedded_input)
	(fn ctxt => fn text =>
	let
	val keywords = C_Thy_Header.get_keywords' ctxt;

	val _ = report_text ctxt text;
	val _ =
	Input.source_explode text
	\|> C_Token.tokenize keywords {strict = true}
	\|> maps (C_Token.reports keywords)
	\|> Context_Position.reports_text ctxt;
	in
	prepare_text ctxt text
	\|> C_Token.explode0 keywords
	\|> maps (C_Document_Output.output_token ctxt)
	\|> Document_Output.isabelle ctxt
	end);

	in

	val _ =
	Theory.setup theory_text_antiquotation;

	end;

	(* C text *)

	local

	fun c_text name c =
	Document_Output.antiquotation_verbatim_embedded name (Scan.lift Parse.embedded_input)
	(fn ctxt => fn text =>
	let val _ = C_Module.eval_in text (SOME (Context.Proof ctxt)) (c text)
	in #1 (Input.source_content text) end);

	in

	val _ = Theory.setup
	(c_text \<^binding>\<open>C\<close> (C_Module.c_enclose "" "") #>
	c_text \<^binding>\<open>C_text\<close> (K C_Lex.read_init));

	end;

	end;
	\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Environment.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Environment.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Environment.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Environment.thy
	@@ -1,609 +1,643 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Parsing Environment\<close>

	theory C_Environment
	imports C_Lexer_Language C_Ast
	begin

	text \<open> The environment comes in two parts: a basic core structure, and a (thin) layer of
	utilities. \<close>

	ML\<open>
	signature C_ENV =
	sig
	val namespace_enum: string
	val namespace_tag: string
	val namespace_typedef: string
	type error_lines = string list

	datatype stream_lang_state = Stream_atomic
	\| Stream_ident of Position.range * string
	\| Stream_regular
	\| Stream_string of (Position.range * string) list
	type ('a, 'b, 'c) stack_elem0 = 'a * ('b * 'c * 'c)
	type 'a stream = ('a, C_Lex.token) C_Scan.either list
	datatype 'a parse_status = Parsed of 'a \| Previous_in_stack

	eqtype markup_global

	type markup_ident = {global : markup_global,
	params : C_Ast.CDerivedDeclr list,
	ret : C_Ast.CDeclSpec list parse_status}
	type 'a markup_store = Position.T list * serial * 'a

	type var_table = {idents : markup_ident markup_store Symtab.table,
	tyidents : markup_global markup_store Symtab.table Symtab.table}

	type env_directives = ( (string * Position.range
	-> Context.generic
	-> C_Lex.token list * Context.generic,
	C_Lex.token list) C_Scan.either
	* (string * Position.range -> Context.generic -> Context.generic))
	markup_store
	Symtab.table

	type env_lang = {env_directives : env_directives,
	namesupply : int,
	scopes : (C_Ast.ident option * var_table) list,
	stream_ignored : C_Antiquote.antiq stream, var_table: var_table}

	type env_tree = {context : Context.generic,
	error_lines : error_lines,
	reports_text : C_Position.reports_text}

	type env_propagation_reduce = int option
	type env_propagation_ctxt = env_propagation_reduce -> Context.generic -> Context.generic
	type env_propagation_directive = env_propagation_reduce -> env_directives
	-> env_lang * env_tree -> env_lang * env_tree
	datatype env_propagation_bottom_up = Exec_annotation of env_propagation_ctxt
	\| Exec_directive of env_propagation_directive
	datatype env_propagation = Bottom_up of env_propagation_bottom_up
	\| Top_down of env_propagation_ctxt

	type rule_static = (env_tree -> env_lang * env_tree) option
	type 'a rule_output0' = {output_env: rule_static, output_pos: 'a option, output_vacuous: bool}
	type ('a, 'b, 'c) stack0 = ('a, 'b, 'c) stack_elem0 list
	type rule_output = C_Ast.class_Pos rule_output0'
	type eval_node = Position.range * env_propagation * env_directives * bool
	type ('a, 'b, 'c) rule_reduce = int * ('a, 'b, 'c) stack0 * eval_node list list
	type ('a, 'b, 'c) rule_reduce0 = (('a, 'b, 'c) stack0 * env_lang * eval_node) list
	type ('a, 'b, 'c) rule_reduce' = int * bool * ('a, 'b, 'c) rule_reduce0
	datatype ('a, 'b, 'c) rule_type = Reduce of rule_static * ('a, 'b, 'c) rule_reduce' \| Shift \| Void
	type ('a, 'b, 'c) rule_ml = {rule_pos: 'c * 'c, rule_type: ('a, 'b, 'c) rule_type}
	type ('a, 'b, 'c) rule_output0 = eval_node list list * ('a, 'b, 'c) rule_reduce0 * ('c * 'c) rule_output0'
	datatype 'a tree = Tree of 'a * 'a tree list
	type ('a, 'b, 'c) stack' = ('a, 'b, 'c) stack0 * eval_node list list * ('c * 'c) list * ('a, 'b, 'c) rule_ml tree list

	datatype comment_style = Comment_directive \| Comment_language

	datatype eval_time =
	Never
	\| Lexing of Position.range * (comment_style -> Context.generic -> Context.generic)
	\| Parsing of (Symbol_Pos.T list * Symbol_Pos.T list) * eval_node

	datatype antiq_language = Antiq_none of C_Lex.token
	\| Antiq_stack of C_Position.reports_text * eval_time

	- type stream_hook = (Symbol_Pos.T list * Symbol_Pos.T list * eval_node) list list
	+ type 'a stream_hook = ('a list * Symbol_Pos.T list * eval_node) list list

	type 'a T = {env_lang : env_lang,
	env_tree : env_tree,
	rule_input : C_Ast.class_Pos list * int,
	rule_output : rule_output,
	- stream_hook : stream_hook,
	+ stream_hook: Symbol_Pos.T stream_hook,
	+ stream_hook_excess : int stream_hook,
	stream_lang : stream_lang_state * 'a stream}

	val decode_positions: string -> Position.T list
	val empty_env_lang: env_lang
	val empty_env_tree: Context.generic -> env_tree
	val empty_rule_output: rule_output
	val encode_positions: Position.T list -> string
	val get_scopes: env_lang -> (C_Ast.ident option * var_table) list
	val make: env_lang -> 'a stream -> env_tree -> 'a T
	val map_context: (Context.generic -> Context.generic)
	-> {context: Context.generic, error_lines: 'c, reports_text: 'd}
	-> {context: Context.generic, error_lines: 'c, reports_text: 'd}
	(* why not just "env_tree" *)
	val map_context': (Context.generic -> 'b * Context.generic)
	-> {context: Context.generic, error_lines: 'd, reports_text: 'e}
	-> 'b * {context: Context.generic, error_lines: 'd, reports_text: 'e}
	(* why not just "env_tree" *)
	val map_reports_text:(C_Position.reports_text -> C_Position.reports_text) -> env_tree -> env_tree
	val map_error_lines: (error_lines -> error_lines)
	-> {context: 'c, error_lines: error_lines, reports_text: 'd}
	-> {context: 'c, error_lines: error_lines, reports_text: 'd}
	(* why not just : "env_tree" *)
	val map_namesupply: (int -> int) -> env_lang -> env_lang
	val map_env_directives: (env_directives -> env_directives) -> env_lang -> env_lang
	val map_scopes : ((C_Ast.ident option * var_table) list
	-> (C_Ast.ident option * var_table) list)
	-> env_lang -> env_lang
	val map_stream_ignored: (C_Antiquote.antiq stream->C_Antiquote.antiq stream) -> env_lang -> env_lang
	val map_var_table: (var_table -> var_table) -> env_lang -> env_lang

	val map_env_lang : (env_lang -> env_lang) -> 'a T -> 'a T
	val map_env_lang_tree : (env_lang -> env_tree -> env_lang * env_tree) -> 'a T -> 'a T
	val map_env_lang_tree': (env_lang -> env_tree -> 'c * (env_lang * env_tree)) -> 'a T -> 'c * 'a T
	val map_env_tree : (env_tree -> env_tree) -> 'a T -> 'a T
	val map_env_tree' : (env_tree -> 'b * env_tree) -> 'a T -> 'b * 'a T
	val map_rule_output: (rule_output -> rule_output) -> 'a T -> 'a T
	- val map_stream_hook: (stream_hook -> stream_hook) -> 'a T -> 'a T
	+ val map_stream_hook: (Symbol_Pos.T stream_hook -> Symbol_Pos.T stream_hook) -> 'a T -> 'a T
	+ val map_stream_hook_excess: (int stream_hook -> int stream_hook) -> 'a T -> 'a T
	val map_rule_input : (C_Ast.class_Pos list * int -> C_Ast.class_Pos list * int) -> 'a T -> 'a T
	val map_stream_lang: (stream_lang_state'a stream -> stream_lang_state'a stream)-> 'a T -> 'a T


	val map_output_env : (rule_static -> rule_static) -> 'a rule_output0' -> 'a rule_output0'
	val map_output_pos : ('a option -> 'a option) -> 'a rule_output0' -> 'a rule_output0'
	val map_output_vacuous : (bool -> bool) -> 'a rule_output0' -> 'a rule_output0'

	val map_idents: (markup_ident markup_store Symtab.table -> markup_ident markup_store Symtab.table)
	-> var_table -> var_table
	val map_tyidents: (markup_global markup_store Symtab.table Symtab.table
	-> markup_global markup_store Symtab.table Symtab.table )
	-> var_table -> var_table

	val string_of: env_lang -> string
	end

	\<close>
	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/context.ML\<close>\<close> \<open>
	structure C_Env : C_ENV = struct

	type 'a markup_store = Position.T list * serial * 'a

	type env_directives =
	( ( string * Position.range -> Context.generic -> C_Lex.token list * Context.generic
	, C_Lex.token list)
	C_Scan.either
	* (string * Position.range -> Context.generic -> Context.generic))
	markup_store
	Symtab.table

	(**)

	datatype 'a parse_status = Parsed of 'a \| Previous_in_stack

	type markup_global = bool (true: global)

	type markup_ident = { global : markup_global
	, params : C_Ast.CDerivedDeclr list
	, ret : C_Ast.CDeclSpec list parse_status }

	-type var_table = { tyidents : markup_global markup_store Symtab.table (ident name)
	- Symtab.table (internal namespace)
	- , idents : markup_ident markup_store Symtab.table (ident name) }
	+type var_table = { tyidents : markup_global markup_store Symtab.table (ident name)
	+ Symtab.table (*internal
	+ namespace*)
	+ , idents : markup_ident markup_store Symtab.table (ident name) }

	type 'antiq_language_list stream = ('antiq_language_list, C_Lex.token) C_Scan.either list

	\<comment> \<open>Key entry point environment to the C language\<close>
	type env_lang = { var_table : var_table \<comment> \<open>current active table in the scope\<close>
	, scopes : (C_Ast.ident option * var_table) list \<comment> \<open>parent scope tables\<close>
	, namesupply : int
	, stream_ignored : C_Antiquote.antiq stream
	, env_directives : env_directives }
	(* NOTE: The distinction between type variable or identifier can not be solely made
	during the lexing process.
	Another pass on the parsed tree is required. *)

	type error_lines = string list

	type env_tree = { context : Context.generic
	, reports_text : C_Position.reports_text
	, error_lines : error_lines }

	type rule_static = (env_tree -> env_lang * env_tree) option

	(**)

	datatype comment_style = Comment_directive
	\| Comment_language

	type env_propagation_reduce = int (reduce rule number) option (* NONE: shift action *)

	type env_propagation_ctxt = env_propagation_reduce -> Context.generic -> Context.generic

	type env_propagation_directive =
	env_propagation_reduce -> env_directives -> env_lang * env_tree -> env_lang * env_tree

	datatype env_propagation_bottom_up = Exec_annotation of env_propagation_ctxt
	\| Exec_directive of env_propagation_directive

	datatype env_propagation = Bottom_up (during parsing) of env_propagation_bottom_up
	\| Top_down (after parsing) of env_propagation_ctxt

	type eval_node = Position.range
	* env_propagation
	* env_directives
	* bool (* true: skip vacuous reduce rules *)

	datatype eval_time = Lexing of Position.range
	* (comment_style -> Context.generic -> Context.generic)
	\| Parsing of (Symbol_Pos.T list (* length = number of tokens to advance *)
	* Symbol_Pos.T list (* length = number of steps back in stack *))
	* eval_node
	\| Never (* to be manually treated by the semantic back-end, and analyzed there *)

	datatype antiq_language = Antiq_stack of C_Position.reports_text * eval_time
	\| Antiq_none of C_Lex.token

	\<comment> \<open> One of the key element of the structure is
	\<^ML_text>\<open>eval_time\<close>, relevant for the generic annotation
	module. \<close>

	(**)

	-type ('LrTable_state, 'a, 'Position_T) stack_elem0 = 'LrTable_state * ('a * 'Position_T * 'Position_T)
	+type ('LrTable_state, 'a, 'Position_T) stack_elem0 = 'LrTable_state
	+ * ('a * 'Position_T * 'Position_T)
	type ('LrTable_state, 'a, 'Position_T) stack0 = ('LrTable_state, 'a, 'Position_T) stack_elem0 list

	type ('LrTable_state, 'svalue0, 'pos) rule_reduce0 =
	(('LrTable_state, 'svalue0, 'pos) stack0 * env_lang * eval_node) list
	type ('LrTable_state, 'svalue0, 'pos) rule_reduce =
	int * ('LrTable_state, 'svalue0, 'pos) stack0 * eval_node list list
	type ('LrTable_state, 'svalue0, 'pos) rule_reduce' =
	int * bool (vacuous) * ('LrTable_state, 'svalue0, 'pos) rule_reduce0

	datatype ('LrTable_state, 'svalue0, 'pos) rule_type =
	Void
	\| Shift
	\| Reduce of rule_static * ('LrTable_state, 'svalue0, 'pos) rule_reduce'

	type ('LrTable_state, 'svalue0, 'pos) rule_ml =
	{ rule_pos : 'pos * 'pos
	, rule_type : ('LrTable_state, 'svalue0, 'pos) rule_type }

	(**)

	type 'class_Pos rule_output0' = { output_pos : 'class_Pos option
	, output_vacuous : bool
	, output_env : rule_static }

	type ('LrTable_state, 'svalue0, 'pos) rule_output0 =
	eval_node list list (* delayed *)
	* ('LrTable_state, 'svalue0, 'pos) rule_reduce0 (* actual *)
	* ('pos * 'pos) rule_output0'

	type rule_output = C_Ast.class_Pos rule_output0'

	-type stream_hook = (Symbol_Pos.T list * Symbol_Pos.T list * eval_node) list list
	-
	(**)

	datatype stream_lang_state = Stream_ident of Position.range * string
	\| Stream_string of (Position.range * string) list
	\| Stream_atomic
	\| Stream_regular

	+type 'a stream_hook = ('a list * Symbol_Pos.T list * eval_node) list list
	+
	type 'a T = {env_lang: env_lang,
	env_tree: env_tree,
	rule_input: C_Ast.class_Pos list * int,
	rule_output: rule_output,
	- stream_hook: (Symbol_Pos.T list * Symbol_Pos.T list * eval_node) list list,
	+ stream_hook: Symbol_Pos.T stream_hook,
	+ stream_hook_excess : int stream_hook,
	stream_lang: stream_lang_state * 'a stream}


	type T' = (C_Antiquote.antiq * antiq_language list) T

	(**)

	datatype 'a tree = Tree of 'a * 'a tree list

	type ('LrTable_state, 'a, 'Position_T) stack' =
	('LrTable_state, 'a, 'Position_T) stack0
	* eval_node list list
	* ('Position_T * 'Position_T) list
	* ('LrTable_state, 'a, 'Position_T) rule_ml tree list

	(**)

	-fun map_env_lang f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_env_lang f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	{env_lang = f
	env_lang, env_tree = env_tree, rule_output = rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = stream_lang}
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang}

	-fun map_env_tree f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_env_tree f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	{env_lang = env_lang, env_tree = f
	env_tree, rule_output = rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = stream_lang}
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang}

	-fun map_rule_output f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_rule_output f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	{env_lang = env_lang, env_tree = env_tree, rule_output = f
	rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = stream_lang}
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang}

	-fun map_rule_input f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_rule_input f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	{env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	rule_input = f
	- rule_input, stream_hook = stream_hook, stream_lang = stream_lang}
	+ rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang}

	-fun map_stream_hook f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_stream_hook f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	{env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	rule_input = rule_input, stream_hook = f
	- stream_hook, stream_lang = stream_lang}
	+ stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang}

	-fun map_stream_lang f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_stream_hook_excess f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	{env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = f
	- stream_lang}
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = f
	+ stream_hook_excess, stream_lang = stream_lang}
	+
	+fun map_stream_lang f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	+ {env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = f
	+ stream_lang}

	(**)

	fun map_output_pos f {output_pos, output_vacuous, output_env} =
	{output_pos = f output_pos, output_vacuous = output_vacuous, output_env = output_env}

	fun map_output_vacuous f {output_pos, output_vacuous, output_env} =
	{output_pos = output_pos, output_vacuous = f output_vacuous, output_env = output_env}

	fun map_output_env f {output_pos, output_vacuous, output_env} =
	{output_pos = output_pos, output_vacuous = output_vacuous, output_env = f output_env}

	(**)

	fun map_tyidents f {tyidents, idents} =
	{tyidents = f tyidents, idents = idents}

	fun map_idents f {tyidents, idents} =
	{tyidents = tyidents, idents = f idents}

	(**)

	fun map_var_table f {var_table, scopes, namesupply, stream_ignored, env_directives} =
	{var_table = f
	var_table, scopes = scopes, namesupply = namesupply,
	stream_ignored = stream_ignored, env_directives = env_directives}

	fun map_scopes f {var_table, scopes, namesupply, stream_ignored, env_directives} =
	{var_table = var_table, scopes = f
	scopes, namesupply = namesupply,
	stream_ignored = stream_ignored, env_directives = env_directives}

	fun map_namesupply f {var_table, scopes, namesupply, stream_ignored, env_directives} =
	{var_table = var_table, scopes = scopes, namesupply = f
	namesupply,
	stream_ignored = stream_ignored, env_directives = env_directives}

	fun map_stream_ignored f {var_table, scopes, namesupply, stream_ignored, env_directives} =
	{var_table = var_table, scopes = scopes, namesupply = namesupply,
	stream_ignored = f
	stream_ignored, env_directives = env_directives}

	fun map_env_directives f {var_table, scopes, namesupply, stream_ignored, env_directives} =
	{var_table = var_table, scopes = scopes, namesupply = namesupply,
	- stream_ignored = stream_ignored, env_directives = f env_directives}
	+ stream_ignored = stream_ignored, env_directives = f
	+ env_directives}

	(**)

	fun map_context f {context, reports_text, error_lines} =
	{context = f context, reports_text = reports_text, error_lines = error_lines}

	fun map_context' f {context, reports_text, error_lines} =
	let val (res, context) = f context
	in (res, {context = context, reports_text = reports_text, error_lines = error_lines})
	end

	fun map_reports_text f {context, reports_text, error_lines} =
	{context = context, reports_text = f reports_text, error_lines = error_lines}

	fun map_error_lines f {context, reports_text, error_lines} =
	{context = context, reports_text = reports_text, error_lines = f error_lines}

	(**)

	-fun map_env_tree' f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_env_tree' f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	let val (res, env_tree) = f env_tree
	in (res, {env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = stream_lang})
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang})
	end

	-fun map_env_lang_tree f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_env_lang_tree f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	let val (env_lang, env_tree) = f env_lang env_tree
	in {env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = stream_lang}
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang}
	end

	-fun map_env_lang_tree' f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_env_lang_tree' f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	let val (res, (env_lang, env_tree)) = f env_lang env_tree
	in (res, {env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = stream_lang})
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang})
	end

	(**)

	fun get_scopes (t : env_lang) = #scopes t

	(**)

	val empty_env_lang : env_lang =
	{var_table = {tyidents = Symtab.make [], idents = Symtab.make []},
	scopes = [], namesupply = 0, stream_ignored = [],
	env_directives = Symtab.empty}
	fun empty_env_tree context =
	{context = context, reports_text = [], error_lines = []}
	val empty_rule_output : rule_output =
	{output_pos = NONE, output_vacuous = true, output_env = NONE}
	fun make env_lang stream_lang env_tree =
	{ env_lang = env_lang
	, env_tree = env_tree
	, rule_output = empty_rule_output
	, rule_input = ([], 0)
	, stream_hook = []
	+ , stream_hook_excess = []
	, stream_lang = ( Stream_regular
	- , map_filter (fn C_Scan.Right (C_Lex.Token (_, (C_Lex.Space, _))) => NONE
	+ , map_filter (fn C_Scan.Right (C_Lex.Token (_, (C_Lex.Space _, _))) => NONE
	\| C_Scan.Right (C_Lex.Token (_, (C_Lex.Comment _, _))) => NONE
	\| C_Scan.Right tok => SOME (C_Scan.Right tok)
	\| C_Scan.Left antiq => SOME (C_Scan.Left antiq))
	stream_lang) }
	fun string_of (env_lang : env_lang) =
	let fun dest0 x f = x \|> Symtab.dest \|> map f
	fun dest {tyidents, idents} =
	(dest0 tyidents #1, dest0 idents (fn (i, (_,_,v)) =>
	(i, if #global v then "global" else "local")))
	in \<^make_string> ( ("var_table", dest (#var_table env_lang))
	, ("scopes", map (fn (id, i) =>
	( Option.map (fn C_Ast.Ident0 (i, _, _) =>
	C_Ast.meta_of_logic i)
	id
	, dest i))
	(#scopes env_lang))
	, ("namesupply", #namesupply env_lang)
	, ("stream_ignored", #stream_ignored env_lang)) end

	val namespace_typedef = "typedef"
	val namespace_tag = "tag"
	val namespace_enum = namespace_tag

	(**)

	val encode_positions =
	map (Position.dest
	#> (fn pos => ((#line pos, #offset pos, #end_offset pos), #props pos)))
	#> let open XML.Encode in list (pair (triple int int int) properties) end
	#> YXML.string_of_body

	val decode_positions =
	YXML.parse_body
	#> let open XML.Decode in list (pair (triple int int int) properties) end
	#> map ((fn ((line, offset, end_offset), props) =>
	{line = line, offset = offset, end_offset = end_offset, props = props})
	#> Position.make)

	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/context.ML\<close>\<close> \<open>
	structure C_Env_Ext =
	struct

	local
	fun map_tyidents' f = C_Env.map_var_table (C_Env.map_tyidents f)
	fun map_tyidents f = C_Env.map_env_lang (map_tyidents' f)
	in
	fun map_tyidents_typedef f =
	map_tyidents (Symtab.map_default (C_Env.namespace_typedef, Symtab.empty) f)
	fun map_tyidents_enum f = map_tyidents (Symtab.map_default (C_Env.namespace_enum, Symtab.empty) f)
	fun map_tyidents'_typedef f =
	map_tyidents' (Symtab.map_default (C_Env.namespace_typedef, Symtab.empty) f)
	fun map_tyidents'_enum f = map_tyidents' (Symtab.map_default (C_Env.namespace_enum, Symtab.empty) f)
	end
	fun map_idents' f = C_Env.map_var_table (C_Env.map_idents f)
	fun map_idents f = C_Env.map_env_lang (map_idents' f)

	(**)

	fun map_var_table f = C_Env.map_env_lang (C_Env.map_var_table f)
	fun map_scopes f = C_Env.map_env_lang (C_Env.map_scopes f)
	fun map_namesupply f = C_Env.map_env_lang (C_Env.map_namesupply f)
	fun map_stream_ignored f = C_Env.map_env_lang (C_Env.map_stream_ignored f)

	(**)

	local
	fun get_tyidents' namespace (env_lang : C_Env.env_lang) =
	case Symtab.lookup (env_lang \|> #var_table \|> #tyidents) namespace of
	NONE => Symtab.empty
	\| SOME t => t

	fun get_tyidents namespace (t : 'a C_Env.T) = get_tyidents' namespace (#env_lang t)
	in
	fun get_tyidents_typedef env= get_tyidents C_Env.namespace_typedef env
	fun get_tyidents_enum env = get_tyidents C_Env.namespace_enum env
	fun get_tyidents'_typedef env = get_tyidents' C_Env.namespace_typedef env
	fun get_tyidents'_enum env = get_tyidents' C_Env.namespace_enum env
	end

	fun get_idents (t: 'a C_Env.T) = #env_lang t \|> #var_table \|> #idents
	fun get_idents' (env:C_Env.env_lang) = env \|> #var_table \|> #idents

	(**)

	fun get_var_table (t: 'a C_Env.T) = #env_lang t \|> #var_table
	fun get_scopes (t:'a C_Env.T) = #env_lang t \|> #scopes
	fun get_namesupply (t: 'a C_Env.T) = #env_lang t \|> #namesupply

	(**)

	fun map_output_pos f = C_Env.map_rule_output (C_Env.map_output_pos f)
	fun map_output_vacuous f = C_Env.map_rule_output (C_Env.map_output_vacuous f)
	fun map_output_env f = C_Env.map_rule_output (C_Env.map_output_env f)

	(**)

	fun get_output_pos (t : 'a C_Env.T) = #rule_output t \|> #output_pos

	(**)

	fun map_context f = C_Env.map_env_tree (C_Env.map_context f)
	fun map_reports_text f = C_Env.map_env_tree (C_Env.map_reports_text f)

	(**)

	fun get_context (t : 'a C_Env.T) = #env_tree t \|> #context
	fun get_reports_text (t : 'a C_Env.T) = #env_tree t \|> #reports_text

	(**)

	fun map_env_directives' f {var_table, scopes, namesupply, stream_ignored, env_directives} =
	let val (res, env_directives) = f env_directives
	in (res, {var_table = var_table, scopes = scopes, namesupply = namesupply,
	stream_ignored = stream_ignored, env_directives = env_directives})
	end

	(**)

	-fun map_stream_lang' f {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_lang} =
	+fun map_stream_lang' f
	+ {env_lang, env_tree, rule_output, rule_input, stream_hook, stream_hook_excess, stream_lang} =
	let val (res, stream_lang) = f stream_lang
	in (res, {env_lang = env_lang, env_tree = env_tree, rule_output = rule_output,
	- rule_input = rule_input, stream_hook = stream_hook, stream_lang = stream_lang})
	+ rule_input = rule_input, stream_hook = stream_hook,
	+ stream_hook_excess = stream_hook_excess, stream_lang = stream_lang})
	end

	(**)

	fun context_map (f : C_Env.env_tree -> C_Env.env_tree) =
	C_Env.empty_env_tree #> f #> #context

	fun context_map' (f : C_Env.env_tree -> 'a * C_Env.env_tree) =
	C_Env.empty_env_tree #> f #> apsnd #context

	(**)

	fun list_lookup tab name = flat (map (fn (x, _, _) => x) (the_list (Symtab.lookup tab name)))

	end

	\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy
	@@ -1,766 +1,808 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Evaluation Scheduling\<close>

	theory C_Eval
	imports C_Parser_Language
	C_Parser_Annotation
	begin

	subsection \<open>Evaluation Engine for the Core Language\<close> \<comment> \<open>\<^file>\<open>~~/src/Pure/Thy/thy_info.ML\<close>:
	\<^theory>\<open>Isabelle_C.C_Parser_Language\<close>\<close>

	ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Environment\<close>\<close> \<open>
	structure C_Stack =
	struct
	type 'a stack_elem = (LALR_Table.state, 'a, Position.T) C_Env.stack_elem0
	type stack_data = (LALR_Table.state, C_Grammar.Tokens.svalue0, Position.T) C_Env.stack0
	type stack_data_elem = (LALR_Table.state, C_Grammar.Tokens.svalue0, Position.T) C_Env.stack_elem0

	fun map_svalue0 f (st, (v, pos1, pos2)) = (st, (f v, pos1, pos2))

	structure Data_Lang =
	struct
	val empty' = ([], C_Env.empty_env_lang)
	structure Data_Lang = Generic_Data
	(
	type T = (stack_data * C_Env.env_lang) option
	val empty = NONE
	val merge = K empty
	)
	open Data_Lang
	fun get' context = case get context of NONE => empty' \| SOME data => data
	fun setmp data f context = put (get context) (f (put data context))
	end

	structure Data_Tree_Args : GENERIC_DATA_ARGS =
	struct
	type T = C_Position.reports_text * C_Env.error_lines
	val empty = ([], [])
	fun merge ((l11, l12), (l21, l22)) = (l11 @ l21, l12 @ l22)
	end

	structure Data_Tree = Generic_Data (Data_Tree_Args)

	fun setmp_tree f context =
	let val x = Data_Tree.get context
	val context = f (Data_Tree.put Data_Tree_Args.empty context)
	in (Data_Tree.get context, Data_Tree.put x context) end

	fun stack_exec0 f {context, reports_text, error_lines} =
	let val ((reports_text', error_lines'), context) = setmp_tree f context
	in { context = context
	, reports_text = append reports_text' reports_text
	, error_lines = append error_lines' error_lines } end

	fun stack_exec env_dir data_put =
	stack_exec0 o Data_Lang.setmp (SOME (apsnd (C_Env.map_env_directives (K env_dir)) data_put))
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/ML/ml_context.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/ML/ml_context.ML
	Author: Makarius

	ML context and antiquotations.
	-*)
	+))
	\<open>
	structure C_Context0 =
	struct
	(* theory data *)

	type env_direct = bool (* internal result for conditional directives: branch skipping *)
	* (C_Env.env_directives * C_Env.env_tree)

	structure Directives = Generic_Data
	- (type T = (Position.T list
	- * serial
	- * ( (* evaluated during lexing phase *)
	- (C_Lex.token_kind_directive
	- -> env_direct
	- -> C_Env.antiq_language list (* nested annotations from the input *)
	- * env_direct (NOTE: remove the possibility of returning a too modified env?))
	- * (* evaluated during parsing phase *)
	- (C_Lex.token_kind_directive -> C_Env.env_propagation_directive)))
	- Symtab.table
	- val empty = Symtab.empty
	- val merge = Symtab.join (K #2));
	+(
	+ type T = (Position.T list
	+ * serial
	+ * ( (* evaluated during lexing phase *)
	+ (C_Lex.token_kind_directive
	+ -> env_direct
	+ -> C_Env.antiq_language list (* nested annotations from the input *)
	+ * env_direct (NOTE: remove the possibility of returning a too modified env?))
	+ * (* evaluated during parsing phase *)
	+ (C_Lex.token_kind_directive -> C_Env.env_propagation_directive)))
	+ Symtab.table
	+ val empty = Symtab.empty
	+ val merge = Symtab.join (K #2)
	+);
	+end
	+\<close>
	+
	+ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Environment\<close>\<close> \<open>
	+structure C_Hook =
	+struct
	+fun add_stream0 (syms_shift, syms, ml_exec) stream_hook =
	+ case
	+ fold (fn _ => fn (eval1, eval2) =>
	+ (case eval2 of e2 :: eval2 => (e2, eval2)
	+ \| [] => ([], []))
	+ \|>> (fn e1 => e1 :: eval1))
	+ syms_shift
	+ ([], stream_hook)
	+ of (eval1, eval2) => fold cons
	+ eval1
	+ (case eval2 of e :: es => ((syms_shift, syms, ml_exec) :: e) :: es
	+ \| [] => [[(syms_shift, syms, ml_exec)]])
	+
	+fun advance00 stack ml_exec =
	+ case ml_exec of
	+ (_, C_Env.Bottom_up (C_Env.Exec_annotation exec), env_dir, _) =>
	+ (fn arg => C_Env.map_env_tree (C_Stack.stack_exec env_dir (stack, #env_lang arg) (exec NONE))
	+ arg)
	+ \| (_, C_Env.Bottom_up (C_Env.Exec_directive exec), env_dir, _) =>
	+ C_Env.map_env_lang_tree (curry (exec NONE env_dir))
	+ \| ((pos, _), C_Env.Top_down exec, env_dir, _) =>
	+ tap (fn _ => warning ("Missing navigation, evaluating as bottom-up style instead of top-down"
	+ ^ Position.here pos))
	+ #>
	+ (fn arg => C_Env.map_env_tree (C_Stack.stack_exec env_dir (stack, #env_lang arg) (exec NONE))
	+ arg)
	+
	+fun advance0 stack (_, syms_reduce, ml_exec) =
	+ let
	+ val len = length syms_reduce
	+ in
	+ if len = 0 then
	+ I #>> advance00 stack ml_exec
	+ else
	+ let
	+ val len = len - 1
	+ in
	+ fn (arg, stack_ml) =>
	+ if length stack_ml - 2 <= len then
	+ ( C_Env.map_stream_hook_excess
	+ (add_stream0 (map_range I (len - length stack_ml + 2), syms_reduce, ml_exec))
	+ arg
	+ , stack_ml)
	+ \|> tap (fn _ => warning ("Navigation out of bounds, "
	+ ^ (if length stack_ml <= len then "maximum depth"
	+ else "internal value")
	+ ^ " reached ("
	+ ^ Int.toString (len - length stack_ml + 3)
	+ ^ " in excess)"
	+ ^ Position.here (Symbol_Pos.range syms_reduce
	+ \|> Position.range_position)))
	+ else
	+ (arg, nth_map len (cons ml_exec) stack_ml)
	+ end
	+ end
	+
	+fun advance stack = (fn f => fn (arg, stack_ml) => f (#stream_hook arg) (arg, stack_ml))
	+ (fn [] => I
	+ \| l :: ls => fold_rev (advance0 stack) l #>> C_Env.map_stream_hook (K ls))
	+
	+fun add_stream exec =
	+ C_Env.map_stream_hook (add_stream0 exec)
	end
	\<close>

	ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Lexer_Language\<close>\<close> \<open>
	structure C_Grammar_Lexer : ARG_LEXER1 =
	struct
	structure LALR_Lex_Instance =
	struct
	type ('a,'b) token = ('a, 'b) C_Grammar.Tokens.token
	type pos = Position.T
	type arg = C_Grammar.Tokens.arg
	type svalue0 = C_Grammar.Tokens.svalue0
	type svalue = arg -> svalue0 * arg
	type state = C_Grammar.ParserData.LALR_Table.state
	end

	type stack =
	(LALR_Lex_Instance.state, LALR_Lex_Instance.svalue0, LALR_Lex_Instance.pos) C_Env.stack'

	-fun advance_hook stack = (fn f => fn (arg, stack_ml) => f (#stream_hook arg) (arg, stack_ml))
	- (fn [] => I \| l :: ls =>
	- I
	- #> fold_rev
	- (fn (_, syms, ml_exec) =>
	- let
	- val len = length syms
	- in
	- if len = 0 then
	- I #>>
	- (case ml_exec of
	- (_, C_Env.Bottom_up (C_Env.Exec_annotation exec), env_dir, _) =>
	- (fn arg => C_Env.map_env_tree (C_Stack.stack_exec env_dir (stack, #env_lang arg)
	- (exec NONE))
	- arg)
	- \| (_, C_Env.Bottom_up (C_Env.Exec_directive exec), env_dir, _) =>
	- C_Env.map_env_lang_tree (curry (exec NONE env_dir))
	- \| ((pos, _), _, _, _) =>
	- C_Env_Ext.map_context (fn _ => error ( "Style of evaluation not yet implemented"
	- ^ Position.here pos)))
	- else
	- I ##>
	- let
	- val len = len - 1
	- in
	- fn stack_ml =>
	- stack_ml
	- \|> (if length stack_ml <= len then
	- tap (fn _ => warning ("Maximum depth reached ("
	- ^ Int.toString (len - length stack_ml + 1)
	- ^ " in excess)"
	- ^ Position.here (Symbol_Pos.range syms
	- \|> Position.range_position)))
	- #> tap (fn _ => warning ("Unevaluated code"
	- ^ Position.here (ml_exec \|> #1
	- \|> Position.range_position)))
	- #> I
	- else if length stack_ml - len <= 2 then
	- tap
	- (fn _ =>
	- warning ("Unevaluated code\
	- \ as the hook is pointing to an internal initial value"
	- ^ Position.here (ml_exec \|> #1 \|> Position.range_position)))
	- #> I
	- else nth_map len (cons ml_exec))
	- end
	- end)
	- l
	- #>> C_Env.map_stream_hook (K ls))
	-
	-fun add_stream_hook (syms_shift, syms, ml_exec) =
	- C_Env.map_stream_hook
	- (fn stream_hook =>
	- case
	- fold (fn _ => fn (eval1, eval2) =>
	- (case eval2 of e2 :: eval2 => (e2, eval2)
	- \| [] => ([], []))
	- \|>> (fn e1 => e1 :: eval1))
	- syms_shift
	- ([], stream_hook)
	- of (eval1, eval2) => fold cons
	- eval1
	- (case eval2 of e :: es => ((syms_shift, syms, ml_exec) :: e) :: es
	- \| [] => [[(syms_shift, syms, ml_exec)]]))
	-
	fun makeLexer ((stack, stack_ml, stack_pos, stack_tree), arg) =
	let val (token, arg) = C_Env_Ext.map_stream_lang' (fn (st, []) => (NONE, (st, []))
	\| (st, x :: xs) => (SOME x, (st, xs)))
	arg
	fun return0' f =
	(arg, stack_ml)
	- \|> advance_hook stack
	+ \|> C_Hook.advance stack
	\|> f
	\|> (fn (arg, stack_ml) => rpair ((stack, stack_ml, stack_pos, stack_tree), arg))
	- fun return0 x = \<comment> \<open>Warning: \<open>advance_hook\<close> must not be early evaluated here, as it might
	+ fun return0 x = \<comment> \<open>Warning: \<open>C_Hook.advance\<close> must not be early evaluated here, as it might
	generate undesirable markup reporting (in annotation commands).\<close>
	- \<comment> \<open>Todo: Arrange \<open>advance_hook\<close> as a pure function, so that the overall could
	+ \<comment> \<open>Todo: Arrange \<open>C_Hook.advance\<close> as a pure function, so that the overall could
	be eta-simplified.\<close>
	return0' I x
	val encoding = fn C_Lex.Encoding_L => true \| _ => false
	open C_Ast
	fun token_err pos1 pos2 src =
	C_Grammar_Tokens.token_of_string
	(C_Grammar.Tokens.error (pos1, pos2))
	(ClangCVersion0 (From_string src))
	(CChar (From_char_hd "0") false)
	(CFloat (From_string src))
	(CInteger 0 DecRepr (Flags 0))
	(CString0 (From_string src, false))
	(Ident (From_string src, 0, OnlyPos NoPosition (NoPosition, 0)))
	src
	pos1
	pos2
	src
	open C_Scan
	in
	case token
	of NONE =>
	- return0'
	- (tap (fn (arg, _) =>
	- fold (uncurry
	- (fn pos =>
	- fold_rev (fn (syms, _, _) => fn () =>
	- let val () = error ("Maximum depth reached ("
	- ^ Int.toString (pos + 1)
	- ^ " in excess)"
	- ^ Position.here (Symbol_Pos.range syms
	- \|> Position.range_position))
	- in () end)))
	- (map_index I (#stream_hook arg))
	- ()))
	- (C_Grammar.Tokens.x25_eof (Position.none, Position.none))
	+ return0 (C_Grammar.Tokens.x25_eof (Position.none, Position.none))
	\| SOME (Left (antiq_raw, l_antiq)) =>
	makeLexer
	( (stack, stack_ml, stack_pos, stack_tree)
	, (arg, false)
	\|> fold (fn C_Env.Antiq_stack (_, C_Env.Parsing ((syms_shift, syms), ml_exec)) =>
	- I #>> add_stream_hook (syms_shift, syms, ml_exec)
	+ I #>> C_Hook.add_stream (syms_shift, syms, ml_exec)
	\| C_Env.Antiq_stack (_, C_Env.Never) => I ##> K true
	\| _ => I)
	l_antiq
	\|> (fn (arg, false) => arg
	\| (arg, true) => C_Env_Ext.map_stream_ignored (cons (Left antiq_raw)) arg))
	\| SOME (Right (tok as C_Lex.Token (_, (C_Lex.Directive dir, _)))) =>
	makeLexer
	( (stack, stack_ml, stack_pos, stack_tree)
	, arg
	\|> let val context = C_Env_Ext.get_context arg
	in
	fold (fn dir_tok =>
	- add_stream_hook
	+ C_Hook.add_stream
	( []
	, []
	, ( Position.no_range
	, C_Env.Bottom_up (C_Env.Exec_directive
	(dir \|> (case Symtab.lookup
	(C_Context0.Directives.get context)
	(C_Lex.content_of dir_tok)
	of NONE => K (K (K I))
	\| SOME (_, _, (_, exec)) => exec)))
	, Symtab.empty
	, true)))
	(C_Lex.directive_cmds dir)
	end
	\|> C_Env_Ext.map_stream_ignored (cons (Right tok)))
	\| SOME (Right (C_Lex.Token ((pos1, pos2), (tok, src)))) =>
	case tok of
	C_Lex.String (C_Lex.Encoding_file (SOME err), _) =>
	return0' (apfst
	(C_Env.map_env_tree (C_Env.map_error_lines (cons (err ^ Position.here pos1)))))
	(token_err pos1 pos2 src)
	\| _ =>
	return0
	(case tok of
	C_Lex.Char (b, [c]) =>
	C_Grammar.Tokens.cchar
	- (CChar (From_char_hd (case c of Left c => c \| _ => chr 0)) (encoding b), pos1, pos2)
	+ (CChar (From_char_hd (case c of Left (c, _) => c \| _ => chr 0)) (encoding b), pos1, pos2)
	\| C_Lex.String (b, s) =>
	C_Grammar.Tokens.cstr
	- (CString0 ( From_string ( implode (map (fn Left s => s \| Right _ => chr 0) s))
	+ (CString0 ( From_string ( implode (map (fn Left (s, _) => s \| Right _ => chr 0) s))
	, encoding b)
	, pos1
	, pos2)
	\| C_Lex.Integer (i, repr, flag) =>
	C_Grammar.Tokens.cint
	( CInteger i (case repr of C_Lex.Repr_decimal => DecRepr0
	\| C_Lex.Repr_hexadecimal => HexRepr0
	\| C_Lex.Repr_octal => OctalRepr0)
	(C_Lex.read_bin
	(fold (fn flag =>
	map (fn (bit, flag0) =>
	( if flag0 = (case flag of
	C_Lex.Flag_unsigned => FlagUnsigned0
	\| C_Lex.Flag_long => FlagLong0
	\| C_Lex.Flag_long_long => FlagLongLong0
	\| C_Lex.Flag_imag => FlagImag0)
	then "1"
	else bit
	, flag0)))
	flag
	([FlagUnsigned, FlagLong, FlagLongLong, FlagImag] \|> rev
	\|> map (pair "0"))
	\|> map #1)
	\|> Flags)
	, pos1
	, pos2)
	\| C_Lex.Float s =>
	C_Grammar.Tokens.cfloat (CFloat (From_string (implode (map #1 s))), pos1, pos2)
	- \| C_Lex.Ident =>
	+ \| C_Lex.Ident _ =>
	let val (name, arg) = C_Grammar_Rule_Lib.getNewName arg
	val ident0 = C_Grammar_Rule_Lib.mkIdent
	(C_Grammar_Rule_Lib.posOf' false (pos1, pos2))
	src
	name
	in if C_Grammar_Rule_Lib.isTypeIdent src arg then
	C_Grammar.Tokens.tyident (ident0, pos1, pos2)
	else
	C_Grammar.Tokens.ident (ident0, pos1, pos2)
	end
	\| _ => token_err pos1 pos2 src)
	end
	end
	\<close>

	text \<open> This is where the instancing of the parser functor (from
	\<^theory>\<open>Isabelle_C.C_Parser_Language\<close>) with the lexer (from
	\<^theory>\<open>Isabelle_C.C_Lexer_Language\<close>) actually happens ... \<close>

	ML \<comment> \<open>\<^theory>\<open>Isabelle_C.C_Parser_Language\<close>\<close> \<open>
	structure C_Grammar_Parser =
	LALR_Parser_Join (structure LrParser = LALR_Parser_Eval
	structure ParserData = C_Grammar.ParserData
	structure Lex = C_Grammar_Lexer)
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/ML/ml_compiler.ML\<close>\<close> \<open>
	structure C_Language = struct

	open C_Env

	fun exec_tree write msg (Tree ({rule_pos, rule_type}, l_tree)) =
	case rule_type of
	Void => write msg rule_pos "VOID" NONE
	\| Shift => write msg rule_pos "SHIFT" NONE
	\| Reduce (rule_static, (rule0, vacuous, rule_antiq)) =>
	write
	msg
	rule_pos
	("REDUCE " ^ Int.toString rule0 ^ " " ^ (if vacuous then "X" else "O"))
	(SOME (C_Grammar_Rule.string_reduce rule0 ^ " " ^ C_Grammar_Rule.type_reduce rule0))
	#> (case rule_static of SOME rule_static => rule_static #>> SOME \| NONE => pair NONE)
	#-> (fn env_lang =>
	fold (fn (stack0, env_lang0, (_, C_Env.Top_down exec, env_dir, _)) =>
	C_Stack.stack_exec env_dir
	(stack0, Option.getOpt (env_lang, env_lang0))
	(exec (SOME rule0))
	\| _ => I)
	rule_antiq)
	#> fold (exec_tree write (msg ^ " ")) l_tree

	fun exec_tree' l env_tree = env_tree
	\|> fold (exec_tree let val ctxt = Context.proof_of (#context env_tree)
	val write =
	if Config.get ctxt C_Options.parser_trace
	andalso Context_Position.is_visible ctxt
	then fn f => tap (tracing o f) else K I
	in fn msg => fn (p1, p2) => fn s1 => fn s2 =>
	write (fn _ => msg ^ s1 ^ " " ^ Position.here p1 ^ " " ^ Position.here p2
	^ (case s2 of SOME s2 => " " ^ s2 \| NONE => ""))
	end
	"")
	l

	-fun uncurry_context f pos = uncurry (fn x => fn arg => map_env_tree' (f pos x (#env_lang arg)) arg)
	+fun uncurry_context f pos = uncurry (fn (stack, stack_ml, stack_pos, stack_tree) =>
	+ (* executing stack_tree *)
	+ (fn arg => map_env_tree' (f pos stack stack_tree (#env_lang arg)) arg)
	+ #> apfst (pair (stack, stack_ml, stack_pos, stack_tree)))

	fun eval env_lang start err accept stream_lang =
	make env_lang stream_lang
	#> C_Grammar_Parser.makeLexer
	#> C_Grammar_Parser.parse
	( 0
	- , uncurry_context (fn (next_pos1, next_pos2) => fn (stack, _, _, stack_tree) => fn env_lang =>
	+ , uncurry_context (fn (next_pos1, next_pos2) => fn stack => fn stack_tree => fn env_lang =>
	C_Env.map_reports_text
	(cons ( ( Position.range_position (case hd stack of (_, (_, pos1, pos2)) =>
	(pos1, pos2))
	, Markup.bad ())
	, "")
	#> (case rev (tl stack) of
	_ :: _ :: stack =>
	append
	(map_filter
	(fn (pos1, pos2) =>
	if Position.offset_of pos1 = Position.offset_of pos2
	then NONE
	else SOME ((Position.range_position (pos1, pos2), Markup.intensify), ""))
	((next_pos1, next_pos2)
	:: map (fn (_, (_, pos1, pos2)) => (pos1, pos2)) stack))
	\| _ => I))
	#> exec_tree' (rev stack_tree)
	#> err
	env_lang
	stack
	(Position.range_position
	(case hd stack_tree of Tree ({rule_pos = (rule_pos1, _), ...}, _) =>
	(rule_pos1, next_pos2))))
	, Position.none
	, start
	- , uncurry_context (fn _ => fn (stack, _, _, stack_tree) => fn env_lang =>
	+ , uncurry_context (fn _ => fn stack => fn stack_tree => fn env_lang =>
	exec_tree' stack_tree
	#> accept env_lang (stack \|> hd \|> C_Stack.map_svalue0 C_Grammar_Rule.reduce0))
	, fn (stack, arg) => arg \|> map_rule_input (K stack)
	\|> map_rule_output (K empty_rule_output)
	, fn (rule0, stack0, pre_ml) => fn arg =>
	let val rule_output = #rule_output arg
	val env_lang = #env_lang arg
	val (delayed, actual) =
	if #output_vacuous rule_output
	then let fun f (_, _, _, to_delay) = to_delay
	in (map (filter f) pre_ml, map (filter_out f) pre_ml) end
	else ([], pre_ml)
	val actual = flat (map rev actual)
	in
	( (delayed, map (fn x => (stack0, env_lang, x)) actual, rule_output)
	, fold (fn (_, C_Env.Bottom_up (C_Env.Exec_annotation exec), env_dir, _) =>
	C_Env.map_env_tree
	(C_Stack.stack_exec env_dir (stack0, env_lang) (exec (SOME rule0)))
	\| (_, C_Env.Bottom_up (C_Env.Exec_directive exec), env_dir, _) =>
	C_Env.map_env_lang_tree (curry (exec (SOME rule0) env_dir))
	\| _ => I)
	actual
	arg)
	end)
	- #> snd
	- #> apsnd #env_tree
	+ #>
	+ (fn (stream, (((stack, stack_ml, stack_pos, stack_tree), user), arg)) =>
	+ let
	+ fun shift_max acc stream =
	+ let val (tok, stream) = C_Grammar_Parser.Stream.get stream
	+ in
	+ if LALR_Parser_Eval.Token.sameToken (tok, C_Grammar.Tokens.x25_eof (Position.none, Position.none)) then
	+ (acc, stream)
	+ else
	+ shift_max (tok :: acc) stream
	+ end
	+
	+ (* executing stack_ml *)
	+ val arg = fold (fold_rev (C_Hook.advance00 stack)) stack_ml arg
	+
	+ (* executing stream_lang *)
	+ val (_, (_, ((stack, stack_ml, _, _), arg))) =
	+ shift_max [] (stream, ((stack, [[], []], stack_pos, stack_tree), arg))
	+ in
	+ arg
	+ (* executing stream_hook *)
	+ \|> (fn arg =>
	+ fold (uncurry
	+ (fn pos =>
	+ fold_rev (fn (syms_shift, syms_reduce, ml_exec) =>
	+ tap (fn _ => warning ("Navigation out of bounds,\
	+ \ maximum breadth reached ("
	+ ^ Int.toString (pos + 1)
	+ ^ " in excess)"
	+ ^ Position.here (Symbol_Pos.range syms_shift
	+ \|> Position.range_position)))
	+ #> C_Hook.advance0 stack (syms_shift, syms_reduce, ml_exec))))
	+ (map_index I (#stream_hook arg))
	+ (arg, stack_ml)
	+ \|> fst)
	+
	+ (* executing stream_hook_excess *)
	+ \|> (fn arg => fold (fold_rev (fn (_, _, ml_exec) => C_Hook.advance00 stack ml_exec))
	+ (#stream_hook_excess arg)
	+ arg)
	+
	+ (**)
	+ \|> pair user o #env_tree
	+ end)
	end
	\<close>

	subsection \<open>Full Evaluation Engine (Core Language with Annotations)\<close> \<comment> \<open>\<^file>\<open>~~/src/Pure/Thy/thy_info.ML\<close>:
	\<^theory>\<open>Isabelle_C.C_Parser_Language\<close>,
	\<^theory>\<open>Isabelle_C.C_Parser_Annotation\<close>\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/ML/ml_context.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/ML/ml_context.ML
	Author: Makarius

	ML context and antiquotations.
	-*)
	+))
	\<open>
	structure C_Context =
	struct
	fun fun_decl a v s ctxt =
	let
	val (b, ctxt') = ML_Context.variant a ctxt;
	val env = "fun " ^ b ^ " " ^ v ^ " = " ^ s ^ " " ^ v ^ ";\n";
	val body = ML_Context.struct_name ctxt ^ "." ^ b;
	fun decl (_: Proof.context) = (env, body);
	in (decl, ctxt') end;

	-(* parsing and evaluation *)
	+(* parsing *)

	local

	fun scan_antiq context syms =
	let val keywords = C_Thy_Header.get_keywords' (Context.proof_of context)
	- in ( C_Token.read_antiq'
	+ in ( C_Parse_Read.read_antiq'
	keywords
	(C_Parse.!!! (Scan.trace (C_Annotation.parse_command (Context.theory_of context))
	>> (I #>> C_Env.Antiq_stack)))
	syms
	- , C_Token.read_with_commands'0 keywords syms)
	+ , C_Parse_Read.read_with_commands'0 keywords syms)
	end

	fun print0 s =
	maps
	(fn C_Lex.Token (_, (t as C_Lex.Directive d, _)) =>
	(s ^ @{make_string} t) :: print0 (s ^ " ") (C_Lex.token_list_of d)
	\| C_Lex.Token (_, t) =>
	[case t of (C_Lex.Char _, _) => "Text Char"
	\| (C_Lex.String _, _) => "Text String"
	\| _ => let val t' = @{make_string} (#2 t)
	in
	if String.size t' <= 2 then @{make_string} (#1 t)
	else
	s ^ @{make_string} (#1 t) ^ " "
	^ (String.substring (t', 1, String.size t' - 2)
	\|> Markup.markup Markup.intensify)
	end])

	val print = tracing o cat_lines o print0 ""

	open C_Scan

	fun markup_directive ty = C_Grammar_Rule_Lib.markup_make (K NONE) (K ()) (K ty)

	in

	fun markup_directive_command data =
	markup_directive
	"directive command"
	(fn cons' => fn def =>
	fn C_Ast.Left _ =>
	cons' (Markup.keyword_properties (if def then Markup.free else Markup.keyword1))
	\| C_Ast.Right (_, msg, f) => tap (fn _ => Output.information msg)
	#> f
	#> cons' (Markup.keyword_properties Markup.free))
	data

	fun directive_update (name, pos) f tab =
	let val pos = [pos]
	val data = (pos, serial (), f)
	val _ = Position.reports_text
	(markup_directive_command (C_Ast.Left (data, C_Env_Ext.list_lookup tab name))
	pos
	name
	[])
	in Symtab.update (name, data) tab end

	fun markup_directive_define in_direct =
	C_Env.map_reports_text ooo
	markup_directive
	"directive define"
	(fn cons' => fn def => fn err =>
	(if def orelse in_direct then I else cons' Markup.language_antiquotation)
	#> (case err of C_Ast.Left _ => I
	\| C_Ast.Right (_, msg, f) => tap (fn _ => Output.information msg) #> f)
	#> (if def then cons' Markup.free else if in_direct then I else cons' Markup.antiquote))

	+
	+(* evaluation *)
	+
	fun eval env start err accept (ants, ants_err) {context, reports_text, error_lines} =
	let val error_lines = ants_err error_lines
	fun scan_comment tag pos (antiq as {explicit, body, ...}) cts =
	let val (res, l_comm) = scan_antiq context body
	in
	Left
	( tag
	, antiq
	, l_comm
	, if forall (fn Right _ => true \| _ => false) res then
	let val (l_msg, res) =
	split_list (map_filter (fn Right (msg, l_report, l_tok) =>
	SOME (msg, (l_report, l_tok))
	\| _ => NONE)
	res)
	val (l_report, l_tok) = split_list res
	in [( C_Env.Antiq_none
	(C_Lex.Token
	(pos, ( (C_Lex.Comment o C_Lex.Comment_suspicious o SOME)
	( explicit
	, cat_lines l_msg
	, if explicit then flat l_report else [])
	, cts)))
	, l_tok)]
	end
	else
	map (fn Left x => x
	\| Right (msg, l_report, tok) =>
	(C_Env.Antiq_none
	(C_Lex.Token
	( C_Token.range_of [tok]
	, ( (C_Lex.Comment o C_Lex.Comment_suspicious o SOME)
	(explicit, msg, l_report)
	, C_Token.content_of tok)))
	, [tok]))
	res)
	end

	val ants = map (fn C_Lex.Token (pos, (C_Lex.Comment (C_Lex.Comment_formal antiq), cts)) =>
	scan_comment C_Env.Comment_language pos antiq cts
	\| tok => Right tok)
	ants

	fun map_ants f1 f2 = maps (fn Left x => f1 x \| Right tok => f2 tok)

	val ants_none =
	map_ants (fn (_, _, _, l) => maps (fn (C_Env.Antiq_none x, _) => [x] \| _ => []) l)
	(K [])
	ants

	val _ = Position.reports (maps (fn Left (_, _, _, [(C_Env.Antiq_none _, _)]) => []
	\| Left (_, {start, stop, range = (pos, _), ...}, _, _) =>
	(case stop of SOME stop => cons (stop, Markup.antiquote)
	\| NONE => I)
	[(start, Markup.antiquote),
	(pos, Markup.language_antiquotation)]
	\| _ => [])
	ants);
	val _ =
	Position.reports_text
	(maps C_Lex.token_report ants_none
	@ maps (fn Left (_, _, _, [(C_Env.Antiq_none _, _)]) => []
	\| Left (_, _, l, ls) =>
	maps (fn (C_Env.Antiq_stack (pos, _), _) => pos \| _ => []) ls
	@ maps (maps (C_Token.reports (C_Thy_Header.get_keywords
	(Context.theory_of context))))
	(l :: map #2 ls)
	\| _ => [])
	ants);
	val error_lines = C_Lex.check ants_none error_lines;

	val ((ants, {context, reports_text, error_lines}), env) =
	C_Env_Ext.map_env_directives'
	(fn env_dir =>
	let val (ants, (env_dir, env_tree)) =
	fold_map
	let
	fun subst_directive tok (range1 as (pos1, _)) name (env_dir, env_tree) =
	case Symtab.lookup env_dir name of
	NONE => (Right (Left tok), (env_dir, env_tree))
	\| SOME (data as (_, _, (exec_toks, exec_antiq))) =>
	env_tree
	\|> markup_directive_define
	false
	(C_Ast.Right ([pos1], SOME data))
	[pos1]
	name
	\|> (case exec_toks of
	Left exec_toks =>
	C_Env.map_context' (exec_toks (name, range1))
	#> apfst
	(fn toks =>
	(toks, Symtab.update (name, ( #1 data
	, #2 data
	, (Right toks, exec_antiq)))
	env_dir))
	\| Right toks => pair (toks, env_dir))
	\|\|> C_Env.map_context (exec_antiq (name, range1))
	\|-> (fn (toks, env_dir) =>
	pair (Right (Right (pos1, map (C_Lex.set_range range1) toks)))
	o pair env_dir)
	in
	fn Left (tag, antiq, toks, l_antiq) =>
	fold_map
	(fn antiq as (C_Env.Antiq_stack (_, C_Env.Lexing (_, exec)), _) =>
	apsnd (C_Stack.stack_exec0 (exec C_Env.Comment_language)) #> pair antiq
	\| (C_Env.Antiq_stack
	(rep, C_Env.Parsing (syms, (range, exec, _, skip))), toks) =>
	(fn env as (env_dir, _) =>
	( ( C_Env.Antiq_stack
	(rep, C_Env.Parsing (syms, (range, exec, env_dir, skip)))
	, toks)
	, env))
	\| antiq => pair antiq)
	l_antiq
	#> apfst (fn l_antiq => Left (tag, antiq, toks, l_antiq))
	\| Right tok =>
	case tok of
	C_Lex.Token (_, (C_Lex.Directive dir, _)) =>
	pair false
	#> fold
	(fn dir_tok =>
	let val name = C_Lex.content_of dir_tok
	val pos1 = [C_Lex.pos_of dir_tok]
	in
	fn env_tree as (_, (_, {context = context, ...})) =>
	let val data = Symtab.lookup (C_Context0.Directives.get context) name
	in
	env_tree
	\|> apsnd (apsnd (C_Env.map_reports_text (markup_directive_command
	(C_Ast.Right (pos1, data))
	pos1
	name)))
	\|> (case data of NONE => I \| SOME (_, _, (exec, _)) => exec dir #> #2)
	end
	end)
	(C_Lex.directive_cmds dir)
	#> snd
	#> tap
	(fn _ =>
	app (fn C_Lex.Token ( (pos, _)
	, (C_Lex.Comment (C_Lex.Comment_formal _), _)) =>
	(Position.reports_text [((pos, Markup.ML_comment), "")];
	(* not yet implemented *)
	warning ("Ignored annotation in directive"
	^ Position.here pos))
	\| _ => ())
	(C_Lex.token_list_of dir))
	#> pair (Right (Left tok))
	\| C_Lex.Token (pos, (C_Lex.Keyword, cts)) => subst_directive tok pos cts
	- \| C_Lex.Token (pos, (C_Lex.Ident, cts)) => subst_directive tok pos cts
	+ \| C_Lex.Token (pos, (C_Lex.Ident _, cts)) => subst_directive tok pos cts
	\| _ => pair (Right (Left tok))
	end
	ants
	( env_dir
	, {context = context, reports_text = reports_text, error_lines = error_lines})
	in ((ants, env_tree), env_dir) end)
	env

	val ants_stack =
	map_ants (single o Left o (fn (_, a, _, l) => (a, maps (single o #1) l)))
	(map Right o (fn Left tok => [tok] \| Right (_, toks) => toks))
	ants
	val _ =
	Position.reports_text (maps (fn Right (Left tok) => C_Lex.token_report tok
	\| Right (Right (pos, [])) => [((pos, Markup.intensify), "")]
	\| _ => [])
	ants);
	val ctxt = Context.proof_of context
	val () = if Config.get ctxt C_Options.lexer_trace andalso Context_Position.is_visible ctxt
	then print (map_filter (fn Right x => SOME x \| _ => NONE) ants_stack)
	else ()
	in
	C_Language.eval env
	start
	err
	accept
	ants_stack
	{context = context, reports_text = reports_text, error_lines = error_lines}
	end


	(* derived versions *)

	fun eval' env start err accept ants =
	Context.>>> (fn context =>
	C_Env_Ext.context_map'
	(eval (env context) (start context) err accept ants
	#> apsnd (tap (Position.reports_text o #reports_text)
	#> tap (#error_lines #> (fn [] => () \| l => error (cat_lines (rev l))))
	#> (C_Env.empty_env_tree o #context)))
	context)
	end;

	fun eval_source env start err accept source =
	eval' env (start source) err accept (C_Lex.read_source source);

	fun eval_source' env start err accept source =
	eval env (start source) err accept (C_Lex.read_source source);

	fun eval_in o_context env start err accept toks =
	Context.setmp_generic_context o_context
	(fn () => eval' env start err accept toks) ();

	fun expression struct_open range name constraint body ants context = context \|>
	ML_Context.exec
	let val verbose = Config.get (Context.proof_of context) C_Options.ML_verbose
	in fn () =>
	ML_Context.eval (ML_Compiler.verbose verbose ML_Compiler.flags) (#1 range)
	(ML_Lex.read ("Context.put_generic_context (SOME (let open " ^ struct_open ^ " val ") @
	ML_Lex.read_range range name @
	ML_Lex.read (": " ^ constraint ^ " =") @ ants @
	ML_Lex.read ("in " ^ body ^ " end (Context.the_generic_context ())));"))
	end;
	end
	\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy
	@@ -1,1396 +1,1413 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Annotation Language: Parsing Combinator\<close>

	theory C_Lexer_Annotation
	imports C_Lexer_Language
	begin

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/keyword.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/Isar/keyword.ML
	Author: Makarius

	Isar keyword classification.
	-*)
	+))
	\<open>
	structure C_Keyword =
	struct

	( keyword classification )

	(* kinds *)


	val command_kinds =
	[Keyword.diag, Keyword.document_heading, Keyword.document_body, Keyword.document_raw,
	Keyword.thy_begin, Keyword.thy_end, Keyword.thy_load, Keyword.thy_decl,
	Keyword.thy_decl_block, Keyword.thy_defn, Keyword.thy_stmt, Keyword.thy_goal,
	Keyword.thy_goal_defn, Keyword.thy_goal_stmt, Keyword.qed, Keyword.qed_script,
	Keyword.qed_block, Keyword.qed_global, Keyword.prf_goal, Keyword.prf_block, Keyword.next_block,
	Keyword.prf_open, Keyword.prf_close, Keyword.prf_chain,
	Keyword.prf_decl, Keyword.prf_asm, Keyword.prf_asm_goal, Keyword.prf_script,
	Keyword.prf_script_goal, Keyword.prf_script_asm_goal];


	(* specifications *)

	+type spec = Keyword.spec;

	type entry =
	{pos: Position.T,
	id: serial,
	kind: string,
	- files: string list, (extensions of embedded files)
	tags: string list};

	-fun check_spec pos ((kind, files), tags) : entry =
	+fun check_spec pos ({kind, tags, ...}: spec) : entry =
	if not (member (op =) command_kinds kind) then
	error ("Unknown annotation syntax keyword kind " ^ quote kind)
	- else if not (null files) andalso kind <> Keyword.thy_load then
	- error ("Illegal specification of files for " ^ quote kind)
	- else {pos = pos, id = serial (), kind = kind, files = files, tags = tags};
	+ else {pos = pos, id = serial (), kind = kind, tags = tags};


	( keyword tables )

	(* type keywords *)

	datatype keywords = Keywords of
	{minor: Scan.lexicon,
	major: Scan.lexicon,
	commands: entry Symtab.table};

	fun minor_keywords (Keywords {minor, ...}) = minor;
	fun major_keywords (Keywords {major, ...}) = major;

	fun make_keywords (minor, major, commands) =
	Keywords {minor = minor, major = major, commands = commands};

	fun map_keywords f (Keywords {minor, major, commands}) =
	make_keywords (f (minor, major, commands));


	-
	(* build keywords *)

	val empty_keywords =
	make_keywords (Scan.empty_lexicon, Scan.empty_lexicon, Symtab.empty);

	fun empty_keywords' minor =
	make_keywords (minor, Scan.empty_lexicon, Symtab.empty);

	fun merge_keywords
	(Keywords {minor = minor1, major = major1, commands = commands1},
	Keywords {minor = minor2, major = major2, commands = commands2}) =
	make_keywords
	(Scan.merge_lexicons (minor1, minor2),
	Scan.merge_lexicons (major1, major2),
	Symtab.merge (K true) (commands1, commands2));

	val add_keywords0 =
	fold
	- (fn ((name, pos), force_minor, spec as ((kind, _), _)) =>
	+ (fn ((name, pos), force_minor, spec as {kind, ...}: spec) =>
	map_keywords (fn (minor, major, commands) =>
	let val extend = Scan.extend_lexicon (Symbol.explode name)
	fun update spec = Symtab.update (name, spec)
	in
	if force_minor then
	(extend minor, major, update (check_spec pos spec) commands)
	else if kind = "" orelse kind = Keyword.before_command
	orelse kind = Keyword.quasi_command then
	(extend minor, major, commands)
	else
	(minor, extend major, update (check_spec pos spec) commands)
	end));

	val add_keywords = add_keywords0 o map (fn (cmd, spec) => (cmd, false, spec))
	val add_keywords_minor = add_keywords0 o map (fn (cmd, spec) => (cmd, true, spec))


	(* keyword status *)

	fun is_command (Keywords {commands, ...}) = Symtab.defined commands;
	fun dest_commands (Keywords {commands, ...}) = Symtab.keys commands;


	(* command keywords *)

	fun lookup_command (Keywords {commands, ...}) = Symtab.lookup commands;

	fun command_markup keywords name =
	- let (* PATCH: copied as such from Isabelle2020 *)
	- fun entity_properties_of def serial pos =
	- if def then (Markup.defN, Value.print_int serial) :: Position.properties_of pos
	- else (Markup.refN, Value.print_int serial) :: Position.def_properties_of pos;
	-
	- in
	- lookup_command keywords name
	- \|> Option.map (fn {pos, id, ...} =>
	- Markup.properties (entity_properties_of false id pos)
	- (Markup.entity Markup.command_keywordN name))
	- end;
	+ lookup_command keywords name
	+ \|> Option.map (fn {pos, id, ...} =>
	+ Position.make_entity_markup {def = false} id Markup.command_keywordN (name, pos));


	-fun command_files keywords name path =
	- (case lookup_command keywords name of
	- NONE => []
	- \| SOME {kind, files, ...} =>
	- if kind <> Keyword.thy_load then []
	- else if null files then [path]
	- else map (fn ext => Path.ext ext path) files);


	(* command categories *)

	fun command_category ks =
	let
	val tab = Symtab.make_set ks;
	fun pred keywords name =
	(case lookup_command keywords name of
	NONE => false
	\| SOME {kind, ...} => Symtab.defined tab kind);
	in pred end;




	val is_theory_end = command_category [Keyword.thy_end];








	val is_proof_asm = command_category [Keyword.prf_asm, Keyword.prf_asm_goal];
	val is_improper = command_category [ Keyword.qed_script
	, Keyword.prf_script
	, Keyword.prf_script_goal
	, Keyword.prf_script_asm_goal];


	end;
	\<close>

	text \<open> Notes:
	\<^item> The next structure contains a duplicated copy of the type
	\<^ML_type>\<open>Token.T\<close>, since it is not possible to set an arbitrary
	\<^emph>\<open>slot\<close> value in \<^ML_structure>\<open>Token\<close>.

	\<^item> Parsing priorities in C and HOL slightly differ, see for instance
	\<^ML>\<open>Token.explode\<close>.
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/token.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/Isar/token.ML
	Author: Markus Wenzel, TU Muenchen

	Outer token syntax for Isabelle/Isar.
	-*)
	+))
	\<open>
	structure C_Token =
	struct

	( tokens )

	(* token kind *)

	+fun equiv_kind kind kind' =
	+ (case (kind, kind') of
	+ (Token.Control _, Token.Control _) => true
	+ \| (Token.Error _, Token.Error _) => true
	+ \| _ => kind = kind');
	+
	val immediate_kinds' = fn Token.Command => 0
	\| Token.Keyword => 1
	\| Token.Ident => 2
	\| Token.Long_Ident => 3
	\| Token.Sym_Ident => 4
	\| Token.Var => 5
	\| Token.Type_Ident => 6
	\| Token.Type_Var => 7
	\| Token.Nat => 8
	\| Token.Float => 9
	\| Token.Space => 10
	\| _ => ~1

	val delimited_kind =
	(fn Token.String => true
	\| Token.Alt_String => true
	\| Token.Cartouche => true
	+ \| Token.Control _ => true
	\| Token.Comment _ => true
	\| _ => false);


	(* datatype token *)

	(*The value slot assigns an (optional) internal value to a token,
	usually as a side-effect of special scanner setup (see also
	args.ML). Note that an assignable ref designates an intermediate
	state of internalization -- it is NOT meant to persist.*)

	datatype T = Token of (Symbol_Pos.text * Position.range) * (Token.kind * string) * slot

	and slot =
	Slot \|
	Value of value option \|
	Assignable of value option Unsynchronized.ref

	and value =
	Source of T list \|
	Literal of bool * Markup.T \|
	Name of Token.name_value * morphism \|
	Typ of typ \|
	Term of term \|
	Fact of string option * thm list \| (optional name for dynamic fact, i.e. fact "variable")
	Attribute of morphism -> attribute \|
	Declaration of declaration \|
	- Files of Token.file Exn.result list;
	+ Files of Token.file Exn.result list \|
	+ Output of XML.body option;

	type src = T list;


	(* position *)

	fun pos_of (Token ((_, (pos, _)), _, _)) = pos;
	fun end_pos_of (Token ((_, (_, pos)), _, _)) = pos;

	fun adjust_offsets adjust (Token ((x, range), y, z)) =
	Token ((x, apply2 (Position.adjust_offsets adjust) range), y, z);


	(* stopper *)

	fun mk_eof pos = Token (("", (pos, Position.none)), (Token.EOF, ""), Slot);
	val eof = mk_eof Position.none;

	fun is_eof (Token (_, (Token.EOF, _), _)) = true
	\| is_eof _ = false;

	val not_eof = not o is_eof;

	val stopper =
	Scan.stopper (fn [] => eof \| toks => mk_eof (end_pos_of (List.last toks))) is_eof;


	(* kind of token *)

	fun kind_of (Token (_, (k, _), _)) = k;
	-fun is_kind k (Token (_, (k', _), _)) = k = k';
	+fun is_kind k (Token (_, (k', _), _)) = equiv_kind k k';
	+
	+fun get_control tok =
	+ (case kind_of tok of Token.Control control => SOME control \| _ => NONE);

	val is_command = is_kind Token.Command;

	fun keyword_with pred (Token (_, (Token.Keyword, x), _)) = pred x
	\| keyword_with _ _ = false;

	val is_command_modifier = keyword_with (fn x => x = "private" orelse x = "qualified");

	fun ident_with pred (Token (_, (Token.Ident, x), _)) = pred x
	\| ident_with _ _ = false;

	fun is_ignored (Token (_, (Token.Space, _), _)) = true
	\| is_ignored (Token (_, (Token.Comment NONE, _), _)) = true
	\| is_ignored _ = false;

	fun is_proper (Token (_, (Token.Space, _), _)) = false
	\| is_proper (Token (_, (Token.Comment _, _), _)) = false
	\| is_proper _ = true;

	fun is_comment (Token (_, (Token.Comment _, _), _)) = true
	\| is_comment _ = false;

	fun is_informal_comment (Token (_, (Token.Comment NONE, _), _)) = true
	\| is_informal_comment _ = false;

	fun is_formal_comment (Token (_, (Token.Comment (SOME _), _), _)) = true
	\| is_formal_comment _ = false;

	fun is_document_marker (Token (_, (Token.Comment (SOME Comment.Marker), _), _)) = true
	\| is_document_marker _ = false;

	fun is_begin_ignore (Token (_, (Token.Comment NONE, "<"), _)) = true
	\| is_begin_ignore _ = false;

	fun is_end_ignore (Token (_, (Token.Comment NONE, ">"), _)) = true
	\| is_end_ignore _ = false;

	fun is_error (Token (_, (Token.Error _, _), _)) = true
	\| is_error _ = false;

	fun is_error' (Token (_, (Token.Error msg, _), _)) = SOME msg
	\| is_error' _ = NONE;

	fun content_of (Token (_, (_, x), _)) = x;
	fun content_of' (Token (_, (_, _), Value (SOME (Source l)))) =
	map (fn Token ((_, (pos, _)), (_, x), _) => (x, pos)) l
	\| content_of' _ = [];

	val is_stack1 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) =>
	forall (fn tok => content_of tok = "+") l
	\| _ => false;

	val is_stack2 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) =>
	forall (fn tok => content_of tok = "@") l
	\| _ => false;

	val is_stack3 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) =>
	forall (fn tok => content_of tok = "&") l
	\| _ => false;


	(* blanks and newlines -- space tokens obey lines *)

	-fun is_space (Token (_, (Space, _), _)) = true
	+fun is_space (Token (_, (Token.Space, _), _)) = true
	\| is_space _ = false;

	-fun is_blank (Token (_, (Space, x), _)) = not (String.isSuffix "\n" x)
	+fun is_blank (Token (_, (Token.Space, x), _)) = not (String.isSuffix "\n" x)
	\| is_blank _ = false;

	-fun is_newline (Token (_, (Space, x), _)) = String.isSuffix "\n" x
	+fun is_newline (Token (_, (Token.Space, x), _)) = String.isSuffix "\n" x
	\| is_newline _ = false;


	(* range of tokens *)

	fun range_of (toks as tok :: _) =
	let val pos' = end_pos_of (List.last toks)
	in Position.range (pos_of tok, pos') end
	\| range_of [] = Position.no_range;

	val core_range_of =
	drop_prefix is_ignored #> drop_suffix is_ignored #> range_of;


	(* token content *)

	fun content_of (Token (_, (_, x), _)) = x;
	fun source_of (Token ((source, _), _, _)) = source;

	fun input_of (Token ((source, range), (kind, _), _)) =
	Input.source (delimited_kind kind) source range;

	fun inner_syntax_of tok =
	let val x = content_of tok
	in if YXML.detect x then x else Syntax.implode_input (input_of tok) end;


	(* markup reports *)

	local

	val token_kind_markup =
	fn Token.Var => (Markup.var, "")
	\| Token.Type_Ident => (Markup.tfree, "")
	\| Token.Type_Var => (Markup.tvar, "")
	\| Token.String => (Markup.string, "")
	\| Token.Alt_String => (Markup.alt_string, "")
	\| Token.Cartouche => (Markup.cartouche, "")
	+ \| Token.Control _ => (Markup.cartouche, "")
	\| Token.Comment _ => (Markup.ML_comment, "")
	\| Token.Error msg => (Markup.bad (), msg)
	\| _ => (Markup.empty, "");

	fun keyword_reports tok = map (fn markup => ((pos_of tok, markup), ""));

	fun command_markups keywords x =
	if C_Keyword.is_theory_end keywords x then [Markup.keyword2 \|> Markup.keyword_properties]
	else
	(if C_Keyword.is_proof_asm keywords x then [Markup.keyword3]
	else if C_Keyword.is_improper keywords x then [Markup.keyword1, Markup.improper]
	else [Markup.keyword1])
	\|> map Markup.command_properties;

	fun keyword_markup (important, keyword) x =
	if important orelse Symbol.is_ascii_identifier x then keyword else Markup.delimiter;

	fun command_minor_markups keywords x =
	if C_Keyword.is_theory_end keywords x then [Markup.keyword2 \|> Markup.keyword_properties]
	else
	(if C_Keyword.is_proof_asm keywords x then [Markup.keyword3]
	else if C_Keyword.is_improper keywords x then [Markup.keyword1, Markup.improper]
	else if C_Keyword.is_command keywords x then [Markup.keyword1]
	else [keyword_markup (false, Markup.keyword2 \|> Markup.keyword_properties) x]);

	in

	fun completion_report tok =
	if is_kind Token.Keyword tok
	then map (fn m => ((pos_of tok, m), "")) (Completion.suppress_abbrevs (content_of tok))
	else [];

	fun reports keywords tok =
	if is_command tok then
	keyword_reports tok (command_markups keywords (content_of tok))
	else if is_stack1 tok orelse is_stack2 tok orelse is_stack3 tok then
	keyword_reports tok [Markup.keyword2 \|> Markup.keyword_properties]
	else if is_kind Token.Keyword tok then
	keyword_reports tok (command_minor_markups keywords (content_of tok))
	else
	let
	val pos = pos_of tok;
	val (m, text) = token_kind_markup (kind_of tok);
	- val delete = (Symbol_Pos.explode_deleted (source_of tok, pos));
	- in ((pos, m), text) :: map (fn p => ((p, Markup.delete), "")) delete end;
	+ val deleted = Symbol_Pos.explode_deleted (source_of tok, pos);
	+ in ((pos, m), text) :: map (fn p => ((p, Markup.delete), "")) deleted end;

	fun markups keywords = map (#2 o #1) o reports keywords;

	end;


	(* unparse *)

	fun unparse' (Token ((source0, _), (kind, x), _)) =
	let
	val source =
	\<comment> \<open> We are computing a reverse function of \<^ML>\<open>Symbol_Pos.implode_range\<close>
	taking into account consecutive \<^ML>\<open>Symbol.DEL\<close> symbols potentially appearing
	- at the beginning, or at the end of the string.
	-
	- As remark, \<^ML>\<open>Symbol_Pos.explode_deleted\<close>
	- will remove any potentially consecutive \<^ML>\<open>Symbol.DEL\<close> symbols.
	- This is why it is not used here.\<close>
	+ at the beginning, or at the end of the string.\<close>
	case Symbol.explode source0 of
	x :: xs =>
	if x = Symbol.DEL then
	case rev xs of x' :: xs => if x' = Symbol.DEL then implode (rev xs) else source0
	\| _ => source0
	else
	source0
	\| _ => source0
	in
	case kind of
	Token.String => Symbol_Pos.quote_string_qq source
	\| Token.Alt_String => Symbol_Pos.quote_string_bq source
	\| Token.Cartouche => cartouche source
	+ \| Token.Control control => Symbol_Pos.content (Antiquote.control_symbols control)
	\| Token.Comment NONE => enclose "(" ")" source
	\| Token.EOF => ""
	\| _ => x
	end;

	fun text_of tok =
	let
	val k = Token.str_of_kind (kind_of tok);
	val ms = markups C_Keyword.empty_keywords tok;
	val s = unparse' tok;
	in
	if s = "" then (k, "")
	else if size s < 40 andalso not (exists_string (fn c => c = "\n") s)
	then (k ^ " " ^ Markup.markups ms s, "")
	else (k, Markup.markups ms s)
	end;



	( associated values )

	(* inlined file content *)

	fun file_source (file: Token.file) =
	let
	val text = cat_lines (#lines file);
	- val end_pos = fold Position.symbol (Symbol.explode text) (#pos file);
	+ val end_pos = Position.symbol_explode text (#pos file);
	in Input.source true text (Position.range (#pos file, end_pos)) end;

	fun get_files (Token (_, _, Value (SOME (Files files)))) = files
	\| get_files _ = [];

	fun put_files [] tok = tok
	\| put_files files (Token (x, y, Slot)) = Token (x, y, Value (SOME (Files files)))
	\| put_files _ tok = raise Fail ("Cannot put inlined files here" ^ Position.here (pos_of tok));


	(* access values *)



	(* reports of value *)



	(* name value *)



	(* maxidx *)



	(* fact values *)



	(* transform *)



	(* static binding *)

	(1st stage: initialize assignable slots)
	fun init_assignable tok =
	(case tok of
	Token (x, y, Slot) => Token (x, y, Assignable (Unsynchronized.ref NONE))
	\| Token (_, _, Value _) => tok
	\| Token (_, _, Assignable r) => (r := NONE; tok));

	(2nd stage: assign values as side-effect of scanning)
	fun assign v tok =
	(case tok of
	Token (x, y, Slot) => Token (x, y, Value v)
	\| Token (_, _, Value _) => tok
	\| Token (_, _, Assignable r) => (r := v; tok));

	fun evaluate mk eval arg =
	let val x = eval arg in (assign (SOME (mk x)) arg; x) end;

	(3rd stage: static closure of final values)
	fun closure (Token (x, y, Assignable (Unsynchronized.ref v))) = Token (x, y, Value v)
	\| closure tok = tok;


	(* pretty *)



	(* src *)







	( scanners )

	open Basic_Symbol_Pos;

	val err_prefix = "Annotation lexical error: ";

	fun !!! msg = Symbol_Pos.!!! (fn () => err_prefix ^ msg);


	(* scan stack *)

	fun scan_stack is_stack = Scan.optional (Scan.one is_stack >> content_of') []


	(* scan symbolic idents *)

	val scan_symid =
	Scan.many1 (Symbol.is_symbolic_char o Symbol_Pos.symbol) \|\|
	Scan.one (Symbol.is_symbolic o Symbol_Pos.symbol) >> single;

	fun is_symid str =
	(case try Symbol.explode str of
	SOME [s] => Symbol.is_symbolic s orelse Symbol.is_symbolic_char s
	\| SOME ss => forall Symbol.is_symbolic_char ss
	\| _ => false);

	fun ident_or_symbolic "begin" = false
	\| ident_or_symbolic ":" = true
	\| ident_or_symbolic "::" = true
	\| ident_or_symbolic s = Symbol_Pos.is_identifier s orelse is_symid s;


	(* scan cartouche *)

	val scan_cartouche =
	Symbol_Pos.scan_pos --
	((Symbol_Pos.scan_cartouche err_prefix >> Symbol_Pos.cartouche_content) -- Symbol_Pos.scan_pos);


	(* scan space *)

	fun space_symbol (s, _) = Symbol.is_blank s andalso s <> "\n";

	val scan_space =
	Scan.many1 space_symbol @@@ Scan.optional ($$$ "\n") [] \|\|
	Scan.many space_symbol @@@ $$$ "\n";


	(* scan comment *)

	val scan_comment =
	Symbol_Pos.scan_pos -- (Symbol_Pos.scan_comment_body err_prefix -- Symbol_Pos.scan_pos);



	( token sources )

	local

	fun token_leq ((_, syms1), (_, syms2)) = length syms1 <= length syms2;

	fun token k ss =
	Token ((Symbol_Pos.implode ss, Symbol_Pos.range ss), (k, Symbol_Pos.content ss), Slot);

	fun token' (mk_value, k) ss =
	if mk_value then
	Token ( (Symbol_Pos.implode ss, Symbol_Pos.range ss)
	, (k, Symbol_Pos.content ss)
	, Value (SOME (Source (map (fn (s, pos) =>
	Token (("", (pos, Position.none)), (k, s), Slot))
	ss))))
	else
	token k ss;

	fun token_t k = token' (true, k)

	fun token_range k (pos1, (ss, pos2)) =
	Token (Symbol_Pos.implode_range (pos1, pos2) ss, (k, Symbol_Pos.content ss), Slot);

	fun scan_token keywords = !!! "bad input"
	(Symbol_Pos.scan_string_qq err_prefix >> token_range Token.String \|\|
	Symbol_Pos.scan_string_bq err_prefix >> token_range Token.Alt_String \|\|
	- scan_cartouche >> token_range Token.Cartouche \|\|
	scan_comment >> token_range (Token.Comment NONE) \|\|
	Comment.scan_outer >> (fn (k, ss) => token (Token.Comment (SOME k)) ss) \|\|
	+ scan_cartouche >> token_range Token.Cartouche \|\|
	+ Antiquote.scan_control err_prefix >> (fn control =>
	+ token (Token.Control control) (Antiquote.control_symbols control)) \|\|
	scan_space >> token Token.Space \|\|
	Scan.repeats1 ($$$ "+") >> token_t Token.Sym_Ident \|\|
	Scan.repeats1 ($$$ "@") >> token_t Token.Sym_Ident \|\|
	Scan.repeats1 ($$$ "&") >> token_t Token.Sym_Ident \|\|
	(Scan.max token_leq
	(Scan.max token_leq
	(Scan.literal (C_Keyword.major_keywords keywords) >> pair Token.Command)
	(Scan.literal (C_Keyword.minor_keywords keywords) >> pair Token.Keyword))
	(Lexicon.scan_longid >> pair Token.Long_Ident \|\|
	Scan.max
	token_leq
	- (C_Lex.scan_ident >> pair Token.Ident)
	+ (C_Lex.scan_ident' >> pair Token.Ident)
	(Lexicon.scan_id >> pair Token.Ident) \|\|
	Lexicon.scan_var >> pair Token.Var \|\|
	Lexicon.scan_tid >> pair Token.Type_Ident \|\|
	Lexicon.scan_tvar >> pair Token.Type_Var \|\|
	Symbol_Pos.scan_float >> pair Token.Float \|\|
	Symbol_Pos.scan_nat >> pair Token.Nat \|\|
	scan_symid >> pair Token.Sym_Ident)) >> uncurry (token' o pair false));

	fun recover msg =
	(Symbol_Pos.recover_string_qq \|\|
	Symbol_Pos.recover_string_bq \|\|
	Symbol_Pos.recover_cartouche \|\|
	Symbol_Pos.recover_comment \|\|
	Scan.one (Symbol.not_eof o Symbol_Pos.symbol) >> single)
	>> (single o token (Token.Error msg));

	in

	fun make_source keywords {strict} =
	let
	val scan_strict = Scan.bulk (scan_token keywords);
	val scan = if strict then scan_strict else Scan.recover scan_strict recover;
	in Source.source Symbol_Pos.stopper scan end;


	end;


	(* explode *)

	fun tokenize keywords strict syms =
	Source.of_list syms \|> make_source keywords strict \|> Source.exhaust;

	fun explode keywords pos text =
	Symbol_Pos.explode (text, pos) \|> tokenize keywords {strict = false};

	fun explode0 keywords = explode keywords Position.none;


	-(* print name in parsable form *)
	+(* print names in parsable form *)



	(* make *)




	( parsers )

	type 'a parser = T list -> 'a * T list;
	type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list);


	-(* read body -- e.g. antiquotation source *)
	-
	-fun read_with_commands'0 keywords syms =
	- Source.of_list syms
	- \|> make_source keywords {strict = false}
	- \|> Source.filter (not o is_proper)
	- \|> Source.exhaust
	-
	-fun read_with_commands' keywords scan syms =
	- Source.of_list syms
	- \|> make_source keywords {strict = false}
	- \|> Source.filter is_proper
	- \|> Source.source
	- stopper
	- (Scan.recover
	- (Scan.bulk scan)
	- (fn msg =>
	- Scan.one (not o is_eof)
	- >> (fn tok => [C_Scan.Right
	- let
	- val msg = case is_error' tok of SOME msg0 => msg0 ^ " (" ^ msg ^ ")"
	- \| NONE => msg
	- in ( msg
	- , [((pos_of tok, Markup.bad ()), msg)]
	- , tok)
	- end])))
	- \|> Source.exhaust;
	-
	-fun read_antiq' keywords scan = read_with_commands' keywords (scan >> C_Scan.Left);
	-
	(* wrapped syntax *)

	local
	fun make src pos = Token.make src pos \|> #1
	fun make_default text pos = make ((~1, 0), text) pos
	fun explode keywords pos text =
	case Token.explode keywords pos text of [tok] => tok
	\| _ => make_default text pos
	in
	fun syntax' f =
	I #> map
	(fn tok0 as Token ((source, (pos1, pos2)), (kind, x), _) =>
	if is_stack1 tok0 orelse is_stack2 tok0 orelse is_stack3 tok0 then
	make_default source pos1
	else if is_eof tok0 then
	Token.eof
	else if delimited_kind kind then
	explode Keyword.empty_keywords pos1 (unparse' tok0)
	else
	let
	val tok1 =
	explode
	((case kind of
	Token.Keyword => Keyword.add_keywords [((x, Position.none), Keyword.no_spec)]
	- \| Token.Command => Keyword.add_keywords [( (x, Position.none),
	- Keyword.command_spec(Keyword.thy_decl, []))]
	+ \| Token.Command => Keyword.add_keywords [( (x, Position.none)
	+ , Keyword.command_spec
	+ (Keyword.thy_decl, []))]
	\| _ => I)
	Keyword.empty_keywords)
	pos1
	source
	in
	if Token.kind_of tok1 = kind then
	tok1
	else
	make ( ( immediate_kinds' kind
	, case Position.distance_of (pos1, pos2) of NONE => 0 \| SOME i => i)
	, source)
	pos1
	end)
	#> f
	#> apsnd (map (fn tok => Token ( (Token.source_of tok, Token.range_of [tok])
	, (Token.kind_of tok, Token.content_of tok)
	, Slot)))
	end
	end;

	type 'a c_parser = 'a C_Token.parser;
	type 'a c_context_parser = 'a C_Token.context_parser;
	\<close>

	+(* parsers for C syntax. A partial copy is unfortunately necessary due to signature restrictions. *)
	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/parse.ML\<close>\<close>
	(* Author: Frédéric Tuong, Université Paris-Saclay
	- parsers for C syntax. A partial copy is unfortunately necessary due to signature restrictions.
	- *)
	-(* based on:
	- Title: Pure/Isar/parse.ML
	+ Analogous to:
	+(* Title: Pure/Isar/parse.ML
	Author: Markus Wenzel, TU Muenchen

	Generic parsers for Isabelle/Isar outer syntax.
	-*)
	+))
	\<open>
	signature C_PARSE =
	sig
	type T
	type src = T list
	type 'a parser = T list -> 'a * T list
	type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list)
	(**)
	val C_source: Input.source parser
	val star: string parser
	(**)
	val group: (unit -> string) -> (T list -> 'a) -> T list -> 'a
	val !!! : (T list -> 'a) -> T list -> 'a
	val !!!! : (T list -> 'a) -> T list -> 'a
	val not_eof: T parser
	val token: 'a parser -> T parser
	val range: 'a parser -> ('a * Position.range) parser
	val position: 'a parser -> ('a * Position.T) parser
	val input: 'a parser -> Input.source parser
	val inner_syntax: 'a parser -> string parser
	val command: string parser
	val keyword: string parser
	val short_ident: string parser
	val long_ident: string parser
	val sym_ident: string parser
	val dots: string parser
	val minus: string parser
	val term_var: string parser
	val type_ident: string parser
	val type_var: string parser
	val number: string parser
	val float_number: string parser
	val string: string parser
	val string_position: (string * Position.T) parser
	val alt_string: string parser
	val cartouche: string parser
	+ val control: Antiquote.control parser
	val eof: string parser
	val command_name: string -> string parser
	val keyword_with: (string -> bool) -> string parser
	val keyword_markup: bool * Markup.T -> string -> string parser
	val keyword_improper: string -> string parser
	val $$$ : string -> string parser
	val reserved: string -> string parser
	val underscore: string parser
	val maybe: 'a parser -> 'a option parser
	val maybe_position: ('a * Position.T) parser -> ('a option * Position.T) parser
	val opt_keyword: string -> bool parser
	val opt_bang: bool parser
	val begin: string parser
	val opt_begin: bool parser
	val nat: int parser
	val int: int parser
	val real: real parser
	val enum_positions: string -> 'a parser -> ('a list * Position.T list) parser
	val enum1_positions: string -> 'a parser -> ('a list * Position.T list) parser
	val enum: string -> 'a parser -> 'a list parser
	val enum1: string -> 'a parser -> 'a list parser
	val and_list: 'a parser -> 'a list parser
	val and_list1: 'a parser -> 'a list parser
	val enum': string -> 'a context_parser -> 'a list context_parser
	val enum1': string -> 'a context_parser -> 'a list context_parser
	val and_list': 'a context_parser -> 'a list context_parser
	val and_list1': 'a context_parser -> 'a list context_parser
	val list: 'a parser -> 'a list parser
	val list1: 'a parser -> 'a list parser
	val name: string parser
	val name_range: (string * Position.range) parser
	val name_position: (string * Position.T) parser
	val binding: binding parser
	val embedded: string parser
	+ val embedded_inner_syntax: string parser
	val embedded_input: Input.source parser
	val embedded_position: (string * Position.T) parser
	+ val path_input: Input.source parser
	val path: string parser
	val path_binding: (string * Position.T) parser
	val session_name: (string * Position.T) parser
	val theory_name: (string * Position.T) parser
	val liberal_name: string parser
	val parname: string parser
	val parbinding: binding parser
	val class: string parser
	val sort: string parser
	val type_const: string parser
	val arity: (string * string list * string) parser
	val multi_arity: (string list * string list * string) parser
	val type_args: string list parser
	val type_args_constrained: (string * string option) list parser
	val typ: string parser
	val mixfix: mixfix parser
	val mixfix': mixfix parser
	val opt_mixfix: mixfix parser
	val opt_mixfix': mixfix parser
	val syntax_mode: Syntax.mode parser
	val where_: string parser
	val const_decl: (string * string * mixfix) parser
	val const_binding: (binding * string * mixfix) parser
	val params: (binding * string option * mixfix) list parser
	val vars: (binding * string option * mixfix) list parser
	val for_fixes: (binding * string option * mixfix) list parser
	val ML_source: Input.source parser
	val document_source: Input.source parser
	val document_marker: Input.source parser
	val const: string parser
	val term: string parser
	val prop: string parser
	val literal_fact: string parser
	val propp: (string * string list) parser
	val termp: (string * string list) parser
	val private: Position.T parser
	val qualified: Position.T parser
	val target: (string * Position.T) parser
	val opt_target: (string * Position.T) option parser
	val args: T list parser
	val args1: (string -> bool) -> T list parser
	val attribs: src list parser
	val opt_attribs: src list parser
	val thm_sel: Facts.interval list parser
	val thm: (Facts.ref * src list) parser
	val thms1: (Facts.ref * src list) list parser
	val options: ((string * Position.T) * (string * Position.T)) list parser
	+ val embedded_ml: ML_Lex.token Antiquote.antiquote list parser
	end;

	structure C_Parse: C_PARSE =
	struct
	type T = C_Token.T
	type src = T list
	type 'a parser = T list -> 'a * T list
	type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list)
	structure Token =
	struct
	open Token
	open C_Token
	end

	( error handling )

	(* group atomic parsers (no cuts!) *)

	fun group s scan = scan \|\| Scan.fail_with
	(fn [] => (fn () => s () ^ " expected,\nbut end-of-input was found")
	\| tok :: _ =>
	(fn () =>
	(case Token.text_of tok of
	(txt, "") =>
	s () ^ " expected,\nbut " ^ txt ^ Position.here (Token.pos_of tok) ^
	" was found"
	\| (txt1, txt2) =>
	s () ^ " expected,\nbut " ^ txt1 ^ Position.here (Token.pos_of tok) ^
	" was found:\n" ^ txt2)));


	(* cut *)

	fun cut kind scan =
	let
	fun get_pos [] = " (end-of-input)"
	\| get_pos (tok :: _) = Position.here (Token.pos_of tok);

	fun err (toks, NONE) = (fn () => kind ^ get_pos toks)
	\| err (toks, SOME msg) =
	(fn () =>
	let val s = msg () in
	if String.isPrefix kind s then s
	else kind ^ get_pos toks ^ ": " ^ s
	end);
	in Scan.!! err scan end;

	fun !!! scan = cut "Annotation syntax error" scan;
	fun !!!! scan = cut "Corrupted annotation syntax in presentation" scan;



	( basic parsers )

	(* tokens *)

	fun RESET_VALUE atom = (required for all primitive parsers)
	Scan.ahead (Scan.one (K true)) -- atom >> (fn (arg, x) => (Token.assign NONE arg; x));


	val not_eof = RESET_VALUE (Scan.one Token.not_eof);

	fun token atom = Scan.ahead not_eof --\| atom;

	fun range scan = (Scan.ahead not_eof >> (Token.range_of o single)) -- scan >> Library.swap;
	fun position scan = (Scan.ahead not_eof >> Token.pos_of) -- scan >> Library.swap;
	fun input atom = Scan.ahead atom \|-- not_eof >> Token.input_of;
	fun inner_syntax atom = Scan.ahead atom \|-- not_eof >> Token.inner_syntax_of;

	fun kind k =
	group (fn () => Token.str_of_kind k)
	(RESET_VALUE (Scan.one (Token.is_kind k) >> Token.content_of));

	val command = kind Token.Command;
	val keyword = kind Token.Keyword;
	val short_ident = kind Token.Ident;
	val long_ident = kind Token.Long_Ident;
	val sym_ident = kind Token.Sym_Ident;
	val term_var = kind Token.Var;
	val type_ident = kind Token.Type_Ident;
	val type_var = kind Token.Type_Var;
	val number = kind Token.Nat;
	val float_number = kind Token.Float;
	val string = kind Token.String;
	val alt_string = kind Token.Alt_String;
	val cartouche = kind Token.Cartouche;
	+val control = token (kind Token.control_kind) >> (the o Token.get_control);
	val eof = kind Token.EOF;

	fun command_name x =
	group (fn () => Token.str_of_kind Token.Command ^ " " ^ quote x)
	(RESET_VALUE (Scan.one (fn tok => Token.is_command tok andalso Token.content_of tok = x)))
	>> Token.content_of;

	fun keyword_with pred = RESET_VALUE (Scan.one (Token.keyword_with pred) >> Token.content_of);

	fun keyword_markup markup x =
	group (fn () => Token.str_of_kind Token.Keyword ^ " " ^ quote x)
	(Scan.ahead not_eof -- keyword_with (fn y => x = y))
	>> (fn (tok, x) => (Token.assign (SOME (Token.Literal markup)) tok; x));

	val keyword_improper = keyword_markup (true, Markup.improper);
	val $$$ = keyword_markup (false, Markup.quasi_keyword);

	fun reserved x =
	group (fn () => "reserved identifier " ^ quote x)
	(RESET_VALUE (Scan.one (Token.ident_with (fn y => x = y)) >> Token.content_of));

	val dots = sym_ident :-- (fn "\<dots>" => Scan.succeed () \| _ => Scan.fail) >> #1;

	val minus = sym_ident :-- (fn "-" => Scan.succeed () \| _ => Scan.fail) >> #1;

	val underscore = sym_ident :-- (fn "_" => Scan.succeed () \| _ => Scan.fail) >> #1;
	fun maybe scan = underscore >> K NONE \|\| scan >> SOME;
	fun maybe_position scan = position (underscore >> K NONE) \|\| scan >> apfst SOME;

	val nat = number >> (#1 o Library.read_int o Symbol.explode);
	val int = Scan.optional (minus >> K ~1) 1 -- nat >> op *;
	val real = float_number >> Value.parse_real \|\| int >> Real.fromInt;

	fun opt_keyword s = Scan.optional ($$$ "(" \|-- !!! (($$$ s >> K true) --\| $$$ ")")) false;
	val opt_bang = Scan.optional ($$$ "!" >> K true) false;

	val begin = $$$ "begin";
	val opt_begin = Scan.optional (begin >> K true) false;


	(* enumerations *)

	fun enum1_positions sep scan =
	scan -- Scan.repeat (position ($$$ sep) -- !!! scan) >>
	(fn (x, ys) => (x :: map #2 ys, map (#2 o #1) ys));
	fun enum_positions sep scan =
	enum1_positions sep scan \|\| Scan.succeed ([], []);

	fun enum1 sep scan = scan ::: Scan.repeat ($$$ sep \|-- !!! scan);
	fun enum sep scan = enum1 sep scan \|\| Scan.succeed [];

	fun enum1' sep scan = scan ::: Scan.repeat (Scan.lift ($$$ sep) \|-- scan);
	fun enum' sep scan = enum1' sep scan \|\| Scan.succeed [];

	fun and_list1 scan = enum1 "and" scan;
	fun and_list scan = enum "and" scan;

	fun and_list1' scan = enum1' "and" scan;
	fun and_list' scan = enum' "and" scan;

	fun list1 scan = enum1 "," scan;
	fun list scan = enum "," scan;


	(* names and embedded content *)

	val name =
	group (fn () => "name")
	(short_ident \|\| long_ident \|\| sym_ident \|\| number \|\| string);

	val name_range = input name >> Input.source_content_range;
	val name_position = input name >> Input.source_content;

	val string_position = input string >> Input.source_content;

	val binding = name_position >> Binding.make;

	val embedded =
	group (fn () => "embedded content")
	(cartouche \|\| string \|\| short_ident \|\| long_ident \|\| sym_ident \|\|
	term_var \|\| type_ident \|\| type_var \|\| number);

	+val embedded_inner_syntax = inner_syntax embedded;
	val embedded_input = input embedded;
	val embedded_position = embedded_input >> Input.source_content;

	-val path = group (fn () => "file name/path specification") embedded;
	+val path_input = group (fn () => "file name/path specification") embedded_input;
	+val path = path_input >> Input.string_of;
	val path_binding = group (fn () => "path binding (strict file name)") (position embedded);

	val session_name = group (fn () => "session name") name_position;
	val theory_name = group (fn () => "theory name") name_position;

	val liberal_name = keyword_with Token.ident_or_symbolic \|\| name;

	val parname = Scan.optional ($$$ "(" \|-- name --\| $$$ ")") "";
	val parbinding = Scan.optional ($$$ "(" \|-- binding --\| $$$ ")") Binding.empty;


	(* type classes *)

	val class = group (fn () => "type class") (inner_syntax embedded);

	val sort = group (fn () => "sort") (inner_syntax embedded);

	val type_const = group (fn () => "type constructor") (inner_syntax embedded);

	val arity = type_const -- ($$$ "::" \|-- !!!
	(Scan.optional ($$$ "(" \|-- !!! (list1 sort --\| $$$ ")")) [] -- sort)) >> Scan.triple2;

	val multi_arity = and_list1 type_const -- ($$$ "::" \|-- !!!
	(Scan.optional ($$$ "(" \|-- !!! (list1 sort --\| $$$ ")")) [] -- sort)) >> Scan.triple2;


	(* types *)

	val typ = group (fn () => "type") (inner_syntax embedded);

	fun type_arguments arg =
	arg >> single \|\|
	$$$ "(" \|-- !!! (list1 arg --\| $$$ ")") \|\|
	Scan.succeed [];

	val type_args = type_arguments type_ident;
	val type_args_constrained = type_arguments (type_ident -- Scan.option ($$$ "::" \|-- !!! sort));


	(* mixfix annotations *)

	local

	val mfix = input (string \|\| cartouche);

	val mixfix_ =
	mfix -- !!! (Scan.optional ($$$ "[" \|-- !!! (list nat --\| $$$ "]")) [] -- Scan.optional nat 1000)
	>> (fn (sy, (ps, p)) => fn range => Mixfix (sy, ps, p, range));

	val structure_ = $$$ "structure" >> K Structure;

	val binder_ =
	$$$ "binder" \|-- !!! (mfix -- ($$$ "[" \|-- nat --\| $$$ "]" -- nat \|\| nat >> (fn n => (n, n))))
	>> (fn (sy, (p, q)) => fn range => Binder (sy, p, q, range));

	val infixl_ = $$$ "infixl"
	\|-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infixl (sy, p, range)));
	val infixr_ = $$$ "infixr"
	\|-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infixr (sy, p, range)));
	val infix_ = $$$ "infix"
	\|-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infix (sy, p, range)));

	val mixfix_body = mixfix_ \|\| structure_ \|\| binder_ \|\| infixl_ \|\| infixr_ \|\| infix_;

	fun annotation guard body =
	Scan.trace ($$$ "(" \|-- guard (body --\| $$$ ")"))
	>> (fn (mx, toks) => mx (Token.range_of toks));

	fun opt_annotation guard body = Scan.optional (annotation guard body) NoSyn;

	in

	val mixfix = annotation !!! mixfix_body;
	val mixfix' = annotation I mixfix_body;
	val opt_mixfix = opt_annotation !!! mixfix_body;
	val opt_mixfix' = opt_annotation I mixfix_body;

	end;


	(* syntax mode *)

	val syntax_mode_spec =
	($$$ "output" >> K ("", false)) \|\| name -- Scan.optional ($$$ "output" >> K false) true;

	val syntax_mode =
	Scan.optional ($$$ "(" \|-- !!! (syntax_mode_spec --\| $$$ ")")) Syntax.mode_default;


	(* fixes *)

	val where_ = $$$ "where";

	val const_decl = name -- ($$$ "::" \|-- !!! typ) -- opt_mixfix >> Scan.triple1;
	val const_binding = binding -- ($$$ "::" \|-- !!! typ) -- opt_mixfix >> Scan.triple1;

	val param_mixfix = binding -- Scan.option ($$$ "::" \|-- typ) -- mixfix' >> (single o Scan.triple1);

	val params =
	(binding -- Scan.repeat binding) -- Scan.option ($$$ "::" \|-- !!! (Scan.ahead typ -- embedded))
	>> (fn ((x, ys), T) =>
	(x, Option.map #1 T, NoSyn) :: map (fn y => (y, Option.map #2 T, NoSyn)) ys);

	val vars = and_list1 (param_mixfix \|\| params) >> flat;

	val for_fixes = Scan.optional ($$$ "for" \|-- !!! vars) [];


	(* embedded source text *)

	val ML_source = input (group (fn () => "ML source") embedded);
	val document_source = input (group (fn () => "document source") embedded);

	val document_marker =
	group (fn () => "document marker")
	(RESET_VALUE (Scan.one Token.is_document_marker >> Token.input_of));


	(* terms *)

	val const = group (fn () => "constant") (inner_syntax embedded);
	val term = group (fn () => "term") (inner_syntax embedded);
	val prop = group (fn () => "proposition") (inner_syntax embedded);

	val literal_fact = inner_syntax (group (fn () => "literal fact") (alt_string \|\| cartouche));


	(* patterns *)

	val is_terms = Scan.repeat1 ($$$ "is" \|-- term);
	val is_props = Scan.repeat1 ($$$ "is" \|-- prop);

	val propp = prop -- Scan.optional ($$$ "(" \|-- !!! (is_props --\| $$$ ")")) [];
	val termp = term -- Scan.optional ($$$ "(" \|-- !!! (is_terms --\| $$$ ")")) [];


	(* target information *)

	val private = position ($$$ "private") >> #2;
	val qualified = position ($$$ "qualified") >> #2;

	val target = ($$$ "(" -- $$$ "in") \|-- !!! (name_position --\| $$$ ")");
	val opt_target = Scan.option target;


	(* arguments within outer syntax *)

	local

	val argument_kinds =
	[Token.Ident, Token.Long_Ident, Token.Sym_Ident, Token.Var, Token.Type_Ident, Token.Type_Var,
	Token.Nat, Token.Float, Token.String, Token.Alt_String, Token.Cartouche];

	fun arguments is_symid =
	let
	fun argument blk =
	group (fn () => "argument")
	(Scan.one (fn tok =>
	let val kind = Token.kind_of tok in
	member (op =) argument_kinds kind orelse
	Token.keyword_with is_symid tok orelse
	(blk andalso Token.keyword_with (fn s => s = ",") tok)
	end));

	fun args blk x = Scan.optional (args1 blk) [] x
	and args1 blk x =
	(Scan.repeats1 (Scan.repeat1 (argument blk) \|\| argsp "(" ")" \|\| argsp "[" "]")) x
	and argsp l r x = (token ($$$ l) ::: !!! (args true @@@ (token ($$$ r) >> single))) x;
	in (args, args1) end;

	in

	val args = #1 (arguments Token.ident_or_symbolic) false;
	fun args1 is_symid = #2 (arguments is_symid) false;

	end;


	(* attributes *)

	val attrib = token liberal_name ::: !!! args;
	val attribs = $$$ "[" \|-- list attrib --\| $$$ "]";
	val opt_attribs = Scan.optional attribs [];


	(* theorem references *)

	val thm_sel = $$$ "(" \|-- list1
	(nat --\| minus -- nat >> Facts.FromTo \|\|
	nat --\| minus >> Facts.From \|\|
	nat >> Facts.Single) --\| $$$ ")";

	val thm =
	$$$ "[" \|-- attribs --\| $$$ "]" >> pair (Facts.named "") \|\|
	(literal_fact >> Facts.Fact \|\|
	name_position -- Scan.option thm_sel >> Facts.Named) -- opt_attribs;

	val thms1 = Scan.repeat1 thm;


	(* options *)

	val option_name = group (fn () => "option name") name_position;
	val option_value = group (fn () => "option value") ((token real \|\| token name) >> Token.content_of);

	val option =
	option_name :-- (fn (_, pos) =>
	Scan.optional ($$$ "=" \|-- !!! (position option_value)) ("true", pos));

	val options = $$$ "[" \|-- list1 option --\| $$$ "]";


	+(* embedded ML *)
	+
	+val embedded_ml =
	+ input underscore >> ML_Lex.read_source \|\|
	+ embedded_input >> ML_Lex.read_source \|\|
	+ control >> (ML_Lex.read_symbols o Antiquote.control_symbols);
	+
	+
	+(* read embedded source, e.g. for antiquotations *)
	+
	+
	+
	( C basic parsers )

	(* embedded source text *)

	val C_source = input (group (fn () => "C source") embedded);

	(* AutoCorres (MODIFIES) *)

	val star = sym_ident :-- (fn "*" => Scan.succeed () \| _ => Scan.fail) >> #1;

	end;

	structure C_Parse_Native: C_PARSE =
	struct
	open Token
	open Parse

	( C basic parsers )

	(* embedded source text *)

	val C_source = input (group (fn () => "C source") embedded);

	(* AutoCorres (MODIFIES) *)

	val star = sym_ident :-- (fn "*" => Scan.succeed () \| _ => Scan.fail) >> #1;
	end;
	+
	+structure C_Parse_Read =
	+struct
	+(* read embedded source, e.g. for antiquotations *)
	+
	+fun read_with_commands'0 keywords syms =
	+ Source.of_list syms
	+ \|> C_Token.make_source keywords {strict = false}
	+ \|> Source.filter (not o C_Token.is_proper)
	+ \|> Source.exhaust
	+
	+fun read_with_commands' keywords scan syms =
	+ Source.of_list syms
	+ \|> C_Token.make_source keywords {strict = false}
	+ \|> Source.filter C_Token.is_proper
	+ \|> Source.source
	+ C_Token.stopper
	+ (Scan.recover
	+ (Scan.bulk scan)
	+ (fn msg =>
	+ Scan.one (not o C_Token.is_eof)
	+ >> (fn tok => [C_Scan.Right
	+ let
	+ val msg = case C_Token.is_error' tok of SOME msg0 => msg0 ^ " (" ^ msg ^ ")"
	+ \| NONE => msg
	+ in ( msg
	+ , [((C_Token.pos_of tok, Markup.bad ()), msg)]
	+ , tok)
	+ end])))
	+ \|> Source.exhaust;
	+
	+fun read_antiq' keywords scan = read_with_commands' keywords (scan >> C_Scan.Left);
	+end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Thy/thy_header.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/Thy/thy_header.ML
	Author: Makarius

	Static theory header information.
	-*)
	+))
	\<open>
	structure C_Thy_Header =
	struct
	val bootstrap_keywords =
	C_Keyword.empty_keywords' (Keyword.minor_keywords (Thy_Header.get_keywords @{theory}))

	(* theory data *)

	structure Data = Theory_Data
	(
	type T = C_Keyword.keywords;
	val empty = bootstrap_keywords;
	val merge = C_Keyword.merge_keywords;
	);

	val add_keywords = Data.map o C_Keyword.add_keywords;
	val add_keywords_minor = Data.map o C_Keyword.add_keywords_minor;

	val get_keywords = Data.get;
	val get_keywords' = get_keywords o Proof_Context.theory_of;

	end
	\<close>

	-
	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Language.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Language.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Language.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Language.thy
	@@ -1,1507 +1,1546 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Core Language: Lexing Support, with Filtered Annotations (without Annotation Lexing)\<close>

	theory C_Lexer_Language
	imports Main
	begin

	text \<open>
	The part implementing the C lexer might resemble to the implementation of the ML one, but the C
	syntax is much complex: for example, the preprocessing of directives is implemented with several
	parsing layers. Also, we will see that the way antiquotations are handled in C is slightly different
	than in ML (especially in the execution part).

	Overall, the next ML structures presented here in this theory are all aligned with
	\<^file>\<open>~~/src/Pure/ROOT.ML\<close>, and are thus accordingly sorted in the same order
	(except for \<^file>\<open>~~/src/Pure/ML/ml_options.ML\<close> which is early included in the boot
	process).

	This theory will stop at \<^file>\<open>~~/src/Pure/ML/ml_lex.ML\<close>. It is basically situated
	in the phase 1 of the bootstrap process (of \<^file>\<open>~~/src/Pure/ROOT.ML\<close>), i.e., the
	part dealing with how to get some C tokens from a raw string:
	\<^ML_text>\<open>Position.T -> string -> token list\<close>.
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/General/scan.ML\<close>\<close> \<open>
	structure C_Scan =
	struct
	datatype ('a, 'b) either = Left of 'a \| Right of 'b

	fun opt x = Scan.optional x [];
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/General/symbol.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/General/symbol.ML
	Author: Makarius

	Generalized characters with infinitely many named symbols.
	-*)
	+))
	\<open>
	structure C_Symbol =
	struct
	fun is_ascii_quasi "_" = true
	\| is_ascii_quasi "$" = true
	\| is_ascii_quasi _ = false;

	fun is_identletter s =
	Symbol.is_ascii_letter s orelse is_ascii_quasi s

	fun is_ascii_oct s =
	Symbol.is_char s andalso Char.ord #"0" <= ord s andalso ord s <= Char.ord #"7";

	fun is_ascii_digit1 s =
	Symbol.is_char s andalso Char.ord #"1" <= ord s andalso ord s <= Char.ord #"9";

	fun is_ascii_letdig s =
	Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s orelse is_ascii_quasi s;

	fun is_ascii_identifier s =
	size s > 0 andalso forall_string is_ascii_letdig s;

	-val is_ascii_blank_no_line =
	- fn " " => true \| "\t" => true \| "\^K" => true \| "\f" => true
	- \| _ => false;
	+val ascii_blank_no_line =
	+ [ ([" "], NONE)
	+ , (["\t", "\^K", "\f"], SOME "Space symbol")
	+ , (["\194\160"], SOME "Non-standard space symbol") ]
	+
	+fun is_ascii_blank_no_line s =
	+ exists (#1 #> exists (curry op = s)) ascii_blank_no_line
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/General/position.ML\<close>\<close> \<open>
	structure C_Position =
	struct
	type reports_text = Position.report_text list
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/General/symbol_pos.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/General/symbol_pos.ML
	Author: Makarius

	Symbols with explicit position information.
	-*)
	+))
	\<open>
	structure C_Basic_Symbol_Pos = (not open by default)
	struct
	open Basic_Symbol_Pos;

	fun one f = Scan.one (f o Symbol_Pos.symbol)
	fun many f = Scan.many (f o Symbol_Pos.symbol)
	fun many1 f = Scan.many1 (f o Symbol_Pos.symbol)
	val one' = Scan.single o one
	fun scan_full !!! mem msg scan =
	scan --\| (Scan.ahead (one' (not o mem)) \|\| !!! msg Scan.fail)
	fun this_string s =
	(fold (fn s0 => uncurry (fn acc => one (fn s1 => s0 = s1) >> (fn x => x :: acc)))
	(Symbol.explode s)
	o pair [])
	>> rev
	val one_not_eof = Scan.one (Symbol.not_eof o #1)
	fun unless_eof scan = Scan.unless scan one_not_eof >> single
	val repeats_one_not_eof = Scan.repeats o unless_eof
	val newline = $$$ "\n"
	\|\| $$$ "\^M" @@@ $$$ "\n"
	\|\| $$$ "\^M"
	val repeats_until_nl = repeats_one_not_eof newline
	end

	structure C_Symbol_Pos =
	struct

	(* basic scanners *)

	val !!! = Symbol_Pos.!!!

	fun !!!! text scan =
	let
	fun get_pos [] = " (end-of-input)"
	\| get_pos ((_, pos) :: _) = Position.here pos;

	fun err ((_, syms), msg) = fn () =>
	text () ^ get_pos syms ^
	Markup.markup Markup.no_report (" at " ^ Symbol.beginning 10 (map Symbol_Pos.symbol syms)) ^
	(case msg of NONE => "" \| SOME m => "\n" ^ m ());
	in Scan.!! err scan end;

	val $$ = Symbol_Pos.$$

	val $$$ = Symbol_Pos.$$$

	val ~$$$ = Symbol_Pos.~$$$


	(* scan string literals *)

	local

	val char_code =
	Scan.one (Symbol.is_ascii_digit o Symbol_Pos.symbol) --
	Scan.one (Symbol.is_ascii_digit o Symbol_Pos.symbol) --
	Scan.one (Symbol.is_ascii_digit o Symbol_Pos.symbol) :\|--
	(fn (((a, pos), (b, _)), (c, _)) =>
	let val (n, _) = Library.read_int [a, b, c]
	in if n <= 255 then Scan.succeed [(chr n, pos)] else Scan.fail end);

	fun scan_str q err_prefix stop =
	$$$ "\\" \|-- !!! (fn () => err_prefix ^ "bad escape character in string")
	($$$ q \|\| $$$ "\\" \|\| char_code) \|\|
	Scan.unless stop
	(Scan.one (fn (s, _) => s <> q andalso s <> "\\" andalso Symbol.not_eof s)) >> single;

	fun scan_strs q err_prefix err_suffix stop =
	Scan.ahead ($$ q) \|--
	!!! (fn () => err_prefix ^ "unclosed string literal within " ^ err_suffix)
	((Symbol_Pos.scan_pos --\| $$$ q)
	-- (Scan.repeats (scan_str q err_prefix stop) -- ($$$ q \|-- Symbol_Pos.scan_pos)));

	in

	fun scan_string_qq_multi err_prefix stop = scan_strs "\"" err_prefix "the comment delimiter" stop;
	fun scan_string_bq_multi err_prefix stop = scan_strs "`" err_prefix "the comment delimiter" stop;
	fun scan_string_qq_inline err_prefix =
	scan_strs "\"" err_prefix "the same line" C_Basic_Symbol_Pos.newline;
	fun scan_string_bq_inline err_prefix =
	scan_strs "`" err_prefix "the same line" C_Basic_Symbol_Pos.newline;

	end;


	(* nested text cartouches *)

	fun scan_cartouche_depth stop =
	Scan.repeat1 (Scan.depend (fn (depth: int option) =>
	(case depth of
	SOME d =>
	$$ Symbol.open_ >> pair (SOME (d + 1)) \|\|
	(if d > 0 then
	Scan.unless stop
	(Scan.one (fn (s, _) => s <> Symbol.close andalso Symbol.not_eof s))
	>> pair depth \|\|
	$$ Symbol.close >> pair (if d = 1 then NONE else SOME (d - 1))
	else Scan.fail)
	\| NONE => Scan.fail)));

	fun scan_cartouche err_prefix err_suffix stop =
	Scan.ahead ($$ Symbol.open_) \|--
	!!! (fn () => err_prefix ^ "unclosed text cartouche within " ^ err_suffix)
	(Scan.provide is_none (SOME 0) (scan_cartouche_depth stop));

	fun scan_cartouche_multi err_prefix stop =
	scan_cartouche err_prefix "the comment delimiter" stop;
	fun scan_cartouche_inline err_prefix =
	scan_cartouche err_prefix "the same line" C_Basic_Symbol_Pos.newline;


	(* C-style comments *)

	local
	val par_l = "/"
	val par_r = "/"

	val scan_body1 = $$$ "*" --\| Scan.ahead (~$$$ par_r)
	val scan_body2 = Scan.one (fn (s, _) => s <> "*" andalso Symbol.not_eof s) >> single
	val scan_cmt =
	Scan.depend (fn (d: int) => $$$ par_l @@@ $$$ "*" >> pair (d + 1)) \|\|
	Scan.depend (fn 0 => Scan.fail \| d => $$$ "*" @@@ $$$ par_r >> pair (d - 1)) \|\|
	Scan.lift scan_body1 \|\|
	Scan.lift scan_body2;

	val scan_cmts = Scan.pass 0 (Scan.repeats scan_cmt);

	in

	fun scan_comment err_prefix =
	Scan.ahead ($$ par_l -- $$ "*") \|--
	!!! (fn () => err_prefix ^ "unclosed comment")
	($$$ par_l @@@ $$$ "" @@@ scan_cmts @@@ $$$ "" @@@ $$$ par_r)
	\|\| $$$ "/" @@@ $$$ "/" @@@ C_Basic_Symbol_Pos.repeats_until_nl;

	fun scan_comment_no_nest err_prefix =
	Scan.ahead ($$ par_l -- $$ "*") \|--
	!!! (fn () => err_prefix ^ "unclosed comment")
	($$$ par_l @@@ $$$ "" @@@ Scan.repeats (scan_body1 \|\| scan_body2) @@@ $$$ "" @@@ $$$ par_r)
	\|\| $$$ "/" @@@ $$$ "/" @@@ C_Basic_Symbol_Pos.repeats_until_nl;

	val recover_comment =
	$$$ par_l @@@ $$$ "*" @@@ Scan.repeats (scan_body1 \|\| scan_body2);

	end
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/General/antiquote.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/General/antiquote.ML
	Author: Makarius

	Antiquotations within plain text.
	-*)
	+))
	\<open>
	structure C_Antiquote =
	struct

	(* datatype antiquote *)

	type antiq = { explicit: bool
	, start: Position.T
	, stop: Position.T option
	, range: Position.range
	, body: Symbol_Pos.T list
	, body_begin: Symbol_Pos.T list
	, body_end: Symbol_Pos.T list }

	(* scan *)

	open C_Basic_Symbol_Pos;

	local

	val err_prefix = "Antiquotation lexical error: ";

	val par_l = "/"
	val par_r = "/"

	val scan_body1 = $$$ "*" --\| Scan.ahead (~$$$ par_r)
	val scan_body1' = $$$ "*" @@@ $$$ par_r
	val scan_body2 = Scan.one (fn (s, _) => s <> "*" andalso Symbol.not_eof s) >> single

	val scan_antiq_body_multi =
	Scan.trace (C_Symbol_Pos.scan_string_qq_multi err_prefix scan_body1' \|\|
	C_Symbol_Pos.scan_string_bq_multi err_prefix scan_body1') >> #2 \|\|
	C_Symbol_Pos.scan_cartouche_multi err_prefix scan_body1' \|\|
	scan_body1 \|\|
	scan_body2;

	val scan_antiq_body_multi_recover =
	scan_body1 \|\|
	scan_body2;

	val scan_antiq_body_inline =
	Scan.trace (C_Symbol_Pos.scan_string_qq_inline err_prefix \|\|
	C_Symbol_Pos.scan_string_bq_inline err_prefix) >> #2 \|\|
	C_Symbol_Pos.scan_cartouche_inline err_prefix \|\|
	unless_eof newline;

	val scan_antiq_body_inline_recover =
	unless_eof newline;

	fun control_name sym = (case Symbol.decode sym of Symbol.Control name => name);

	fun scan_antiq_multi scan =
	Symbol_Pos.scan_pos
	-- (Scan.trace ($$ par_l \|-- $$ "*" \|-- scan)
	-- Symbol_Pos.scan_pos
	-- Symbol_Pos.!!! (fn () => err_prefix ^ "missing closing antiquotation")
	(Scan.repeats scan_antiq_body_multi
	-- Symbol_Pos.scan_pos
	-- ($$$ "*" @@@ $$$ par_r)
	-- Symbol_Pos.scan_pos))

	fun scan_antiq_multi_recover scan =
	Symbol_Pos.scan_pos
	-- ($$ par_l \|-- $$ "*" \|-- scan -- Symbol_Pos.scan_pos --
	(Scan.repeats scan_antiq_body_multi_recover
	-- Symbol_Pos.scan_pos -- ($$ "*" \|-- $$ par_r \|-- Symbol_Pos.scan_pos)))

	fun scan_antiq_inline scan =
	(Symbol_Pos.scan_pos -- Scan.trace ($$ "/" \|-- $$ "/" \|-- scan)
	-- Symbol_Pos.scan_pos
	-- Scan.repeats scan_antiq_body_inline -- Symbol_Pos.scan_pos)

	fun scan_antiq_inline_recover scan =
	(Symbol_Pos.scan_pos --\| $$ "/" --\| $$ "/" -- scan
	-- Symbol_Pos.scan_pos
	-- Scan.repeats scan_antiq_body_inline_recover -- Symbol_Pos.scan_pos)

	in

	val scan_control =
	Scan.option (Scan.one (Symbol.is_control o Symbol_Pos.symbol)) --
	Symbol_Pos.scan_cartouche err_prefix >>
	(fn (opt_control, body) =>
	let
	val (name, range) =
	(case opt_control of
	SOME (sym, pos) => ((control_name sym, pos), Symbol_Pos.range ((sym, pos) :: body))
	\| NONE => (("cartouche", #2 (hd body)), Symbol_Pos.range body));
	in {name = name, range = range, body = body} end) \|\|
	Scan.one (Symbol.is_control o Symbol_Pos.symbol) >>
	(fn (sym, pos) =>
	{name = (control_name sym, pos), range = Symbol_Pos.range [(sym, pos)], body = []});

	val scan_antiq =
	scan_antiq_multi ($$$ "@" >> K true \|\| scan_body1 >> K false)
	>> (fn (pos1, (((explicit, body_begin), pos2), (((body, pos3), body_end), pos4))) =>
	{explicit = explicit,
	start = Position.range_position (pos1, pos2),
	stop = SOME (Position.range_position (pos3, pos4)),
	range = Position.range (pos1, pos4),
	body = body,
	body_begin = body_begin,
	body_end = body_end}) \|\|
	scan_antiq_inline ($$$ "@" >> K true \|\| $$$ "*" >> K false)
	>> (fn ((((pos1, (explicit, body_begin)), pos2), body), pos3) =>
	{explicit = explicit,
	start = Position.range_position (pos1, pos2),
	stop = NONE,
	range = Position.range (pos1, pos3),
	body = body,
	body_begin = body_begin,
	body_end = []})

	val scan_antiq_recover =
	scan_antiq_multi_recover ($$$ "@" >> K true \|\| scan_body1 >> K false)
	>> (fn (_, ((explicit, _), _)) => explicit)
	\|\|
	scan_antiq_inline_recover ($$$ "@" >> K true \|\| $$$ "*" >> K false)
	>> (fn ((((_, explicit), _), _), _) => explicit)

	end;

	end;
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/ML/ml_options.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/ML/ml_options.ML
	Author: Makarius

	ML configuration options.
	-*)
	+))
	\<open>
	structure C_Options =
	struct

	(* source trace *)

	val lexer_trace = Attrib.setup_config_bool @{binding C_lexer_trace} (K false);
	val parser_trace = Attrib.setup_config_bool @{binding C_parser_trace} (K false);
	val ML_verbose = Attrib.setup_config_bool @{binding C_ML_verbose} (K true);
	val starting_env = Attrib.setup_config_string @{binding C\<^sub>e\<^sub>n\<^sub>v\<^sub>0} (K "empty");
	val starting_rule = Attrib.setup_config_string @{binding C\<^sub>r\<^sub>u\<^sub>l\<^sub>e\<^sub>0} (K "translation_unit");

	end
	\<close>

	-ML \<comment> \<open>analogous to \<^file>\<open>~~/src/Pure/ML/ml_lex.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+ML \<comment> \<open>\<^file>\<open>~~/src/Pure/ML/ml_lex.ML\<close>\<close>
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	+(* Title: Pure/ML/ml_lex.ML
	+ Author: Makarius
	+
	+Lexical syntax for Isabelle/ML and Standard ML.
	+))
	\<open>
	structure C_Lex =
	struct

	open C_Scan;
	open C_Basic_Symbol_Pos;


	( keywords )

	val keywords =
	["(",
	")",
	"[",
	"]",
	"->",
	".",
	"!",
	"~",
	"++",
	"--",
	"+",
	"-",
	"*",
	"/",
	"%",
	"&",
	"<<",
	">>",
	"<",
	"<=",
	">",
	">=",
	"==",
	"!=",
	"^",
	"\|",
	"&&",
	"\|\|",
	"?",
	":",
	"=",
	"+=",
	"-=",
	"*=",
	"/=",
	"%=",
	"&=",
	"^=",
	"\|=",
	"<<=",
	">>=",
	",",
	";",
	"{",
	"}",
	"...",
	(**)
	"_Alignas",
	"_Alignof",
	"__alignof",
	"alignof",
	"__alignof__",
	"__asm",
	"asm",
	"__asm__",
	"_Atomic",
	"__attribute",
	"__attribute__",
	"auto",
	"_Bool",
	"break",
	"__builtin_offsetof",
	"__builtin_types_compatible_p",
	"__builtin_va_arg",
	"case",
	"char",
	"_Complex",
	"__complex__",
	"__const",
	"const",
	"__const__",
	"continue",
	"default",
	"do",
	"double",
	"else",
	"enum",
	"__extension__",
	"extern",
	"float",
	"for",
	"_Generic",
	"goto",
	"if",
	"__imag",
	"__imag__",
	"__inline",
	"inline",
	"__inline__",
	"int",
	"__int128",
	"__label__",
	"long",
	"_Nonnull",
	"__nonnull",
	"_Noreturn",
	"_Nullable",
	"__nullable",
	"__real",
	"__real__",
	"register",
	"__restrict",
	"restrict",
	"__restrict__",
	"return",
	"short",
	"__signed",
	"signed",
	"__signed__",
	"sizeof",
	"static",
	"_Static_assert",
	"struct",
	"switch",
	"__thread",
	"_Thread_local",
	"typedef",
	"__typeof",
	"typeof",
	"__typeof__",
	"union",
	"unsigned",
	"void",
	"__volatile",
	"volatile",
	"__volatile__",
	"while"];

	val keywords2 =
	["__asm",
	"asm",
	"__asm__",
	"extern"];

	val keywords3 =
	["_Bool",
	"char",
	"double",
	"float",
	"int",
	"__int128",
	"long",
	"short",
	"__signed",
	"signed",
	"__signed__",
	"unsigned",
	"void"];

	val lexicon = Scan.make_lexicon (map raw_explode keywords);



	( tokens )

	(* datatype token *)

	datatype token_kind_comment =
	Comment_formal of C_Antiquote.antiq
	\| Comment_suspicious of (bool * string * ((Position.T * Markup.T) * string) list) option

	datatype token_kind_encoding =
	Encoding_L
	\| Encoding_default
	\| Encoding_file of string (* error message *) option

	type token_kind_string =
	token_kind_encoding
	- * (Symbol.symbol, Position.range * int \<comment> \<open>exceeding \<^ML>\<open>Char.maxOrd\<close>\<close>) either list
	+ * (Symbol_Pos.T, Position.range * int \<comment> \<open>exceeding \<^ML>\<open>Char.maxOrd\<close>\<close>) either list

	datatype token_kind_int_repr = Repr_decimal
	\| Repr_hexadecimal
	\| Repr_octal

	datatype token_kind_int_flag = Flag_unsigned
	\| Flag_long
	\| Flag_long_long
	\| Flag_imag

	datatype token_kind =
	- Keyword \| Ident \| Type_ident \| GnuC \| ClangC \|
	+ Keyword \| Ident of (Symbol_Pos.T list, Symbol_Pos.T) either list \| Type_ident \| GnuC \| ClangC \|
	(**)
	Char of token_kind_string \|
	Integer of int * token_kind_int_repr * token_kind_int_flag list \|
	Float of Symbol_Pos.T list \|
	String of token_kind_string \|
	File of token_kind_string \|
	(**)
	- Space \| Comment of token_kind_comment \| Sharp of int \|
	+ Space of (string * Symbol_Pos.T) option list \| Comment of token_kind_comment \| Sharp of int \|
	(**)
	Unknown \| Error of string * token_group \| Directive of token_kind_directive \| EOF

	and token_kind_directive = Inline of token_group (* a not yet analyzed directive *)
	\| Include of token_group
	\| Define of token_group (* define *)
	* token_group (* name *)
	* token_group option (* functional arguments *)
	* token_group (* rewrite body *)
	\| Undef of token_group (* name *)
	\| Cpp of token_group
	\| Conditional of token_group (* if *)
	* token_group list (* elif *)
	* token_group option (* else *)
	* token_group (* endif *)

	and token_group = Group1 of token list (* spaces and comments filtered from the directive *)
	* token list (* directive: raw data *)
	\| Group2 of token list (* spaces and comments filtered from the directive *)
	* token list (* directive: function *)
	* token list (* directive: arguments (same line) *)
	\| Group3 of ( Position.range (* full directive (with blanks) *)
	* token list (* spaces and comments filtered from the directive *)
	* token list (* directive: function *)
	* token list (* directive: arguments (same line) *))
	* (Position.range * token list) (* C code or directive:
	arguments (following lines) *)

	and token = Token of Position.range * (token_kind * string);


	(* position *)

	fun set_range range (Token (_, x)) = Token (range, x);
	fun range_of (Token (range, _)) = range;

	val pos_of = #1 o range_of;
	val end_pos_of = #2 o range_of;


	(* stopper *)

	fun mk_eof pos = Token ((pos, Position.none), (EOF, ""));
	val eof = mk_eof Position.none;

	fun is_eof (Token (_, (EOF, _))) = true
	\| is_eof _ = false;

	val stopper =
	Scan.stopper (fn [] => eof \| toks => mk_eof (end_pos_of (List.last toks))) is_eof;

	val one_not_eof = Scan.one (not o is_eof)

	(* token content *)

	fun kind_of (Token (_, (k, _))) = k;

	val group_list_of = fn
	Inline g => [g]
	\| Include g => [g]
	\| Define (g1, g2, o_g3, g4) => flat [[g1], [g2], the_list o_g3, [g4]]
	\| Undef g => [g]
	\| Cpp g => [g]
	\| Conditional (g1, gs2, o_g3, g4) => flat [[g1], gs2, the_list o_g3, [g4]]

	fun content_of (Token (_, (_, x))) = x;
	fun token_leq (tok, tok') = content_of tok <= content_of tok';

	val directive_cmds = fn
	Inline (Group1 (_, _ :: tok2 :: _)) => [tok2]
	\| Include (Group2 (_, [_, tok2], _)) => [tok2]
	\| Define (Group1 (_, [_, tok2]), _, _, _) => [tok2]
	\| Undef (Group2 (_, [_, tok2], _)) => [tok2]
	\| Conditional (c1, cs2, c3, c4) =>
	maps (fn Group3 ((_, _, [_, tok2], _), _) => [tok2]
	\| _ => error "Only expecting Group3")
	(flat [[c1], cs2, the_list c3, [c4]])
	\| _ => []

	fun is_keyword (Token (_, (Keyword, _))) = true
	\| is_keyword _ = false;

	-fun is_ident (Token (_, (Ident, _))) = true
	+fun is_ident (Token (_, (Ident _, _))) = true
	\| is_ident _ = false;

	fun is_integer (Token (_, (Integer _, _))) = true
	\| is_integer _ = false;

	fun is_delimiter (Token (_, (Keyword, x))) = not (C_Symbol.is_ascii_identifier x)
	\| is_delimiter _ = false;

	(* range *)

	val range_list_of0 =
	fn [] => Position.no_range
	\| toks as tok1 :: _ => Position.range (pos_of tok1, end_pos_of (List.last toks))
	(* WARNING the use of:
	\<comment>\<open>\<^ML>\<open>fn content_of => fn pos_of => fn tok2 =>
	List.last (Symbol_Pos.explode (content_of tok2, pos_of tok2)) \|-> Position.symbol\<close>\<close>
	would not return an accurate position if for example several
	"backslash newlines" are present in the symbol *)

	fun range_list_of toks = (range_list_of0 toks, toks)
	fun range_list_of' toks1 toks2 = (range_list_of0 toks1, toks2)

	local
	fun cmp_pos x2 x1 = case Position.distance_of (pos_of x2, pos_of x1) of SOME dist => dist < 0
	\| NONE => error "cmp_pos"

	fun merge_pos xs = case xs of (xs1, []) => xs1
	\| ([], xs2) => xs2
	\| (x1 :: xs1, x2 :: xs2) =>
	let val (x, xs) = if cmp_pos x2 x1 then (x1, (xs1, x2 :: xs2))
	else (x2, (x1 :: xs1, xs2))
	in x :: merge_pos xs end
	in
	fun merge_blank toks_bl xs1 xs2 =
	let val cmp_tok2 = cmp_pos (List.last xs1)
	in ( range_list_of (merge_pos (xs1, filter cmp_tok2 toks_bl))
	, range_list_of (merge_pos (xs2, filter_out cmp_tok2 toks_bl)))
	end
	end

	val token_list_of =
	let fun merge_blank' toks_bl xs1 xs2 =
	let val ((_, l1), (_, l2)) = merge_blank toks_bl xs1 xs2
	in [l1, l2] end
	in group_list_of
	#> maps (fn
	Group1 (toks_bl, []) => [toks_bl]
	\| Group1 (toks_bl, xs1) => merge_blank' toks_bl xs1 []
	\| Group2 (toks_bl, xs1, xs2) => merge_blank' toks_bl xs1 xs2
	\| Group3 ((_, toks_bl, xs1, xs2), (_, xs3)) => flat [merge_blank' toks_bl xs1 xs2, [xs3]])
	#> flat
	end

	local

	-fun warn0 pos l s =
	- ()
	- \|> tap
	- (fn _ =>
	- if exists (fn Left s => not (Symbol.is_printable s) \| _ => false) l then
	- app (fn (s, pos) =>
	- if Symbol.is_printable s
	- then ()
	- else Output.information ("Not printable character " ^ @{make_string} (ord s, s)
	- ^ Position.here pos))
	- (Symbol_Pos.explode (s, pos))
	- else ())
	- \|> tap
	- (fn _ =>
	- app (fn Left _ => ()
	- \| Right ((pos1, _), n) =>
	- Output.information
	- ("Out of the supported range (character number " ^ Int.toString n ^ ")"
	- ^ Position.here pos1))
	- l)
	+fun warn_utf8 s pos =
	+ Output.information ("UTF-8 " ^ @{make_string} s ^ Position.here pos)

	-
	-
	-fun unknown pos = Output.information ("Unknown symbol" ^ Position.here pos)
	+val warn_ident = app (fn Right (s, pos) => warn_utf8 s pos \| _ => ())

	-val app_directive =
	- app (fn Token (_, (Error (msg, _), _)) => warning msg
	- \| Token ((pos, _), (Unknown, _)) => unknown pos
	- \| _ => ())
	+val warn_string =
	+ app (fn Left (s, pos) =>
	+ if Symbol.is_utf8 s then
	+ warn_utf8 s pos
	+ else if Symbol.is_printable s then
	+ ()
	+ else
	+ let val ord_s = ord s
	+ in
	+ Output.information ("Not printable symbol "
	+ ^ (if chr ord_s = s then @{make_string} (ord_s, s)
	+ else @{make_string} s)
	+ ^ Position.here pos)
	+ end
	+ \| Right ((pos1, _), n) =>
	+ Output.information
	+ ("Out of the supported range (character number " ^ Int.toString n ^ ")"
	+ ^ Position.here pos1))
	+
	+val warn_space =
	+ app (fn SOME (msg, (s, pos)) =>
	+ Output.information (msg ^ " " ^ @{make_string} s ^ Position.here pos)
	+ \| _ => ())
	+
	+fun warn_unknown pos = Output.information ("Unknown symbol" ^ Position.here pos)
	+
	+val warn_directive =
	+ app (fn Token (_, (Error (msg, _), _)) => warning msg
	+ \| Token ((pos, _), (Unknown, _)) => warn_unknown pos
	+ \| _ => ())

	in
	val warn = fn
	- Token ((pos, _), (Char (_, l), s)) => warn0 pos l s
	- \| Token ((pos, _), (String (_, l), s)) => warn0 pos l s
	- \| Token ((pos, _), (File (_, l), s)) => warn0 pos l s
	- \| Token ((pos, _), (Unknown, _)) => unknown pos
	+ Token (_, (Ident l, _)) => warn_ident l
	+ \| Token (_, (Char (_, l), _)) => warn_string l
	+ \| Token (_, (String (_, l), _)) => warn_string l
	+ \| Token (_, (File (_, l), _)) => warn_string l
	+ \| Token (_, (Space l, _)) => warn_space l
	+ \| Token ((pos, _), (Unknown, _)) => warn_unknown pos
	\| Token (_, (Comment (Comment_suspicious (SOME (explicit, msg, _))), _)) =>
	(if explicit then warning else tracing) msg
	- \| Token (_, (Directive (kind as Conditional _), _)) => app_directive (token_list_of kind)
	- \| Token (_, (Directive (Define (_, _, _, Group1 (_, toks4))), _)) => app_directive toks4
	+ \| Token (_, (Directive (kind as Conditional _), _)) => warn_directive (token_list_of kind)
	+ \| Token (_, (Directive (Define (_, _, _, Group1 (_, toks4))), _)) => warn_directive toks4
	\| Token (_, (Directive (Include (Group2 (_, _, toks))), _)) =>
	(case toks of
	[Token (_, (String _, _))] => ()
	\| [Token (_, (File _, _))] => ()
	\| _ => Output.information
	("Expecting at least and at most one file"
	^ Position.here
	(Position.range_position (pos_of (hd toks), end_pos_of (List.last toks)))))
	\| _ => ();
	end

	fun check_error tok =
	case kind_of tok of
	Error (msg, _) => [msg]
	\| _ => [];

	(* markup *)

	local

	val token_kind_markup0 =
	fn Char _ => (Markup.ML_char, "")
	\| Integer _ => (Markup.ML_numeral, "")
	\| Float _ => (Markup.ML_numeral, "")
	\| ClangC => (Markup.ML_numeral, "")
	\| String _ => (Markup.ML_string, "")
	\| File _ => (Markup.ML_string, "")
	\| Sharp _ => (Markup.antiquote, "")
	\| Unknown => (Markup.intensify, "")
	\| Error (msg, _) => (Markup.bad (), msg)
	\| _ => (Markup.empty, "");

	fun token_report' escape_directive (tok as Token ((pos, _), (kind, x))) =
	if escape_directive andalso (is_keyword tok orelse is_ident tok) then
	[((pos, Markup.antiquote), "")]
	else if is_keyword tok then
	let
	val (markup, txt) = if is_delimiter tok then (Markup.ML_delimiter, "")
	else if member (op =) keywords2 x then (Markup.ML_keyword2 \|> Markup.keyword_properties, "")
	else if member (op =) keywords3 x then (Markup.ML_keyword3 \|> Markup.keyword_properties, "")
	else (Markup.ML_keyword1 \|> Markup.keyword_properties, "");
	in [((pos, markup), txt)] end
	else
	case kind of
	Directive (tokens as Inline _) =>
	((pos, Markup.antiquoted), "") :: maps token_report0 (token_list_of tokens)
	\| Directive (Include (Group2 (toks_bl, tok1 :: _, toks2))) =>
	((pos, Markup.antiquoted), "")
	:: flat [ maps token_report1 [tok1]
	, maps token_report0 toks2
	, maps token_report0 toks_bl ]
	\| Directive
	(Define
	(Group1 (toks_bl1, tok1 :: _), Group1 (toks_bl2, _), toks3, Group1 (toks_bl4, toks4))) =>
	let val (toks_bl3, toks3) = case toks3 of SOME (Group1 x) => x \| _ => ([], [])
	in ((pos, Markup.antiquoted), "")
	:: ((range_list_of0 toks4 \|> #1, Markup.intensify), "")
	:: flat [ maps token_report1 [tok1]
	, maps token_report0 toks3
	, maps token_report0 toks4
	, maps token_report0 toks_bl1
	, maps token_report0 toks_bl2
	, map (fn tok => ((pos_of tok, Markup.antiquote), "")) toks_bl3
	, maps token_report0 toks_bl4 ] end
	\| Directive (Undef (Group2 (toks_bl, tok1 :: _, _))) =>
	((pos, Markup.antiquoted), "")
	:: flat [ maps token_report1 [tok1]
	, maps token_report0 toks_bl ]
	\| Directive (Cpp (Group2 (toks_bl, toks1, toks2))) =>
	((pos, Markup.antiquoted), "")
	:: flat [ maps token_report1 toks1
	, maps token_report0 toks2
	, maps token_report0 toks_bl ]
	\| Directive (Conditional (c1, cs2, c3, c4)) =>
	maps (fn Group3 (((pos, _), toks_bl, tok1 :: _, toks2), ((pos3, _), toks3)) =>
	((pos, Markup.antiquoted), "")
	:: ((pos3, Markup.intensify), "")
	:: flat [ maps token_report1 [tok1]
	, maps token_report0 toks2
	, maps token_report0 toks3
	, maps token_report0 toks_bl ]
	\| _ => error "Only expecting Group3")
	(flat [[c1], cs2, the_list c3, [c4]])
	\| Error (msg, Group2 (toks_bl, toks1, toks2)) =>
	((range_list_of0 toks1 \|> #1, Markup.bad ()), msg)
	:: ((pos, Markup.antiquoted), "")
	:: flat [ maps token_report1 toks1
	, maps token_report0 toks2
	, maps token_report0 toks_bl ]
	\| Error (msg, Group3 ((_, toks_bl, toks1, toks2), _)) =>
	((range_list_of0 toks1 \|> #1, Markup.bad ()), msg)
	:: ((pos, Markup.antiquoted), "")
	:: flat [ maps token_report1 toks1
	, maps token_report0 toks2
	, maps token_report0 toks_bl ]
	\| Comment (Comment_suspicious c) => ((pos, Markup.ML_comment), "")
	:: (case c of NONE => [] \| SOME (_, _, l) => l)
	\| x => [let val (markup, txt) = token_kind_markup0 x in ((pos, markup), txt) end]

	and token_report0 tok = token_report' false tok
	and token_report1 tok = token_report' true tok

	in
	val token_report = token_report0
	end;



	( scanners )

	val err_prefix = "C lexical error: ";

	fun !!! msg = Symbol_Pos.!!! (fn () => err_prefix ^ msg);

	fun !!!! msg = C_Symbol_Pos.!!!! (fn () => err_prefix ^ msg);

	-val many1_blanks_no_line = many1 C_Symbol.is_ascii_blank_no_line
	+val many1_blanks_no_line =
	+ Scan.repeat1
	+ (one C_Symbol.is_ascii_blank_no_line
	+ >> (fn (s, pos) =>
	+ List.find (#1 #> exists (curry op = s)) C_Symbol.ascii_blank_no_line
	+ \|> the
	+ \|> #2
	+ \|> Option.map (rpair (s, pos))))

	(* identifiers *)

	+local
	+fun left x = [Left x]
	+fun right x = [Right x]
	+in
	val scan_ident_sym =
	let val hex = one' Symbol.is_ascii_hex
	- in one' C_Symbol.is_identletter
	- \|\| $$$ "\\" @@@ $$$ "u" @@@ hex @@@ hex @@@ hex @@@ hex
	- \|\| $$$ "\\" @@@ $$$ "U" @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex
	- \|\| one' Symbol.is_symbolic
	- \|\| one' Symbol.is_control
	- \|\| one' Symbol.is_utf8
	+ in one' C_Symbol.is_identletter >> left
	+ \|\| $$$ "\\" @@@ $$$ "u" @@@ hex @@@ hex @@@ hex @@@ hex >> left
	+ \|\| $$$ "\\" @@@ $$$ "U" @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex @@@ hex >> left
	+ \|\| one' Symbol.is_symbolic >> left
	+ \|\| one' Symbol.is_control >> left
	+ \|\| one Symbol.is_utf8 >> right
	end

	val scan_ident =
	scan_ident_sym
	- @@@ Scan.repeats (scan_ident_sym \|\| one' Symbol.is_ascii_digit);
	+ @@@ Scan.repeats (scan_ident_sym \|\| one' Symbol.is_ascii_digit >> left);
	+
	+val scan_ident' = scan_ident >> maps (fn Left s => s \| Right c => [c]);
	+end

	val keywords_ident =
	map_filter
	(fn s =>
	Source.of_list (Symbol_Pos.explode (s, Position.none))
	\|> Source.source
	Symbol_Pos.stopper
	(Scan.bulk (scan_ident >> SOME \|\| Scan.one (not o Symbol_Pos.is_eof) >> K NONE))
	\|> Source.exhaust
	\|> (fn [SOME _] => SOME s \| _ => NONE))
	keywords

	(* numerals *)

	fun read_bin s = #1 (read_radix_int 2 s)
	fun read_oct s = #1 (read_radix_int 8 s)
	fun read_dec s = #1 (read_int s)
	val read_hex =
	let fun conv_ascii c1 c0 = String.str (Char.chr (Char.ord #"9" + Char.ord c1 - Char.ord c0 + 1))
	in map (fn s => let val c = String.sub (s, 0) in
	if c >= #"A" andalso c <= #"F" then
	conv_ascii c #"A"
	else if c >= #"a" andalso c <= #"f" then
	conv_ascii c #"a"
	else s
	end)
	#> read_radix_int 16
	#> #1
	end

	local
	val many_digit = many Symbol.is_ascii_digit
	val many1_digit = many1 Symbol.is_ascii_digit
	val many_hex = many Symbol.is_ascii_hex
	val many1_hex = many1 Symbol.is_ascii_hex

	val scan_suffix_ll = ($$$ "l" @@@ $$$ "l" \|\| $$$ "L" @@@ $$$ "L") >> K [Flag_long_long]
	fun scan_suffix_gnu flag = ($$$ "i" \|\| $$$ "j") >> K [flag]
	val scan_suffix_int =
	let val u = ($$$ "u" \|\| $$$ "U") >> K [Flag_unsigned]
	val l = ($$$ "l" \|\| $$$ "L") >> K [Flag_long] in
	u @@@ scan_suffix_ll
	\|\| scan_suffix_ll @@@ opt u
	\|\| u @@@ opt l
	\|\| l @@@ opt u
	end

	val scan_suffix_gnu_int0 = scan_suffix_gnu Flag_imag
	val scan_suffix_gnu_int = scan_full !!!
	(member (op =) (raw_explode "uUlLij"))
	"Invalid integer constant suffix"
	( scan_suffix_int @@@ opt scan_suffix_gnu_int0
	\|\| scan_suffix_gnu_int0 @@@ opt scan_suffix_int)

	fun scan_intgnu x =
	x -- opt scan_suffix_gnu_int
	>> (fn ((s1', read, repr), l) => (read (map (Symbol_Pos.content o single) s1'), repr, l))

	val scan_intoct = scan_intgnu ($$ "0" \|--
	scan_full
	!!!
	Symbol.is_ascii_digit
	"Invalid digit in octal constant"
	(Scan.max
	(fn ((xs2, _, _), (xs1, _, _)) => length xs2 < length xs1)
	(many C_Symbol.is_ascii_oct
	>> (fn xs => (xs, read_oct, Repr_octal)))
	(many (fn x => x = "0")
	>> (fn xs => (xs, read_dec, Repr_decimal)))))
	val scan_intdec = scan_intgnu (one C_Symbol.is_ascii_digit1 -- many Symbol.is_ascii_digit
	>> (fn (x, xs) => (x :: xs, read_dec, Repr_decimal)))
	val scan_inthex = scan_intgnu (($$ "0" -- ($$ "x" \|\| $$ "X")) \|-- many1_hex
	>> (fn xs2 => (xs2, read_hex, Repr_hexadecimal)))

	(**)

	fun scan_signpart a A = ($$$ a \|\| $$$ A) @@@ opt ($$$ "+" \|\| $$$ "-") @@@ many1_digit
	val scan_exppart = scan_signpart "e" "E"

	val scan_suffix_float = $$$ "f" \|\| $$$ "F" \|\| $$$ "l" \|\| $$$ "L"
	val scan_suffix_gnu_float0 = Scan.trace (scan_suffix_gnu ()) >> #2
	val scan_suffix_gnu_float = scan_full !!!
	(member (op =) (raw_explode "fFlLij"))
	"Invalid float constant suffix"
	( scan_suffix_float @@@ opt scan_suffix_gnu_float0
	\|\| scan_suffix_gnu_float0 @@@ opt scan_suffix_float)

	val scan_hex_pref = $$$ "0" @@@ $$$ "x"

	val scan_hexmant = many_hex @@@ $$$ "." @@@ many1_hex
	\|\| many1_hex @@@ $$$ "."
	val scan_floatdec =
	( ( many_digit @@@ $$$ "." @@@ many1_digit
	\|\| many1_digit @@@ $$$ ".")
	@@@ opt scan_exppart
	\|\| many1_digit @@@ scan_exppart)
	@@@ opt scan_suffix_gnu_float

	val scan_floathex = scan_hex_pref @@@ (scan_hexmant \|\| many1_hex)
	@@@ scan_signpart "p" "P" @@@ opt scan_suffix_gnu_float
	val scan_floatfail = scan_hex_pref @@@ scan_hexmant
	in
	val scan_int = scan_inthex
	\|\| scan_intoct
	\|\| scan_intdec

	val recover_int =
	many1 (fn s => Symbol.is_ascii_hex s orelse member (op =) (raw_explode "xXuUlLij") s)

	val scan_float = scan_floatdec
	\|\| scan_floathex
	\|\| scan_floatfail @@@ !!! "Hexadecimal floating constant requires an exponent"
	Scan.fail

	val scan_clangversion = many1_digit @@@ $$$ "." @@@ many1_digit @@@ $$$ "." @@@ many1_digit

	end;


	(* chars and strings *)

	val scan_blanks1 = many1 Symbol.is_ascii_blank

	local
	val escape_char = [ ("n", #"\n")
	, ("t", #"\t")
	, ("v", #"\v")
	, ("b", #"\b")
	, ("r", #"\r")
	, ("f", #"\f")
	, ("a", #"\a")
	, ("e", #"\^[")
	, ("E", #"\^[")
	, ("\\", #"\\")
	, ("?", #"?")
	, ("'", #"'")
	, ("\"", #"\"") ]

	val _ = \<comment> \<open>printing a ML function translating code point from \<^ML_type>\<open>int -> string\<close>\<close>
	fn _ =>
	app (fn (x0, x) => writeln (" \| "
	^ string_of_int (Char.ord x)
	^ " => \"\\\\"
	^ (if exists (fn x1 => x0 = x1) ["\"", "\\"] then "\\" ^ x0 else x0)
	^ "\""))
	escape_char

	fun scan_escape s0 =
	let val oct = one' C_Symbol.is_ascii_oct
	val hex = one' Symbol.is_ascii_hex
	+ val sym_pos = Symbol_Pos.range #> Position.range_position
	fun chr' f l =
	let val x = f (map Symbol_Pos.content l)
	- in [if x <= Char.maxOrd then Left (chr x) else Right (Symbol_Pos.range (flat l), x)] end
	+ val l = flat l
	+ in [if x <= Char.maxOrd then Left (chr x, sym_pos l) else Right (Symbol_Pos.range l, x)] end
	val read_oct' = chr' read_oct
	val read_hex' = chr' read_hex
	in one' (member (op =) (raw_explode (s0 ^ String.concat (map #1 escape_char))))
	>> (fn i =>
	- [Left (case AList.lookup (op =) escape_char (Symbol_Pos.content i) of
	- NONE => s0
	- \| SOME c => String.str c)])
	+ [Left (( case AList.lookup (op =) escape_char (Symbol_Pos.content i) of
	+ NONE => s0
	+ \| SOME c => String.str c)
	+ , sym_pos i)])
	\|\| oct -- oct -- oct >> (fn ((o1, o2), o3) => read_oct' [o1, o2, o3])
	\|\| oct -- oct >> (fn (o1, o2) => read_oct' [o1, o2])
	\|\| oct >> (read_oct' o single)
	\|\| $$ "x" \|-- many1 Symbol.is_ascii_hex
	>> (read_hex' o map single)
	\|\| $$ "u" \|-- hex -- hex -- hex -- hex
	>> (fn (((x1, x2), x3), x4) => read_hex' [x1, x2, x3, x4])
	\|\| $$ "U" \|-- hex -- hex -- hex -- hex -- hex -- hex -- hex -- hex
	>> (fn (((((((x1, x2), x3), x4), x5), x6), x7), x8) =>
	read_hex' [x1, x2, x3, x4, x5, x6, x7, x8])
	end

	fun scan_str s0 =
	Scan.unless newline
	(Scan.one (fn (s, _) => Symbol.not_eof s andalso s <> s0 andalso s <> "\\"))
	- >> (fn s => [Left (#1 s)])
	+ >> (single o Left)
	\|\| Scan.ahead newline \|-- !!! "bad newline" Scan.fail
	\|\| $$ "\\" \|-- !!! "bad escape character" (scan_escape s0);

	fun scan_string0 s0 msg repeats =
	Scan.optional ($$ "L" >> K Encoding_L) Encoding_default --
	(Scan.ahead ($$ s0) \|--
	!!! ("unclosed " ^ msg ^ " literal")
	($$ s0 \|-- repeats (scan_str s0) --\| $$ s0))

	fun recover_string0 s0 repeats =
	opt ($$$ "L") @@@ $$$ s0 @@@ repeats (Scan.permissive (Scan.trace (scan_str s0) >> #2));
	in

	val scan_char = scan_string0 "'" "char" Scan.repeats1
	val scan_string = scan_string0 "\"" "string" Scan.repeats
	fun scan_string' src =
	case
	Source.source
	Symbol_Pos.stopper
	(Scan.recover (Scan.bulk (!!! "bad input" scan_string >> K NONE))
	(fn msg => C_Basic_Symbol_Pos.one_not_eof >> K [SOME msg]))
	(Source.of_list src)
	\|> Source.exhaust
	of
	[NONE] => NONE
	\| [] => SOME "Empty input"
	\| l => case map_filter I l of msg :: _ => SOME msg
	\| _ => SOME "More than one string"
	val scan_file =
	let fun scan !!! s_l s_r =
	Scan.ahead ($$ s_l) \|--
	!!!
	($$ s_l
	\|-- Scan.repeats
	(Scan.unless newline
	(Scan.one (fn (s, _) => Symbol.not_eof s andalso s <> s_r)
	- >> (fn s => [Left (#1 s)])))
	+ >> (single o Left)))
	--\| $$ s_r)
	in
	Scan.trace (scan (!!! ("unclosed file literal")) "\"" "\"")
	>> (fn (s, src) => String (Encoding_file (scan_string' src), s))
	\|\| scan I \<comment> \<open>Due to conflicting symbols, raising \<^ML>\<open>Symbol_Pos.!!!\<close> here will not let a potential
	legal \<^ML>\<open>"<"\<close> symbol be tried and parsed as a \<^emph>\<open>keyword\<close>.\<close>
	"<" ">" >> (fn s => File (Encoding_default, s))
	end

	val recover_char = recover_string0 "'" Scan.repeats1
	val recover_string = recover_string0 "\"" Scan.repeats

	end;

	(* scan tokens *)

	val check = fold (tap warn #> fold cons o check_error)

	local

	fun token k ss = Token (Symbol_Pos.range ss, (k, Symbol_Pos.content ss));
	fun scan_token f1 f2 = Scan.trace f1 >> (fn (v, s) => token (f2 v) s)

	val comments =
	Scan.recover
	(scan_token C_Antiquote.scan_antiq (Comment o Comment_formal))
	(fn msg => Scan.ahead C_Antiquote.scan_antiq_recover
	-- C_Symbol_Pos.scan_comment_no_nest err_prefix
	>> (fn (explicit, res) =>
	token (Comment (Comment_suspicious (SOME (explicit, msg, [])))) res)
	\|\| Scan.fail_with (fn _ => fn _ => msg))
	\|\| C_Symbol_Pos.scan_comment_no_nest err_prefix >> token (Comment (Comment_suspicious NONE))

	fun scan_fragment blanks comments sharps non_blanks =
	non_blanks (scan_token scan_char Char)
	\|\| non_blanks (scan_token scan_string String)
	\|\| blanks
	\|\| comments
	\|\| non_blanks sharps
	\|\| non_blanks (Scan.max token_leq (Scan.literal lexicon >> token Keyword)
	( scan_clangversion >> token ClangC
	\|\| scan_token scan_float Float
	\|\| scan_token scan_int Integer
	- \|\| scan_ident >> token Ident))
	+ \|\| scan_token scan_ident Ident))
	\|\| non_blanks (Scan.one (Symbol.is_printable o #1) >> single >> token Unknown)

	(* scan tokens, directive part *)

	val scan_sharp1 = $$$ "#"
	val scan_sharp2 = $$$ "#" @@@ $$$ "#"

	val scan_directive =
	- let val f_filter = fn Token (_, (Space, _)) => true
	+ let val f_filter = fn Token (_, (Space _, _)) => true
	\| Token (_, (Comment _, _)) => true
	\| Token (_, (Error _, _)) => true
	\| _ => false
	val sharp1 = scan_sharp1 >> token (Sharp 1)
	in (sharp1 >> single)
	@@@ Scan.repeat ( scan_token scan_file I
	- \|\| scan_fragment (many1_blanks_no_line >> token Space)
	+ \|\| scan_fragment (scan_token many1_blanks_no_line Space)
	comments
	(scan_sharp2 >> token (Sharp 2) \|\| sharp1)
	I)
	>> (fn tokens => Inline (Group1 (filter f_filter tokens, filter_out f_filter tokens)))
	end

	local
	fun !!! text scan =
	let
	fun get_pos [] = " (end-of-input)"
	\| get_pos (t :: _) = Position.here (pos_of t);

	fun err (syms, msg) = fn () =>
	err_prefix ^ text ^ get_pos syms ^
	(case msg of NONE => "" \| SOME m => "\n" ^ m ());
	in Scan.!! err scan end

	val pos_here_of = Position.here o pos_of

	fun one_directive f =
	Scan.one (fn Token (_, (Directive ( Inline (Group1 (_, Token (_, (Sharp 1, _))
	:: Token (_, s)
	:: _)))
	, _))
	=> f s
	\| _ => false)

	val get_cond = fn Token (pos, (Directive (Inline (Group1 (toks_bl, tok1 :: tok2 :: toks))), _)) =>
	(fn t3 => Group3 ((pos, toks_bl, [tok1, tok2], toks), range_list_of t3))
	\| _ => error "Inline directive expected"

	val one_start_cond = one_directive (fn (Keyword, "if") => true
	- \| (Ident, "ifdef") => true
	- \| (Ident, "ifndef") => true
	+ \| (Ident _, "ifdef") => true
	+ \| (Ident _, "ifndef") => true
	\| _ => false)
	-val one_elif = one_directive (fn (Ident, "elif") => true \| _ => false)
	+val one_elif = one_directive (fn (Ident _, "elif") => true \| _ => false)
	val one_else = one_directive (fn (Keyword, "else") => true \| _ => false)
	-val one_endif = one_directive (fn (Ident, "endif") => true \| _ => false)
	+val one_endif = one_directive (fn (Ident _, "endif") => true \| _ => false)

	val not_cond =
	Scan.unless
	(one_start_cond \|\| one_elif \|\| one_else \|\| one_endif)
	(one_not_eof
	>>
	(fn Token (pos, ( Directive (Inline (Group1 ( toks_bl
	, (tok1 as Token (_, (Sharp _, _)))
	- :: (tok2 as Token (_, (Ident, "include")))
	+ :: (tok2 as Token (_, (Ident _, "include")))
	:: toks)))
	, s)) =>
	Token (pos, ( case toks of [] =>
	Error ( "Expecting at least one file"
	^ Position.here (end_pos_of tok2)
	, Group2 (toks_bl, [tok1, tok2], toks))
	\| _ => Directive (Include (Group2 (toks_bl, [tok1, tok2], toks)))
	, s))
	\| Token (pos, ( Directive (Inline (Group1 ( toks_bl
	, (tok1 as Token (_, (Sharp _, _)))
	- :: (tok2 as Token (_, (Ident, "define")))
	+ :: (tok2 as Token (_, (Ident _, "define")))
	:: toks)))
	, s)) =>
	let
	fun define tok3 toks =
	case
	case toks of
	(tok3' as Token (pos, (Keyword, "("())))) :: toks =>
	if Position.offset_of (end_pos_of tok3) = Position.offset_of (pos_of tok3')
	then
	let
	fun right msg pos = Right (msg ^ Position.here pos)
	fun right1 msg = right msg o #1
	fun right2 msg = right msg o #2
	fun take_prefix' toks_bl toks_acc pos =
	fn
	- (tok1 as Token (_, (Ident, _)))
	+ (tok1 as Token (_, (Ident _, _)))
	:: (tok2 as Token (pos2, (Keyword, key)))
	:: toks =>
	if key = ","
	then take_prefix' (tok2 :: toks_bl) (tok1 :: toks_acc) pos2 toks
	else if key = (( )")" then
	Left (rev (tok2 :: toks_bl), rev (tok1 :: toks_acc), toks)
	else
	right1 "Expecting a colon delimiter or a closing parenthesis" pos2
	- \| Token (pos1, (Ident, _)) :: _ =>
	+ \| Token (pos1, (Ident _, _)) :: _ =>
	right2 "Expecting a colon delimiter or a closing parenthesis" pos1
	\| (tok1 as Token (_, (Keyword, key1)))
	:: (tok2 as Token (pos2, (Keyword, key2)))
	:: toks =>
	if key1 = "..." then
	if key2 = (( )")"
	then Left (rev (tok2 :: toks_bl), rev (tok1 :: toks_acc), toks)
	else right1 "Expecting a closing parenthesis" pos2
	else right2 "Expecting an identifier or the keyword '...'" pos
	\| _ => right2 "Expecting an identifier or the keyword '...'" pos
	in case
	case toks of
	(tok2 as Token (_, (Keyword, (( )")"))) :: toks => Left ([tok2], [], toks)
	\| _ => take_prefix' [] [] pos toks
	of Left (toks_bl, toks_acc, toks) =>
	Left (SOME (Group1 (tok3' :: toks_bl, toks_acc)), Group1 ([], toks))
	\| Right x => Right x
	end
	else Left (NONE, Group1 ([], tok3' :: toks))
	\| _ => Left (NONE, Group1 ([], toks))
	of Left (gr1, gr2) =>
	Directive (Define (Group1 (toks_bl, [tok1, tok2]), Group1 ([], [tok3]), gr1, gr2))
	\| Right msg => Error (msg, Group2 (toks_bl, [tok1, tok2], tok3 :: toks))
	fun err () = Error ( "Expecting at least one identifier" ^ Position.here (end_pos_of tok2)
	, Group2 (toks_bl, [tok1, tok2], toks))
	in
	Token (pos, ( case toks of
	- (tok3 as Token (_, (Ident, _))) :: toks => define tok3 toks
	+ (tok3 as Token (_, (Ident _, _))) :: toks => define tok3 toks
	\| (tok3 as Token (_, (Keyword, cts))) :: toks =>
	if exists (fn cts0 => cts = cts0) keywords_ident
	then define tok3 toks
	else err ()
	\| _ => err ()
	, s))
	end
	\| Token (pos, ( Directive (Inline (Group1 ( toks_bl
	, (tok1 as Token (_, (Sharp _, _)))
	- :: (tok2 as Token (_, (Ident, "undef")))
	+ :: (tok2 as Token (_, (Ident _, "undef")))
	:: toks)))
	, s)) =>
	Token (pos, ( let fun err () = Error ( "Expecting at least and at most one identifier"
	^ Position.here (end_pos_of tok2)
	, Group2 (toks_bl, [tok1, tok2], toks))
	in
	case toks of
	- [Token (_, (Ident, _))] =>
	+ [Token (_, (Ident _, _))] =>
	Directive (Undef (Group2 (toks_bl, [tok1, tok2], toks)))
	\| [Token (_, (Keyword, cts))] =>
	if exists (fn cts0 => cts = cts0) keywords_ident
	then Directive (Undef (Group2 (toks_bl, [tok1, tok2], toks)))
	else err ()
	\| _ => err ()
	end
	, s))
	\| Token (pos, ( Directive (Inline (Group1 ( toks_bl
	, (tok1 as Token (_, (Sharp _, _)))
	:: (tok2 as Token (_, (Integer _, _)))
	:: (tok3 as Token (_, (String _, _)))
	:: toks)))
	, s)) =>
	Token (pos, ( if forall is_integer toks then
	Directive (Cpp (Group2 (toks_bl, [tok1], tok2 :: tok3 :: toks)))
	else Error ( "Expecting an integer"
	^ Position.here (drop_prefix is_integer toks \|> hd \|> pos_of)
	, Group2 (toks_bl, [tok1], tok2 :: tok3 :: toks))
	, s))
	\| x => x))

	fun scan_cond xs = xs \|>
	(one_start_cond -- scan_cond_list
	-- Scan.repeat (one_elif -- scan_cond_list)
	-- Scan.option (one_else -- scan_cond_list)
	-- Scan.recover one_endif
	(fn msg =>
	Scan.fail_with
	(fn toks => fn () =>
	case toks of
	tok :: _ => "can be closed here" ^ Position.here (pos_of tok)
	\| _ => msg))
	>> (fn (((t_if, t_elif), t_else), t_endif) =>
	Token ( Position.no_range
	, ( Directive
	(Conditional
	let fun t_body x = x \|-> get_cond
	in
	( t_body t_if
	, map t_body t_elif
	, Option.map t_body t_else
	, t_body (t_endif, []))
	end)
	, ""))))

	and scan_cond_list xs = xs \|> Scan.repeat (not_cond \|\| scan_cond)

	val scan_directive_cond0 =
	not_cond
	\|\| Scan.ahead ( one_start_cond \|-- scan_cond_list
	\|-- Scan.repeat (one_elif -- scan_cond_list)
	\|-- one_else --\| scan_cond_list -- (one_elif \|\| one_else))
	:-- (fn (tok1, tok2) => !!! ( "directive" ^ pos_here_of tok2
	^ " not expected after" ^ pos_here_of tok1
	^ ", detected at")
	Scan.fail)
	>> #2
	\|\| (Scan.ahead one_start_cond \|-- !!! "unclosed directive" scan_cond)
	\|\| (Scan.ahead one_not_eof \|-- !!! "missing or ambiguous beginning of conditional" Scan.fail)

	fun scan_directive_recover msg =
	not_cond
	\|\| one_not_eof >>
	(fn tok as Token (pos, (_, s)) => Token (pos, (Error (msg, get_cond tok []), s)))

	in

	val scan_directive_cond =
	Scan.recover
	(Scan.bulk scan_directive_cond0)
	(fn msg => scan_directive_recover msg >> single)

	end

	(* scan tokens, main *)

	val scan_ml =
	Scan.depend
	let
	fun non_blanks st scan = scan >> pair st
	fun scan_frag st =
	- scan_fragment ( C_Basic_Symbol_Pos.newline >> token Space >> pair true
	- \|\| many1_blanks_no_line >> token Space >> pair st)
	+ scan_fragment ( scan_token (C_Basic_Symbol_Pos.newline >> K [NONE]) Space >> pair true
	+ \|\| scan_token many1_blanks_no_line Space >> pair st)
	(non_blanks st comments)
	((scan_sharp2 \|\| scan_sharp1) >> token Keyword)
	(non_blanks false)
	in
	fn true => scan_token scan_directive Directive >> pair false \|\| scan_frag true
	\| false => scan_frag false
	end;

	fun recover msg =
	(recover_char \|\|
	recover_string \|\|
	Symbol_Pos.recover_cartouche \|\|
	C_Symbol_Pos.recover_comment \|\|
	recover_int \|\|
	one' Symbol.not_eof)
	>> token (Error (msg, Group1 ([], [])));

	fun reader scan syms =
	let
	val termination =
	if null syms then []
	else
	let
	val pos1 = List.last syms \|-> Position.symbol;
	val pos2 = Position.symbol Symbol.space pos1;
	- in [Token (Position.range (pos1, pos2), (Space, Symbol.space))] end;
	+ in [Token (Position.range (pos1, pos2), (Space [NONE], Symbol.space))] end;

	val backslash1 =
	$$$ "\\" @@@ many C_Symbol.is_ascii_blank_no_line @@@ C_Basic_Symbol_Pos.newline
	val backslash2 = Scan.one (not o Symbol_Pos.is_eof)

	val input0 =
	Source.of_list syms
	\|> Source.source Symbol_Pos.stopper (Scan.bulk (backslash1 >> SOME \|\| backslash2 >> K NONE))
	\|> Source.map_filter I
	\|> Source.exhaust
	\|> map (Symbol_Pos.range #> Position.range_position)

	val input1 =
	Source.of_list syms
	\|> Source.source Symbol_Pos.stopper (Scan.bulk (backslash1 >> K NONE \|\| backslash2 >> SOME))
	\|> Source.map_filter I
	\|> Source.source' true
	Symbol_Pos.stopper
	(Scan.recover (Scan.bulk (!!!! "bad input" scan))
	(fn msg => Scan.lift (recover msg) >> single))
	\|> Source.source stopper scan_directive_cond
	\|> Source.exhaust
	\|> (fn input => input @ termination);

	val _ = app (fn pos => Output.information ("Backslash newline" ^ Position.here pos)) input0
	val _ = Position.reports_text (map (fn pos => ((pos, Markup.intensify), "")) input0);
	in (input1, check input1)
	end;

	in

	fun op @@ ((input1, f_error_lines1), (input2, f_error_lines2)) =
	(input1 @ input2, f_error_lines1 #> f_error_lines2)

	val read_init = ([], I)

	fun read text = (reader scan_ml o Symbol_Pos.explode) (text, Position.none);

	fun read_source' {language, symbols} scan source =
	let
	val pos = Input.pos_of source;
	val _ =
	if Position.is_reported_range pos
	then Position.report pos (language (Input.is_delimited source))
	else ();
	in
	Input.source_explode source
	\|> not symbols ? maps (fn (s, p) => raw_explode s \|> map (rpair p))
	\|> reader scan
	end;

	val read_source =
	read_source' { language =
	Markup.language' {name = "C", symbols = false, antiquotes = true}, symbols = true}
	scan_ml;

	end;

	end;
	\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy
	@@ -1,259 +1,256 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Annotation Language: Command Parser Registration\<close>

	theory C_Parser_Annotation
	imports C_Lexer_Annotation C_Environment
	begin

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Isar/outer_syntax.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/Isar/outer_syntax.ML
	Author: Markus Wenzel, TU Muenchen

	Isabelle/Isar outer syntax.
	-*)
	+))
	\<open>
	-structure C_Annotation =
	+structure C_Annotation =
	struct

	( outer syntax )

	(* errors *)

	fun err_command msg name ps =
	error (msg ^ quote (Markup.markup Markup.keyword1 name) ^ Position.here_list ps);

	fun err_dup_command name ps =
	err_command "Duplicate annotation syntax command " name ps;


	(* command parsers *)

	datatype command_parser =
	Parser of (Symbol_Pos.T list * (bool * Symbol_Pos.T list)) * Position.range ->
	C_Env.eval_time c_parser;

	datatype command = Command of
	{comment: string,
	command_parser: command_parser,
	pos: Position.T,
	id: serial};

	fun eq_command (Command {id = id1, ...}, Command {id = id2, ...}) = id1 = id2;

	fun new_command comment command_parser pos =
	Command {comment = comment, command_parser = command_parser, pos = pos, id = serial ()};

	fun command_pos (Command {pos, ...}) = pos;

	fun command_markup def (name, Command {pos, id, ...}) =
	- let (* PATCH: copied as such from Isabelle2020 *)
	- fun entity_properties_of def serial pos =
	- if def then (Markup.defN, Value.print_int serial) :: Position.properties_of pos
	- else (Markup.refN, Value.print_int serial) :: Position.def_properties_of pos;
	-
	- in Markup.properties (entity_properties_of def id pos)
	- (Markup.entity Markup.commandN name)
	- end;
	+ Position.make_entity_markup def id Markup.commandN (name, pos);



	(* theory data *)

	structure Data = Theory_Data
	(
	type T = command Symtab.table;
	val empty = Symtab.empty;
	fun merge data : T =
	data \|> Symtab.join (fn name => fn (cmd1, cmd2) =>
	if eq_command (cmd1, cmd2) then raise Symtab.SAME
	else err_dup_command name [command_pos cmd1, command_pos cmd2]);
	);

	val get_commands = Data.get;
	val dest_commands = get_commands #> Symtab.dest #> sort_by #1;
	val lookup_commands = Symtab.lookup o get_commands;


	(* maintain commands *)

	fun add_command name cmd thy =
	let
	val _ =
	C_Keyword.is_command (C_Thy_Header.get_keywords thy) name orelse
	err_command "Undeclared outer syntax command " name [command_pos cmd];
	val _ =
	(case lookup_commands thy name of
	NONE => ()
	\| SOME cmd' => err_dup_command name [command_pos cmd, command_pos cmd']);
	val _ =
	Context_Position.report_generic (Context.the_generic_context ())
	- (command_pos cmd) (command_markup true (name, cmd));
	+ (command_pos cmd) (command_markup {def = true} (name, cmd));
	in Data.map (Symtab.update (name, cmd)) thy end;

	fun delete_command (name, pos) thy =
	let
	val _ =
	C_Keyword.is_command (C_Thy_Header.get_keywords thy) name orelse
	err_command "Undeclared outer syntax command " name [pos];
	in Data.map (Symtab.delete name) thy end;


	(* implicit theory setup *)

	type command_keyword = string * Position.T;

	fun raw_command0 kind (name, pos) comment command_parser =
	- C_Thy_Header.add_keywords [((name, pos), ((kind, []), [name]))]
	+ C_Thy_Header.add_keywords [((name, pos), Keyword.command_spec (kind, [name]))]
	#> add_command name (new_command comment command_parser pos);

	fun raw_command (name, pos) comment command_parser =
	let val setup = add_command name (new_command comment command_parser pos)
	in Context.>> (Context.mapping setup (Local_Theory.background_theory setup)) end;

	fun command (name, pos) comment parse =
	raw_command (name, pos) comment (Parser parse);

	fun command'' kind (name, pos) comment parse =
	raw_command0 kind (name, pos) comment (Parser parse);

	val command' = command'' Keyword.thy_decl;



	( toplevel parsing )

	(* parse spans *)


	(* parse commands *)

	local
	fun scan_stack' f b = Scan.one f >> (pair b o C_Token.content_of')
	in
	val before_command =
	C_Token.scan_stack C_Token.is_stack1
	-- Scan.optional ( scan_stack' C_Token.is_stack2 false
	\|\| scan_stack' C_Token.is_stack3 true)
	(pair false [])
	end

	fun parse_command thy =
	Scan.ahead (before_command \|-- C_Parse.position C_Parse.command) :\|-- (fn (name, pos) =>
	let val command_tags = before_command -- C_Parse.range C_Parse.command
	>> (fn (cmd, (_, range)) => (cmd, range));
	in
	case lookup_commands thy name of
	SOME (cmd as Command {command_parser = Parser parse, ...}) =>
	C_Parse.!!! (command_tags :\|-- parse)
	- >> pair [((pos, command_markup false (name, cmd)), "")]
	+ >> pair [((pos, command_markup {def = false} (name, cmd)), "")]
	\| NONE =>
	Scan.fail_with (fn _ => fn _ =>
	let
	val msg = "undefined command ";
	in msg ^ quote (Markup.markup Markup.keyword1 name) end)
	end)


	(* check commands *)

	fun command_reports thy tok =
	if C_Token.is_command tok then
	let val name = C_Token.content_of tok in
	(case lookup_commands thy name of
	NONE => []
	- \| SOME cmd => [((C_Token.pos_of tok, command_markup false (name, cmd)), "")])
	+ \| SOME cmd => [((C_Token.pos_of tok, command_markup {def = false} (name, cmd)), "")])
	end
	else [];

	fun check_command ctxt (name, pos) =
	let
	val thy = Proof_Context.theory_of ctxt;
	val keywords = C_Thy_Header.get_keywords thy;
	in
	if C_Keyword.is_command keywords name then
	let
	val markup =
	C_Token.explode0 keywords name
	\|> maps (command_reports thy)
	\|> map (#2 o #1);
	val _ = Context_Position.reports ctxt (map (pair pos) markup);
	in name end
	else
	let
	val completion_report =
	Completion.make_report (name, pos)
	(fn completed =>
	C_Keyword.dest_commands keywords
	\|> filter completed
	\|> sort_strings
	\|> map (fn a => (a, (Markup.commandN, a))));
	in error ("Bad command " ^ quote name ^ Position.here pos ^ completion_report) end
	end;
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/PIDE/resources.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/PIDE/resources.ML
	Author: Makarius

	Resources for theories and auxiliary files.
	-*)
	+))
	\<open>
	structure C_Resources =
	struct
	(* load files *)

	-fun parse_files cmd =
	- Scan.ahead C_Parse.not_eof -- C_Parse.path >> (fn (tok, name) => fn thy =>
	+fun parse_files make_paths =
	+ Scan.ahead C_Parse.not_eof -- C_Parse.path_input >> (fn (tok, source) => fn thy =>
	(case C_Token.get_files tok of
	[] =>
	let
	- val keywords = C_Thy_Header.get_keywords thy;
	val master_dir = Resources.master_directory thy;
	- val pos = C_Token.pos_of tok;
	- val delimited = Input.is_delimited (C_Token.input_of tok);
	- val src_paths = C_Keyword.command_files keywords cmd (Path.explode name);
	+ val name = Input.string_of source;
	+ val pos = Input.pos_of source;
	+ val delimited = Input.is_delimited source;
	+ val src_paths = make_paths (Path.explode name);
	in map (Command.read_file master_dir pos delimited) src_paths end
	\| files => map Exn.release files));

	+val parse_file = parse_files single >> (fn f => f #> the_single);
	+
	end;
	\<close>

	end
	diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Language.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Language.thy
	--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Language.thy
	+++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Language.thy
	@@ -1,1380 +1,1385 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	section \<open>Core Language: Parsing Support (C Language without Annotations)\<close>

	theory C_Parser_Language
	imports C_Environment
	begin

	text \<open> As mentioned in \<^theory>\<open>Isabelle_C.C_Ast\<close>, Isabelle/C depends on
	certain external parsing libraries, such as \<^dir>\<open>../../src_ext/mlton\<close>, and more
	specifically \<^dir>\<open>../../src_ext/mlton/lib/mlyacc-lib\<close>. Actually, the sole theory
	making use of the files in \<^dir>\<open>../../src_ext/mlton/lib/mlyacc-lib\<close> is the present
	\<^file>\<open>C_Parser_Language.thy\<close>. (Any other remaining files in
	\<^dir>\<open>../../src_ext/mlton\<close> are not used by Isabelle/C, they come from the original
	repository of MLton: \<^url>\<open>https://github.com/MLton/mlton\<close>.) \<close>

	subsection \<open>Parsing Library (Including Semantic Functions)\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>\<close>
	(*
	* Modified by Frédéric Tuong, Université Paris-Saclay
	*
	* * * * * * * * * * * * * * * * * * * * * * * * * *
	*
	* Language.C
	* https://hackage.haskell.org/package/language-c
	*
	* Copyright (c) 1999-2017 Manuel M T Chakravarty
	* Duncan Coutts
	* Benedikt Huber
	* Portions Copyright (c) 1989,1990 James A. Roskind
	*
	* * * * * * * * * * * * * * * * * * * * * * * * * *
	*
	* Language.C.Comments
	* https://hackage.haskell.org/package/language-c-comments
	*
	* Copyright (c) 2010-2014 Geoff Hulette
	*)
	\<open>
	signature C_GRAMMAR_RULE_LIB =
	sig
	type arg = (C_Antiquote.antiq * C_Env.antiq_language list) C_Env.T
	type 'a monad = arg -> 'a * arg

	(* type aliases *)
	type class_Pos = C_Ast.class_Pos
	type reports_text0' = { markup : Markup.T, markup_body : string }
	type reports_text0 = reports_text0' list -> reports_text0' list
	type ('a, 'b) reports_base = ('a C_Env.markup_store * Position.T list,
	Position.T list * 'a C_Env.markup_store option) C_Ast.either ->
	Position.T list ->
	string ->
	'b ->
	'b
	(**)
	type NodeInfo = C_Ast.nodeInfo
	type CStorageSpec = NodeInfo C_Ast.cStorageSpecifier
	type CFunSpec = NodeInfo C_Ast.cFunctionSpecifier
	type CConst = NodeInfo C_Ast.cConstant
	type 'a CInitializerList = ('a C_Ast.cPartDesignator List.list * 'a C_Ast.cInitializer) List.list
	type CTranslUnit = NodeInfo C_Ast.cTranslationUnit
	type CExtDecl = NodeInfo C_Ast.cExternalDeclaration
	type CFunDef = NodeInfo C_Ast.cFunctionDef
	type CDecl = NodeInfo C_Ast.cDeclaration
	type CDeclr = NodeInfo C_Ast.cDeclarator
	type CDerivedDeclr = NodeInfo C_Ast.cDerivedDeclarator
	type CArrSize = NodeInfo C_Ast.cArraySize
	type CStat = NodeInfo C_Ast.cStatement
	type CAsmStmt = NodeInfo C_Ast.cAssemblyStatement
	type CAsmOperand = NodeInfo C_Ast.cAssemblyOperand
	type CBlockItem = NodeInfo C_Ast.cCompoundBlockItem
	type CDeclSpec = NodeInfo C_Ast.cDeclarationSpecifier
	type CTypeSpec = NodeInfo C_Ast.cTypeSpecifier
	type CTypeQual = NodeInfo C_Ast.cTypeQualifier
	type CAlignSpec = NodeInfo C_Ast.cAlignmentSpecifier
	type CStructUnion = NodeInfo C_Ast.cStructureUnion
	type CEnum = NodeInfo C_Ast.cEnumeration
	type CInit = NodeInfo C_Ast.cInitializer
	type CInitList = NodeInfo CInitializerList
	type CDesignator = NodeInfo C_Ast.cPartDesignator
	type CAttr = NodeInfo C_Ast.cAttribute
	type CExpr = NodeInfo C_Ast.cExpression
	type CBuiltin = NodeInfo C_Ast.cBuiltinThing
	type CStrLit = NodeInfo C_Ast.cStringLiteral
	(**)
	type ClangCVersion = C_Ast.clangCVersion
	type Ident = C_Ast.ident
	type Position = C_Ast.positiona
	type PosLength = Position * int
	type Name = C_Ast.namea
	type Bool = bool
	type CString = C_Ast.cString
	type CChar = C_Ast.cChar
	type CInteger = C_Ast.cInteger
	type CFloat = C_Ast.cFloat
	type CStructTag = C_Ast.cStructTag
	type CUnaryOp = C_Ast.cUnaryOp
	type 'a CStringLiteral = 'a C_Ast.cStringLiteral
	type 'a CConstant = 'a C_Ast.cConstant
	type ('a, 'b) Either = ('a, 'b) C_Ast.either
	type CIntRepr = C_Ast.cIntRepr
	type CIntFlag = C_Ast.cIntFlag
	type CAssignOp = C_Ast.cAssignOp
	type Comment = C_Ast.comment
	(**)
	type 'a Reversed = 'a C_Ast.Reversed
	type CDeclrR = C_Ast.CDeclrR
	type 'a Maybe = 'a C_Ast.optiona
	type 'a Located = 'a C_Ast.Located
	(**)
	structure List : sig val reverse : 'a list -> 'a list end

	(* monadic operations *)
	val return : 'a -> 'a monad
	val bind : 'a monad -> ('a -> 'b monad) -> 'b monad
	val bind' : 'b monad -> ('b -> unit monad) -> 'b monad
	val >> : unit monad * 'a monad -> 'a monad

	(* position reports *)
	val markup_make : ('a -> reports_text0' option) ->
	('a -> 'b) ->
	('b option -> string) ->
	((Markup.T -> reports_text0) ->
	bool ->
	('b, 'b option * string * reports_text0) C_Ast.either ->
	reports_text0) ->
	('a, C_Position.reports_text) reports_base
	val markup_tvar : (C_Env.markup_global, C_Position.reports_text) reports_base
	val markup_var_enum : (C_Env.markup_global, C_Position.reports_text) reports_base
	val markup_var : (C_Env.markup_ident, C_Position.reports_text) reports_base
	val markup_var_bound : (C_Env.markup_ident, C_Position.reports_text) reports_base
	val markup_var_improper : (C_Env.markup_ident, C_Position.reports_text) reports_base

	(* Language.C.Data.RList *)
	val empty : 'a list Reversed
	val singleton : 'a -> 'a list Reversed
	val snoc : 'a list Reversed -> 'a -> 'a list Reversed
	val rappend : 'a list Reversed -> 'a list -> 'a list Reversed
	val rappendr : 'a list Reversed -> 'a list Reversed -> 'a list Reversed
	val rmap : ('a -> 'b) -> 'a list Reversed -> 'b list Reversed

	(* Language.C.Data.Position *)
	val posOf : 'a -> Position
	val posOf' : bool -> class_Pos -> Position * int
	val make_comment :
	Symbol_Pos.T list -> Symbol_Pos.T list -> Symbol_Pos.T list -> Position.range -> Comment

	(* Language.C.Data.Node *)
	val mkNodeInfo' : Position -> PosLength -> Name -> NodeInfo
	val decode : NodeInfo -> (class_Pos, string) Either
	val decode_error' : NodeInfo -> Position.range

	(* Language.C.Data.Ident *)
	val quad : string list -> int
	val ident_encode : string -> int
	val ident_decode : int -> string
	val mkIdent : Position * int -> string -> Name -> Ident
	val internalIdent : string -> Ident

	(* Language.C.Syntax.AST *)
	val liftStrLit : 'a CStringLiteral -> 'a CConstant

	(* Language.C.Syntax.Constants *)
	val concatCStrings : CString list -> CString

	(* Language.C.Parser.ParserMonad *)
	val getNewName : Name monad
	val shadowTypedef0'''' : string ->
	Position.T list ->
	C_Env.markup_ident ->
	C_Env.env_lang ->
	C_Env.env_tree ->
	C_Env.env_lang * C_Env.env_tree
	val shadowTypedef0' : C_Ast.CDeclSpec list C_Env.parse_status ->
	bool ->
	C_Ast.ident * C_Ast.CDerivedDeclr list ->
	C_Env.env_lang ->
	C_Env.env_tree ->
	C_Env.env_lang * C_Env.env_tree
	val isTypeIdent : string -> arg -> bool
	val enterScope : unit monad
	val leaveScope : unit monad
	val getCurrentPosition : Position monad

	(* Language.C.Parser.Tokens *)
	val CTokCLit : CChar -> (CChar -> 'a) -> 'a
	val CTokILit : CInteger -> (CInteger -> 'a) -> 'a
	val CTokFLit : CFloat -> (CFloat -> 'a) -> 'a
	val CTokSLit : CString -> (CString -> 'a) -> 'a

	(* Language.C.Parser.Parser *)
	val reverseList : 'a list -> 'a list Reversed
	val L : 'a -> int -> 'a Located monad
	val unL : 'a Located -> 'a
	val withNodeInfo : int -> (NodeInfo -> 'a) -> 'a monad
	val withNodeInfo_CExtDecl : CExtDecl -> (NodeInfo -> 'a) -> 'a monad
	val withNodeInfo_CExpr : CExpr list Reversed -> (NodeInfo -> 'a) -> 'a monad
	val withLength : NodeInfo -> (NodeInfo -> 'a) -> 'a monad
	val reverseDeclr : CDeclrR -> CDeclr
	val withAttribute : int -> CAttr list -> (NodeInfo -> CDeclrR) -> CDeclrR monad
	val withAttributePF : int -> CAttr list -> (NodeInfo -> CDeclrR -> CDeclrR) ->
	(CDeclrR -> CDeclrR) monad
	val appendObjAttrs : CAttr list -> CDeclr -> CDeclr
	val withAsmNameAttrs : CStrLit Maybe * CAttr list -> CDeclrR -> CDeclrR monad
	val appendDeclrAttrs : CAttr list -> CDeclrR -> CDeclrR
	val ptrDeclr : CDeclrR -> CTypeQual list -> NodeInfo -> CDeclrR
	val funDeclr : CDeclrR -> (Ident list, (CDecl list * Bool)) Either -> CAttr list -> NodeInfo ->
	CDeclrR
	val arrDeclr : CDeclrR -> CTypeQual list -> Bool -> Bool -> CExpr Maybe -> NodeInfo -> CDeclrR
	val liftTypeQuals : CTypeQual list Reversed -> CDeclSpec list
	val liftCAttrs : CAttr list -> CDeclSpec list
	val addTrailingAttrs : CDeclSpec list Reversed -> CAttr list -> CDeclSpec list Reversed
	val emptyDeclr : CDeclrR
	val mkVarDeclr : Ident -> NodeInfo -> CDeclrR
	val doDeclIdent : CDeclSpec list -> CDeclrR -> unit monad
	val ident_of_decl : (Ident list, CDecl list * bool) C_Ast.either ->
	(Ident * CDerivedDeclr list * CDeclSpec list) list
	val doFuncParamDeclIdent : CDeclr -> unit monad
	end

	structure C_Grammar_Rule_Lib : C_GRAMMAR_RULE_LIB =
	struct
	open C_Ast
	type arg = (C_Antiquote.antiq * C_Env.antiq_language list) C_Env.T
	type 'a monad = arg -> 'a * arg

	(**)
	type reports_text0' = { markup : Markup.T, markup_body : string }
	type reports_text0 = reports_text0' list -> reports_text0' list
	type 'a reports_store = Position.T list * serial * 'a
	type ('a, 'b) reports_base = ('a C_Env.markup_store * Position.T list,
	Position.T list * 'a C_Env.markup_store option) C_Ast.either ->
	Position.T list ->
	string ->
	'b ->
	'b
	fun markup_init markup = { markup = markup, markup_body = "" }
	val look_idents = C_Env_Ext.list_lookup o C_Env_Ext.get_idents
	val look_idents' = C_Env_Ext.list_lookup o C_Env_Ext.get_idents'
	val look_tyidents_typedef = C_Env_Ext.list_lookup o C_Env_Ext.get_tyidents_typedef
	val look_tyidents'_typedef = C_Env_Ext.list_lookup o C_Env_Ext.get_tyidents'_typedef
	val To_string0 = meta_of_logic
	val ident_encode =
	Word8Vector.foldl (fn (w, acc) => Word8.toInt w + acc * 256) 0 o Byte.stringToBytes
	fun ident_decode nb = radixpand (256, nb) \|> map chr \|> implode
	fun reverse l = rev l

	fun report _ [] _ = I
	\| report markup ps x =
	let val ms = markup x
	in fold (fn p => fold (fn {markup, markup_body} => cons ((p, markup), markup_body)) ms) ps
	end

	fun markup_make typing get_global desc report' data =
	report
	(fn name =>
	let
	val (def, ps, id, global, typing) =
	case data of
	Left ((ps, id, param), ps' as _ :: _) =>
	( true
	, ps
	, id
	, Right ( SOME (get_global param)
	, "Redefinition of " ^ quote name ^ Position.here_list ps
	\<comment> \<open>Any positions provided here will be explicitly reported, which might not be the
	desired effect. So we explicitly refer the reader to a separate tooltip.\<close>
	^ " (more details in the command modifier tooltip)"
	, cons { markup = Markup.class_parameter
	, markup_body = "redefining this" ^ Position.here_list ps' })
	, typing param)
	\| Left ((ps, id, param), _) => (true, ps, id, Left (get_global param), typing param)
	\| Right (_, SOME (ps, id, param)) => (false, ps, id, Left (get_global param), typing param)
	\| Right (ps, _) => ( true
	, ps
	, serial ()
	, Right (NONE, "Undeclared " ^ quote name ^ Position.here_list ps, I)
	, NONE)
	fun markup_elem name = (name, (name, []): Markup.T)
	val (varN, var) = markup_elem (desc (case global of Left b => SOME b
	\| Right (SOME b, _, _) => SOME b
	\| _ => NONE));
	- val entity = Markup.entity varN name
	val cons' = cons o markup_init
	- val _ = make_entity_markup
	- (* PATCH: copied as such from Isabelle2020 *)
	- fun entity_properties_of def serial pos =
	- if def then (Markup.defN, Value.print_int serial) :: properties_of pos
	- else (Markup.refN, Value.print_int serial) :: def_properties_of pos;
	-
	in
	(cons' var
	#> report' cons' def global
	#> (case typing of NONE => I \| SOME x => cons x))
	- (map (fn pos =>
	-(* WAS: markup_init (Markup.properties (Position.entity_properties_of def id pos) entity)) *)
	-(* NEW in Isabelle 2021-1RC:
	- fun make_entity_markup {def} serial kind (name, pos) =
	- let
	- val props =
	- if def then (Markup.defN, Value.print_int serial) :: properties_of pos
	- else (Markup.refN, Value.print_int serial) :: def_properties_of pos;
	- in Markup.entity kind name \|> Markup.properties props end;
	-*)
	- markup_init (Markup.properties (entity_properties_of def id pos) entity))
	- ps)
	+ (map (markup_init o Position.make_entity_markup {def = def} id varN o pair name) ps)
	end)

	fun markup_make' typing get_global desc report =
	markup_make
	typing
	get_global
	(fn global =>
	"C " ^ (case global of SOME true => "global "
	\| SOME false => "local "
	\| NONE => "")
	^ desc)
	(fn cons' => fn def =>
	fn Left b => report cons' def b
	\| Right (b, msg, f) => tap (fn _ => Output.information msg)
	#> f
	#> (case b of NONE => cons' Markup.free \| SOME b => report cons' def b))

	fun markup_tvar0 desc =
	markup_make'
	(K NONE)
	I
	desc
	(fn cons' => fn def =>
	fn true => cons' (if def then Markup.free else Markup.ML_keyword3)
	\| false => cons' Markup.skolem)

	val markup_tvar = markup_tvar0 "type variable"
	val markup_var_enum = markup_tvar0 "enum tag"

	fun string_of_list f =
	(fn [] => NONE \| [s] => SOME s \| s => SOME ("[" ^ String.concatWith ", " s ^ "]"))
	o map f

	val string_of_cDeclarationSpecifier =
	fn C_Ast.CStorageSpec0 _ => "storage"
	\| C_Ast.CTypeSpec0 t => (case t of
	CVoidType0 _ => "void"
	\| CCharType0 _ => "char"
	\| CShortType0 _ => "short"
	\| CIntType0 _ => "int"
	\| CLongType0 _ => "long"
	\| CFloatType0 _ => "float"
	\| CDoubleType0 _ => "double"
	\| CSignedType0 _ => "signed"
	\| CUnsigType0 _ => "unsig"
	\| CBoolType0 _ => "bool"
	\| CComplexType0 _ => "complex"
	\| CInt128Type0 _ => "int128"
	\| CSUType0 _ => "SU"
	\| CEnumType0 _ => "enum"
	\| CTypeDef0 _ => "typedef"
	\| CTypeOfExpr0 _ => "type_of_expr"
	\| CTypeOfType0 _ => "type_of_type"
	\| CAtomicType0 _ => "atomic")
	\| C_Ast.CTypeQual0 _ => "type_qual"
	\| C_Ast.CFunSpec0 _ => "fun"
	\| C_Ast.CAlignSpec0 _ => "align"

	fun typing {params, ret, ...} =
	SOME
	{ markup = Markup.typing
	, markup_body =
	case
	( string_of_list
	(fn C_Ast.CPtrDeclr0 _ => "pointer"
	\| C_Ast.CArrDeclr0 _ => "array"
	\| C_Ast.CFunDeclr0 (C_Ast.Left _, _, _) => "function [...] ->"
	\| C_Ast.CFunDeclr0 (C_Ast.Right (l_decl, _), _, _) =>
	"function "
	^ (String.concatWith
	" -> "
	(map (fn CDecl0 ([decl], _, _) => string_of_cDeclarationSpecifier decl
	\| CDecl0 (l, _, _) => "(" ^ String.concatWith
	" "
	(map string_of_cDeclarationSpecifier l)
	^ ")"
	\| CStaticAssert0 _ => "static_assert")
	l_decl))
	^ " ->")
	params
	, case ret of C_Env.Previous_in_stack => SOME "..."
	\| C_Env.Parsed ret => string_of_list string_of_cDeclarationSpecifier ret)
	of (NONE, NONE) => let val _ = warning "markup_var: Not yet implemented" in "" end
	\| (SOME params, NONE) => params
	\| (NONE, SOME ret) => ret
	\| (SOME params, SOME ret) => params ^ " " ^ ret }

	val markup_var =
	markup_make'
	typing
	#global
	"variable"
	(fn cons' => fn def =>
	fn true => if def then cons' Markup.free else cons' Markup.delimiter (*explicit black color,
	otherwise the default color of constants might
	be automatically chosen (especially in term
	cartouches)*)
	\| false => cons' Markup.bound)

	val markup_var_bound =
	markup_make' typing #global "variable" (fn cons' => K (K (cons' Markup.bound)))

	val markup_var_improper =
	markup_make' typing #global "variable" (fn cons' => K (K (cons' Markup.improper)))

	(**)
	val return = pair
	fun bind f g = f #-> g
	fun bind' f g = bind f (fn r => bind (g r) (fn () => return r))
	fun a >> b = a #> b o #2
	fun sequence_ f = fn [] => return ()
	\| x :: xs => f x >> sequence_ f xs

	(* Language.C.Data.RList *)
	val empty = []
	fun singleton x = [x]
	fun snoc xs x = x :: xs
	fun rappend xs ys = rev ys @ xs
	fun rappendr xs ys = ys @ xs
	val rmap = map
	val viewr = fn [] => error "viewr: empty RList"
	\| x :: xs => (xs, x)

	(* Language.C.Data.Position *)
	val nopos = NoPosition
	fun posOf _ = NoPosition
	fun posOf' mk_range =
	(if mk_range then Position.range else I)
	#> (fn (pos1, pos2) =>
	let val {offset = offset, end_offset = end_offset, ...} = Position.dest pos1
	in ( Position offset (From_string (C_Env.encode_positions [pos1, pos2])) 0 0
	, end_offset - offset)
	end)
	fun posOf'' node env =
	let val (stack, len) = #rule_input env
	val (mk_range, (pos1a, pos1b)) = case node of Left i => (true, nth stack (len - i - 1))
	\| Right range => (false, range)
	val (pos2a, pos2b) = nth stack 0
	in ( (posOf' mk_range (pos1a, pos1b) \|> #1, posOf' true (pos2a, pos2b))
	, env \|> C_Env_Ext.map_output_pos (K (SOME (pos1a, pos2b)))
	\|> C_Env_Ext.map_output_vacuous (K false)) end
	val posOf''' = posOf'' o Left
	val internalPos = InternalPosition
	fun make_comment body_begin body body_end range =
	Commenta ( posOf' false range \|> #1
	, From_string (Symbol_Pos.implode (body_begin @ body @ body_end))
	, case body_end of [] => SingleLine \| _ => MultiLine)

	(* Language.C.Data.Node *)
	val undefNode = OnlyPos nopos (nopos, ~1)
	fun mkNodeInfoOnlyPos pos = OnlyPos pos (nopos, ~1)
	fun mkNodeInfo pos name = NodeInfo pos (nopos, ~1) name
	val mkNodeInfo' = NodeInfo
	val decode =
	(fn OnlyPos0 range => range
	\| NodeInfo0 (pos1, (pos2, len2), _) => (pos1, (pos2, len2)))
	#> (fn (Position0 (_, s1, _, _), (Position0 (_, s2, _, _), _)) =>
	(case (C_Env.decode_positions (To_string0 s1), C_Env.decode_positions (To_string0 s2))
	of ([pos1, _], [_, pos2]) => Left (Position.range (pos1, pos2))
	\| _ => Right "Expecting 2 elements")
	\| _ => Right "Invalid position")
	fun decode_error' x = case decode x of Left x => x \| Right msg => error msg
	fun decode_error x = Right (decode_error' x)
	val nameOfNode = fn OnlyPos0 _ => NONE
	\| NodeInfo0 (_, _, name) => SOME name

	(* Language.C.Data.Ident *)
	local
	val bits7 = Integer.pow 7 2
	val bits14 = Integer.pow 14 2
	val bits21 = Integer.pow 21 2
	val bits28 = Integer.pow 28 2
	- val ord = SML90.ord; (* copied from ML_init in Isabelle2020. *)
	in
	fun quad s = case s of
	[] => 0
	\| c1 :: [] => ord c1
	\| c1 :: c2 :: [] => ord c2 * bits7 + ord c1
	\| c1 :: c2 :: c3 :: [] => ord c3 * bits14 + ord c2 * bits7 + ord c1
	\| c1 :: c2 :: c3 :: c4 :: s => ((ord c4 * bits21
	+ ord c3 * bits14
	+ ord c2 * bits7
	+ ord c1)
	mod bits28)
	+ (quad s mod bits28)
	end

	local
	fun internalIdent0 pos s = Ident (From_string s, ident_encode s, pos)
	in
	fun mkIdent (pos, len) s name = internalIdent0 (mkNodeInfo' pos (pos, len) name) s
	val internalIdent = internalIdent0 (mkNodeInfoOnlyPos internalPos)
	end

	(* Language.C.Syntax.AST *)
	fun liftStrLit (CStrLit0 (str, at)) = CStrConst str at

	(* Language.C.Syntax.Constants *)
	fun concatCStrings cs =
	CString0 (flattena (map (fn CString0 (s,_) => s) cs), exists (fn CString0 (_, b) => b) cs)

	(* Language.C.Parser.ParserMonad *)
	fun getNewName env =
	(Namea (C_Env_Ext.get_namesupply env), C_Env_Ext.map_namesupply (fn x => x + 1) env)

	fun addTypedef (Ident0 (_, i, node)) env =
	let val name = ident_decode i
	val pos1 = [decode_error' node \|> #1]
	val data = (pos1, serial (), null (C_Env_Ext.get_scopes env))
	in ((), env \|> C_Env_Ext.map_idents (Symtab.delete_safe name)
	\|> C_Env_Ext.map_tyidents_typedef (Symtab.update (name, data))
	\|> C_Env_Ext.map_reports_text
	(markup_tvar
	(Left (data, flat [ look_idents env name, look_tyidents_typedef env name ]))
	pos1
	name))
	end
	fun shadowTypedef0''' name pos data0 env_lang env_tree =
	let val data = (pos, serial (), data0)
	val update_id = Symtab.update (name, data)
	in ( env_lang \|> C_Env_Ext.map_tyidents'_typedef (Symtab.delete_safe name)
	\|> C_Env_Ext.map_idents' update_id
	, update_id
	, env_tree
	\|> C_Env.map_reports_text
	(markup_var (Left (data, flat [ look_idents' env_lang name
	, look_tyidents'_typedef env_lang name ]))
	pos
	name))
	end
	fun shadowTypedef0'''' name pos data0 env_lang env_tree =
	let val (env_lang, _, env_tree) = shadowTypedef0''' name pos data0 env_lang env_tree
	in ( env_lang, env_tree) end
	fun shadowTypedef0'' ret global (Ident0 (_, i, node), params) =
	shadowTypedef0''' (ident_decode i)
	[decode_error' node \|> #1]
	{global = global, params = params, ret = ret}
	fun shadowTypedef0' ret global ident env_lang env_tree =
	let val (env_lang, _, env_tree) = shadowTypedef0'' ret global ident env_lang env_tree
	in (env_lang, env_tree) end
	fun shadowTypedef0 ret global f ident env =
	let val (update_id, env) =
	C_Env.map_env_lang_tree'
	(fn env_lang => fn env_tree =>
	let val (env_lang, update_id, env_tree) =
	shadowTypedef0'' ret global ident env_lang env_tree
	in (update_id, (env_lang, env_tree)) end)
	env
	in ((), f update_id env) end
	fun shadowTypedef_fun ident env =
	shadowTypedef0 C_Env.Previous_in_stack
	(case C_Env_Ext.get_scopes env of _ :: [] => true \| _ => false)
	(fn update_id =>
	C_Env_Ext.map_scopes
	(fn (NONE, x) :: xs => (SOME (fst ident), C_Env.map_idents update_id x) :: xs
	\| (SOME _, _) :: _ => error "Not yet implemented"
	\| [] => error "Not expecting an empty scope"))
	ident
	env
	fun shadowTypedef (i, params, ret) env =
	shadowTypedef0 (C_Env.Parsed ret) (List.null (C_Env_Ext.get_scopes env)) (K I) (i, params) env
	- fun isTypeIdent s0 arg = (Symtab.exists (fn (s1, _) => s0 = s1) o C_Env_Ext.get_tyidents_typedef) arg
	+ fun isTypeIdent s0 = Symtab.exists (fn (s1, _) => s0 = s1) o C_Env_Ext.get_tyidents_typedef
	fun enterScope env =
	((), C_Env_Ext.map_scopes (cons (NONE, C_Env_Ext.get_var_table env)) env)
	fun leaveScope env =
	case C_Env_Ext.get_scopes env of
	[] => error "leaveScope: already in global scope"
	\| (_, var_table) :: scopes => ((), env \|> C_Env_Ext.map_scopes (K scopes)
	\|> C_Env_Ext.map_var_table (K var_table))
	val getCurrentPosition = return NoPosition

	(* Language.C.Parser.Tokens *)
	fun CTokCLit x f = x \|> f
	fun CTokILit x f = x \|> f
	fun CTokFLit x f = x \|> f
	fun CTokSLit x f = x \|> f

	(* Language.C.Parser.Parser *)
	fun reverseList x = rev x
	fun L a i = posOf''' i #>> curry Located a
	fun unL (Located (a, _)) = a
	fun withNodeInfo00 (pos1, (pos2, len2)) mkAttrNode name =
	return (mkAttrNode (NodeInfo pos1 (pos2, len2) name))
	fun withNodeInfo0 x = x \|> bind getNewName oo withNodeInfo00
	fun withNodeInfo0' node mkAttrNode env = let val (range, env) = posOf'' node env
	in withNodeInfo0 range mkAttrNode env end
	fun withNodeInfo x = x \|> withNodeInfo0' o Left
	fun withNodeInfo' x = x \|> withNodeInfo0' o decode_error
	fun withNodeInfo_CExtDecl x = x \|>
	withNodeInfo' o (fn CDeclExt0 (CDecl0 (_, _, node)) => node
	\| CDeclExt0 (CStaticAssert0 (_, _, node)) => node
	\| CFDefExt0 (CFunDef0 (_, _, _, _, node)) => node
	\| CAsmExt0 (_, node) => node)
	val get_node_CExpr =
	fn CComma0 (_, a) => a \| CAssign0 (_, _, _, a) => a \| CCond0 (_, _, _, a) => a \|
	CBinary0 (_, _, _, a) => a \| CCast0 (_, _, a) => a \| CUnary0 (_, _, a) => a \|
	CSizeofExpr0 (_, a) => a \| CSizeofType0 (_, a) => a \| CAlignofExpr0 (_, a) => a \|
	CAlignofType0 (_, a) => a \| CComplexReal0 (_, a) => a \| CComplexImag0 (_, a) => a \|
	CIndex0 (_, _, a) => a \|
	CCall0 (_, _, a) => a \| CMember0 (_, _, _, a) => a \| CVar0 (_, a) => a \| CConst0 c => (case c of
	CIntConst0 (_, a) => a \| CCharConst0 (_, a) => a \| CFloatConst0 (_, a) => a \|
	CStrConst0 (_, a) => a) \|
	CCompoundLit0 (_, _, a) => a \| CGenericSelection0 (_, _, a) => a \| CStatExpr0 (_, a) => a \|
	CLabAddrExpr0 (_, a) => a \| CBuiltinExpr0 cBuiltinThing => (case cBuiltinThing
	of CBuiltinVaArg0 (_, _, a) => a
	\| CBuiltinOffsetOf0 (_, _, a) => a
	\| CBuiltinTypesCompatible0 (_, _, a) => a)
	fun withNodeInfo_CExpr x = x \|> withNodeInfo' o get_node_CExpr o hd
	fun withLength node mkAttrNode =
	bind (posOf'' (decode_error node)) (fn range =>
	withNodeInfo00 range mkAttrNode (case nameOfNode node of NONE => error "nameOfNode"
	\| SOME name => name))
	fun reverseDeclr (CDeclrR0 (ide, reversedDDs, asmname, cattrs, at)) =
	CDeclr ide (rev reversedDDs) asmname cattrs at
	fun appendDeclrAttrs newAttrs (CDeclrR0 (ident, l, asmname, cattrs, at)) =
	case l of
	[] => CDeclrR ident empty asmname (cattrs @ newAttrs) at
	\| x :: xs =>
	let
	val appendAttrs =
	fn CPtrDeclr0 (typeQuals, at) => CPtrDeclr (typeQuals @ map CAttrQual newAttrs) at
	\| CArrDeclr0 (typeQuals, arraySize, at) => CArrDeclr (typeQuals @ map CAttrQual newAttrs)
	arraySize
	at
	\| CFunDeclr0 (parameters, cattrs, at) => CFunDeclr parameters (cattrs @ newAttrs) at
	in CDeclrR ident (appendAttrs x :: xs) asmname cattrs at end
	fun withAttribute node cattrs mkDeclrNode =
	bind (posOf''' node) (fn (pos, _) =>
	bind getNewName (fn name =>
	let val attrs = mkNodeInfo pos name
	val newDeclr = appendDeclrAttrs cattrs (mkDeclrNode attrs)
	in return newDeclr end))
	fun withAttributePF node cattrs mkDeclrCtor =
	bind (posOf''' node) (fn (pos, _) =>
	bind getNewName (fn name =>
	let val attrs = mkNodeInfo pos name
	val newDeclr = appendDeclrAttrs cattrs o mkDeclrCtor attrs
	in return newDeclr end))
	fun appendObjAttrs newAttrs (CDeclr0 (ident, indirections, asmname, cAttrs, at)) =
	CDeclr ident indirections asmname (cAttrs @ newAttrs) at
	fun appendObjAttrsR newAttrs (CDeclrR0 (ident, indirections, asmname, cAttrs, at)) =
	CDeclrR ident indirections asmname (cAttrs @ newAttrs) at
	fun setAsmName mAsmName (CDeclrR0 (ident, indirections, oldName, cattrs, at)) =
	case (case (mAsmName, oldName)
	of (None, None) => Right None
	\| (None, oldname as Some _) => Right oldname
	\| (newname as Some _, None) => Right newname
	\| (Some n1, Some n2) => Left (n1, n2))
	of
	Left (n1, n2) => let fun showName (CStrLit0 (CString0 (s, _), _)) = To_string0 s
	in error ("Duplicate assembler name: " ^ showName n1 ^ " " ^ showName n2) end
	\| Right newName => return (CDeclrR ident indirections newName cattrs at)
	fun withAsmNameAttrs (mAsmName, newAttrs) declr =
	setAsmName mAsmName (appendObjAttrsR newAttrs declr)
	fun ptrDeclr (CDeclrR0 (ident, derivedDeclrs, asmname, cattrs, dat)) tyquals at =
	CDeclrR ident (snoc derivedDeclrs (CPtrDeclr tyquals at)) asmname cattrs dat
	fun funDeclr (CDeclrR0 (ident, derivedDeclrs, asmname, dcattrs, dat)) params cattrs at =
	CDeclrR ident (snoc derivedDeclrs (CFunDeclr params cattrs at)) asmname dcattrs dat
	fun arrDeclr (CDeclrR0 (ident, derivedDeclrs, asmname, cattrs, dat))
	tyquals
	var_sized
	static_size
	size_expr_opt
	at =
	CDeclrR ident
	(snoc
	derivedDeclrs
	(CArrDeclr tyquals (case size_expr_opt of
	Some e => CArrSize static_size e
	\| None => CNoArrSize var_sized) at))
	asmname
	cattrs
	dat
	val liftTypeQuals = map CTypeQual o reverse
	val liftCAttrs = map (CTypeQual o CAttrQual)
	fun addTrailingAttrs declspecs new_attrs =
	case viewr declspecs of
	(specs_init, CTypeSpec0 (CSUType0 (CStruct0 (tag, name, Some def, def_attrs, su_node), node)))
	=>
	snoc
	specs_init
	(CTypeSpec (CSUType (CStruct tag name (Just def) (def_attrs @ new_attrs) su_node) node))
	\| (specs_init, CTypeSpec0 (CEnumType0 (CEnum0 (name, Some def, def_attrs, e_node), node))) =>
	snoc
	specs_init
	(CTypeSpec (CEnumType (CEnum name (Just def) (def_attrs @ new_attrs) e_node) node))
	\| _ => rappend declspecs (liftCAttrs new_attrs)
	val emptyDeclr = CDeclrR Nothing empty Nothing [] undefNode
	fun mkVarDeclr ident = CDeclrR (Some ident) empty Nothing []
	fun doDeclIdent declspecs (decl as CDeclrR0 (mIdent, _, _, _, _)) =
	case mIdent of
	None => return ()
	\| Some ident =>
	if exists (fn CStorageSpec0 (CTypedef0 _) => true \| _ => false) declspecs
	then addTypedef ident
	else shadowTypedef ( ident
	, case reverseDeclr decl of CDeclr0 (_, params, _, _, _) => params
	, declspecs)

	val ident_of_decl =
	fn Left params => map (fn i => (i, [], [])) params
	\| Right (params, _) =>
	maps (fn CDecl0 (ret, l, _) =>
	maps (fn ((Some (CDeclr0 (Some mIdent, params, _, _, _)),_),_) =>
	[(mIdent, params, ret)]
	\| _ => [])
	l
	\| _ => [])
	params

	local
	fun sequence_' f = sequence_ f o ident_of_decl
	val is_fun = fn CFunDeclr0 _ => true \| _ => false
	in
	fun doFuncParamDeclIdent (CDeclr0 (mIdent0, param0, _, _, node0)) =
	let
	val (param_not_fun, param0') = chop_prefix (not o is_fun) param0
	val () =
	if null param_not_fun then ()
	else
	Output.information
	("Not a function"
	^ Position.here
	(decode_error' (case mIdent0 of None => node0
	\| Some (Ident0 (_, _, node)) => node) \|> #1))
	val (param_fun, param0') = chop_prefix is_fun param0'
	in
	(case mIdent0 of None => return ()
	\| Some mIdent0 => shadowTypedef_fun (mIdent0, param0))
	>>
	sequence_ shadowTypedef
	(maps (fn CFunDeclr0 (params, _, _) => ident_of_decl params \| _ => []) param_fun)
	>>
	sequence_
	(fn CFunDeclr0 (params, _, _) =>
	C_Env.map_env_tree
	(pair Symtab.empty
	#> sequence_'
	(fn (Ident0 (_, i, node), params, ret) => fn (env_lang, env_tree) => pair ()
	let
	val name = ident_decode i
	val pos = [decode_error' node \|> #1]
	val data = ( pos
	, serial ()
	, {global = false, params = params, ret = C_Env.Parsed ret})
	in
	( env_lang \|> Symtab.update (name, data)
	, env_tree
	\|> C_Env.map_reports_text
	(markup_var_improper
	(Left (data, C_Env_Ext.list_lookup env_lang name))
	pos
	name))
	end)
	params
	#> #2 o #2)
	#> pair ()
	\| _ => return ())
	param0'
	end
	end

	(**)
	structure List = struct val reverse = rev end
	end
	\<close>

	subsection \<open>Miscellaneous\<close>

	ML \<comment> \<open>\<^file>\<open>~~/src/Pure/Thy/document_antiquotations.ML\<close>\<close>
	-(* Author: Frédéric Tuong, Université Paris-Saclay *)
	+(* Author: Frédéric Tuong, Université Paris-Saclay
	+ Analogous to:
	(* Title: Pure/Thy/document_antiquotations.ML
	Author: Makarius

	Miscellaneous document antiquotations.
	-*)
	+))
	\<open>
	structure ML_Document_Antiquotations =
	struct

	(* ML text *)

	local

	fun ml_text name ml =
	Document_Output.antiquotation_raw_embedded name (Scan.lift Parse.embedded_input \<comment> \<open>TODO: enable reporting with \<^ML_type>\<open>Token.file\<close> as in \<^ML>\<open>Resources.parse_files\<close>\<close>)
	(fn ctxt => fn text =>
	let val file_content =
	Token.file_source
	(Command.read_file (Resources.master_directory (Proof_Context.theory_of ctxt))
	- Position.none false
	+ Position.none
	+ false
	(Path.explode (#1 (Input.source_content text))))
	val _ = (TODO: avoid multiple file scanning)
	ML_Context.eval_in (SOME ctxt) ML_Compiler.flags Position.none (* \<leftarrow> (optionally)
	disabling a potential
	double report*)
	(ml file_content)
	in file_content
	\|> Input.source_explode
	\|> Source.of_list
	\|> Source.source
	Symbol_Pos.stopper
	(Scan.bulk (Symbol_Pos.scan_comment "" >> (C_Scan.Left o pair true)
	\|\| Scan.many1 (Symbol.is_ascii_blank o Symbol_Pos.symbol)
	>> (C_Scan.Left o pair false)
	\|\| Scan.one (not o Symbol_Pos.is_eof) >> C_Scan.Right))
	\|> Source.exhaust
	\|> drop_prefix (fn C_Scan.Left _ => true \| _ => false)
	\|> drop_suffix (fn C_Scan.Left (false, _) => true \| _ => false)
	\|> maps (fn C_Scan.Left (_, x) => x \| C_Scan.Right x => [x])
	\|> Symbol_Pos.implode
	\|> enclose "\n" "\n"
	\|> cartouche
	\|> Document_Output.output_source ctxt
	\|> Document_Output.isabelle ctxt
	end);

	fun ml_enclose bg en source =
	ML_Lex.read bg @ ML_Lex.read_source source @ ML_Lex.read en;

	in

	val _ = Theory.setup (ml_text \<^binding>\<open>ML_file\<close> (ml_enclose "" ""));

	end;

	end;
	\<close>

	subsection \<open>Loading the Grammar Simulator\<close>

	text \<open> The parser consists of a generic module
	\<^file>\<open>../../src_ext/mlton/lib/mlyacc-lib/base.sig\<close>, which interprets an
	automata-like format generated from ML-Yacc. \<close>

	ML_file "../../src_ext/mlton/lib/mlyacc-lib/base.sig" \<comment>
	\<open>\<^ML_file>\<open>../../src_ext/mlton/lib/mlyacc-lib/base.sig\<close>\<close>
	ML_file "../../src_ext/mlton/lib/mlyacc-lib/join.sml" \<comment>
	\<open>\<^ML_file>\<open>../../src_ext/mlton/lib/mlyacc-lib/join.sml\<close>\<close>
	ML_file "../../src_ext/mlton/lib/mlyacc-lib/lrtable.sml" \<comment>
	\<open>\<^ML_file>\<open>../../src_ext/mlton/lib/mlyacc-lib/lrtable.sml\<close>\<close>
	ML_file "../../src_ext/mlton/lib/mlyacc-lib/stream.sml" \<comment>
	\<open>\<^ML_file>\<open>../../src_ext/mlton/lib/mlyacc-lib/stream.sml\<close>\<close>
	ML_file "../../src_ext/mlton/lib/mlyacc-lib/parser1.sml" \<comment>
	\<open>\<^ML_file>\<open>../../src_ext/mlton/lib/mlyacc-lib/parser1.sml\<close>\<close>

	subsection \<open>Loading the Generated Grammar (SML signature)\<close>

	ML_file "../generated/c_grammar_fun.grm.sig"

	+ML \<comment> \<open>\<^file>\<open>../generated/c_grammar_fun.grm.sig\<close>\<close>
	+(TODO: the whole part should be maximally generated and integrated in the signature file)
	+\<open>
	+structure C_Grammar_Rule = struct
	+open C_Grammar_Rule
	+
	+(* ast_generic is an untyped universe of (some) ast's with the specific lenses put ... get ... *)
	+
	+type ast_generic = start_happy
	+
	+val get_CExpr = start_happy4
	+val get_CStat = start_happy3
	+val get_CExtDecl = start_happy2
	+val get_CTranslUnit = start_happy1
	+
	+fun put_CExpr (x : C_Grammar_Rule_Lib.CExpr) = Right (Right (Right (Left x))) : ast_generic
	+fun put_CStat (x : C_Grammar_Rule_Lib.CStat) = Right (Right (Left x)) : ast_generic
	+fun put_CExtDecl (x : C_Grammar_Rule_Lib.CExtDecl) = Right (Left x) : ast_generic
	+fun put_CTranslUnit (x : C_Grammar_Rule_Lib.CTranslUnit) = Left x : ast_generic
	+end
	+\<close>
	+
	subsection \<open>Overloading Grammar Rules (Optional Part)\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>\<close> \<open>
	structure C_Grammar_Rule_Wrap_Overloading = struct
	open C_Grammar_Rule_Lib

	fun update_env_bottom_up f x arg = ((), C_Env.map_env_lang_tree (f x) arg)
	fun update_env_top_down f x =
	pair () ##> (fn arg => C_Env_Ext.map_output_env (K (SOME (f x (#env_lang arg)))) arg)

	(type variable (report bound))

	val specifier3 : (CDeclSpec list) -> unit monad =
	update_env_bottom_up
	(fn l => fn env_lang => fn env_tree =>
	( env_lang
	, fold
	let open C_Ast
	in fn CTypeSpec0 (CTypeDef0 (Ident0 (_, i, node), _)) =>
	let val name = ident_decode i
	val pos1 = [decode_error' node \|> #1]
	in
	C_Env.map_reports_text
	(markup_tvar
	(Right (pos1, Symtab.lookup (C_Env_Ext.get_tyidents'_typedef env_lang) name))
	pos1
	name)
	end
	\| _ => I
	end
	l
	env_tree))
	val declaration_specifier3 : (CDeclSpec list) -> unit monad = specifier3
	val type_specifier3 : (CDeclSpec list) -> unit monad = specifier3


	(basic variable (report bound))

	val primary_expression1 : (CExpr) -> unit monad =
	update_env_bottom_up
	(fn e => fn env_lang => fn env_tree =>
	( env_lang
	, let open C_Ast
	in fn CVar0 (Ident0 (_, i, node), _) =>
	let val name = ident_decode i
	val pos1 = [decode_error' node \|> #1]
	in
	C_Env.map_reports_text
	(markup_var
	(Right (pos1, Symtab.lookup (C_Env_Ext.get_idents' env_lang) name))
	pos1
	name)
	end
	\| _ => I
	end
	e
	env_tree))


	(basic variable, parameter functions (report bound))

	val declarator1 : (CDeclrR) -> unit monad =
	update_env_bottom_up
	(fn d => fn env_lang => fn env_tree =>
	( env_lang
	, let open C_Ast
	fun markup markup_var params =
	pair Symtab.empty
	#> fold
	(fn (Ident0 (_, i, node), params, ret) => fn (env_lang, env_tree) =>
	let
	val name = ident_decode i
	val pos = [decode_error' node \|> #1]
	val data = ( pos
	, serial ()
	, {global = false, params = params, ret = C_Env.Parsed ret})
	in
	( env_lang \|> Symtab.update (name, data)
	, env_tree
	\|> C_Env.map_reports_text
	(markup_var (Left (data, C_Env_Ext.list_lookup env_lang name))
	pos
	name))
	end)
	(ident_of_decl params)
	#> #2
	in fn CDeclrR0 (_, param0, _, _, _) =>
	(case rev param0 of
	CFunDeclr0 (params, _, _) :: param0 =>
	pair param0 o markup markup_var_bound params
	\| param0 => pair param0)
	#->
	fold
	(fn CFunDeclr0 (params, _, _) => markup markup_var_improper params
	\| _ => I)
	end
	d
	env_tree))


	(old style syntax for functions (legacy feature))

	val external_declaration1 : (CExtDecl) -> unit monad =
	update_env_bottom_up (fn f => fn env_lang => fn env_tree =>
	( env_lang
	, let open C_Ast
	in fn CFDefExt0 (CFunDef0 (_, _, l, _, node)) =>
	if null l then
	I
	else
	tap (fn _ => legacy_feature ("Scope analysing for old function syntax not implemented"
	^ Position.here (decode_error' node \|> #1)))
	\| _ => I
	end
	f
	env_tree))


	((type) enum, struct, union (report define & report bound))

	fun report_enum_bound i' node env_lang =
	let open C_Ast
	val name = ident_decode i'
	val pos1 = [decode_error' node \|> #1]
	in
	C_Env.map_reports_text
	(markup_var_enum
	(Right (pos1, Symtab.lookup (C_Env_Ext.get_tyidents'_enum env_lang) name)) pos1 name)
	end

	local
	val look_tyidents'_enum = C_Env_Ext.list_lookup o C_Env_Ext.get_tyidents'_enum
	val declaration : (CDecl) -> unit monad =
	update_env_bottom_up
	(fn decl => fn env_lang => fn env_tree =>
	let open C_Ast
	in
	fn CDecl0 (l, _, _) =>
	fold
	(fn CTypeSpec0 (CEnumType0 (CEnum0 (Some (Ident0 (_, i, node)), body, _, _), _)) =>
	(case body of
	None => (fn (env_lang, env_tree) =>
	(env_lang, report_enum_bound i node env_lang env_tree))
	\| Some _ =>
	fn (env_lang, env_tree) =>
	let val name = ident_decode i
	val pos1 = [decode_error' node \|> #1]
	val data = (pos1, serial (), null (C_Env.get_scopes env_lang))
	in
	( C_Env_Ext.map_tyidents'_enum (Symtab.update (name, data)) env_lang
	, C_Env.map_reports_text
	(markup_var_enum
	(Left (data, look_tyidents'_enum env_lang name))
	pos1
	name)
	env_tree)
	end)
	\| _ => I)
	l
	\| _ => I
	end
	decl
	(env_lang, env_tree))
	in
	val declaration1 = declaration
	val declaration2 = declaration
	val declaration3 = declaration
	end


	((basic) enum, struct, union (report define))

	local
	val enumerator : ( ( Ident * CExpr Maybe ) ) -> unit monad =
	update_env_bottom_up
	(fn id => fn env_lang =>
	let open C_Ast
	in
	fn (ident as Ident0 (_, _, node), _) =>
	C_Grammar_Rule_Lib.shadowTypedef0'
	(C_Env.Parsed [CTypeSpec0 (CIntType0 node)])
	(null (C_Env.get_scopes env_lang))
	(ident, [])
	env_lang
	end
	id)
	in
	val enumerator1 = enumerator
	val enumerator2 = enumerator
	val enumerator3 = enumerator
	val enumerator4 = enumerator
	end


	((type) enum, struct, union (report bound))

	local
	fun declaration_specifier env_lang =
	let open C_Ast
	in
	fold
	(fn CTypeSpec0 (CEnumType0 (CEnum0 (Some (Ident0 (_, i, node)), _, _, _), _)) =>
	report_enum_bound i node env_lang
	\| _ => I)
	end
	in
	val declaration_specifier2 : (CDeclSpec list) -> unit monad =
	update_env_bottom_up
	(fn d => fn env_lang => fn env_tree =>
	let open C_Ast
	in
	( env_lang
	, env_tree \|>
	(if exists (fn CStorageSpec0 (CTypedef0 _) => true \| _ => false) d then
	I
	else
	declaration_specifier env_lang d))
	end)

	local
	val f_definition : (CFunDef) -> unit monad =
	update_env_bottom_up
	(fn d => fn env_lang => fn env_tree =>
	( env_lang
	, let open C_Ast
	in
	fn CFunDef0 (l, _, _, _, _) => declaration_specifier env_lang l
	end
	d
	env_tree))
	in
	val function_definition4 = f_definition
	val nested_function_definition2 = f_definition
	end

	local
	val parameter_type_list : ( ( CDecl list * Bool ) ) -> unit monad =
	update_env_bottom_up
	(fn d => fn env_lang => fn env_tree =>
	( env_lang
	, let open C_Ast
	in
	#1 #> fold (fn CDecl0 (l, _, _) => declaration_specifier env_lang l \| _ => I)
	end
	d
	env_tree))
	in
	val parameter_type_list2 = parameter_type_list
	val parameter_type_list3 = parameter_type_list
	end
	end
	end
	\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>\<close> \<open>
	structure C_Grammar_Rule_Wrap = struct
	open C_Grammar_Rule_Wrap
	open C_Grammar_Rule_Wrap_Overloading
	end
	\<close>

	subsection \<open>Loading the Generated Grammar (SML structure)\<close>

	ML_file "../generated/c_grammar_fun.grm.sml"

	subsection \<open>Grammar Initialization\<close>

	subsubsection \<open>Functor Application\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>\<close> \<open>
	structure C_Grammar = C_Grammar_Fun (structure Token = LALR_Parser_Eval.Token)
	\<close>

	subsubsection \<open>Mapping Strings to Structured Tokens\<close>

	ML \<comment> \<open>\<^file>\<open>../generated/c_grammar_fun.grm.sml\<close>\<close> \<open>
	structure C_Grammar_Tokens =
	struct
	local open C_Grammar.Tokens in
	fun token_of_string
	error
	ty_ClangCVersion
	ty_cChar
	ty_cFloat
	ty_cInteger
	ty_cString
	ty_ident
	ty_string
	a1
	a2 =
	fn
	"(" => x28 (ty_string, a1, a2)
	\| ")" => x29 (ty_string, a1, a2)
	\| "[" => x5b (ty_string, a1, a2)
	\| "]" => x5d (ty_string, a1, a2)
	\| "->" => x2d_x3e (ty_string, a1, a2)
	\| "." => x2e (ty_string, a1, a2)
	\| "!" => x21 (ty_string, a1, a2)
	\| "~" => x7e (ty_string, a1, a2)
	\| "++" => x2b_x2b (ty_string, a1, a2)
	\| "--" => x2d_x2d (ty_string, a1, a2)
	\| "+" => x2b (ty_string, a1, a2)
	\| "-" => x2d (ty_string, a1, a2)
	\| "*" => x2a (ty_string, a1, a2)
	\| "/" => x2f (ty_string, a1, a2)
	\| "%" => x25 (ty_string, a1, a2)
	\| "&" => x26 (ty_string, a1, a2)
	\| "<<" => x3c_x3c (ty_string, a1, a2)
	\| ">>" => x3e_x3e (ty_string, a1, a2)
	\| "<" => x3c (ty_string, a1, a2)
	\| "<=" => x3c_x3d (ty_string, a1, a2)
	\| ">" => x3e (ty_string, a1, a2)
	\| ">=" => x3e_x3d (ty_string, a1, a2)
	\| "==" => x3d_x3d (ty_string, a1, a2)
	\| "!=" => x21_x3d (ty_string, a1, a2)
	\| "^" => x5e (ty_string, a1, a2)
	\| "\|" => x7c (ty_string, a1, a2)
	\| "&&" => x26_x26 (ty_string, a1, a2)
	\| "\|\|" => x7c_x7c (ty_string, a1, a2)
	\| "?" => x3f (ty_string, a1, a2)
	\| ":" => x3a (ty_string, a1, a2)
	\| "=" => x3d (ty_string, a1, a2)
	\| "+=" => x2b_x3d (ty_string, a1, a2)
	\| "-=" => x2d_x3d (ty_string, a1, a2)
	\| "*=" => x2a_x3d (ty_string, a1, a2)
	\| "/=" => x2f_x3d (ty_string, a1, a2)
	\| "%=" => x25_x3d (ty_string, a1, a2)
	\| "&=" => x26_x3d (ty_string, a1, a2)
	\| "^=" => x5e_x3d (ty_string, a1, a2)
	\| "\|=" => x7c_x3d (ty_string, a1, a2)
	\| "<<=" => x3c_x3c_x3d (ty_string, a1, a2)
	\| ">>=" => x3e_x3e_x3d (ty_string, a1, a2)
	\| "," => x2c (ty_string, a1, a2)
	\| ";" => x3b (ty_string, a1, a2)
	\| "{" => x7b (ty_string, a1, a2)
	\| "}" => x7d (ty_string, a1, a2)
	\| "..." => x2e_x2e_x2e (ty_string, a1, a2)
	\| x => let
	val alignof = alignof (ty_string, a1, a2)
	val alignas = alignas (ty_string, a1, a2)
	val atomic = x5f_Atomic (ty_string, a1, a2)
	val asm = asm (ty_string, a1, a2)
	val auto = auto (ty_string, a1, a2)
	val break = break (ty_string, a1, a2)
	val bool = x5f_Bool (ty_string, a1, a2)
	val case0 = case0 (ty_string, a1, a2)
	val char = char (ty_string, a1, a2)
	val const = const (ty_string, a1, a2)
	val continue = continue (ty_string, a1, a2)
	val complex = x5f_Complex (ty_string, a1, a2)
	val default = default (ty_string, a1, a2)
	val do0 = do0 (ty_string, a1, a2)
	val double = double (ty_string, a1, a2)
	val else0 = else0 (ty_string, a1, a2)
	val enum = enum (ty_string, a1, a2)
	val extern = extern (ty_string, a1, a2)
	val float = float (ty_string, a1, a2)
	val for0 = for0 (ty_string, a1, a2)
	val generic = x5f_Generic (ty_string, a1, a2)
	val goto = goto (ty_string, a1, a2)
	val if0 = if0 (ty_string, a1, a2)
	val inline = inline (ty_string, a1, a2)
	val int = int (ty_string, a1, a2)
	val int128 = x5f_x5f_int_x31_x32_x38 (ty_string, a1, a2)
	val long = long (ty_string, a1, a2)
	val label = x5f_x5f_label_x5f_x5f (ty_string, a1, a2)
	val noreturn = x5f_Noreturn (ty_string, a1, a2)
	val nullable = x5f_Nullable (ty_string, a1, a2)
	val nonnull = x5f_Nonnull (ty_string, a1, a2)
	val register = register (ty_string, a1, a2)
	val restrict = restrict (ty_string, a1, a2)
	val return0 = return0 (ty_string, a1, a2)
	val short = short (ty_string, a1, a2)
	val signed = signed (ty_string, a1, a2)
	val sizeof = sizeof (ty_string, a1, a2)
	val static = static (ty_string, a1, a2)
	val staticassert = x5f_Static_assert (ty_string, a1, a2)
	val struct0 = struct0 (ty_string, a1, a2)
	val switch = switch (ty_string, a1, a2)
	val typedef = typedef (ty_string, a1, a2)
	val typeof = typeof (ty_string, a1, a2)
	val thread = x5f_x5f_thread (ty_string, a1, a2)
	val union = union (ty_string, a1, a2)
	val unsigned = unsigned (ty_string, a1, a2)
	val void = void (ty_string, a1, a2)
	val volatile = volatile (ty_string, a1, a2)
	val while0 = while0 (ty_string, a1, a2)
	val cchar = cchar (ty_cChar, a1, a2)
	val cint = cint (ty_cInteger, a1, a2)
	val cfloat = cfloat (ty_cFloat, a1, a2)
	val cstr = cstr (ty_cString, a1, a2)
	val ident = ident (ty_ident, a1, a2)
	val tyident = tyident (ty_ident, a1, a2)
	val attribute = x5f_x5f_attribute_x5f_x5f (ty_string, a1, a2)
	val extension = x5f_x5f_extension_x5f_x5f (ty_string, a1, a2)
	val real = x5f_x5f_real_x5f_x5f (ty_string, a1, a2)
	val imag = x5f_x5f_imag_x5f_x5f (ty_string, a1, a2)
	val builtinvaarg = x5f_x5f_builtin_va_arg (ty_string, a1, a2)
	val builtinoffsetof = x5f_x5f_builtin_offsetof (ty_string, a1, a2)
	val builtintypescompatiblep = x5f_x5f_builtin_types_compatible_p (ty_string, a1, a2)
	val clangcversion = clangcversion (ty_ClangCVersion, a1, a2)
	in case x of
	"_Alignas" => alignas
	\| "_Alignof" => alignof
	\| "__alignof" => alignof
	\| "alignof" => alignof
	\| "__alignof__" => alignof
	\| "__asm" => asm
	\| "asm" => asm
	\| "__asm__" => asm
	\| "_Atomic" => atomic
	\| "__attribute" => attribute
	\| "__attribute__" => attribute
	\| "auto" => auto
	\| "_Bool" => bool
	\| "break" => break
	\| "__builtin_offsetof" => builtinoffsetof
	\| "__builtin_types_compatible_p" => builtintypescompatiblep
	\| "__builtin_va_arg" => builtinvaarg
	\| "case" => case0
	\| "char" => char
	\| "_Complex" => complex
	\| "__complex__" => complex
	\| "__const" => const
	\| "const" => const
	\| "__const__" => const
	\| "continue" => continue
	\| "default" => default
	\| "do" => do0
	\| "double" => double
	\| "else" => else0
	\| "enum" => enum
	\| "__extension__" => extension
	\| "extern" => extern
	\| "float" => float
	\| "for" => for0
	\| "_Generic" => generic
	\| "goto" => goto
	\| "if" => if0
	\| "__imag" => imag
	\| "__imag__" => imag
	\| "__inline" => inline
	\| "inline" => inline
	\| "__inline__" => inline
	\| "int" => int
	\| "__int128" => int128
	\| "__label__" => label
	\| "long" => long
	\| "_Nonnull" => nonnull
	\| "__nonnull" => nonnull
	\| "_Noreturn" => noreturn
	\| "_Nullable" => nullable
	\| "__nullable" => nullable
	\| "__real" => real
	\| "__real__" => real
	\| "register" => register
	\| "__restrict" => restrict
	\| "restrict" => restrict
	\| "__restrict__" => restrict
	\| "return" => return0
	\| "short" => short
	\| "__signed" => signed
	\| "signed" => signed
	\| "__signed__" => signed
	\| "sizeof" => sizeof
	\| "static" => static
	\| "_Static_assert" => staticassert
	\| "struct" => struct0
	\| "switch" => switch
	\| "__thread" => thread
	\| "_Thread_local" => thread
	\| "typedef" => typedef
	\| "__typeof" => typeof
	\| "typeof" => typeof
	\| "__typeof__" => typeof
	\| "union" => union
	\| "unsigned" => unsigned
	\| "void" => void
	\| "__volatile" => volatile
	\| "volatile" => volatile
	\| "__volatile__" => volatile
	\| "while" => while0
	\| _ => error
	end
	end
	end
	\<close>

	end
	diff --git a/thys/Isabelle_C/README.thy b/thys/Isabelle_C/README.thy
	--- a/thys/Isabelle_C/README.thy
	+++ b/thys/Isabelle_C/README.thy
	@@ -1,143 +1,143 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	(* Authors: Frédéric Tuong, Burkhart Wolff *)

	theory README imports Main begin

	section \<open>Isabelle/C\<close>

	text \<open>
	Isabelle/C contains a C99/C11/C18 front-end support for Isabelle. The front-end is actually composed
	of two possibly interchangeable parsers (from two different projects):

	\<^item> \<^dir>\<open>C11-FrontEnd\<close>: \<^url>\<open>https://hackage.haskell.org/package/language-c\<close>
	\<^item> \<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/tree/C/C18-FrontEnd\<close>:
	\<^url>\<open>https://github.com/jhjourdan/C11parser\<close>

	At present, the recommended and default version is C11.
	\<close>

	section \<open>Getting started\<close>

	text \<open> A first installation step is:
	\<^item> \<^verbatim>\<open>isabelle build -D\<close> \<^dir>\<open>.\<close>
	\<close>
	text \<open> which should work out of the box.
	\<close>

	text \<open> The following C examples or entry-points of documentation can be executed:

	\<^item> \<^verbatim>\<open>isabelle jedit -d\<close> \<^dir>\<open>.\<close> \<^file>\<open>C11-FrontEnd/examples/C0.thy\<close>
	\<^item> \<^verbatim>\<open>isabelle jedit -d\<close> \<^dir>\<open>.\<close> \<^file>\<open>C11-FrontEnd/examples/C2.thy\<close>
	\<^item> \<^verbatim>\<open>isabelle jedit -d\<close> \<^dir>\<open>.\<close> \<^file>\<open>C11-FrontEnd/examples/C1.thy\<close>
	-\<^item> \<^verbatim>\<open>isabelle jedit -d\<close> \<^dir>\<open>.\<close> \<^file>\<open>C11-FrontEnd/C_Appendices.thy\<close>
	+\<^item> \<^verbatim>\<open>isabelle jedit -d\<close> \<^dir>\<open>.\<close> \<^file>\<open>C11-FrontEnd/appendices/C_Appendices.thy\<close>
	\<close>

	text \<open>
	\<^item> The example \<^file>\<open>C11-FrontEnd/examples/C0.thy\<close> is basically used to
	demonstrate the faithfulness of the C11 parser implementation.
	\<^item> The example \<^file>\<open>C11-FrontEnd/examples/C2.thy\<close> shows common cases of C and
	C editing support in PIDE; it also contains annotation commands without any semantics.
	\<^item> The example \<^file>\<open>C11-FrontEnd/examples/C1.thy\<close> is a show-case for markup
	generation and the use of bindings resulting from the static C environment.
	-\<^item> The example \<^file>\<open>C11-FrontEnd/C_Appendices.thy\<close> shows the use of
	+\<^item> The example \<^file>\<open>C11-FrontEnd/appendices/C_Appendices.thy\<close> shows the use of
	Isabelle/C documentation facilities.
	\<close>

	text \<open>
	The AFP version of Isabelle/C does not include semantic back-ends (these are distributed by other
	AFP submissions or available via the web; see below). The structure of \<^dir>\<open>.\<close> has
	been designed to create a directory \<open>C11-BackEnds\<close> into which back-ends can be
	installed. The structure of \<^dir>\<open>.\<close> is actually similar as
	\<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c\<close>: see for example
	\<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/tree/C/C11-BackEnds\<close> where several
	back-ends can be copied and tried.
	\<close>

	subsection \<open>Isabelle/C/README\<close>

	text \<open>
	\<^file>\<open>README.md\<close> is automatically generated from \<^file>\<open>README.thy\<close>
	using \<^url>\<open>https://gitlri.lri.fr/ftuong/isabelle_c/blob/C/README.sh\<close>.
	\<close>

	text \<open> Note that this shell-script requires the prior installation of
	\<^verbatim>\<open>pandoc\<close> (\<^url>\<open>https://github.com/jgm/pandoc\<close>).
	\<close>

	section \<open>Authors\<close>

	text \<open>
	\<^item> Frédéric Tuong (\<^url>\<open>https://www.lri.fr/~ftuong\<close>)
	\<^item> Burkhart Wolff (\<^url>\<open>https://www.lri.fr/~wolff\<close>)
	\<close>

	section \<open>License\<close>

	text \<open>
	Isabelle/C is licensed under a 3-clause BSD-style license (where certain files are in the HPND
	license compatible with the 3-clause BSD).

	In more details:
	\<^item> The generated files \<^file>\<open>C11-FrontEnd/generated/c_ast.ML\<close> and
	\<^file>\<open>C11-FrontEnd/generated/c_grammar_fun.grm\<close> are mixing several source code of
	different projects:
	\<^item> In 3-clause BSD: the part representing the Haskell Language.C library.
	\<^item> In 2-clause BSD: the C99 AST in HOL (before reflection to SML) adapted from the original
	one in the L4.verified project.
	\<^item> In 3-clause BSD: the HOL translation C11 to C99 from the Securify project.
	\<^item> In 3-clause BSD: any other binding and translations of meta-models from the Citadelle
	project.
	\<^item> In 3-clause BSD: the two combined generators generating
	\<^file>\<open>C11-FrontEnd/generated/c_ast.ML\<close> based on some modified version of Haskabelle
	and Citadelle.
	\<^item> In 3-clause BSD: the Happy modified generator generating
	\<^file>\<open>C11-FrontEnd/generated/c_grammar_fun.grm\<close>
	\<^item> In HPND: the ML-Yacc modified generator generating the two
	\<^file>\<open>C11-FrontEnd/generated/c_grammar_fun.grm.sig\<close> and
	\<^file>\<open>C11-FrontEnd/generated/c_grammar_fun.grm.sml\<close> (i.e., the ML-Yacc version of
	MLton).
	\<^item> In HPND: the modified grammar library of ML-Yacc loaded in
	\<^file>\<open>C11-FrontEnd/src/C_Parser_Language.thy\<close>.
	\<^item> In 3-clause BSD: the remaining files in \<^dir>\<open>C11-FrontEnd/src\<close> constituting
	Isabelle/C core implementation.
	\<^item> Most examples in \<^dir>\<open>C11-FrontEnd/examples\<close> are in 3-clause BSD, some are
	used for quotation purposes to test the Isabelle/C lexer (hyperlinks around each example detail
	their provenance).
	\<close>

	end
	diff --git a/thys/Isabelle_C/ROOT b/thys/Isabelle_C/ROOT
	--- a/thys/Isabelle_C/ROOT
	+++ b/thys/Isabelle_C/ROOT
	@@ -1,86 +1,85 @@
	(******************************************************************************
	* Isabelle/C
	*
	* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
	*
	* All rights reserved.
	*
	* Redistribution and use in source and binary forms, with or without
	* modification, are permitted provided that the following conditions are
	* met:
	*
	* * Redistributions of source code must retain the above copyright
	* notice, this list of conditions and the following disclaimer.
	*
	* * Redistributions in binary form must reproduce the above
	* copyright notice, this list of conditions and the following
	* disclaimer in the documentation and/or other materials provided
	* with the distribution.
	*
	* * Neither the name of the copyright holders nor the names of its
	* contributors may be used to endorse or promote products derived
	* from this software without specific prior written permission.
	*
	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	******************************************************************************)

	chapter AFP

	session Isabelle_C (AFP) = HOL +
	options [timeout = 600, document_variants="document:outline=/proof"]
	sessions
	"HOL-ex"
	"Isar_Ref"
	directories
	- "C11-FrontEnd"
	+ "C11-FrontEnd/appendices"
	+ "C11-FrontEnd/examples"
	+ "C11-FrontEnd/main"
	"C11-FrontEnd/src"
	- "C11-FrontEnd/examples"
	theories [document = false]
	"HOL-ex.Cartouche_Examples" (* LaTeX error in Isabelle2019 *)
	theories [document = true]
	"C11-FrontEnd/examples/C0"
	"C11-FrontEnd/examples/C1"
	"C11-FrontEnd/examples/C2"
	- "C11-FrontEnd/examples/C3"
	- "C11-FrontEnd/examples/C4"
	"C11-FrontEnd/examples/C_paper"
	theories (* document *)
	- "C11-FrontEnd/C_Appendices"
	+ "C11-FrontEnd/appendices/C_Appendices"
	"./README"
	document_files (in "C11-FrontEnd/document/generated")
	"DOF-COL.sty"
	"DOF-core.sty"
	"DOF-scholarly_paper.sty"
	"DOF-technical_report.sty"
	"figures/A-C-Source10.png"
	"figures/A-C-Source2.png"
	"figures/A-C-Source3.png"
	"figures/A-C-Source5.png"
	"figures/A-C-Source6.png"
	"figures/A-C-Source7.png"
	"figures/A-C-Source80.png"
	"figures/A-C-Source8.png"
	"figures/A-C-Source9.png"
	"figures/A-C-Source.png"
	"figures/C11-Package-Architecture.pdf"
	"figures/C-export-example.png"
	"figures/document-model1.pdf"
	"figures/document-model2.pdf"
	"figures/markup-demo.png"
	"ontologies.tex"
	"paper.tex"
	document_files (in "C11-FrontEnd/document")
	"lstisadof.sty"
	"preamble.tex"
	"root.bib"
	"root.tex"
	diff --git a/thys/Jordan_Normal_Form/Matrix.thy b/thys/Jordan_Normal_Form/Matrix.thy
	--- a/thys/Jordan_Normal_Form/Matrix.thy
	+++ b/thys/Jordan_Normal_Form/Matrix.thy
	@@ -1,3003 +1,3032 @@
	(*
	Author: René Thiemann
	Akihisa Yamada
	License: BSD
	*)
	(* with contributions from Alexander Bentkamp, Universität des Saarlandes *)

	section\<open>Vectors and Matrices\<close>

	text \<open>We define vectors as pairs of dimension and a characteristic function from natural numbers
	to elements.
	Similarly, matrices are defined as triples of two dimensions and one
	characteristic function from pairs of natural numbers to elements.
	Via a subtype we ensure that the characteristic function always behaves the same
	on indices outside the intended one. Hence, every matrix has a unique representation.

	In this part we define basic operations like matrix-addition, -multiplication, scalar-product,
	etc. We connect these operations to HOL-Algebra with its explicit carrier sets.\<close>

	theory Matrix
	imports
	Polynomial_Interpolation.Ring_Hom
	Missing_Ring
	Conjugate
	"HOL-Algebra.Module"
	begin

	subsection\<open>Vectors\<close>

	text \<open>Here we specify which value should be returned in case
	an index is out of bounds. The current solution has the advantage
	that in the implementation later on, no index comparison has to be performed.\<close>

	definition undef_vec :: "nat \<Rightarrow> 'a" where
	"undef_vec i \<equiv> [] ! i"

	definition mk_vec :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)" where
	"mk_vec n f \<equiv> \<lambda> i. if i < n then f i else undef_vec (i - n)"

	typedef 'a vec = "{(n, mk_vec n f) \| n f :: nat \<Rightarrow> 'a. True}"
	by auto

	setup_lifting type_definition_vec

	lift_definition dim_vec :: "'a vec \<Rightarrow> nat" is fst .
	lift_definition vec_index :: "'a vec \<Rightarrow> (nat \<Rightarrow> 'a)" (infixl "$" 100) is snd .
	lift_definition vec :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a vec"
	is "\<lambda> n f. (n, mk_vec n f)" by auto

	lift_definition vec_of_list :: "'a list \<Rightarrow> 'a vec" is
	"\<lambda> v. (length v, mk_vec (length v) (nth v))" by auto

	lift_definition list_of_vec :: "'a vec \<Rightarrow> 'a list" is
	"\<lambda> (n,v). map v [0 ..< n]" .

	definition carrier_vec :: "nat \<Rightarrow> 'a vec set" where
	"carrier_vec n = { v . dim_vec v = n}"

	lemma carrier_vec_dim_vec[simp]: "v \<in> carrier_vec (dim_vec v)" unfolding carrier_vec_def by auto

	lemma dim_vec[simp]: "dim_vec (vec n f) = n" by transfer simp
	lemma vec_carrier[simp]: "vec n f \<in> carrier_vec n" unfolding carrier_vec_def by auto
	lemma index_vec[simp]: "i < n \<Longrightarrow> vec n f $ i = f i" by transfer (simp add: mk_vec_def)
	lemma eq_vecI[intro]: "(\<And> i. i < dim_vec w \<Longrightarrow> v $ i = w $ i) \<Longrightarrow> dim_vec v = dim_vec w
	\<Longrightarrow> v = w"
	by (transfer, auto simp: mk_vec_def)

	lemma carrier_dim_vec: "v \<in> carrier_vec n \<longleftrightarrow> dim_vec v = n"
	unfolding carrier_vec_def by auto

	lemma carrier_vecD[simp]: "v \<in> carrier_vec n \<Longrightarrow> dim_vec v = n" using carrier_dim_vec by auto

	lemma carrier_vecI: "dim_vec v = n \<Longrightarrow> v \<in> carrier_vec n" using carrier_dim_vec by auto

	instantiation vec :: (plus) plus
	begin
	definition plus_vec :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a :: plus vec" where
	"v\<^sub>1 + v\<^sub>2 \<equiv> vec (dim_vec v\<^sub>2) (\<lambda> i. v\<^sub>1 $ i + v\<^sub>2 $ i)"
	instance ..
	end

	instantiation vec :: (minus) minus
	begin
	definition minus_vec :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a :: minus vec" where
	"v\<^sub>1 - v\<^sub>2 \<equiv> vec (dim_vec v\<^sub>2) (\<lambda> i. v\<^sub>1 $ i - v\<^sub>2 $ i)"
	instance ..
	end

	definition
	zero_vec :: "nat \<Rightarrow> 'a :: zero vec" ("0\<^sub>v")
	where "0\<^sub>v n \<equiv> vec n (\<lambda> i. 0)"

	lemma zero_carrier_vec[simp]: "0\<^sub>v n \<in> carrier_vec n"
	unfolding zero_vec_def carrier_vec_def by auto

	lemma index_zero_vec[simp]: "i < n \<Longrightarrow> 0\<^sub>v n $ i = 0" "dim_vec (0\<^sub>v n) = n"
	unfolding zero_vec_def by auto

	lemma vec_of_dim_0[simp]: "dim_vec v = 0 \<longleftrightarrow> v = 0\<^sub>v 0" by auto

	definition
	unit_vec :: "nat \<Rightarrow> nat \<Rightarrow> ('a :: zero_neq_one) vec"
	where "unit_vec n i = vec n (\<lambda> j. if j = i then 1 else 0)"

	lemma index_unit_vec[simp]:
	"i < n \<Longrightarrow> j < n \<Longrightarrow> unit_vec n i $ j = (if j = i then 1 else 0)"
	"i < n \<Longrightarrow> unit_vec n i $ i = 1"
	"dim_vec (unit_vec n i) = n"
	unfolding unit_vec_def by auto

	lemma unit_vec_eq[simp]:
	assumes i: "i < n"
	shows "(unit_vec n i = unit_vec n j) = (i = j)"
	proof -
	have "i \<noteq> j \<Longrightarrow> unit_vec n i $ i \<noteq> unit_vec n j $ i"
	unfolding unit_vec_def using i by simp
	then show ?thesis by metis
	qed

	lemma unit_vec_nonzero[simp]:
	assumes i_n: "i < n" shows "unit_vec n i \<noteq> zero_vec n" (is "?l \<noteq> ?r")
	proof -
	have "?l $ i = 1" "?r $ i = 0" using i_n by auto
	thus "?l \<noteq> ?r" by auto
	qed

	lemma unit_vec_carrier[simp]: "unit_vec n i \<in> carrier_vec n"
	unfolding unit_vec_def carrier_vec_def by auto

	definition unit_vecs:: "nat \<Rightarrow> 'a :: zero_neq_one vec list"
	where "unit_vecs n = map (unit_vec n) [0..<n]"

	text "List of first i units"

	fun unit_vecs_first:: "nat \<Rightarrow> nat \<Rightarrow> 'a::zero_neq_one vec list"
	where "unit_vecs_first n 0 = []"
	\| "unit_vecs_first n (Suc i) = unit_vecs_first n i @ [unit_vec n i]"

	lemma unit_vecs_first: "unit_vecs n = unit_vecs_first n n"
	unfolding unit_vecs_def set_map set_upt
	proof -
	{fix m
	have "m \<le> n \<Longrightarrow> map (unit_vec n) [0..<m] = unit_vecs_first n m"
	proof (induct m)
	case (Suc m) then have mn:"m\<le>n" by auto
	show ?case unfolding upt_Suc using Suc(1)[OF mn] by auto
	qed auto
	}
	thus "map (unit_vec n) [0..<n] = unit_vecs_first n n" by auto
	qed

	text "list of last i units"

	fun unit_vecs_last:: "nat \<Rightarrow> nat \<Rightarrow> 'a :: zero_neq_one vec list"
	where "unit_vecs_last n 0 = []"
	\| "unit_vecs_last n (Suc i) = unit_vec n (n - Suc i) # unit_vecs_last n i"

	lemma unit_vecs_last_carrier: "set (unit_vecs_last n i) \<subseteq> carrier_vec n"
	by (induct i;auto)

	lemma unit_vecs_last[code]: "unit_vecs n = unit_vecs_last n n"
	proof -
	{ fix m assume "m = n"
	have "m \<le> n \<Longrightarrow> map (unit_vec n) [n-m..<n] = unit_vecs_last n m"
	proof (induction m)
	case (Suc m)
	then have nm:"n - Suc m < n" by auto
	have ins: "[n - Suc m ..< n] = (n - Suc m) # [n - m ..< n]"
	unfolding upt_conv_Cons[OF nm]
	by (auto simp: Suc.prems Suc_diff_Suc Suc_le_lessD)
	show ?case
	unfolding ins
	unfolding unit_vecs_last.simps
	unfolding list.map
	using Suc
	unfolding Suc by auto
	qed simp
	}
	thus "unit_vecs n = unit_vecs_last n n"
	unfolding unit_vecs_def by auto
	qed

	lemma unit_vecs_carrier: "set (unit_vecs n) \<subseteq> carrier_vec n"
	proof
	fix u :: "'a vec" assume u: "u \<in> set (unit_vecs n)"
	then obtain i where "u = unit_vec n i" unfolding unit_vecs_def by auto
	then show "u \<in> carrier_vec n"
	using unit_vec_carrier by auto
	qed

	lemma unit_vecs_last_distinct:
	"j \<le> n \<Longrightarrow> i < n - j \<Longrightarrow> unit_vec n i \<notin> set (unit_vecs_last n j)"
	by (induction j arbitrary:i, auto)

	lemma unit_vecs_first_distinct:
	"i \<le> j \<Longrightarrow> j < n \<Longrightarrow> unit_vec n j \<notin> set (unit_vecs_first n i)"
	by (induction i arbitrary:j, auto)

	definition map_vec where "map_vec f v \<equiv> vec (dim_vec v) (\<lambda>i. f (v $ i))"

	instantiation vec :: (uminus) uminus
	begin
	definition uminus_vec :: "'a :: uminus vec \<Rightarrow> 'a vec" where
	"- v \<equiv> vec (dim_vec v) (\<lambda> i. - (v $ i))"
	instance ..
	end

	definition smult_vec :: "'a :: times \<Rightarrow> 'a vec \<Rightarrow> 'a vec" (infixl "\<cdot>\<^sub>v" 70)
	where "a \<cdot>\<^sub>v v \<equiv> vec (dim_vec v) (\<lambda> i. a * v $ i)"

	definition scalar_prod :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a :: semiring_0" (infix "\<bullet>" 70)
	where "v \<bullet> w \<equiv> \<Sum> i \<in> {0 ..< dim_vec w}. v $ i * w $ i"

	definition monoid_vec :: "'a itself \<Rightarrow> nat \<Rightarrow> ('a :: monoid_add vec) monoid" where
	"monoid_vec ty n \<equiv> \<lparr>
	carrier = carrier_vec n,
	mult = (+),
	one = 0\<^sub>v n\<rparr>"

	definition module_vec ::
	"'a :: semiring_1 itself \<Rightarrow> nat \<Rightarrow> ('a,'a vec) module" where
	"module_vec ty n \<equiv> \<lparr>
	carrier = carrier_vec n,
	mult = undefined,
	one = undefined,
	zero = 0\<^sub>v n,
	add = (+),
	smult = (\<cdot>\<^sub>v)\<rparr>"

	lemma monoid_vec_simps:
	"mult (monoid_vec ty n) = (+)"
	"carrier (monoid_vec ty n) = carrier_vec n"
	"one (monoid_vec ty n) = 0\<^sub>v n"
	unfolding monoid_vec_def by auto

	lemma module_vec_simps:
	"add (module_vec ty n) = (+)"
	"zero (module_vec ty n) = 0\<^sub>v n"
	"carrier (module_vec ty n) = carrier_vec n"
	"smult (module_vec ty n) = (\<cdot>\<^sub>v)"
	unfolding module_vec_def by auto

	definition finsum_vec :: "'a :: monoid_add itself \<Rightarrow> nat \<Rightarrow> ('c \<Rightarrow> 'a vec) \<Rightarrow> 'c set \<Rightarrow> 'a vec" where
	"finsum_vec ty n = finprod (monoid_vec ty n)"

	lemma index_add_vec[simp]:
	"i < dim_vec v\<^sub>2 \<Longrightarrow> (v\<^sub>1 + v\<^sub>2) $ i = v\<^sub>1 $ i + v\<^sub>2 $ i" "dim_vec (v\<^sub>1 + v\<^sub>2) = dim_vec v\<^sub>2"
	unfolding plus_vec_def by auto

	lemma index_minus_vec[simp]:
	"i < dim_vec v\<^sub>2 \<Longrightarrow> (v\<^sub>1 - v\<^sub>2) $ i = v\<^sub>1 $ i - v\<^sub>2 $ i" "dim_vec (v\<^sub>1 - v\<^sub>2) = dim_vec v\<^sub>2"
	unfolding minus_vec_def by auto

	lemma index_map_vec[simp]:
	"i < dim_vec v \<Longrightarrow> map_vec f v $ i = f (v $ i)"
	"dim_vec (map_vec f v) = dim_vec v"
	unfolding map_vec_def by auto

	lemma map_carrier_vec[simp]: "map_vec h v \<in> carrier_vec n = (v \<in> carrier_vec n)"
	unfolding map_vec_def carrier_vec_def by auto

	lemma index_uminus_vec[simp]:
	"i < dim_vec v \<Longrightarrow> (- v) $ i = - (v $ i)"
	"dim_vec (- v) = dim_vec v"
	unfolding uminus_vec_def by auto

	lemma index_smult_vec[simp]:
	"i < dim_vec v \<Longrightarrow> (a \<cdot>\<^sub>v v) $ i = a * v $ i" "dim_vec (a \<cdot>\<^sub>v v) = dim_vec v"
	unfolding smult_vec_def by auto

	lemma add_carrier_vec[simp]:
	"v\<^sub>1 \<in> carrier_vec n \<Longrightarrow> v\<^sub>2 \<in> carrier_vec n \<Longrightarrow> v\<^sub>1 + v\<^sub>2 \<in> carrier_vec n"
	unfolding carrier_vec_def by auto

	lemma minus_carrier_vec[simp]:
	"v\<^sub>1 \<in> carrier_vec n \<Longrightarrow> v\<^sub>2 \<in> carrier_vec n \<Longrightarrow> v\<^sub>1 - v\<^sub>2 \<in> carrier_vec n"
	unfolding carrier_vec_def by auto

	lemma comm_add_vec[ac_simps]:
	"(v\<^sub>1 :: 'a :: ab_semigroup_add vec) \<in> carrier_vec n \<Longrightarrow> v\<^sub>2 \<in> carrier_vec n \<Longrightarrow> v\<^sub>1 + v\<^sub>2 = v\<^sub>2 + v\<^sub>1"
	by (intro eq_vecI, auto simp: ac_simps)

	lemma assoc_add_vec[simp]:
	"(v\<^sub>1 :: 'a :: semigroup_add vec) \<in> carrier_vec n \<Longrightarrow> v\<^sub>2 \<in> carrier_vec n \<Longrightarrow> v\<^sub>3 \<in> carrier_vec n
	\<Longrightarrow> (v\<^sub>1 + v\<^sub>2) + v\<^sub>3 = v\<^sub>1 + (v\<^sub>2 + v\<^sub>3)"
	by (intro eq_vecI, auto simp: ac_simps)

	lemma zero_minus_vec[simp]: "(v :: 'a :: group_add vec) \<in> carrier_vec n \<Longrightarrow> 0\<^sub>v n - v = - v"
	by (intro eq_vecI, auto)

	lemma minus_zero_vec[simp]: "(v :: 'a :: group_add vec) \<in> carrier_vec n \<Longrightarrow> v - 0\<^sub>v n = v"
	by (intro eq_vecI, auto)

	lemma minus_cancel_vec[simp]: "(v :: 'a :: group_add vec) \<in> carrier_vec n \<Longrightarrow> v - v = 0\<^sub>v n"
	by (intro eq_vecI, auto)

	lemma minus_add_uminus_vec: "(v :: 'a :: group_add vec) \<in> carrier_vec n \<Longrightarrow>
	w \<in> carrier_vec n \<Longrightarrow> v - w = v + (- w)"
	by (intro eq_vecI, auto)

	lemma comm_monoid_vec: "comm_monoid (monoid_vec TYPE ('a :: comm_monoid_add) n)"
	by (unfold_locales, auto simp: monoid_vec_def ac_simps)

	lemma left_zero_vec[simp]: "(v :: 'a :: monoid_add vec) \<in> carrier_vec n \<Longrightarrow> 0\<^sub>v n + v = v" by auto

	lemma right_zero_vec[simp]: "(v :: 'a :: monoid_add vec) \<in> carrier_vec n \<Longrightarrow> v + 0\<^sub>v n = v" by auto


	lemma uminus_carrier_vec[simp]:
	"(- v \<in> carrier_vec n) = (v \<in> carrier_vec n)"
	unfolding carrier_vec_def by auto

	lemma uminus_r_inv_vec[simp]:
	"(v :: 'a :: group_add vec) \<in> carrier_vec n \<Longrightarrow> (v + - v) = 0\<^sub>v n"
	by (intro eq_vecI, auto)

	lemma uminus_l_inv_vec[simp]:
	"(v :: 'a :: group_add vec) \<in> carrier_vec n \<Longrightarrow> (- v + v) = 0\<^sub>v n"
	by (intro eq_vecI, auto)

	lemma add_inv_exists_vec:
	"(v :: 'a :: group_add vec) \<in> carrier_vec n \<Longrightarrow> \<exists> w \<in> carrier_vec n. w + v = 0\<^sub>v n \<and> v + w = 0\<^sub>v n"
	by (intro bexI[of _ "- v"], auto)

	lemma comm_group_vec: "comm_group (monoid_vec TYPE ('a :: ab_group_add) n)"
	by (unfold_locales, insert add_inv_exists_vec, auto simp: monoid_vec_def ac_simps Units_def)

	lemmas finsum_vec_insert =
	comm_monoid.finprod_insert[OF comm_monoid_vec, folded finsum_vec_def, unfolded monoid_vec_simps]

	lemmas finsum_vec_closed =
	comm_monoid.finprod_closed[OF comm_monoid_vec, folded finsum_vec_def, unfolded monoid_vec_simps]

	lemmas finsum_vec_empty =
	comm_monoid.finprod_empty[OF comm_monoid_vec, folded finsum_vec_def, unfolded monoid_vec_simps]

	lemma smult_carrier_vec[simp]: "(a \<cdot>\<^sub>v v \<in> carrier_vec n) = (v \<in> carrier_vec n)"
	unfolding carrier_vec_def by auto

	lemma scalar_prod_left_zero[simp]: "v \<in> carrier_vec n \<Longrightarrow> 0\<^sub>v n \<bullet> v = 0"
	unfolding scalar_prod_def
	by (rule sum.neutral, auto)

	lemma scalar_prod_right_zero[simp]: "v \<in> carrier_vec n \<Longrightarrow> v \<bullet> 0\<^sub>v n = 0"
	unfolding scalar_prod_def
	by (rule sum.neutral, auto)

	lemma scalar_prod_left_unit[simp]: assumes v: "(v :: 'a :: semiring_1 vec) \<in> carrier_vec n" and i: "i < n"
	shows "unit_vec n i \<bullet> v = v $ i"
	proof -
	let ?f = "\<lambda> k. unit_vec n i $ k * v $ k"
	have id: "(\<Sum>k\<in>{0..<n}. ?f k) = unit_vec n i $ i * v $ i + (\<Sum>k\<in>{0..<n} - {i}. ?f k)"
	by (rule sum.remove, insert i, auto)
	also have "(\<Sum> k\<in>{0..<n} - {i}. ?f k) = 0"
	by (rule sum.neutral, insert i, auto)
	finally
	show ?thesis unfolding scalar_prod_def using i v by simp
	qed

	lemma scalar_prod_right_unit[simp]: assumes i: "i < n"
	shows "(v :: 'a :: semiring_1 vec) \<bullet> unit_vec n i = v $ i"
	proof -
	let ?f = "\<lambda> k. v $ k * unit_vec n i $ k"
	have id: "(\<Sum>k\<in>{0..<n}. ?f k) = v $ i * unit_vec n i $ i + (\<Sum>k\<in>{0..<n} - {i}. ?f k)"
	by (rule sum.remove, insert i, auto)
	also have "(\<Sum>k\<in>{0..<n} - {i}. ?f k) = 0"
	by (rule sum.neutral, insert i, auto)
	finally
	show ?thesis unfolding scalar_prod_def using i by simp
	qed

	lemma add_scalar_prod_distrib: assumes v: "v\<^sub>1 \<in> carrier_vec n" "v\<^sub>2 \<in> carrier_vec n" "v\<^sub>3 \<in> carrier_vec n"
	shows "(v\<^sub>1 + v\<^sub>2) \<bullet> v\<^sub>3 = v\<^sub>1 \<bullet> v\<^sub>3 + v\<^sub>2 \<bullet> v\<^sub>3"
	proof -
	have "(\<Sum>i\<in>{0..<dim_vec v\<^sub>3}. (v\<^sub>1 + v\<^sub>2) $ i * v\<^sub>3 $ i) = (\<Sum>i\<in>{0..<dim_vec v\<^sub>3}. v\<^sub>1 $ i * v\<^sub>3 $ i + v\<^sub>2 $ i * v\<^sub>3 $ i)"
	by (rule sum.cong, insert v, auto simp: algebra_simps)
	thus ?thesis unfolding scalar_prod_def using v by (auto simp: sum.distrib)
	qed

	lemma scalar_prod_add_distrib: assumes v: "v\<^sub>1 \<in> carrier_vec n" "v\<^sub>2 \<in> carrier_vec n" "v\<^sub>3 \<in> carrier_vec n"
	shows "v\<^sub>1 \<bullet> (v\<^sub>2 + v\<^sub>3) = v\<^sub>1 \<bullet> v\<^sub>2 + v\<^sub>1 \<bullet> v\<^sub>3"
	proof -
	have "(\<Sum>i\<in>{0..<dim_vec v\<^sub>3}. v\<^sub>1 $ i * (v\<^sub>2 + v\<^sub>3) $ i) = (\<Sum>i\<in>{0..<dim_vec v\<^sub>3}. v\<^sub>1 $ i * v\<^sub>2 $ i + v\<^sub>1 $ i * v\<^sub>3 $ i)"
	by (rule sum.cong, insert v, auto simp: algebra_simps)
	thus ?thesis unfolding scalar_prod_def using v by (auto intro: sum.distrib)
	qed

	lemma smult_scalar_prod_distrib[simp]: assumes v: "v\<^sub>1 \<in> carrier_vec n" "v\<^sub>2 \<in> carrier_vec n"
	shows "(a \<cdot>\<^sub>v v\<^sub>1) \<bullet> v\<^sub>2 = a * (v\<^sub>1 \<bullet> v\<^sub>2)"
	unfolding scalar_prod_def sum_distrib_left
	by (rule sum.cong, insert v, auto simp: ac_simps)

	lemma scalar_prod_smult_distrib[simp]: assumes v: "v\<^sub>1 \<in> carrier_vec n" "v\<^sub>2 \<in> carrier_vec n"
	shows "v\<^sub>1 \<bullet> (a \<cdot>\<^sub>v v\<^sub>2) = (a :: 'a :: comm_ring) * (v\<^sub>1 \<bullet> v\<^sub>2)"
	unfolding scalar_prod_def sum_distrib_left
	by (rule sum.cong, insert v, auto simp: ac_simps)

	lemma comm_scalar_prod: assumes "(v\<^sub>1 :: 'a :: comm_semiring_0 vec) \<in> carrier_vec n" "v\<^sub>2 \<in> carrier_vec n"
	shows "v\<^sub>1 \<bullet> v\<^sub>2 = v\<^sub>2 \<bullet> v\<^sub>1"
	unfolding scalar_prod_def
	by (rule sum.cong, insert assms, auto simp: ac_simps)

	lemma add_smult_distrib_vec:
	"((a::'a::ring) + b) \<cdot>\<^sub>v v = a \<cdot>\<^sub>v v + b \<cdot>\<^sub>v v"
	unfolding smult_vec_def plus_vec_def
	by (rule eq_vecI, auto simp: distrib_right)

	lemma smult_add_distrib_vec:
	assumes "v \<in> carrier_vec n" "w \<in> carrier_vec n"
	shows "(a::'a::ring) \<cdot>\<^sub>v (v + w) = a \<cdot>\<^sub>v v + a \<cdot>\<^sub>v w"
	apply (rule eq_vecI)
	unfolding smult_vec_def plus_vec_def
	using assms distrib_left by auto

	lemma smult_smult_assoc:
	"a \<cdot>\<^sub>v (b \<cdot>\<^sub>v v) = (a * b::'a::ring) \<cdot>\<^sub>v v"
	apply (rule sym, rule eq_vecI)
	unfolding smult_vec_def plus_vec_def using mult.assoc by auto

	lemma one_smult_vec [simp]:
	"(1::'a::ring_1) \<cdot>\<^sub>v v = v" unfolding smult_vec_def
	by (rule eq_vecI,auto)

	lemma uminus_zero_vec[simp]: "- (0\<^sub>v n) = (0\<^sub>v n :: 'a :: group_add vec)"
	by (intro eq_vecI, auto)

	lemma index_finsum_vec: assumes "finite F" and i: "i < n"
	and vs: "vs \<in> F \<rightarrow> carrier_vec n"
	shows "finsum_vec TYPE('a :: comm_monoid_add) n vs F $ i = sum (\<lambda> f. vs f $ i) F"
	using \<open>finite F\<close> vs
	proof (induct F)
	case (insert f F)
	hence IH: "finsum_vec TYPE('a) n vs F $ i = (\<Sum>f\<in>F. vs f $ i)"
	and vs: "vs \<in> F \<rightarrow> carrier_vec n" "vs f \<in> carrier_vec n" by auto
	show ?case unfolding finsum_vec_insert[OF insert(1-2) vs]
	unfolding sum.insert[OF insert(1-2)]
	unfolding IH[symmetric]
	by (rule index_add_vec, insert i, insert finsum_vec_closed[OF vs(1)], auto)
	qed (insert i, auto simp: finsum_vec_empty)

	text \<open>Definition of pointwise ordering on vectors for non-strict part, and
	strict version is defined in a way such that the @{class order} constraints are satisfied.\<close>

	instantiation vec :: (ord) ord
	begin

	definition less_eq_vec :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> bool" where
	"less_eq_vec v w = (dim_vec v = dim_vec w \<and> (\<forall> i < dim_vec w. v $ i \<le> w $ i))"

	definition less_vec :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> bool" where
	"less_vec v w = (v \<le> w \<and> \<not> (w \<le> v))"
	instance ..
	end

	instantiation vec :: (preorder) preorder
	begin
	instance
	by (standard, auto simp: less_vec_def less_eq_vec_def order_trans)
	end

	instantiation vec :: (order) order
	begin
	instance
	by (standard, intro eq_vecI, auto simp: less_eq_vec_def order.antisym)
	end


	subsection\<open>Matrices\<close>

	text \<open>Similarly as for vectors, we specify which value should be returned in case
	an index is out of bounds. It is defined in a way that only few
	index comparisons have to be performed in the implementation.\<close>

	definition undef_mat :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a) \<Rightarrow> nat \<times> nat \<Rightarrow> 'a" where
	"undef_mat nr nc f \<equiv> \<lambda> (i,j). [[f (i,j). j <- [0 ..< nc]] . i <- [0 ..< nr]] ! i ! j"

	lemma undef_cong_mat: assumes "\<And> i j. i < nr \<Longrightarrow> j < nc \<Longrightarrow> f (i,j) = f' (i,j)"
	shows "undef_mat nr nc f x = undef_mat nr nc f' x"
	proof (cases x)
	case (Pair i j)
	have nth_map_ge: "\<And> i xs. \<not> i < length xs \<Longrightarrow> xs ! i = [] ! (i - length xs)"
	by (metis append_Nil2 nth_append)
	note [simp] = Pair undef_mat_def nth_map_ge[of i] nth_map_ge[of j]
	show ?thesis
	by (cases "i < nr", simp, cases "j < nc", insert assms, auto)
	qed

	definition mk_mat :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a) \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a)" where
	"mk_mat nr nc f \<equiv> \<lambda> (i,j). if i < nr \<and> j < nc then f (i,j) else undef_mat nr nc f (i,j)"

	lemma cong_mk_mat: assumes "\<And> i j. i < nr \<Longrightarrow> j < nc \<Longrightarrow> f (i,j) = f' (i,j)"
	shows "mk_mat nr nc f = mk_mat nr nc f'"
	using undef_cong_mat[of nr nc f f', OF assms]
	using assms unfolding mk_mat_def
	by auto

	typedef 'a mat = "{(nr, nc, mk_mat nr nc f) \| nr nc f :: nat \<times> nat \<Rightarrow> 'a. True}"
	by auto

	setup_lifting type_definition_mat

	lift_definition dim_row :: "'a mat \<Rightarrow> nat" is fst .
	lift_definition dim_col :: "'a mat \<Rightarrow> nat" is "fst o snd" .
	lift_definition index_mat :: "'a mat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a)" (infixl "$$" 100) is "snd o snd" .
	lift_definition mat :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a) \<Rightarrow> 'a mat"
	is "\<lambda> nr nc f. (nr, nc, mk_mat nr nc f)" by auto
	lift_definition mat_of_row_fun :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a vec) \<Rightarrow> 'a mat" ("mat\<^sub>r")
	is "\<lambda> nr nc f. (nr, nc, mk_mat nr nc (\<lambda> (i,j). f i $ j))" by auto

	definition mat_to_list :: "'a mat \<Rightarrow> 'a list list" where
	"mat_to_list A = [ [A $$ (i,j) . j <- [0 ..< dim_col A]] . i <- [0 ..< dim_row A]]"

	fun square_mat :: "'a mat \<Rightarrow> bool" where "square_mat A = (dim_col A = dim_row A)"

	definition upper_triangular :: "'a::zero mat \<Rightarrow> bool"
	where "upper_triangular A \<equiv>
	\<forall>i < dim_row A. \<forall> j < i. A $$ (i,j) = 0"

	lemma upper_triangularD[elim] :
	"upper_triangular A \<Longrightarrow> j < i \<Longrightarrow> i < dim_row A \<Longrightarrow> A $$ (i,j) = 0"
	unfolding upper_triangular_def by auto

	lemma upper_triangularI[intro] :
	"(\<And>i j. j < i \<Longrightarrow> i < dim_row A \<Longrightarrow> A $$ (i,j) = 0) \<Longrightarrow> upper_triangular A"
	unfolding upper_triangular_def by auto

	lemma dim_row_mat[simp]: "dim_row (mat nr nc f) = nr" "dim_row (mat\<^sub>r nr nc g) = nr"
	by (transfer, simp)+

	lemma dim_col_mat[simp]: "dim_col (mat nr nc f) = nc" "dim_col (mat\<^sub>r nr nc g) = nc"
	by (transfer, simp)+

	definition carrier_mat :: "nat \<Rightarrow> nat \<Rightarrow> 'a mat set"
	where "carrier_mat nr nc = { m . dim_row m = nr \<and> dim_col m = nc}"

	lemma carrier_mat_triv[simp]: "m \<in> carrier_mat (dim_row m) (dim_col m)"
	unfolding carrier_mat_def by auto

	lemma mat_carrier[simp]: "mat nr nc f \<in> carrier_mat nr nc"
	unfolding carrier_mat_def by auto

	definition elements_mat :: "'a mat \<Rightarrow> 'a set"
	where "elements_mat A = set [A $$ (i,j). i <- [0 ..< dim_row A], j <- [0 ..< dim_col A]]"

	lemma elements_matD [dest]:
	"a \<in> elements_mat A \<Longrightarrow> \<exists>i j. i < dim_row A \<and> j < dim_col A \<and> a = A $$ (i,j)"
	unfolding elements_mat_def by force

	lemma elements_matI [intro]:
	"A \<in> carrier_mat nr nc \<Longrightarrow> i < nr \<Longrightarrow> j < nc \<Longrightarrow> a = A $$ (i,j) \<Longrightarrow> a \<in> elements_mat A"
	unfolding elements_mat_def carrier_mat_def by force

	lemma index_mat[simp]: "i < nr \<Longrightarrow> j < nc \<Longrightarrow> mat nr nc f $$ (i,j) = f (i,j)"
	"i < nr \<Longrightarrow> j < nc \<Longrightarrow> mat\<^sub>r nr nc g $$ (i,j) = g i $ j"
	by (transfer', simp add: mk_mat_def)+

	lemma eq_matI[intro]: "(\<And> i j . i < dim_row B \<Longrightarrow> j < dim_col B \<Longrightarrow> A $$ (i,j) = B $$ (i,j))
	\<Longrightarrow> dim_row A = dim_row B
	\<Longrightarrow> dim_col A = dim_col B
	\<Longrightarrow> A = B"
	by (transfer, auto intro!: cong_mk_mat, auto simp: mk_mat_def)

	lemma carrier_matI[intro]:
	assumes "dim_row A = nr" "dim_col A = nc" shows "A \<in> carrier_mat nr nc"
	using assms unfolding carrier_mat_def by auto

	lemma carrier_matD[dest,simp]: assumes "A \<in> carrier_mat nr nc"
	shows "dim_row A = nr" "dim_col A = nc" using assms
	unfolding carrier_mat_def by auto

	lemma cong_mat: assumes "nr = nr'" "nc = nc'" "\<And> i j. i < nr \<Longrightarrow> j < nc \<Longrightarrow>
	f (i,j) = f' (i,j)" shows "mat nr nc f = mat nr' nc' f'"
	by (rule eq_matI, insert assms, auto)

	definition row :: "'a mat \<Rightarrow> nat \<Rightarrow> 'a vec" where
	"row A i = vec (dim_col A) (\<lambda> j. A $$ (i,j))"

	definition rows :: "'a mat \<Rightarrow> 'a vec list" where
	"rows A = map (row A) [0..<dim_row A]"

	lemma row_carrier[simp]: "row A i \<in> carrier_vec (dim_col A)" unfolding row_def by auto

	lemma rows_carrier[simp]: "set (rows A) \<subseteq> carrier_vec (dim_col A)" unfolding rows_def by auto

	lemma length_rows[simp]: "length (rows A) = dim_row A" unfolding rows_def by auto

	lemma nth_rows[simp]: "i < dim_row A \<Longrightarrow> rows A ! i = row A i"
	unfolding rows_def by auto

	lemma row_mat_of_row_fun[simp]: "i < nr \<Longrightarrow> dim_vec (f i) = nc \<Longrightarrow> row (mat\<^sub>r nr nc f) i = f i"
	by (rule eq_vecI, auto simp: row_def)

	lemma set_rows_carrier:
	assumes "A \<in> carrier_mat m n" and "v \<in> set (rows A)" shows "v \<in> carrier_vec n"
	using assms by (auto simp: rows_def row_def)

	definition mat_of_rows :: "nat \<Rightarrow> 'a vec list \<Rightarrow> 'a mat"
	where "mat_of_rows n rs = mat (length rs) n (\<lambda>(i,j). rs ! i $ j)"

	definition mat_of_rows_list :: "nat \<Rightarrow> 'a list list \<Rightarrow> 'a mat" where
	"mat_of_rows_list nc rs = mat (length rs) nc (\<lambda> (i,j). rs ! i ! j)"

	lemma mat_of_rows_carrier[simp]:
	"mat_of_rows n vs \<in> carrier_mat (length vs) n"
	"dim_row (mat_of_rows n vs) = length vs"
	"dim_col (mat_of_rows n vs) = n"
	unfolding mat_of_rows_def by auto

	lemma mat_of_rows_row[simp]:
	assumes i:"i < length vs" and n: "vs ! i \<in> carrier_vec n"
	shows "row (mat_of_rows n vs) i = vs ! i"
	unfolding mat_of_rows_def row_def using n i by auto

	lemma rows_mat_of_rows[simp]:
	assumes "set vs \<subseteq> carrier_vec n" shows "rows (mat_of_rows n vs) = vs"
	unfolding rows_def apply (rule nth_equalityI)
	using assms unfolding subset_code(1) by auto

	lemma mat_of_rows_rows[simp]:
	"mat_of_rows (dim_col A) (rows A) = A"
	unfolding mat_of_rows_def by (rule, auto simp: row_def)


	definition col :: "'a mat \<Rightarrow> nat \<Rightarrow> 'a vec" where
	"col A j = vec (dim_row A) (\<lambda> i. A $$ (i,j))"

	definition cols :: "'a mat \<Rightarrow> 'a vec list" where
	"cols A = map (col A) [0..<dim_col A]"

	definition mat_of_cols :: "nat \<Rightarrow> 'a vec list \<Rightarrow> 'a mat"
	where "mat_of_cols n cs = mat n (length cs) (\<lambda>(i,j). cs ! j $ i)"

	definition mat_of_cols_list :: "nat \<Rightarrow> 'a list list \<Rightarrow> 'a mat" where
	"mat_of_cols_list nr cs = mat nr (length cs) (\<lambda> (i,j). cs ! j ! i)"

	lemma col_dim[simp]: "col A i \<in> carrier_vec (dim_row A)" unfolding col_def by auto

	lemma dim_col[simp]: "dim_vec (col A i) = dim_row A" by auto

	lemma cols_dim[simp]: "set (cols A) \<subseteq> carrier_vec (dim_row A)" unfolding cols_def by auto

	lemma cols_length[simp]: "length (cols A) = dim_col A" unfolding cols_def by auto

	lemma cols_nth[simp]: "i < dim_col A \<Longrightarrow> cols A ! i = col A i"
	unfolding cols_def by auto

	lemma mat_of_cols_carrier[simp]:
	"mat_of_cols n vs \<in> carrier_mat n (length vs)"
	"dim_row (mat_of_cols n vs) = n"
	"dim_col (mat_of_cols n vs) = length vs"
	unfolding mat_of_cols_def by auto

	lemma col_mat_of_cols[simp]:
	assumes j:"j < length vs" and n: "vs ! j \<in> carrier_vec n"
	shows "col (mat_of_cols n vs) j = vs ! j"
	unfolding mat_of_cols_def col_def using j n by auto

	lemma cols_mat_of_cols[simp]:
	assumes "set vs \<subseteq> carrier_vec n" shows "cols (mat_of_cols n vs) = vs"
	unfolding cols_def apply(rule nth_equalityI)
	using assms unfolding subset_code(1) by auto

	lemma mat_of_cols_cols[simp]:
	"mat_of_cols (dim_row A) (cols A) = A"
	unfolding mat_of_cols_def by (rule, auto simp: col_def)


	instantiation mat :: (ord) ord
	begin

	definition less_eq_mat :: "'a mat \<Rightarrow> 'a mat \<Rightarrow> bool" where
	"less_eq_mat A B = (dim_row A = dim_row B \<and> dim_col A = dim_col B \<and>
	(\<forall> i < dim_row B. \<forall> j < dim_col B. A $$ (i,j) \<le> B $$ (i,j)))"

	definition less_mat :: "'a mat \<Rightarrow> 'a mat \<Rightarrow> bool" where
	"less_mat A B = (A \<le> B \<and> \<not> (B \<le> A))"
	instance ..
	end

	instantiation mat :: (preorder) preorder
	begin
	instance
	proof (standard, auto simp: less_mat_def less_eq_mat_def, goal_cases)
	case (1 A B C i j)
	thus ?case using order_trans[of "A $$ (i,j)" "B $$ (i,j)" "C $$ (i,j)"] by auto
	qed
	end

	instantiation mat :: (order) order
	begin
	instance
	by (standard, intro eq_matI, auto simp: less_eq_mat_def order.antisym)
	end

	instantiation mat :: (plus) plus
	begin
	definition plus_mat :: "('a :: plus) mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
	"A + B \<equiv> mat (dim_row B) (dim_col B) (\<lambda> ij. A $$ ij + B $$ ij)"
	instance ..
	end

	definition map_mat :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a mat \<Rightarrow> 'b mat" where
	"map_mat f A \<equiv> mat (dim_row A) (dim_col A) (\<lambda> ij. f (A $$ ij))"

	definition smult_mat :: "'a :: times \<Rightarrow> 'a mat \<Rightarrow> 'a mat" (infixl "\<cdot>\<^sub>m" 70)
	where "a \<cdot>\<^sub>m A \<equiv> map_mat (\<lambda> b. a * b) A"

	definition zero_mat :: "nat \<Rightarrow> nat \<Rightarrow> 'a :: zero mat" ("0\<^sub>m") where
	"0\<^sub>m nr nc \<equiv> mat nr nc (\<lambda> ij. 0)"

	lemma elements_0_mat [simp]: "elements_mat (0\<^sub>m nr nc) \<subseteq> {0}"
	unfolding elements_mat_def zero_mat_def by auto

	definition transpose_mat :: "'a mat \<Rightarrow> 'a mat" where
	"transpose_mat A \<equiv> mat (dim_col A) (dim_row A) (\<lambda> (i,j). A $$ (j,i))"

	definition one_mat :: "nat \<Rightarrow> 'a :: {zero,one} mat" ("1\<^sub>m") where
	"1\<^sub>m n \<equiv> mat n n (\<lambda> (i,j). if i = j then 1 else 0)"

	instantiation mat :: (uminus) uminus
	begin
	definition uminus_mat :: "'a :: uminus mat \<Rightarrow> 'a mat" where
	"- A \<equiv> mat (dim_row A) (dim_col A) (\<lambda> ij. - (A $$ ij))"
	instance ..
	end

	instantiation mat :: (minus) minus
	begin
	definition minus_mat :: "('a :: minus) mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
	"A - B \<equiv> mat (dim_row B) (dim_col B) (\<lambda> ij. A $$ ij - B $$ ij)"
	instance ..
	end

	instantiation mat :: (semiring_0) times
	begin
	definition times_mat :: "'a :: semiring_0 mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
	where "A * B \<equiv> mat (dim_row A) (dim_col B) (\<lambda> (i,j). row A i \<bullet> col B j)"
	instance ..
	end

	definition mult_mat_vec :: "'a :: semiring_0 mat \<Rightarrow> 'a vec \<Rightarrow> 'a vec" (infixl "*\<^sub>v" 70)
	where "A *\<^sub>v v \<equiv> vec (dim_row A) (\<lambda> i. row A i \<bullet> v)"

	definition inverts_mat :: "'a :: semiring_1 mat \<Rightarrow> 'a mat \<Rightarrow> bool" where
	"inverts_mat A B \<equiv> A * B = 1\<^sub>m (dim_row A)"

	definition invertible_mat :: "'a :: semiring_1 mat \<Rightarrow> bool"
	where "invertible_mat A \<equiv> square_mat A \<and> (\<exists>B. inverts_mat A B \<and> inverts_mat B A)"

	definition monoid_mat :: "'a :: monoid_add itself \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat monoid" where
	"monoid_mat ty nr nc \<equiv> \<lparr>
	carrier = carrier_mat nr nc,
	mult = (+),
	one = 0\<^sub>m nr nc\<rparr>"

	definition ring_mat :: "'a :: semiring_1 itself \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> ('a mat,'b) ring_scheme" where
	"ring_mat ty n b \<equiv> \<lparr>
	carrier = carrier_mat n n,
	mult = (*),
	one = 1\<^sub>m n,
	zero = 0\<^sub>m n n,
	add = (+),
	\<dots> = b\<rparr>"

	definition module_mat :: "'a :: semiring_1 itself \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a,'a mat)module" where
	"module_mat ty nr nc \<equiv> \<lparr>
	carrier = carrier_mat nr nc,
	mult = (*),
	one = 1\<^sub>m nr,
	zero = 0\<^sub>m nr nc,
	add = (+),
	smult = (\<cdot>\<^sub>m)\<rparr>"

	lemma ring_mat_simps:
	"mult (ring_mat ty n b) = (*)"
	"add (ring_mat ty n b) = (+)"
	"one (ring_mat ty n b) = 1\<^sub>m n"
	"zero (ring_mat ty n b) = 0\<^sub>m n n"
	"carrier (ring_mat ty n b) = carrier_mat n n"
	unfolding ring_mat_def by auto

	lemma module_mat_simps:
	"mult (module_mat ty nr nc) = (*)"
	"add (module_mat ty nr nc) = (+)"
	"one (module_mat ty nr nc) = 1\<^sub>m nr"
	"zero (module_mat ty nr nc) = 0\<^sub>m nr nc"
	"carrier (module_mat ty nr nc) = carrier_mat nr nc"
	"smult (module_mat ty nr nc) = (\<cdot>\<^sub>m)"
	unfolding module_mat_def by auto

	lemma index_zero_mat[simp]: "i < nr \<Longrightarrow> j < nc \<Longrightarrow> 0\<^sub>m nr nc $$ (i,j) = 0"
	"dim_row (0\<^sub>m nr nc) = nr" "dim_col (0\<^sub>m nr nc) = nc"
	unfolding zero_mat_def by auto

	lemma index_one_mat[simp]: "i < n \<Longrightarrow> j < n \<Longrightarrow> 1\<^sub>m n $$ (i,j) = (if i = j then 1 else 0)"
	"dim_row (1\<^sub>m n) = n" "dim_col (1\<^sub>m n) = n"
	unfolding one_mat_def by auto

	lemma index_add_mat[simp]:
	"i < dim_row B \<Longrightarrow> j < dim_col B \<Longrightarrow> (A + B) $$ (i,j) = A $$ (i,j) + B $$ (i,j)"
	"dim_row (A + B) = dim_row B" "dim_col (A + B) = dim_col B"
	unfolding plus_mat_def by auto

	lemma index_minus_mat[simp]:
	"i < dim_row B \<Longrightarrow> j < dim_col B \<Longrightarrow> (A - B) $$ (i,j) = A $$ (i,j) - B $$ (i,j)"
	"dim_row (A - B) = dim_row B" "dim_col (A - B) = dim_col B"
	unfolding minus_mat_def by auto

	lemma index_map_mat[simp]:
	"i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> map_mat f A $$ (i,j) = f (A $$ (i,j))"
	"dim_row (map_mat f A) = dim_row A" "dim_col (map_mat f A) = dim_col A"
	unfolding map_mat_def by auto

	lemma index_smult_mat[simp]:
	"i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> (a \<cdot>\<^sub>m A) $$ (i,j) = a * A $$ (i,j)"
	"dim_row (a \<cdot>\<^sub>m A) = dim_row A" "dim_col (a \<cdot>\<^sub>m A) = dim_col A"
	unfolding smult_mat_def by auto

	lemma index_uminus_mat[simp]:
	"i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> (- A) $$ (i,j) = - (A $$ (i,j))"
	"dim_row (- A) = dim_row A" "dim_col (- A) = dim_col A"
	unfolding uminus_mat_def by auto

	lemma index_transpose_mat[simp]:
	"i < dim_col A \<Longrightarrow> j < dim_row A \<Longrightarrow> transpose_mat A $$ (i,j) = A $$ (j,i)"
	"dim_row (transpose_mat A) = dim_col A" "dim_col (transpose_mat A) = dim_row A"
	unfolding transpose_mat_def by auto

	lemma index_mult_mat[simp]:
	"i < dim_row A \<Longrightarrow> j < dim_col B \<Longrightarrow> (A * B) $$ (i,j) = row A i \<bullet> col B j"
	"dim_row (A * B) = dim_row A" "dim_col (A * B) = dim_col B"
	by (auto simp: times_mat_def)

	lemma dim_mult_mat_vec[simp]: "dim_vec (A *\<^sub>v v) = dim_row A"
	by (auto simp: mult_mat_vec_def)

	lemma index_mult_mat_vec[simp]: "i < dim_row A \<Longrightarrow> (A *\<^sub>v v) $ i = row A i \<bullet> v"
	by (auto simp: mult_mat_vec_def)

	lemma index_row[simp]:
	"i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> row A i $ j = A $$ (i,j)"
	"dim_vec (row A i) = dim_col A"
	by (auto simp: row_def)

	lemma index_col[simp]: "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> col A j $ i = A $$ (i,j)"
	by (auto simp: col_def)

	lemma upper_triangular_one[simp]: "upper_triangular (1\<^sub>m n)"
	by (rule, auto)

	lemma upper_triangular_zero[simp]: "upper_triangular (0\<^sub>m n n)"
	by (rule, auto)

	lemma mat_row_carrierI[intro,simp]: "mat\<^sub>r nr nc r \<in> carrier_mat nr nc"
	by (unfold carrier_mat_def carrier_vec_def, auto)

	lemma eq_rowI: assumes rows: "\<And> i. i < dim_row B \<Longrightarrow> row A i = row B i"
	and dims: "dim_row A = dim_row B" "dim_col A = dim_col B"
	shows "A = B"
	proof (rule eq_matI[OF _ dims])
	fix i j
	assume i: "i < dim_row B" and j: "j < dim_col B"
	from rows[OF i] have id: "row A i $ j = row B i $ j" by simp
	show "A $$ (i, j) = B $$ (i, j)"
	using index_row(1)[OF i j, folded id] index_row(1)[of i A j] i j dims
	by auto
	qed

	lemma row_mat[simp]: "i < nr \<Longrightarrow> row (mat nr nc f) i = vec nc (\<lambda> j. f (i,j))"
	by auto

	lemma col_mat[simp]: "j < nc \<Longrightarrow> col (mat nr nc f) j = vec nr (\<lambda> i. f (i,j))"
	by auto

	lemma zero_carrier_mat[simp]: "0\<^sub>m nr nc \<in> carrier_mat nr nc"
	unfolding carrier_mat_def by auto

	lemma smult_carrier_mat[simp]:
	"A \<in> carrier_mat nr nc \<Longrightarrow> k \<cdot>\<^sub>m A \<in> carrier_mat nr nc"
	unfolding carrier_mat_def by auto

	lemma add_carrier_mat[simp]:
	"B \<in> carrier_mat nr nc \<Longrightarrow> A + B \<in> carrier_mat nr nc"
	unfolding carrier_mat_def by force

	lemma one_carrier_mat[simp]: "1\<^sub>m n \<in> carrier_mat n n"
	unfolding carrier_mat_def by auto

	lemma uminus_carrier_mat:
	"A \<in> carrier_mat nr nc \<Longrightarrow> (- A \<in> carrier_mat nr nc)"
	unfolding carrier_mat_def by auto

	lemma uminus_carrier_iff_mat[simp]:
	"(- A \<in> carrier_mat nr nc) = (A \<in> carrier_mat nr nc)"
	unfolding carrier_mat_def by auto

	lemma minus_carrier_mat:
	"B \<in> carrier_mat nr nc \<Longrightarrow> (A - B \<in> carrier_mat nr nc)"
	unfolding carrier_mat_def by auto

	lemma transpose_carrier_mat[simp]: "(transpose_mat A \<in> carrier_mat nc nr) = (A \<in> carrier_mat nr nc)"
	unfolding carrier_mat_def by auto

	lemma row_carrier_vec[simp]: "i < nr \<Longrightarrow> A \<in> carrier_mat nr nc \<Longrightarrow> row A i \<in> carrier_vec nc"
	unfolding carrier_vec_def by auto

	lemma col_carrier_vec[simp]: "j < nc \<Longrightarrow> A \<in> carrier_mat nr nc \<Longrightarrow> col A j \<in> carrier_vec nr"
	unfolding carrier_vec_def by auto

	lemma mult_carrier_mat[simp]:
	"A \<in> carrier_mat nr n \<Longrightarrow> B \<in> carrier_mat n nc \<Longrightarrow> A * B \<in> carrier_mat nr nc"
	unfolding carrier_mat_def by auto

	lemma mult_mat_vec_carrier[simp]:
	"A \<in> carrier_mat nr n \<Longrightarrow> v \<in> carrier_vec n \<Longrightarrow> A *\<^sub>v v \<in> carrier_vec nr"
	unfolding carrier_mat_def carrier_vec_def by auto


	lemma comm_add_mat[ac_simps]:
	"(A :: 'a :: comm_monoid_add mat) \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc \<Longrightarrow> A + B = B + A"
	by (intro eq_matI, auto simp: ac_simps)


	lemma minus_r_inv_mat[simp]:
	"(A :: 'a :: group_add mat) \<in> carrier_mat nr nc \<Longrightarrow> (A - A) = 0\<^sub>m nr nc"
	by (intro eq_matI, auto)

	lemma uminus_l_inv_mat[simp]:
	"(A :: 'a :: group_add mat) \<in> carrier_mat nr nc \<Longrightarrow> (- A + A) = 0\<^sub>m nr nc"
	by (intro eq_matI, auto)

	lemma add_inv_exists_mat:
	"(A :: 'a :: group_add mat) \<in> carrier_mat nr nc \<Longrightarrow> \<exists> B \<in> carrier_mat nr nc. B + A = 0\<^sub>m nr nc \<and> A + B = 0\<^sub>m nr nc"
	by (intro bexI[of _ "- A"], auto)

	lemma assoc_add_mat[simp]:
	"(A :: 'a :: monoid_add mat) \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc \<Longrightarrow> C \<in> carrier_mat nr nc
	\<Longrightarrow> (A + B) + C = A + (B + C)"
	by (intro eq_matI, auto simp: ac_simps)

	lemma uminus_add_mat: fixes A :: "'a :: group_add mat"
	assumes "A \<in> carrier_mat nr nc"
	and "B \<in> carrier_mat nr nc"
	shows "- (A + B) = - B + - A"
	by (intro eq_matI, insert assms, auto simp: minus_add)

	lemma transpose_transpose[simp]:
	"transpose_mat (transpose_mat A) = A"
	by (intro eq_matI, auto)

	lemma transpose_one[simp]: "transpose_mat (1\<^sub>m n) = (1\<^sub>m n)"
	by auto

	lemma row_transpose[simp]:
	"j < dim_col A \<Longrightarrow> row (transpose_mat A) j = col A j"
	unfolding row_def col_def
	by (intro eq_vecI, auto)

	lemma col_transpose[simp]:
	"i < dim_row A \<Longrightarrow> col (transpose_mat A) i = row A i"
	unfolding row_def col_def
	by (intro eq_vecI, auto)

	lemma row_zero[simp]:
	"i < nr \<Longrightarrow> row (0\<^sub>m nr nc) i = 0\<^sub>v nc"
	by (intro eq_vecI, auto)

	lemma col_zero[simp]:
	"j < nc \<Longrightarrow> col (0\<^sub>m nr nc) j = 0\<^sub>v nr"
	by (intro eq_vecI, auto)

	lemma row_one[simp]:
	"i < n \<Longrightarrow> row (1\<^sub>m n) i = unit_vec n i"
	by (intro eq_vecI, auto)

	lemma col_one[simp]:
	"j < n \<Longrightarrow> col (1\<^sub>m n) j = unit_vec n j"
	by (intro eq_vecI, auto)

	lemma transpose_add: "A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc
	\<Longrightarrow> transpose_mat (A + B) = transpose_mat A + transpose_mat B"
	by (intro eq_matI, auto)

	lemma transpose_minus: "A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc
	\<Longrightarrow> transpose_mat (A - B) = transpose_mat A - transpose_mat B"
	by (intro eq_matI, auto)

	-lemma transpose_uminus: "A \<in> carrier_mat nr nc \<Longrightarrow> transpose_mat (- A) = - (transpose_mat A)"
	+lemma transpose_uminus: "transpose_mat (- A) = - (transpose_mat A)"
	by (intro eq_matI, auto)

	lemma row_add[simp]:
	"A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc \<Longrightarrow> i < nr
	\<Longrightarrow> row (A + B) i = row A i + row B i"
	"i < dim_row A \<Longrightarrow> dim_row B = dim_row A \<Longrightarrow> dim_col B = dim_col A \<Longrightarrow> row (A + B) i = row A i + row B i"
	by (rule eq_vecI, auto)

	lemma col_add[simp]:
	"A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc \<Longrightarrow> j < nc
	\<Longrightarrow> col (A + B) j = col A j + col B j"
	by (rule eq_vecI, auto)

	lemma row_mult[simp]: assumes m: "A \<in> carrier_mat nr n" "B \<in> carrier_mat n nc"
	and i: "i < nr"
	shows "row (A * B) i = vec nc (\<lambda> j. row A i \<bullet> col B j)"
	by (rule eq_vecI, insert m i, auto)

	lemma col_mult[simp]: assumes m: "A \<in> carrier_mat nr n" "B \<in> carrier_mat n nc"
	and j: "j < nc"
	shows "col (A * B) j = vec nr (\<lambda> i. row A i \<bullet> col B j)"
	by (rule eq_vecI, insert m j, auto)

	lemma transpose_mult:
	"(A :: 'a :: comm_semiring_0 mat) \<in> carrier_mat nr n \<Longrightarrow> B \<in> carrier_mat n nc
	\<Longrightarrow> transpose_mat (A * B) = transpose_mat B * transpose_mat A"
	by (intro eq_matI, auto simp: comm_scalar_prod[of _ n])

	lemma left_add_zero_mat[simp]:
	"(A :: 'a :: monoid_add mat) \<in> carrier_mat nr nc \<Longrightarrow> 0\<^sub>m nr nc + A = A"
	by (intro eq_matI, auto)

	lemma add_uminus_minus_mat: "A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc \<Longrightarrow>
	A + (- B) = A - (B :: 'a :: group_add mat)"
	by (intro eq_matI, auto)

	lemma right_add_zero_mat[simp]: "A \<in> carrier_mat nr nc \<Longrightarrow>
	A + 0\<^sub>m nr nc = (A :: 'a :: monoid_add mat)"
	by (intro eq_matI, auto)

	lemma left_mult_zero_mat:
	"A \<in> carrier_mat n nc \<Longrightarrow> 0\<^sub>m nr n * A = 0\<^sub>m nr nc"
	by (intro eq_matI, auto)

	lemma left_mult_zero_mat'[simp]: "dim_row A = n \<Longrightarrow> 0\<^sub>m nr n * A = 0\<^sub>m nr (dim_col A)"
	by (rule left_mult_zero_mat, unfold carrier_mat_def, simp)

	lemma right_mult_zero_mat:
	"A \<in> carrier_mat nr n \<Longrightarrow> A * 0\<^sub>m n nc = 0\<^sub>m nr nc"
	by (intro eq_matI, auto)

	lemma right_mult_zero_mat'[simp]: "dim_col A = n \<Longrightarrow> A * 0\<^sub>m n nc = 0\<^sub>m (dim_row A) nc"
	by (rule right_mult_zero_mat, unfold carrier_mat_def, simp)

	lemma left_mult_one_mat:
	"(A :: 'a :: semiring_1 mat) \<in> carrier_mat nr nc \<Longrightarrow> 1\<^sub>m nr * A = A"
	by (intro eq_matI, auto)

	lemma left_mult_one_mat'[simp]: "dim_row (A :: 'a :: semiring_1 mat) = n \<Longrightarrow> 1\<^sub>m n * A = A"
	by (rule left_mult_one_mat, unfold carrier_mat_def, simp)

	lemma right_mult_one_mat:
	"(A :: 'a :: semiring_1 mat) \<in> carrier_mat nr nc \<Longrightarrow> A * 1\<^sub>m nc = A"
	by (intro eq_matI, auto)

	lemma right_mult_one_mat'[simp]: "dim_col (A :: 'a :: semiring_1 mat) = n \<Longrightarrow> A * 1\<^sub>m n = A"
	by (rule right_mult_one_mat, unfold carrier_mat_def, simp)

	lemma one_mult_mat_vec[simp]:
	"(v :: 'a :: semiring_1 vec) \<in> carrier_vec n \<Longrightarrow> 1\<^sub>m n *\<^sub>v v = v"
	by (intro eq_vecI, auto)

	lemma minus_add_uminus_mat: fixes A :: "'a :: group_add mat"
	shows "A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc \<Longrightarrow>
	A - B = A + (- B)"
	by (intro eq_matI, auto)

	lemma add_mult_distrib_mat[algebra_simps]: assumes m: "A \<in> carrier_mat nr n"
	"B \<in> carrier_mat nr n" "C \<in> carrier_mat n nc"
	shows "(A + B) * C = A * C + B * C"
	using m by (intro eq_matI, auto simp: add_scalar_prod_distrib[of _ n])

	lemma mult_add_distrib_mat[algebra_simps]: assumes m: "A \<in> carrier_mat nr n"
	"B \<in> carrier_mat n nc" "C \<in> carrier_mat n nc"
	shows "A * (B + C) = A * B + A * C"
	using m by (intro eq_matI, auto simp: scalar_prod_add_distrib[of _ n])

	lemma add_mult_distrib_mat_vec[algebra_simps]: assumes m: "A \<in> carrier_mat nr nc"
	"B \<in> carrier_mat nr nc" "v \<in> carrier_vec nc"
	shows "(A + B) \<^sub>v v = A \<^sub>v v + B *\<^sub>v v"
	using m by (intro eq_vecI, auto intro!: add_scalar_prod_distrib)

	lemma mult_add_distrib_mat_vec[algebra_simps]: assumes m: "A \<in> carrier_mat nr nc"
	"v\<^sub>1 \<in> carrier_vec nc" "v\<^sub>2 \<in> carrier_vec nc"
	shows "A \<^sub>v (v\<^sub>1 + v\<^sub>2) = A \<^sub>v v\<^sub>1 + A *\<^sub>v v\<^sub>2"
	using m by (intro eq_vecI, auto simp: scalar_prod_add_distrib[of _ nc])

	lemma mult_mat_vec:
	assumes m: "(A::'a::field mat) \<in> carrier_mat nr nc" and v: "v \<in> carrier_vec nc"
	shows "A \<^sub>v (k \<cdot>\<^sub>v v) = k \<cdot>\<^sub>v (A \<^sub>v v)" (is "?l = ?r")
	proof
	have nr: "dim_vec ?l = nr" using m v by auto
	also have "... = dim_vec ?r" using m v by auto
	finally show "dim_vec ?l = dim_vec ?r".

	show "\<And>i. i < dim_vec ?r \<Longrightarrow> ?l $ i = ?r $ i"
	proof -
	fix i assume "i < dim_vec ?r"
	hence i: "i < dim_row A" using nr m by auto
	hence i2: "i < dim_vec (A *\<^sub>v v)" using m by auto
	show "?l $ i = ?r $ i"
	apply (subst (1) mult_mat_vec_def)
	apply (subst (2) smult_vec_def)
	unfolding index_vec[OF i] index_vec[OF i2]
	unfolding mult_mat_vec_def smult_vec_def
	unfolding scalar_prod_def index_vec[OF i]
	by (simp add: mult.left_commute sum_distrib_left)
	qed
	qed

	lemma assoc_scalar_prod: assumes *: "v\<^sub>1 \<in> carrier_vec nr" "A \<in> carrier_mat nr nc" "v\<^sub>2 \<in> carrier_vec nc"
	shows "vec nc (\<lambda>j. v\<^sub>1 \<bullet> col A j) \<bullet> v\<^sub>2 = v\<^sub>1 \<bullet> vec nr (\<lambda>i. row A i \<bullet> v\<^sub>2)"
	proof -
	have "vec nc (\<lambda>j. v\<^sub>1 \<bullet> col A j) \<bullet> v\<^sub>2 = (\<Sum>i\<in>{0..<nc}. vec nc (\<lambda>j. \<Sum>k\<in>{0..<nr}. v\<^sub>1 $ k * col A j $ k) $ i * v\<^sub>2 $ i)"
	unfolding scalar_prod_def using * by auto
	also have "\<dots> = (\<Sum>i\<in>{0..<nc}. (\<Sum>k\<in>{0..<nr}. v\<^sub>1 $ k * col A i $ k) * v\<^sub>2 $ i)"
	by (rule sum.cong, auto)
	also have "\<dots> = (\<Sum>i\<in>{0..<nc}. (\<Sum>k\<in>{0..<nr}. v\<^sub>1 $ k * col A i $ k * v\<^sub>2 $ i))"
	unfolding sum_distrib_right ..
	also have "\<dots> = (\<Sum>k\<in>{0..<nr}. (\<Sum>i\<in>{0..<nc}. v\<^sub>1 $ k * col A i $ k * v\<^sub>2 $ i))"
	by (rule sum.swap)
	also have "\<dots> = (\<Sum>k\<in>{0..<nr}. (\<Sum>i\<in>{0..<nc}. v\<^sub>1 $ k * (col A i $ k * v\<^sub>2 $ i)))"
	by (simp add: ac_simps)
	also have "\<dots> = (\<Sum>k\<in>{0..<nr}. v\<^sub>1 $ k * (\<Sum>i\<in>{0..<nc}. col A i $ k * v\<^sub>2 $ i))"
	unfolding sum_distrib_left ..
	also have "\<dots> = (\<Sum>k\<in>{0..<nr}. v\<^sub>1 $ k * vec nr (\<lambda>k. \<Sum>i\<in>{0..<nc}. row A k $ i * v\<^sub>2 $ i) $ k)"
	using * by auto
	also have "\<dots> = v\<^sub>1 \<bullet> vec nr (\<lambda>i. row A i \<bullet> v\<^sub>2)" unfolding scalar_prod_def using * by simp
	finally show ?thesis .
	qed

	+lemma transpose_vec_mult_scalar:
	+ fixes A :: "'a :: comm_semiring_0 mat"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and x: "x \<in> carrier_vec nc"
	+ and y: "y \<in> carrier_vec nr"
	+ shows "(transpose_mat A \<^sub>v y) \<bullet> x = y \<bullet> (A \<^sub>v x)"
	+proof -
	+ have "(transpose_mat A *\<^sub>v y) = vec nc (\<lambda>i. col A i \<bullet> y)"
	+ unfolding mult_mat_vec_def using A by auto
	+ also have "\<dots> = vec nc (\<lambda>i. y \<bullet> col A i)"
	+ by (intro eq_vecI, simp, rule comm_scalar_prod[OF _ y], insert A, auto)
	+ also have "\<dots> \<bullet> x = y \<bullet> vec nr (\<lambda>i. row A i \<bullet> x)"
	+ by (rule assoc_scalar_prod[OF y A x])
	+ also have "vec nr (\<lambda>i. row A i \<bullet> x) = A *\<^sub>v x"
	+ unfolding mult_mat_vec_def using A by auto
	+ finally show ?thesis .
	+qed
	+
	lemma assoc_mult_mat[simp]:
	"A \<in> carrier_mat n\<^sub>1 n\<^sub>2 \<Longrightarrow> B \<in> carrier_mat n\<^sub>2 n\<^sub>3 \<Longrightarrow> C \<in> carrier_mat n\<^sub>3 n\<^sub>4
	\<Longrightarrow> (A * B) * C = A * (B * C)"
	by (intro eq_matI, auto simp: assoc_scalar_prod)

	lemma assoc_mult_mat_vec[simp]:
	"A \<in> carrier_mat n\<^sub>1 n\<^sub>2 \<Longrightarrow> B \<in> carrier_mat n\<^sub>2 n\<^sub>3 \<Longrightarrow> v \<in> carrier_vec n\<^sub>3
	\<Longrightarrow> (A * B) \<^sub>v v = A \<^sub>v (B *\<^sub>v v)"
	by (intro eq_vecI, auto simp add: mult_mat_vec_def assoc_scalar_prod)

	lemma comm_monoid_mat: "comm_monoid (monoid_mat TYPE('a :: comm_monoid_add) nr nc)"
	by (unfold_locales, auto simp: monoid_mat_def ac_simps)

	lemma comm_group_mat: "comm_group (monoid_mat TYPE('a :: ab_group_add) nr nc)"
	by (unfold_locales, insert add_inv_exists_mat, auto simp: monoid_mat_def ac_simps Units_def)

	lemma semiring_mat: "semiring (ring_mat TYPE('a :: semiring_1) n b)"
	by (unfold_locales, auto simp: ring_mat_def algebra_simps)

	lemma ring_mat: "ring (ring_mat TYPE('a :: comm_ring_1) n b)"
	by (unfold_locales, insert add_inv_exists_mat, auto simp: ring_mat_def algebra_simps Units_def)

	lemma abelian_group_mat: "abelian_group (module_mat TYPE('a :: comm_ring_1) nr nc)"
	by (unfold_locales, insert add_inv_exists_mat, auto simp: module_mat_def Units_def)

	lemma row_smult[simp]: assumes i: "i < dim_row A"
	shows "row (k \<cdot>\<^sub>m A) i = k \<cdot>\<^sub>v (row A i)"
	by (rule eq_vecI, insert i, auto)

	lemma col_smult[simp]: assumes i: "i < dim_col A"
	shows "col (k \<cdot>\<^sub>m A) i = k \<cdot>\<^sub>v (col A i)"
	by (rule eq_vecI, insert i, auto)

	lemma row_uminus[simp]: assumes i: "i < dim_row A"
	shows "row (- A) i = - (row A i)"
	by (rule eq_vecI, insert i, auto)

	lemma scalar_prod_uminus_left[simp]: assumes dim: "dim_vec v = dim_vec (w :: 'a :: ring vec)"
	shows "- v \<bullet> w = - (v \<bullet> w)"
	unfolding scalar_prod_def dim[symmetric]
	by (subst sum_negf[symmetric], rule sum.cong, auto)

	lemma col_uminus[simp]: assumes i: "i < dim_col A"
	shows "col (- A) i = - (col A i)"
	by (rule eq_vecI, insert i, auto)

	lemma scalar_prod_uminus_right[simp]: assumes dim: "dim_vec v = dim_vec (w :: 'a :: ring vec)"
	shows "v \<bullet> - w = - (v \<bullet> w)"
	unfolding scalar_prod_def dim
	by (subst sum_negf[symmetric], rule sum.cong, auto)

	context fixes A B :: "'a :: ring mat"
	assumes dim: "dim_col A = dim_row B"
	begin
	lemma uminus_mult_left_mat[simp]: "(- A * B) = - (A * B)"
	by (intro eq_matI, insert dim, auto)

	lemma uminus_mult_right_mat[simp]: "(A * - B) = - (A * B)"
	by (intro eq_matI, insert dim, auto)
	end

	lemma minus_mult_distrib_mat[algebra_simps]: fixes A :: "'a :: ring mat"
	assumes m: "A \<in> carrier_mat nr n" "B \<in> carrier_mat nr n" "C \<in> carrier_mat n nc"
	shows "(A - B) * C = A * C - B * C"
	unfolding minus_add_uminus_mat[OF m(1,2)]
	add_mult_distrib_mat[OF m(1) uminus_carrier_mat[OF m(2)] m(3)]
	by (subst uminus_mult_left_mat, insert m, auto)

	lemma minus_mult_distrib_mat_vec[algebra_simps]: assumes A: "(A :: 'a :: ring mat) \<in> carrier_mat nr nc"
	and B: "B \<in> carrier_mat nr nc"
	and v: "v \<in> carrier_vec nc"
	shows "(A - B) \<^sub>v v = A \<^sub>v v - B *\<^sub>v v"
	unfolding minus_add_uminus_mat[OF A B]
	by (subst add_mult_distrib_mat_vec[OF A _ v], insert A B v, auto)

	lemma mult_minus_distrib_mat_vec[algebra_simps]: assumes A: "(A :: 'a :: ring mat) \<in> carrier_mat nr nc"
	and v: "v \<in> carrier_vec nc"
	and w: "w \<in> carrier_vec nc"
	shows "A \<^sub>v (v - w) = A \<^sub>v v - A *\<^sub>v w"
	unfolding minus_add_uminus_vec[OF v w]
	by (subst mult_add_distrib_mat_vec[OF A], insert A v w, auto)

	lemma mult_minus_distrib_mat[algebra_simps]: fixes A :: "'a :: ring mat"
	assumes m: "A \<in> carrier_mat nr n" "B \<in> carrier_mat n nc" "C \<in> carrier_mat n nc"
	shows "A * (B - C) = A * B - A * C"
	unfolding minus_add_uminus_mat[OF m(2,3)]
	mult_add_distrib_mat[OF m(1) m(2) uminus_carrier_mat[OF m(3)]]
	by (subst uminus_mult_right_mat, insert m, auto)

	lemma uminus_mult_mat_vec[simp]: assumes v: "dim_vec v = dim_col (A :: 'a :: ring mat)"
	shows "- A \<^sub>v v = - (A \<^sub>v v)"
	using v by (intro eq_vecI, auto)

	lemma uminus_zero_vec_eq: assumes v: "(v :: 'a :: group_add vec) \<in> carrier_vec n"
	shows "(- v = 0\<^sub>v n) = (v = 0\<^sub>v n)"
	proof
	assume z: "- v = 0\<^sub>v n"
	{
	fix i
	assume i: "i < n"
	have "v $ i = - (- (v $ i))" by simp
	also have "- (v $ i) = 0" using arg_cong[OF z, of "\<lambda> v. v $ i"] i v by auto
	also have "- 0 = (0 :: 'a)" by simp
	finally have "v $ i = 0" .
	}
	thus "v = 0\<^sub>v n" using v
	by (intro eq_vecI, auto)
	qed auto

	lemma map_carrier_mat[simp]:
	"(map_mat f A \<in> carrier_mat nr nc) = (A \<in> carrier_mat nr nc)"
	unfolding carrier_mat_def by auto

	lemma col_map_mat[simp]:
	assumes "j < dim_col A" shows "col (map_mat f A) j = map_vec f (col A j)"
	unfolding map_mat_def map_vec_def using assms by auto

	lemma scalar_vec_one[simp]: "1 \<cdot>\<^sub>v (v :: 'a :: semiring_1 vec) = v"
	by (rule eq_vecI, auto)

	lemma scalar_prod_smult_right[simp]:
	"dim_vec w = dim_vec v \<Longrightarrow> w \<bullet> (k \<cdot>\<^sub>v v) = (k :: 'a :: comm_semiring_0) * (w \<bullet> v)"
	unfolding scalar_prod_def sum_distrib_left
	by (auto intro: sum.cong simp: ac_simps)

	lemma scalar_prod_smult_left[simp]:
	"dim_vec w = dim_vec v \<Longrightarrow> (k \<cdot>\<^sub>v w) \<bullet> v = (k :: 'a :: comm_semiring_0) * (w \<bullet> v)"
	unfolding scalar_prod_def sum_distrib_left
	by (auto intro: sum.cong simp: ac_simps)

	lemma mult_smult_distrib: assumes A: "A \<in> carrier_mat nr n" and B: "B \<in> carrier_mat n nc"
	shows "A * (k \<cdot>\<^sub>m B) = (k :: 'a :: comm_semiring_0) \<cdot>\<^sub>m (A * B)"
	by (rule eq_matI, insert A B, auto)

	lemma add_smult_distrib_left_mat: assumes "A \<in> carrier_mat nr nc" "B \<in> carrier_mat nr nc"
	shows "k \<cdot>\<^sub>m (A + B) = (k :: 'a :: semiring) \<cdot>\<^sub>m A + k \<cdot>\<^sub>m B"
	by (rule eq_matI, insert assms, auto simp: field_simps)

	lemma add_smult_distrib_right_mat: assumes "A \<in> carrier_mat nr nc"
	shows "(k + l) \<cdot>\<^sub>m A = (k :: 'a :: semiring) \<cdot>\<^sub>m A + l \<cdot>\<^sub>m A"
	by (rule eq_matI, insert assms, auto simp: field_simps)

	lemma mult_smult_assoc_mat: assumes A: "A \<in> carrier_mat nr n" and B: "B \<in> carrier_mat n nc"
	shows "(k \<cdot>\<^sub>m A) * B = (k :: 'a :: comm_semiring_0) \<cdot>\<^sub>m (A * B)"
	by (rule eq_matI, insert A B, auto)

	definition similar_mat_wit :: "'a :: semiring_1 mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat \<Rightarrow> bool" where
	"similar_mat_wit A B P Q = (let n = dim_row A in {A,B,P,Q} \<subseteq> carrier_mat n n \<and> P * Q = 1\<^sub>m n \<and> Q * P = 1\<^sub>m n \<and>
	A = P * B * Q)"

	definition similar_mat :: "'a :: semiring_1 mat \<Rightarrow> 'a mat \<Rightarrow> bool" where
	"similar_mat A B = (\<exists> P Q. similar_mat_wit A B P Q)"

	lemma similar_matD: assumes "similar_mat A B"
	shows "\<exists> n P Q. {A,B,P,Q} \<subseteq> carrier_mat n n \<and> P * Q = 1\<^sub>m n \<and> Q * P = 1\<^sub>m n \<and> A = P * B * Q"
	using assms unfolding similar_mat_def similar_mat_wit_def[abs_def] Let_def by blast

	lemma similar_matI: assumes "{A,B,P,Q} \<subseteq> carrier_mat n n" "P * Q = 1\<^sub>m n" "Q * P = 1\<^sub>m n" "A = P * B * Q"
	shows "similar_mat A B" unfolding similar_mat_def
	by (rule exI[of _ P], rule exI[of _ Q], unfold similar_mat_wit_def Let_def, insert assms, auto)

	fun pow_mat :: "'a :: semiring_1 mat \<Rightarrow> nat \<Rightarrow> 'a mat" (infixr "^\<^sub>m" 75) where
	"A ^\<^sub>m 0 = 1\<^sub>m (dim_row A)"
	\| "A ^\<^sub>m (Suc k) = A ^\<^sub>m k * A"

	lemma pow_mat_dim[simp]:
	"dim_row (A ^\<^sub>m k) = dim_row A"
	"dim_col (A ^\<^sub>m k) = (if k = 0 then dim_row A else dim_col A)"
	by (induct k, auto)

	lemma pow_mat_dim_square[simp]:
	"A \<in> carrier_mat n n \<Longrightarrow> dim_row (A ^\<^sub>m k) = n"
	"A \<in> carrier_mat n n \<Longrightarrow> dim_col (A ^\<^sub>m k) = n"
	by auto

	lemma pow_carrier_mat[simp]: "A \<in> carrier_mat n n \<Longrightarrow> A ^\<^sub>m k \<in> carrier_mat n n"
	unfolding carrier_mat_def by auto

	definition diag_mat :: "'a mat \<Rightarrow> 'a list" where
	"diag_mat A = map (\<lambda> i. A $$ (i,i)) [0 ..< dim_row A]"

	lemma prod_list_diag_prod: "prod_list (diag_mat A) = (\<Prod> i = 0 ..< dim_row A. A $$ (i,i))"
	unfolding diag_mat_def
	by (subst prod.distinct_set_conv_list[symmetric], auto)

	lemma diag_mat_transpose[simp]: "dim_row A = dim_col A \<Longrightarrow>
	diag_mat (transpose_mat A) = diag_mat A" unfolding diag_mat_def by auto

	lemma diag_mat_zero[simp]: "diag_mat (0\<^sub>m n n) = replicate n 0"
	unfolding diag_mat_def
	by (rule nth_equalityI, auto)

	lemma diag_mat_one[simp]: "diag_mat (1\<^sub>m n) = replicate n 1"
	unfolding diag_mat_def
	by (rule nth_equalityI, auto)

	lemma pow_mat_ring_pow: assumes A: "(A :: ('a :: semiring_1)mat) \<in> carrier_mat n n"
	shows "A ^\<^sub>m k = A [^]\<^bsub>ring_mat TYPE('a) n b\<^esub> k"
	(is "_ = A [^]\<^bsub>?C\<^esub> k")
	proof -
	interpret semiring ?C by (rule semiring_mat)
	show ?thesis
	by (induct k, insert A, auto simp: ring_mat_def nat_pow_def)
	qed

	definition diagonal_mat :: "'a::zero mat \<Rightarrow> bool" where
	"diagonal_mat A \<equiv> \<forall>i<dim_row A. \<forall>j<dim_col A. i \<noteq> j \<longrightarrow> A $$ (i,j) = 0"

	definition (in comm_monoid_add) sum_mat :: "'a mat \<Rightarrow> 'a" where
	"sum_mat A = sum (\<lambda> ij. A $$ ij) ({0 ..< dim_row A} \<times> {0 ..< dim_col A})"

	lemma sum_mat_0[simp]: "sum_mat (0\<^sub>m nr nc) = (0 :: 'a :: comm_monoid_add)"
	unfolding sum_mat_def
	by (rule sum.neutral, auto)

	lemma sum_mat_add: assumes A: "(A :: 'a :: comm_monoid_add mat) \<in> carrier_mat nr nc" and B: "B \<in> carrier_mat nr nc"
	shows "sum_mat (A + B) = sum_mat A + sum_mat B"
	proof -
	from A B have id: "dim_row A = nr" "dim_row B = nr" "dim_col A = nc" "dim_col B = nc"
	by auto
	show ?thesis unfolding sum_mat_def id
	by (subst sum.distrib[symmetric], rule sum.cong, insert A B, auto)
	qed

	subsection \<open>Update Operators\<close>

	definition update_vec :: "'a vec \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a vec" ("_ \|\<^sub>v _ \<mapsto> _" [60,61,62] 60)
	where "v \|\<^sub>v i \<mapsto> a = vec (dim_vec v) (\<lambda>i'. if i' = i then a else v $ i')"

	definition update_mat :: "'a mat \<Rightarrow> nat \<times> nat \<Rightarrow> 'a \<Rightarrow> 'a mat" ("_ \|\<^sub>m _ \<mapsto> _" [60,61,62] 60)
	where "A \|\<^sub>m ij \<mapsto> a = mat (dim_row A) (dim_col A) (\<lambda>ij'. if ij' = ij then a else A $$ ij')"

	lemma dim_update_vec[simp]:
	"dim_vec (v \|\<^sub>v i \<mapsto> a) = dim_vec v" unfolding update_vec_def by simp

	lemma index_update_vec1[simp]:
	assumes "i < dim_vec v" shows "(v \|\<^sub>v i \<mapsto> a) $ i = a"
	unfolding update_vec_def using assms by simp

	lemma index_update_vec2[simp]:
	assumes "i' \<noteq> i" shows "(v \|\<^sub>v i \<mapsto> a) $ i' = v $ i'"
	unfolding update_vec_def
	using assms apply transfer unfolding mk_vec_def by auto

	lemma dim_update_mat[simp]:
	"dim_row (A \|\<^sub>m ij \<mapsto> a) = dim_row A"
	"dim_col (A \|\<^sub>m ij \<mapsto> a) = dim_col A" unfolding update_mat_def by simp+

	lemma index_update_mat1[simp]:
	assumes "i < dim_row A" "j < dim_col A" shows "(A \|\<^sub>m (i,j) \<mapsto> a) $$ (i,j) = a"
	unfolding update_mat_def using assms by simp

	lemma index_update_mat2[simp]:
	assumes i': "i' < dim_row A" and j': "j' < dim_col A" and neq: "(i',j') \<noteq> ij"
	shows "(A \|\<^sub>m ij \<mapsto> a) $$ (i',j') = A $$ (i',j')"
	unfolding update_mat_def using assms by auto

	subsection \<open>Block Vectors and Matrices\<close>

	definition append_vec :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a vec" (infixr "@\<^sub>v" 65) where
	"v @\<^sub>v w \<equiv> let n = dim_vec v; m = dim_vec w in
	vec (n + m) (\<lambda> i. if i < n then v $ i else w $ (i - n))"

	lemma index_append_vec[simp]: "i < dim_vec v + dim_vec w
	\<Longrightarrow> (v @\<^sub>v w) $ i = (if i < dim_vec v then v $ i else w $ (i - dim_vec v))"
	"dim_vec (v @\<^sub>v w) = dim_vec v + dim_vec w"
	unfolding append_vec_def Let_def by auto

	lemma append_carrier_vec[simp,intro]:
	"v \<in> carrier_vec n1 \<Longrightarrow> w \<in> carrier_vec n2 \<Longrightarrow> v @\<^sub>v w \<in> carrier_vec (n1 + n2)"
	unfolding carrier_vec_def by auto

	lemma scalar_prod_append: assumes "v1 \<in> carrier_vec n1" "v2 \<in> carrier_vec n2"
	"w1 \<in> carrier_vec n1" "w2 \<in> carrier_vec n2"
	shows "(v1 @\<^sub>v v2) \<bullet> (w1 @\<^sub>v w2) = v1 \<bullet> w1 + v2 \<bullet> w2"
	proof -
	from assms have dim: "dim_vec v1 = n1" "dim_vec v2 = n2" "dim_vec w1 = n1" "dim_vec w2 = n2" by auto
	have id: "{0 ..< n1 + n2} = {0 ..< n1} \<union> {n1 ..< n1 + n2}" by auto
	have id2: "{n1 ..< n1 + n2} = (plus n1) ` {0 ..< n2}"
	by (simp add: ac_simps)
	have "(v1 @\<^sub>v v2) \<bullet> (w1 @\<^sub>v w2) = (\<Sum>i = 0..<n1. v1 $ i * w1 $ i) +
	(\<Sum>i = n1..<n1 + n2. v2 $ (i - n1) * w2 $ (i - n1))"
	unfolding scalar_prod_def
	by (auto simp: dim id, subst sum.union_disjoint, insert assms, force+)
	also have "(\<Sum>i = n1..<n1 + n2. v2 $ (i - n1) * w2 $ (i - n1))
	= (\<Sum>i = 0..< n2. v2 $ i * w2 $ i)"
	by (rule sum.reindex_cong [OF _ id2]) simp_all
	finally show ?thesis by (simp, insert assms, auto simp: scalar_prod_def)
	qed

	definition "vec_first v n \<equiv> vec n (\<lambda>i. v $ i)"
	definition "vec_last v n \<equiv> vec n (\<lambda>i. v $ (dim_vec v - n + i))"

	lemma dim_vec_first[simp]: "dim_vec (vec_first v n) = n" unfolding vec_first_def by auto
	lemma dim_vec_last[simp]: "dim_vec (vec_last v n) = n" unfolding vec_last_def by auto

	lemma vec_first_carrier[simp]: "vec_first v n \<in> carrier_vec n" by (rule carrier_vecI, auto)
	lemma vec_last_carrier[simp]: "vec_last v n \<in> carrier_vec n" by (rule carrier_vecI, auto)

	lemma vec_first_last_append[simp]:
	assumes "v \<in> carrier_vec (n+m)" shows "vec_first v n @\<^sub>v vec_last v m = v"
	apply(rule) unfolding vec_first_def vec_last_def using assms by auto

	lemma append_vec_le: assumes "v \<in> carrier_vec n" and w: "w \<in> carrier_vec n"
	shows "v @\<^sub>v v' \<le> w @\<^sub>v w' \<longleftrightarrow> v \<le> w \<and> v' \<le> w'"
	proof -
	{
	fix i
	assume *: "\<forall>i. (\<not> i < n \<longrightarrow> i < n + dim_vec w' \<longrightarrow> v' $ (i - n) \<le> w' $ (i - n))"
	and i: "i < dim_vec w'"
	have "v' $ i \<le> w' $ i" using *[rule_format, of "n + i"] i by auto
	}
	thus ?thesis using assms unfolding less_eq_vec_def by auto
	qed

	lemma all_vec_append: "(\<forall> x \<in> carrier_vec (n + m). P x) \<longleftrightarrow> (\<forall> x1 \<in> carrier_vec n. \<forall> x2 \<in> carrier_vec m. P (x1 @\<^sub>v x2))"
	proof (standard, force, intro ballI, goal_cases)
	case (1 x)
	have "x = vec n (\<lambda> i. x $ i) @\<^sub>v vec m (\<lambda> i. x $ (n + i))"
	by (rule eq_vecI, insert 1(2), auto)
	hence "P x = P (vec n (\<lambda> i. x $ i) @\<^sub>v vec m (\<lambda> i. x $ (n + i)))" by simp
	also have "\<dots>" using 1 by auto
	finally show ?case .
	qed


	(* A B
	C D *)
	definition four_block_mat :: "'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
	"four_block_mat A B C D =
	(let nra = dim_row A; nrd = dim_row D;
	nca = dim_col A; ncd = dim_col D
	in
	mat (nra + nrd) (nca + ncd) (\<lambda> (i,j). if i < nra then
	if j < nca then A $$ (i,j) else B $$ (i,j - nca)
	else if j < nca then C $$ (i - nra, j) else D $$ (i - nra, j - nca)))"

	lemma index_mat_four_block[simp]:
	"i < dim_row A + dim_row D \<Longrightarrow> j < dim_col A + dim_col D \<Longrightarrow> four_block_mat A B C D $$ (i,j)
	= (if i < dim_row A then
	if j < dim_col A then A $$ (i,j) else B $$ (i,j - dim_col A)
	else if j < dim_col A then C $$ (i - dim_row A, j) else D $$ (i - dim_row A, j - dim_col A))"
	"dim_row (four_block_mat A B C D) = dim_row A + dim_row D"
	"dim_col (four_block_mat A B C D) = dim_col A + dim_col D"
	unfolding four_block_mat_def Let_def by auto

	lemma four_block_carrier_mat[simp]:
	"A \<in> carrier_mat nr1 nc1 \<Longrightarrow> D \<in> carrier_mat nr2 nc2 \<Longrightarrow>
	four_block_mat A B C D \<in> carrier_mat (nr1 + nr2) (nc1 + nc2)"
	unfolding carrier_mat_def by auto

	lemma cong_four_block_mat: "A1 = B1 \<Longrightarrow> A2 = B2 \<Longrightarrow> A3 = B3 \<Longrightarrow> A4 = B4 \<Longrightarrow>
	four_block_mat A1 A2 A3 A4 = four_block_mat B1 B2 B3 B4" by auto

	lemma four_block_one_mat[simp]:
	"four_block_mat (1\<^sub>m n1) (0\<^sub>m n1 n2) (0\<^sub>m n2 n1) (1\<^sub>m n2) = 1\<^sub>m (n1 + n2)"
	by (rule eq_matI, auto)

	lemma four_block_zero_mat[simp]:
	"four_block_mat (0\<^sub>m nr1 nc1) (0\<^sub>m nr1 nc2) (0\<^sub>m nr2 nc1) (0\<^sub>m nr2 nc2) = 0\<^sub>m (nr1 + nr2) (nc1 + nc2)"
	by (rule eq_matI, auto)

	lemma row_four_block_mat:
	assumes c: "A \<in> carrier_mat nr1 nc1" "B \<in> carrier_mat nr1 nc2"
	"C \<in> carrier_mat nr2 nc1" "D \<in> carrier_mat nr2 nc2"
	shows
	"i < nr1 \<Longrightarrow> row (four_block_mat A B C D) i = row A i @\<^sub>v row B i" (is "_ \<Longrightarrow> ?AB")
	"\<not> i < nr1 \<Longrightarrow> i < nr1 + nr2 \<Longrightarrow> row (four_block_mat A B C D) i = row C (i - nr1) @\<^sub>v row D (i - nr1)"
	(is "_ \<Longrightarrow> _ \<Longrightarrow> ?CD")
	proof -
	assume i: "i < nr1"
	show ?AB by (rule eq_vecI, insert i c, auto)
	next
	assume i: "\<not> i < nr1" "i < nr1 + nr2"
	show ?CD by (rule eq_vecI, insert i c, auto)
	qed

	lemma col_four_block_mat:
	assumes c: "A \<in> carrier_mat nr1 nc1" "B \<in> carrier_mat nr1 nc2"
	"C \<in> carrier_mat nr2 nc1" "D \<in> carrier_mat nr2 nc2"
	shows
	"j < nc1 \<Longrightarrow> col (four_block_mat A B C D) j = col A j @\<^sub>v col C j" (is "_ \<Longrightarrow> ?AC")
	"\<not> j < nc1 \<Longrightarrow> j < nc1 + nc2 \<Longrightarrow> col (four_block_mat A B C D) j = col B (j - nc1) @\<^sub>v col D (j - nc1)"
	(is "_ \<Longrightarrow> _ \<Longrightarrow> ?BD")
	proof -
	assume j: "j < nc1"
	show ?AC by (rule eq_vecI, insert j c, auto)
	next
	assume j: "\<not> j < nc1" "j < nc1 + nc2"
	show ?BD by (rule eq_vecI, insert j c, auto)
	qed

	lemma mult_four_block_mat: assumes
	c1: "A1 \<in> carrier_mat nr1 n1" "B1 \<in> carrier_mat nr1 n2" "C1 \<in> carrier_mat nr2 n1" "D1 \<in> carrier_mat nr2 n2" and
	c2: "A2 \<in> carrier_mat n1 nc1" "B2 \<in> carrier_mat n1 nc2" "C2 \<in> carrier_mat n2 nc1" "D2 \<in> carrier_mat n2 nc2"
	shows "four_block_mat A1 B1 C1 D1 * four_block_mat A2 B2 C2 D2
	= four_block_mat (A1 * A2 + B1 * C2) (A1 * B2 + B1 * D2)
	(C1 * A2 + D1 * C2) (C1 * B2 + D1 * D2)" (is "?M1 * ?M2 = _")
	proof -
	note row = row_four_block_mat[OF c1]
	note col = col_four_block_mat[OF c2]
	{
	fix i j
	assume i: "i < nr1" and j: "j < nc1"
	have "row ?M1 i \<bullet> col ?M2 j = row A1 i \<bullet> col A2 j + row B1 i \<bullet> col C2 j"
	unfolding row(1)[OF i] col(1)[OF j]
	by (rule scalar_prod_append[of _ n1 _ n2], insert c1 c2 i j, auto)
	}
	moreover
	{
	fix i j
	assume i: "\<not> i < nr1" "i < nr1 + nr2" and j: "j < nc1"
	hence i': "i - nr1 < nr2" by auto
	have "row ?M1 i \<bullet> col ?M2 j = row C1 (i - nr1) \<bullet> col A2 j + row D1 (i - nr1) \<bullet> col C2 j"
	unfolding row(2)[OF i] col(1)[OF j]
	by (rule scalar_prod_append[of _ n1 _ n2], insert c1 c2 i i' j, auto)
	}
	moreover
	{
	fix i j
	assume i: "i < nr1" and j: "\<not> j < nc1" "j < nc1 + nc2"
	hence j': "j - nc1 < nc2" by auto
	have "row ?M1 i \<bullet> col ?M2 j = row A1 i \<bullet> col B2 (j - nc1) + row B1 i \<bullet> col D2 (j - nc1)"
	unfolding row(1)[OF i] col(2)[OF j]
	by (rule scalar_prod_append[of _ n1 _ n2], insert c1 c2 i j' j, auto)
	}
	moreover
	{
	fix i j
	assume i: "\<not> i < nr1" "i < nr1 + nr2" and j: "\<not> j < nc1" "j < nc1 + nc2"
	hence i': "i - nr1 < nr2" and j': "j - nc1 < nc2" by auto
	have "row ?M1 i \<bullet> col ?M2 j = row C1 (i - nr1) \<bullet> col B2 (j - nc1) + row D1 (i - nr1) \<bullet> col D2 (j - nc1)"
	unfolding row(2)[OF i] col(2)[OF j]
	by (rule scalar_prod_append[of _ n1 _ n2], insert c1 c2 i i' j' j, auto)
	}
	ultimately show ?thesis
	by (intro eq_matI, insert c1 c2, auto)
	qed

	definition append_rows :: "'a :: zero mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" (infixr "@\<^sub>r" 65)where
	"A @\<^sub>r B = four_block_mat A (0\<^sub>m (dim_row A) 0) B (0\<^sub>m (dim_row B) 0)"

	lemma carrier_append_rows[simp,intro]: "A \<in> carrier_mat nr1 nc \<Longrightarrow> B \<in> carrier_mat nr2 nc \<Longrightarrow>
	A @\<^sub>r B \<in> carrier_mat (nr1 + nr2) nc"
	unfolding append_rows_def by auto

	lemma col_mult2[simp]:
	assumes A: "A : carrier_mat nr n"
	and B: "B : carrier_mat n nc"
	and j: "j < nc"
	shows "col (A * B) j = A *\<^sub>v col B j"
	proof
	have AB: "A * B : carrier_mat nr nc" using A B by auto
	fix i assume i: "i < dim_vec (A *\<^sub>v col B j)"
	show "col (A * B) j $ i = (A *\<^sub>v col B j) $ i"
	using A B AB j i by simp
	qed auto

	lemma mat_vec_as_mat_mat_mult: assumes A: "A \<in> carrier_mat nr nc"
	and v: "v \<in> carrier_vec nc"
	shows "A \<^sub>v v = col (A mat_of_cols nc [v]) 0"
	by (subst col_mult2[OF A], insert v, auto)

	lemma mat_mult_append: assumes A: "A \<in> carrier_mat nr1 nc"
	and B: "B \<in> carrier_mat nr2 nc"
	and v: "v \<in> carrier_vec nc"
	shows "(A @\<^sub>r B) \<^sub>v v = (A \<^sub>v v) @\<^sub>v (B *\<^sub>v v)"
	proof -
	let ?Fb1 = "four_block_mat A (0\<^sub>m nr1 0) B (0\<^sub>m nr2 0)"
	let ?Fb2 = "four_block_mat (mat_of_cols nc [v]) (0\<^sub>m nc 0) (0\<^sub>m 0 1) (0\<^sub>m 0 0)"
	have id: "?Fb2 = mat_of_cols nc [v]"
	using v by auto
	have "(A @\<^sub>r B) \<^sub>v v = col (?Fb1 ?Fb2) 0" unfolding id
	by (subst mat_vec_as_mat_mat_mult[OF _ v], insert A B, auto simp: append_rows_def)
	also have "?Fb1 * ?Fb2 = four_block_mat (A * mat_of_cols nc [v] + 0\<^sub>m nr1 0 * 0\<^sub>m 0 1) (A * 0\<^sub>m nc 0 + 0\<^sub>m nr1 0 * 0\<^sub>m 0 0)
	(B * mat_of_cols nc [v] + 0\<^sub>m nr2 0 * 0\<^sub>m 0 1) (B * 0\<^sub>m nc 0 + 0\<^sub>m nr2 0 * 0\<^sub>m 0 0)"
	by (rule mult_four_block_mat[OF A _ B], auto)
	also have "(A * mat_of_cols nc [v] + 0\<^sub>m nr1 0 * 0\<^sub>m 0 1) = A * mat_of_cols nc [v]"
	using A v by auto
	also have "(B * mat_of_cols nc [v] + 0\<^sub>m nr2 0 * 0\<^sub>m 0 1) = B * mat_of_cols nc [v]"
	using B v by auto
	also have "(A * 0\<^sub>m nc 0 + 0\<^sub>m nr1 0 * 0\<^sub>m 0 0) = 0\<^sub>m nr1 0" using A by auto
	also have "(B * 0\<^sub>m nc 0 + 0\<^sub>m nr2 0 * 0\<^sub>m 0 0) = 0\<^sub>m nr2 0" using B by auto
	finally have "(A @\<^sub>r B) \<^sub>v v = col (four_block_mat (A mat_of_cols nc [v]) (0\<^sub>m nr1 0) (B * mat_of_cols nc [v]) (0\<^sub>m nr2 0)) 0" .
	also have "\<dots> = col (A * mat_of_cols nc [v]) 0 @\<^sub>v col (B * mat_of_cols nc [v]) 0"
	by (rule col_four_block_mat, insert A B v, auto)
	also have "col (A * mat_of_cols nc [v]) 0 = A *\<^sub>v v"
	by (rule mat_vec_as_mat_mat_mult[symmetric, OF A v])
	also have "col (B * mat_of_cols nc [v]) 0 = B *\<^sub>v v"
	by (rule mat_vec_as_mat_mat_mult[symmetric, OF B v])
	finally show ?thesis .
	qed

	lemma append_rows_le: assumes A: "A \<in> carrier_mat nr1 nc"
	and B: "B \<in> carrier_mat nr2 nc"
	and a: "a \<in> carrier_vec nr1"
	and v: "v \<in> carrier_vec nc"
	shows "(A @\<^sub>r B) \<^sub>v v \<le> (a @\<^sub>v b) \<longleftrightarrow> A \<^sub>v v \<le> a \<and> B *\<^sub>v v \<le> b"
	unfolding mat_mult_append[OF A B v]
	by (rule append_vec_le[OF _ a], insert A v, auto)


	lemma elements_four_block_mat:
	assumes c: "A \<in> carrier_mat nr1 nc1" "B \<in> carrier_mat nr1 nc2"
	"C \<in> carrier_mat nr2 nc1" "D \<in> carrier_mat nr2 nc2"
	shows
	"elements_mat (four_block_mat A B C D) \<subseteq>
	elements_mat A \<union> elements_mat B \<union> elements_mat C \<union> elements_mat D"
	(is "elements_mat ?four \<subseteq> _")
	proof rule
	fix a assume "a \<in> elements_mat ?four"
	then obtain i j
	where i4: "i < dim_row ?four" and j4: "j < dim_col ?four" and a: "a = ?four $$ (i, j)"
	by auto
	show "a \<in> elements_mat A \<union> elements_mat B \<union> elements_mat C \<union> elements_mat D"
	proof (cases "i < nr1")
	case True note i1 = this
	show ?thesis
	proof (cases "j < nc1")
	case True
	then have "a = A $$ (i,j)" using c i1 a by simp
	thus ?thesis using c i1 True by auto next
	case False
	then have "a = B $$ (i,j-nc1)" using c i1 a j4 by simp
	moreover have "j - nc1 < nc2" using c j4 False by auto
	ultimately show ?thesis using c i1 by auto
	qed next
	case False note i1 = this
	have i2: "i - nr1 < nr2" using c i1 i4 by auto
	show ?thesis
	proof (cases "j < nc1")
	case True
	then have "a = C $$ (i-nr1,j)" using c i2 a i1 by simp
	thus ?thesis using c i2 True by auto next
	case False
	then have "a = D $$ (i-nr1,j-nc1)" using c i2 a i1 j4 by simp
	moreover have "j - nc1 < nc2" using c j4 False by auto
	ultimately show ?thesis using c i2 by auto
	qed
	qed
	qed

	lemma assoc_four_block_mat: fixes FB :: "'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a :: zero mat"
	defines FB: "FB \<equiv> \<lambda> Bb Cc. four_block_mat Bb (0\<^sub>m (dim_row Bb) (dim_col Cc)) (0\<^sub>m (dim_row Cc) (dim_col Bb)) Cc"
	shows "FB A (FB B C) = FB (FB A B) C" (is "?L = ?R")
	proof -
	let ?ar = "dim_row A" let ?ac = "dim_col A"
	let ?br = "dim_row B" let ?bc = "dim_col B"
	let ?cr = "dim_row C" let ?cc = "dim_col C"
	let ?r = "?ar + ?br + ?cr" let ?c = "?ac + ?bc + ?cc"
	let ?BC = "FB B C" let ?AB = "FB A B"
	have dL: "dim_row ?L = ?r" "dim_col ?L = ?c" unfolding FB by auto
	have dR: "dim_row ?R = ?ar + ?br + ?cr" "dim_col ?R = ?ac + ?bc + ?cc" unfolding FB by auto
	have dBC: "dim_row ?BC = ?br + ?cr" "dim_col ?BC = ?bc + ?cc" unfolding FB by auto
	have dAB: "dim_row ?AB = ?ar + ?br" "dim_col ?AB = ?ac + ?bc" unfolding FB by auto
	show ?thesis
	proof (intro eq_matI[of ?R ?L, unfolded dL dR, OF _ refl refl])
	fix i j
	assume i: "i < ?r" and j: "j < ?c"
	show "?L $$ (i,j) = ?R $$ (i,j)"
	proof (cases "i < ?ar")
	case True note i = this
	thus ?thesis using j
	by (cases "j < ?ac", auto simp: FB)
	next
	case False note ii = this
	show ?thesis
	proof (cases "j < ?ac")
	case True
	with i ii show ?thesis unfolding FB by auto
	next
	case False note jj = this
	from j jj i ii have L: "?L $$ (i,j) = ?BC $$ (i - ?ar, j - ?ac)" unfolding FB by auto
	have R: "?R $$ (i,j) = ?BC $$ (i - ?ar, j - ?ac)" using ii jj i j
	by (cases "i < ?ar + ?br"; cases "j < ?ac + ?bc", auto simp: FB)
	show ?thesis unfolding L R ..
	qed
	qed
	qed
	qed

	definition split_block :: "'a mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a mat \<times> 'a mat \<times> 'a mat \<times> 'a mat)"
	where "split_block A sr sc = (let
	nr = dim_row A; nc = dim_col A;
	nr2 = nr - sr; nc2 = nc - sc;
	A1 = mat sr sc (\<lambda> ij. A $$ ij);
	A2 = mat sr nc2 (\<lambda> (i,j). A $$ (i,j+sc));
	A3 = mat nr2 sc (\<lambda> (i,j). A $$ (i+sr,j));
	A4 = mat nr2 nc2 (\<lambda> (i,j). A $$ (i+sr,j+sc))
	in (A1,A2,A3,A4))"

	lemma split_block: assumes res: "split_block A sr1 sc1 = (A1,A2,A3,A4)"
	and dims: "dim_row A = sr1 + sr2" "dim_col A = sc1 + sc2"
	shows "A1 \<in> carrier_mat sr1 sc1" "A2 \<in> carrier_mat sr1 sc2"
	"A3 \<in> carrier_mat sr2 sc1" "A4 \<in> carrier_mat sr2 sc2"
	"A = four_block_mat A1 A2 A3 A4"
	using res unfolding split_block_def Let_def
	by (auto simp: dims)

	text \<open>Using @{const four_block_mat} we define block-diagonal matrices.\<close>

	fun diag_block_mat :: "'a :: zero mat list \<Rightarrow> 'a mat" where
	"diag_block_mat [] = 0\<^sub>m 0 0"
	\| "diag_block_mat (A # As) = (let
	B = diag_block_mat As
	in four_block_mat A (0\<^sub>m (dim_row A) (dim_col B)) (0\<^sub>m (dim_row B) (dim_col A)) B)"

	lemma dim_diag_block_mat:
	"dim_row (diag_block_mat As) = sum_list (map dim_row As)" (is "?row")
	"dim_col (diag_block_mat As) = sum_list (map dim_col As)" (is "?col")
	proof -
	have "?row \<and> ?col"
	by (induct As, auto simp: Let_def)
	thus ?row and ?col by auto
	qed

	lemma diag_block_mat_singleton[simp]: "diag_block_mat [A] = A"
	by auto

	lemma diag_block_mat_append: "diag_block_mat (As @ Bs) =
	(let A = diag_block_mat As; B = diag_block_mat Bs
	in four_block_mat A (0\<^sub>m (dim_row A) (dim_col B)) (0\<^sub>m (dim_row B) (dim_col A)) B)"
	unfolding Let_def
	proof (induct As)
	case (Cons A As)
	show ?case
	unfolding append.simps
	unfolding diag_block_mat.simps Let_def
	unfolding Cons
	by (rule assoc_four_block_mat)
	qed auto

	lemma diag_block_mat_last: "diag_block_mat (As @ [B]) =
	(let A = diag_block_mat As
	in four_block_mat A (0\<^sub>m (dim_row A) (dim_col B)) (0\<^sub>m (dim_row B) (dim_col A)) B)"
	unfolding diag_block_mat_append diag_block_mat_singleton by auto


	lemma diag_block_mat_square:
	"Ball (set As) square_mat \<Longrightarrow> square_mat (diag_block_mat As)"
	by (induct As, auto simp:Let_def)

	lemma diag_block_one_mat[simp]:
	"diag_block_mat (map (\<lambda>A. 1\<^sub>m (dim_row A)) As) = (1\<^sub>m (sum_list (map dim_row As)))"
	by (induct As, auto simp: Let_def)

	lemma elements_diag_block_mat:
	"elements_mat (diag_block_mat As) \<subseteq> {0} \<union> \<Union> (set (map elements_mat As))"
	proof (induct As)
	case Nil then show ?case using dim_diag_block_mat[of Nil] by auto next
	case (Cons A As)
	let ?D = "diag_block_mat As"
	let ?B = "0\<^sub>m (dim_row A) (dim_col ?D)"
	let ?C = "0\<^sub>m (dim_row ?D) (dim_col A)"
	have A: "A \<in> carrier_mat (dim_row A) (dim_col A)" by auto
	have B: "?B \<in> carrier_mat (dim_row A) (dim_col ?D)" by auto
	have C: "?C \<in> carrier_mat (dim_row ?D) (dim_col A)" by auto
	have D: "?D \<in> carrier_mat (dim_row ?D) (dim_col ?D)" by auto
	have
	"elements_mat (diag_block_mat (A#As)) \<subseteq>
	elements_mat A \<union> elements_mat ?B \<union> elements_mat ?C \<union> elements_mat ?D"
	unfolding diag_block_mat.simps Let_def
	using elements_four_block_mat[OF A B C D] elements_0_mat
	by auto
	also have "... \<subseteq> {0} \<union> elements_mat A \<union> elements_mat ?D"
	using elements_0_mat by auto
	finally show ?case using Cons by auto
	qed

	lemma diag_block_pow_mat: assumes sq: "Ball (set As) square_mat"
	shows "diag_block_mat As ^\<^sub>m n = diag_block_mat (map (\<lambda> A. A ^\<^sub>m n) As)" (is "?As ^\<^sub>m _ = _")
	proof (induct n)
	case 0
	have "?As ^\<^sub>m 0 = 1\<^sub>m (dim_row ?As)" by simp
	also have "dim_row ?As = sum_list (map dim_row As)"
	using diag_block_mat_square[OF sq] unfolding dim_diag_block_mat by auto
	also have "1\<^sub>m \<dots> = diag_block_mat (map (\<lambda>A. 1\<^sub>m (dim_row A)) As)" by simp
	also have "\<dots> = diag_block_mat (map (\<lambda> A. A ^\<^sub>m 0) As)" by simp
	finally show ?case .
	next
	case (Suc n)
	let ?An = "\<lambda> As. diag_block_mat (map (\<lambda>A. A ^\<^sub>m n) As)"
	let ?Asn = "\<lambda> As. diag_block_mat (map (\<lambda>A. A ^\<^sub>m n * A) As)"
	from Suc have "?case = (?An As * diag_block_mat As = ?Asn As)" by simp
	also have "\<dots>" using sq
	proof (induct As)
	case (Cons A As)
	hence IH: "?An As * diag_block_mat As = ?Asn As"
	and sq: "Ball (set As) square_mat" and A: "dim_col A = dim_row A" by auto
	have sq2: "Ball (set (List.map (\<lambda>A. A ^\<^sub>m n) As)) square_mat"
	and sq3: "Ball (set (List.map (\<lambda>A. A ^\<^sub>m n * A) As)) square_mat"
	using sq by auto
	define n1 where "n1 = dim_row A"
	define n2 where "n2 = sum_list (map dim_row As)"
	from A have A: "A \<in> carrier_mat n1 n1" unfolding n1_def carrier_mat_def by simp
	have [simp]: "dim_col (?An As) = n2" "dim_row (?An As) = n2"
	unfolding n2_def
	using diag_block_mat_square[OF sq2,unfolded square_mat.simps]
	unfolding dim_diag_block_mat map_map by (auto simp:o_def)
	have [simp]: "dim_col (?Asn As) = n2" "dim_row (?Asn As) = n2"
	unfolding n2_def
	using diag_block_mat_square[OF sq3,unfolded square_mat.simps]
	unfolding dim_diag_block_mat map_map by (auto simp:o_def)
	have [simp]:
	"dim_row (diag_block_mat As) = n2"
	"dim_col (diag_block_mat As) = n2"
	unfolding n2_def
	using diag_block_mat_square[OF sq,unfolded square_mat.simps]
	unfolding dim_diag_block_mat by auto

	have [simp]: "diag_block_mat As \<in> carrier_mat n2 n2" unfolding carrier_mat_def by simp
	have [simp]: "?An As \<in> carrier_mat n2 n2" unfolding carrier_mat_def by simp
	show ?case unfolding diag_block_mat.simps Let_def list.simps
	by (subst mult_four_block_mat[of _ n1 n1 _ n2 _ n2 _ _ n1 _ n2],
	insert A, auto simp: IH)
	qed auto
	finally show ?case by simp
	qed

	lemma diag_block_upper_triangular: assumes
	"\<And> A i j. A \<in> set As \<Longrightarrow> j < i \<Longrightarrow> i < dim_row A \<Longrightarrow> A $$ (i,j) = 0"
	and "Ball (set As) square_mat"
	and "j < i" "i < dim_row (diag_block_mat As)"
	shows "diag_block_mat As $$ (i,j) = 0"
	using assms
	proof (induct As arbitrary: i j)
	case (Cons A As i j)
	let ?n1 = "dim_row A"
	let ?n2 = "sum_list (map dim_row As)"
	from Cons have [simp]: "dim_col A = ?n1" by simp
	from Cons have "Ball (set As) square_mat" by auto
	note [simp] = diag_block_mat_square[OF this,unfolded square_mat.simps]
	note [simp] = dim_diag_block_mat(1)
	from Cons(5) have i: "i < ?n1 + ?n2" by simp
	show ?case
	proof (cases "i < ?n1")
	case True
	with Cons(4) have j: "j < ?n1" by auto
	with True Cons(2)[of A, OF _ Cons(4)] show ?thesis
	by (simp add: Let_def)
	next
	case False note iAs = this
	show ?thesis
	proof (cases "j < ?n1")
	case True
	with i iAs show ?thesis by (simp add: Let_def)
	next
	case False note jAs = this
	from Cons(4) i have j: "j < ?n1 + ?n2" by auto
	show ?thesis using iAs jAs i j
	by (simp add: Let_def, subst Cons(1), insert Cons(2-4), auto)
	qed
	qed
	qed simp

	lemma smult_four_block_mat: assumes c: "A \<in> carrier_mat nr1 nc1" "B \<in> carrier_mat nr1 nc2"
	"C \<in> carrier_mat nr2 nc1" "D \<in> carrier_mat nr2 nc2"
	shows "a \<cdot>\<^sub>m four_block_mat A B C D = four_block_mat (a \<cdot>\<^sub>m A) (a \<cdot>\<^sub>m B) (a \<cdot>\<^sub>m C) (a \<cdot>\<^sub>m D)"
	by (rule eq_matI, insert c, auto)

	lemma map_four_block_mat: assumes c: "A \<in> carrier_mat nr1 nc1" "B \<in> carrier_mat nr1 nc2"
	"C \<in> carrier_mat nr2 nc1" "D \<in> carrier_mat nr2 nc2"
	shows "map_mat f (four_block_mat A B C D) = four_block_mat (map_mat f A) (map_mat f B) (map_mat f C) (map_mat f D)"
	by (rule eq_matI, insert c, auto)

	lemma add_four_block_mat: assumes
	c1: "A1 \<in> carrier_mat nr1 nc1" "B1 \<in> carrier_mat nr1 nc2" "C1 \<in> carrier_mat nr2 nc1" "D1 \<in> carrier_mat nr2 nc2" and
	c2: "A2 \<in> carrier_mat nr1 nc1" "B2 \<in> carrier_mat nr1 nc2" "C2 \<in> carrier_mat nr2 nc1" "D2 \<in> carrier_mat nr2 nc2"
	shows "four_block_mat A1 B1 C1 D1 + four_block_mat A2 B2 C2 D2
	= four_block_mat (A1 + A2) (B1 + B2) (C1 + C2) (D1 + D2)"
	by (rule eq_matI, insert assms, auto)


	lemma diag_four_block_mat: assumes c: "A \<in> carrier_mat n1 n1"
	"D \<in> carrier_mat n2 n2"
	shows "diag_mat (four_block_mat A B C D) = diag_mat A @ diag_mat D"
	by (rule nth_equalityI, insert c, auto simp: diag_mat_def nth_append)

	definition mk_diagonal :: "'a::zero list \<Rightarrow> 'a mat"
	where "mk_diagonal as = diag_block_mat (map (\<lambda>a. mat (Suc 0) (Suc 0) (\<lambda>_. a)) as)"

	lemma mk_diagonal_dim:
	"dim_row (mk_diagonal as) = length as" "dim_col (mk_diagonal as) = length as"
	unfolding mk_diagonal_def by(induct as, auto simp: Let_def)

	lemma mk_diagonal_diagonal: "diagonal_mat (mk_diagonal as)"
	unfolding mk_diagonal_def
	proof (induct as)
	case Nil show ?case unfolding mk_diagonal_def diagonal_mat_def by simp next
	case (Cons a as)
	let ?n = "length (a#as)"
	let ?A = "mat (Suc 0) (Suc 0) (\<lambda>_. a)"
	let ?f = "map (\<lambda>a. mat (Suc 0) (Suc 0) (\<lambda>_. a))"
	let ?AS = "diag_block_mat (?f as)"
	let ?AAS = "diag_block_mat (?f (a#as))"
	show ?case
	unfolding diagonal_mat_def
	proof(intro allI impI)
	fix i j assume ir: "i < dim_row ?AAS" and jc: "j < dim_col ?AAS" and ij: "i \<noteq> j"
	hence ir2: "i < 1 + dim_row ?AS" and jc2: "j < 1 + dim_col ?AS"
	unfolding dim_row_mat list.map diag_block_mat.simps Let_def
	by auto
	show "?AAS $$ (i,j) = 0"
	proof (cases "i = 0")
	case True
	then show ?thesis using jc ij by (auto simp: Let_def) next
	case False note i0 = this
	show ?thesis
	proof (cases "j = 0")
	case True
	then show ?thesis using ir ij by (auto simp: Let_def) next
	case False
	have ir3: "i-1 < dim_row ?AS" and jc3: "j-1 < dim_col ?AS"
	using ir2 jc2 i0 False by auto
	have IH: "\<And>i j. i < dim_row ?AS \<Longrightarrow> j < dim_col ?AS \<Longrightarrow> i \<noteq> j \<Longrightarrow>
	?AS $$ (i,j) = 0"
	using Cons unfolding diagonal_mat_def by auto
	have "?AS $$ (i-1,j-1) = 0"
	using IH[OF ir3 jc3] i0 False ij by auto
	thus ?thesis using ir jc ij by (simp add: Let_def)
	qed
	qed
	qed
	qed

	definition orthogonal_mat :: "'a::semiring_0 mat \<Rightarrow> bool"
	where "orthogonal_mat A \<equiv>
	let B = transpose_mat A * A in
	diagonal_mat B \<and> (\<forall>i<dim_col A. B $$ (i,i) \<noteq> 0)"

	lemma orthogonal_matD[elim]:
	"orthogonal_mat A \<Longrightarrow>
	i < dim_col A \<Longrightarrow> j < dim_col A \<Longrightarrow> (col A i \<bullet> col A j = 0) = (i \<noteq> j)"
	unfolding orthogonal_mat_def diagonal_mat_def by auto

	lemma orthogonal_matI[intro]:
	"(\<And>i j. i < dim_col A \<Longrightarrow> j < dim_col A \<Longrightarrow> (col A i \<bullet> col A j = 0) = (i \<noteq> j)) \<Longrightarrow>
	orthogonal_mat A"
	unfolding orthogonal_mat_def diagonal_mat_def by auto

	definition orthogonal :: "'a::semiring_0 vec list \<Rightarrow> bool"
	where "orthogonal vs \<equiv>
	\<forall>i j. i < length vs \<longrightarrow> j < length vs \<longrightarrow>
	(vs ! i \<bullet> vs ! j = 0) = (i \<noteq> j)"

	lemma orthogonalD[elim]:
	"orthogonal vs \<Longrightarrow> i < length vs \<Longrightarrow> j < length vs \<Longrightarrow>
	(nth vs i \<bullet> nth vs j = 0) = (i \<noteq> j)"
	unfolding orthogonal_def by auto

	lemma orthogonalI[intro]:
	"(\<And>i j. i < length vs \<Longrightarrow> j < length vs \<Longrightarrow> (nth vs i \<bullet> nth vs j = 0) = (i \<noteq> j)) \<Longrightarrow>
	orthogonal vs"
	unfolding orthogonal_def by auto


	lemma transpose_four_block_mat: assumes *: "A \<in> carrier_mat nr1 nc1" "B \<in> carrier_mat nr1 nc2"
	"C \<in> carrier_mat nr2 nc1" "D \<in> carrier_mat nr2 nc2"
	shows "transpose_mat (four_block_mat A B C D) =
	four_block_mat (transpose_mat A) (transpose_mat C) (transpose_mat B) (transpose_mat D)"
	by (rule eq_matI, insert *, auto)

	lemma zero_transpose_mat[simp]: "transpose_mat (0\<^sub>m n m) = (0\<^sub>m m n)"
	by (rule eq_matI, auto)

	lemma upper_triangular_four_block: assumes AD: "A \<in> carrier_mat n n" "D \<in> carrier_mat m m"
	and ut: "upper_triangular A" "upper_triangular D"
	shows "upper_triangular (four_block_mat A B (0\<^sub>m m n) D)"
	proof -
	let ?C = "four_block_mat A B (0\<^sub>m m n) D"
	from AD have dim: "dim_row ?C = n + m" "dim_col ?C = n + m" "dim_row A = n" by auto
	show ?thesis
	proof (rule upper_triangularI, unfold dim)
	fix i j
	assume *: "j < i" "i < n + m"
	show "?C $$ (i,j) = 0"
	proof (cases "i < n")
	case True
	with upper_triangularD[OF ut(1) (1)] AD show ?thesis by auto
	next
	case False note i = this
	show ?thesis by (cases "j < n", insert upper_triangularD[OF ut(2)] * i AD, auto)
	qed
	qed
	qed

	lemma pow_four_block_mat: assumes A: "A \<in> carrier_mat n n"
	and B: "B \<in> carrier_mat m m"
	shows "(four_block_mat A (0\<^sub>m n m) (0\<^sub>m m n) B) ^\<^sub>m k =
	four_block_mat (A ^\<^sub>m k) (0\<^sub>m n m) (0\<^sub>m m n) (B ^\<^sub>m k)"
	proof (induct k)
	case (Suc k)
	let ?FB = "\<lambda> A B. four_block_mat A (0\<^sub>m n m) (0\<^sub>m m n) B"
	let ?A = "?FB A B"
	let ?B = "?FB (A ^\<^sub>m k) (B ^\<^sub>m k)"
	from A B have Ak: "A ^\<^sub>m k \<in> carrier_mat n n" and Bk: "B ^\<^sub>m k \<in> carrier_mat m m" by auto
	have "?A ^\<^sub>m Suc k = ?A ^\<^sub>m k * ?A" by simp
	also have "?A ^\<^sub>m k = ?B " by (rule Suc)
	also have "?B * ?A = ?FB (A ^\<^sub>m Suc k) (B ^\<^sub>m Suc k)"
	by (subst mult_four_block_mat[OF Ak _ _ Bk A _ _ B], insert A B, auto)
	finally show ?case .
	qed (insert A B, auto)

	lemma uminus_scalar_prod:
	assumes [simp]: "v : carrier_vec n" "w : carrier_vec n"
	shows "- ((v::'a::field vec) \<bullet> w) = (- v) \<bullet> w"
	unfolding scalar_prod_def uminus_vec_def
	apply (subst sum_negf[symmetric])
	proof (rule sum.cong[OF refl])
	fix i assume i: "i : {0 ..<dim_vec w}"
	have [simp]: "dim_vec v = n" "dim_vec w = n" by auto
	show "- (v $ i * w $ i) = vec (dim_vec v) (\<lambda>i. - v $ i) $ i * w $ i"
	unfolding minus_mult_left using i by auto
	qed


	lemma append_vec_eq:
	assumes [simp]: "v : carrier_vec n" "v' : carrier_vec n"
	shows [simp]: "v @\<^sub>v w = v' @\<^sub>v w' \<longleftrightarrow> v = v' \<and> w = w'" (is "?L \<longleftrightarrow> ?R")
	proof
	have [simp]: "dim_vec v = n" "dim_vec v' = n" by auto
	{ assume L: ?L
	have vv': "v = v'"
	proof
	fix i assume i: "i < dim_vec v'"
	have "(v @\<^sub>v w) $ i = (v' @\<^sub>v w') $ i" using L by auto
	thus "v $ i = v' $ i" using i by auto
	qed auto
	moreover have "w = w'"
	proof
	show "dim_vec w = dim_vec w'" using vv' L
	by (metis add_diff_cancel_left' index_append_vec(2))
	moreover fix i assume i: "i < dim_vec w'"
	have "(v @\<^sub>v w) $ (n + i) = (v' @\<^sub>v w') $ (n + i)" using L by auto
	ultimately show "w $ i = w' $ i" using i by simp
	qed
	ultimately show ?R by simp
	}
	qed auto

	lemma append_vec_add:
	assumes [simp]: "v : carrier_vec n" "v' : carrier_vec n"
	and [simp]: "w : carrier_vec m" "w' : carrier_vec m"
	shows "(v @\<^sub>v w) + (v' @\<^sub>v w') = (v + v') @\<^sub>v (w + w')" (is "?L = ?R")
	proof
	have [simp]: "dim_vec v = n" "dim_vec v' = n" by auto
	have [simp]: "dim_vec w = m" "dim_vec w' = m" by auto
	fix i assume i: "i < dim_vec ?R"
	thus "?L $ i = ?R $ i" by (cases "i < n",auto)
	qed auto

	+lemma four_block_mat_mult_vec:
	+ assumes A: "A : carrier_mat nr1 nc1"
	+ and B: "B : carrier_mat nr1 nc2"
	+ and C: "C : carrier_mat nr2 nc1"
	+ and D: "D : carrier_mat nr2 nc2"
	+ and a: "a : carrier_vec nc1"
	+ and d: "d : carrier_vec nc2"
	+ shows "four_block_mat A B C D \<^sub>v (a @\<^sub>v d) = (A \<^sub>v a + B \<^sub>v d) @\<^sub>v (C \<^sub>v a + D *\<^sub>v d)"
	+ (is "?ABCD *\<^sub>v _ = ?r")
	+proof
	+ have ABCD: "?ABCD : carrier_mat (nr1+nr2) (nc1+nc2)" using four_block_carrier_mat[OF A D].
	+ fix i assume i: "i < dim_vec ?r"
	+ show "(?ABCD *\<^sub>v (a @\<^sub>v d)) $ i = ?r $ i" (is "?li = _")
	+ proof (cases "i < nr1")
	+ case True
	+ have "?li = (row A i @\<^sub>v row B i) \<bullet> (a @\<^sub>v d)"
	+ using A row_four_block_mat[OF A B C D] True by simp
	+ also have "... = row A i \<bullet> a + row B i \<bullet> d"
	+ apply (rule scalar_prod_append) using A B D a d True by auto
	+ finally show ?thesis using A B True by auto
	+ next case False
	+ let ?i = "i - nr1"
	+ have "?li = (row C ?i @\<^sub>v row D ?i) \<bullet> (a @\<^sub>v d)"
	+ using i row_four_block_mat[OF A B C D] False A B C D by simp
	+ also have "... = row C ?i \<bullet> a + row D ?i \<bullet> d"
	+ apply (rule scalar_prod_append) using A B C D a d False by auto
	+ finally show ?thesis using A B C D False i by auto
	+ qed
	+qed (insert A B, auto)

	lemma mult_mat_vec_split:
	assumes A: "A : carrier_mat n n"
	and D: "D : carrier_mat m m"
	and a: "a : carrier_vec n"
	and d: "d : carrier_vec m"
	shows "four_block_mat A (0\<^sub>m n m) (0\<^sub>m m n) D \<^sub>v (a @\<^sub>v d) = A \<^sub>v a @\<^sub>v D *\<^sub>v d"
	- (is "?A00D *\<^sub>v _ = ?r")
	-proof
	- have A00D: "?A00D : carrier_mat (n+m) (n+m)" using four_block_carrier_mat[OF A D].
	- fix i assume i: "i < dim_vec ?r"
	- show "(?A00D *\<^sub>v (a @\<^sub>v d)) $ i = ?r $ i" (is "?li = _")
	- proof (cases "i < n")
	- case True
	- have "?li = (row A i @\<^sub>v 0\<^sub>v m) \<bullet> (a @\<^sub>v d)"
	- using A row_four_block_mat[OF A _ _ D] True by simp
	- also have "... = row A i \<bullet> a + 0\<^sub>v m \<bullet> d"
	- apply (rule scalar_prod_append) using A D a d True by auto
	- also have "... = row A i \<bullet> a" using d by simp
	- finally show ?thesis using A True by auto
	- next case False
	- let ?i = "i - n"
	- have "?li = (0\<^sub>v n @\<^sub>v row D ?i) \<bullet> (a @\<^sub>v d)"
	- using i row_four_block_mat[OF A _ _ D] False A D by simp
	- also have "... = 0\<^sub>v n \<bullet> a + row D ?i \<bullet> d"
	- apply (rule scalar_prod_append) using A D a d False by auto
	- also have "... = row D ?i \<bullet> d" using a by simp
	- finally show ?thesis using A D False i by auto
	- qed
	-qed auto
	+ by (subst four_block_mat_mult_vec[OF A _ _ D a d], insert A D a d, auto)

	lemma similar_mat_witI: assumes "P * Q = 1\<^sub>m n" "Q * P = 1\<^sub>m n" "A = P * B * Q"
	"A \<in> carrier_mat n n" "B \<in> carrier_mat n n" "P \<in> carrier_mat n n" "Q \<in> carrier_mat n n"
	shows "similar_mat_wit A B P Q" using assms unfolding similar_mat_wit_def Let_def by auto

	lemma similar_mat_witD: assumes "n = dim_row A" "similar_mat_wit A B P Q"
	shows "P * Q = 1\<^sub>m n" "Q * P = 1\<^sub>m n" "A = P * B * Q"
	"A \<in> carrier_mat n n" "B \<in> carrier_mat n n" "P \<in> carrier_mat n n" "Q \<in> carrier_mat n n"
	using assms(2) unfolding similar_mat_wit_def Let_def assms(1)[symmetric] by auto

	lemma similar_mat_witD2: assumes "A \<in> carrier_mat n m" "similar_mat_wit A B P Q"
	shows "P * Q = 1\<^sub>m n" "Q * P = 1\<^sub>m n" "A = P * B * Q"
	"A \<in> carrier_mat n n" "B \<in> carrier_mat n n" "P \<in> carrier_mat n n" "Q \<in> carrier_mat n n"
	using similar_mat_witD[OF _ assms(2), of n] assms(1)[unfolded carrier_mat_def] by auto

	lemma similar_mat_wit_sym: assumes sim: "similar_mat_wit A B P Q"
	shows "similar_mat_wit B A Q P"
	proof -
	from similar_mat_witD[OF refl sim] obtain n where
	AB: "{A, B, P, Q} \<subseteq> carrier_mat n n" "P * Q = 1\<^sub>m n" "Q * P = 1\<^sub>m n" and A: "A = P * B * Q" by blast
	hence : "{B, A, Q, P} \<subseteq> carrier_mat n n" "Q P = 1\<^sub>m n" "P * Q = 1\<^sub>m n" by auto
	let ?c = "\<lambda> A. A \<in> carrier_mat n n"
	from * have Carr: "?c B" "?c P" "?c Q" by auto
	note [simp] = assoc_mult_mat[of _ n n _ n _ n]
	show ?thesis
	proof (rule similar_mat_witI[of _ _ n])
	have "Q * A * P = (Q * P) * B * (Q * P)"
	using Carr unfolding A by simp
	also have "\<dots> = B" using Carr unfolding AB by simp
	finally show "B = Q * A * P" by simp
	qed (insert * AB, auto)
	qed

	lemma similar_mat_wit_refl: assumes A: "A \<in> carrier_mat n n"
	shows "similar_mat_wit A A (1\<^sub>m n) (1\<^sub>m n)"
	by (rule similar_mat_witI[OF _ _ _ A], insert A, auto)

	lemma similar_mat_wit_trans: assumes AB: "similar_mat_wit A B P Q"
	and BC: "similar_mat_wit B C P' Q'"
	shows "similar_mat_wit A C (P * P') (Q' * Q)"
	proof -
	from similar_mat_witD[OF refl AB] obtain n where
	AB: "{A, B, P, Q} \<subseteq> carrier_mat n n" "P * Q = 1\<^sub>m n" "Q * P = 1\<^sub>m n" "A = P * B * Q" by blast
	hence B: "B \<in> carrier_mat n n" by auto
	from similar_mat_witD2[OF B BC] have
	BC: "{C, P', Q'} \<subseteq> carrier_mat n n" "P' * Q' = 1\<^sub>m n" "Q' * P' = 1\<^sub>m n" "B = P' * C * Q'" by auto
	let ?c = "\<lambda> A. A \<in> carrier_mat n n"
	let ?P = "P * P'"
	let ?Q = "Q' * Q"
	from AB BC have carr: "?c A" "?c B" "?c C" "?c P" "?c P'" "?c Q" "?c Q'"
	and Carr: "{A, C, ?P, ?Q} \<subseteq> carrier_mat n n" by auto
	note [simp] = assoc_mult_mat[of _ n n _ n _ n]
	have id: "A = ?P * C * ?Q" unfolding AB(4)[unfolded BC(4)] using carr
	by simp
	have "?P * ?Q = P * (P' * Q') * Q" using carr by simp
	also have "\<dots> = 1\<^sub>m n" unfolding BC using carr AB by simp
	finally have PQ: "?P * ?Q = 1\<^sub>m n" .
	have "?Q * ?P = Q' * (Q * P) * P'" using carr by simp
	also have "\<dots> = 1\<^sub>m n" unfolding AB using carr BC by simp
	finally have QP: "?Q * ?P = 1\<^sub>m n" .
	show ?thesis
	by (rule similar_mat_witI[OF PQ QP id], insert Carr, auto)
	qed

	lemma similar_mat_refl: "A \<in> carrier_mat n n \<Longrightarrow> similar_mat A A"
	using similar_mat_wit_refl unfolding similar_mat_def by blast

	lemma similar_mat_trans: "similar_mat A B \<Longrightarrow> similar_mat B C \<Longrightarrow> similar_mat A C"
	using similar_mat_wit_trans unfolding similar_mat_def by blast

	lemma similar_mat_sym: "similar_mat A B \<Longrightarrow> similar_mat B A"
	using similar_mat_wit_sym unfolding similar_mat_def by blast

	lemma similar_mat_wit_four_block: assumes
	1: "similar_mat_wit A1 B1 P1 Q1"
	and 2: "similar_mat_wit A2 B2 P2 Q2"
	and URA: "URA = (P1 * UR * Q2)"
	and LLA: "LLA = (P2 * LL * Q1)"
	and A1: "A1 \<in> carrier_mat n n"
	and A2: "A2 \<in> carrier_mat m m"
	and LL: "LL \<in> carrier_mat m n"
	and UR: "UR \<in> carrier_mat n m"
	shows "similar_mat_wit (four_block_mat A1 URA LLA A2) (four_block_mat B1 UR LL B2)
	(four_block_mat P1 (0\<^sub>m n m) (0\<^sub>m m n) P2) (four_block_mat Q1 (0\<^sub>m n m) (0\<^sub>m m n) Q2)"
	(is "similar_mat_wit ?A ?B ?P ?Q")
	proof -
	let ?n = "n + m"
	let ?O1 = "1\<^sub>m n" let ?O2 = "1\<^sub>m m" let ?O = "1\<^sub>m ?n"
	from similar_mat_witD2[OF A1 1] have 11: "P1 * Q1 = ?O1" "Q1 * P1 = ?O1"
	and P1: "P1 \<in> carrier_mat n n" and Q1: "Q1 \<in> carrier_mat n n"
	and B1: "B1 \<in> carrier_mat n n" and 1: "A1 = P1 * B1 * Q1" by auto
	from similar_mat_witD2[OF A2 2] have 21: "P2 * Q2 = ?O2" "Q2 * P2 = ?O2"
	and P2: "P2 \<in> carrier_mat m m" and Q2: "Q2 \<in> carrier_mat m m"
	and B2: "B2 \<in> carrier_mat m m" and 2: "A2 = P2 * B2 * Q2" by auto
	have PQ1: "?P * ?Q = ?O"
	by (subst mult_four_block_mat[OF P1 _ _ P2 Q1 _ _ Q2], unfold 11 21, insert P1 P2 Q1 Q2,
	auto intro!: eq_matI)
	have QP1: "?Q * ?P = ?O"
	by (subst mult_four_block_mat[OF Q1 _ _ Q2 P1 _ _ P2], unfold 11 21, insert P1 P2 Q1 Q2,
	auto intro!: eq_matI)
	let ?PB = "?P * ?B"
	have P: "?P \<in> carrier_mat ?n ?n" using P1 P2 by auto
	have Q: "?Q \<in> carrier_mat ?n ?n" using Q1 Q2 by auto
	have B: "?B \<in> carrier_mat ?n ?n" using B1 UR LL B2 by auto
	have PB: "?PB \<in> carrier_mat ?n ?n" using P B by auto
	have PB1: "P1 * B1 \<in> carrier_mat n n" using P1 B1 by auto
	have PB2: "P2 * B2 \<in> carrier_mat m m" using P2 B2 by auto
	have P1UR: "P1 * UR \<in> carrier_mat n m" using P1 UR by auto
	have P2LL: "P2 * LL \<in> carrier_mat m n" using P2 LL by auto
	have id: "?PB = four_block_mat (P1 * B1) (P1 * UR) (P2 * LL) (P2 * B2)"
	by (subst mult_four_block_mat[OF P1 _ _ P2 B1 UR LL B2], insert P1 P2 B1 B2 LL UR, auto)
	have id: "?PB * ?Q = four_block_mat (P1 * B1 * Q1) (P1 * UR * Q2)
	(P2 * LL * Q1) (P2 * B2 * Q2)" unfolding id
	by (subst mult_four_block_mat[OF PB1 P1UR P2LL PB2 Q1 _ _ Q2],
	insert P1 P2 B1 B2 Q1 Q2 UR LL, auto)
	have id: "?A = ?P * ?B * ?Q" unfolding id 1 2 URA LLA ..
	show ?thesis
	by (rule similar_mat_witI[OF PQ1 QP1 id], insert A1 A2 B1 B2 Q1 Q2 P1 P2, auto)
	qed


	lemma similar_mat_four_block_0_ex: assumes
	1: "similar_mat A1 B1"
	and 2: "similar_mat A2 B2"
	and A0: "A0 \<in> carrier_mat n m"
	and A1: "A1 \<in> carrier_mat n n"
	and A2: "A2 \<in> carrier_mat m m"
	shows "\<exists> B0. B0 \<in> carrier_mat n m \<and> similar_mat (four_block_mat A1 A0 (0\<^sub>m m n) A2)
	(four_block_mat B1 B0 (0\<^sub>m m n) B2)"
	proof -
	from 1[unfolded similar_mat_def] obtain P1 Q1 where 1: "similar_mat_wit A1 B1 P1 Q1" by auto
	note w1 = similar_mat_witD2[OF A1 1]
	from 2[unfolded similar_mat_def] obtain P2 Q2 where 2: "similar_mat_wit A2 B2 P2 Q2" by auto
	note w2 = similar_mat_witD2[OF A2 2]
	from w1 w2 have C: "B1 \<in> carrier_mat n n" "B2 \<in> carrier_mat m m" by auto
	from w1 w2 have id: "0\<^sub>m m n = Q2 * 0\<^sub>m m n * P1" by simp
	let ?wit = "Q1 * A0 * P2"
	from w1 w2 A0 have wit: "?wit \<in> carrier_mat n m" by auto
	from similar_mat_wit_sym[OF similar_mat_wit_four_block[OF similar_mat_wit_sym[OF 1] similar_mat_wit_sym[OF 2]
	refl id C zero_carrier_mat A0]]
	have "similar_mat (four_block_mat A1 A0 (0\<^sub>m m n) A2) (four_block_mat B1 (Q1 * A0 * P2) (0\<^sub>m m n) B2)"
	unfolding similar_mat_def by auto
	thus ?thesis using wit by auto
	qed

	lemma similar_mat_four_block_0_0: assumes
	1: "similar_mat A1 B1"
	and 2: "similar_mat A2 B2"
	and A1: "A1 \<in> carrier_mat n n"
	and A2: "A2 \<in> carrier_mat m m"
	shows "similar_mat (four_block_mat A1 (0\<^sub>m n m) (0\<^sub>m m n) A2)
	(four_block_mat B1 (0\<^sub>m n m) (0\<^sub>m m n) B2)"
	proof -
	from 1[unfolded similar_mat_def] obtain P1 Q1 where 1: "similar_mat_wit A1 B1 P1 Q1" by auto
	note w1 = similar_mat_witD2[OF A1 1]
	from 2[unfolded similar_mat_def] obtain P2 Q2 where 2: "similar_mat_wit A2 B2 P2 Q2" by auto
	note w2 = similar_mat_witD2[OF A2 2]
	from w1 w2 have C: "B1 \<in> carrier_mat n n" "B2 \<in> carrier_mat m m" by auto
	from w1 w2 have id: "0\<^sub>m m n = Q2 * 0\<^sub>m m n * P1" by simp
	from w1 w2 have id2: "0\<^sub>m n m = Q1 * 0\<^sub>m n m * P2" by simp
	from similar_mat_wit_sym[OF similar_mat_wit_four_block[OF similar_mat_wit_sym[OF 1] similar_mat_wit_sym[OF 2]
	id2 id C zero_carrier_mat zero_carrier_mat]]
	show ?thesis unfolding similar_mat_def by blast
	qed

	lemma similar_diag_mat_block_mat: assumes "\<And> A B. (A,B) \<in> set Ms \<Longrightarrow> similar_mat A B"
	shows "similar_mat (diag_block_mat (map fst Ms)) (diag_block_mat (map snd Ms))"
	using assms
	proof (induct Ms)
	case Nil
	show ?case by (auto intro!: similar_mat_refl[of _ 0])
	next
	case (Cons AB Ms)
	obtain A B where AB: "AB = (A,B)" by force
	from Cons(2)[of A B] have simAB: "similar_mat A B" unfolding AB by auto
	from similar_matD[OF this] obtain n where A: "A \<in> carrier_mat n n" and B: "B \<in> carrier_mat n n" by auto
	hence [simp]: "dim_row A = n" "dim_col A = n" "dim_row B = n" "dim_col B = n" by auto
	let ?C = "diag_block_mat (map fst Ms)" let ?D = "diag_block_mat (map snd Ms)"
	from Cons(1)[OF Cons(2)] have simRec: "similar_mat ?C ?D" by auto
	from similar_matD[OF this] obtain m where C: "?C \<in> carrier_mat m m" and D: "?D \<in> carrier_mat m m" by auto
	hence [simp]: "dim_row ?C = m" "dim_col ?C = m" "dim_row ?D = m" "dim_col ?D = m" by auto
	have "similar_mat (diag_block_mat (map fst (AB # Ms))) (diag_block_mat (map snd (AB # Ms)))
	= similar_mat (four_block_mat A (0\<^sub>m n m) (0\<^sub>m m n) ?C) (four_block_mat B (0\<^sub>m n m) (0\<^sub>m m n) ?D)"
	unfolding AB by (simp add: Let_def)
	also have "\<dots>"
	by (rule similar_mat_four_block_0_0[OF simAB simRec A C])
	finally show ?case .
	qed

	lemma similar_mat_wit_pow: assumes wit: "similar_mat_wit A B P Q"
	shows "similar_mat_wit (A ^\<^sub>m k) (B ^\<^sub>m k) P Q"
	proof -
	define n where "n = dim_row A"
	let ?C = "carrier_mat n n"
	from similar_mat_witD[OF refl wit, folded n_def] have
	A: "A \<in> ?C" and B: "B \<in> ?C" and P: "P \<in> ?C" and Q: "Q \<in> ?C"
	and PQ: "P * Q = 1\<^sub>m n" and QP: "Q * P = 1\<^sub>m n"
	and AB: "A = P * B * Q"
	by auto
	from A B have *: "(A ^\<^sub>m k) \<in> carrier_mat n n" "B ^\<^sub>m k \<in> carrier_mat n n" by auto
	note carr = A B P Q
	have id: "A ^\<^sub>m k = P * B ^\<^sub>m k * Q" unfolding AB
	proof (induct k)
	case 0
	thus ?case using carr by (simp add: PQ)
	next
	case (Suc k)
	define Bk where "Bk = B ^\<^sub>m k"
	have Bk: "Bk \<in> carrier_mat n n" unfolding Bk_def using carr by simp
	have "(P * B * Q) ^\<^sub>m Suc k = (P * Bk * Q) * (P * B * Q)" by (simp add: Suc Bk_def)
	also have "\<dots> = P * (Bk * (Q * P) * B) * Q"
	using carr Bk by (simp add: assoc_mult_mat[of _ n n _ n _ n])
	also have "Bk * (Q * P) = Bk" unfolding QP using Bk by simp
	finally show ?case unfolding Bk_def by simp
	qed
	show ?thesis
	by (rule similar_mat_witI[OF PQ QP id * P Q])
	qed

	lemma similar_mat_wit_pow_id: "similar_mat_wit A B P Q \<Longrightarrow> A ^\<^sub>m k = P * B ^\<^sub>m k * Q"
	using similar_mat_wit_pow[of A B P Q k] unfolding similar_mat_wit_def Let_def by blast

	subsection\<open>Homomorphism properties\<close>

	context semiring_hom
	begin
	abbreviation mat_hom :: "'a mat \<Rightarrow> 'b mat" ("mat\<^sub>h")
	where "mat\<^sub>h \<equiv> map_mat hom"

	abbreviation vec_hom :: "'a vec \<Rightarrow> 'b vec" ("vec\<^sub>h")
	where "vec\<^sub>h \<equiv> map_vec hom"

	lemma vec_hom_zero: "vec\<^sub>h (0\<^sub>v n) = 0\<^sub>v n"
	by (rule eq_vecI, auto)

	lemma mat_hom_one: "mat\<^sub>h (1\<^sub>m n) = 1\<^sub>m n"
	by (rule eq_matI, auto)

	lemma mat_hom_mult: assumes A: "A \<in> carrier_mat nr n" and B: "B \<in> carrier_mat n nc"
	shows "mat\<^sub>h (A * B) = mat\<^sub>h A * mat\<^sub>h B"
	proof -
	let ?L = "mat\<^sub>h (A * B)"
	let ?R = "mat\<^sub>h A * mat\<^sub>h B"
	let ?A = "mat\<^sub>h A"
	let ?B = "mat\<^sub>h B"
	from A B have id:
	"dim_row ?L = nr" "dim_row ?R = nr"
	"dim_col ?L = nc" "dim_col ?R = nc" by auto
	show ?thesis
	proof (rule eq_matI, unfold id)
	fix i j
	assume *: "i < nr" "j < nc"
	define I where "I = {0 ..< n}"
	have id: "{0 ..< dim_vec (col ?B j)} = I" "{0 ..< dim_vec (col B j)} = I"
	unfolding I_def using * B by auto
	have finite: "finite I" unfolding I_def by auto
	have I: "I \<subseteq> {0 ..< n}" unfolding I_def by auto
	have "?L $$ (i,j) = hom (row A i \<bullet> col B j)" using A B * by auto
	also have "\<dots> = row ?A i \<bullet> col ?B j" unfolding scalar_prod_def id using finite I
	proof (induct I)
	case (insert k I)
	show ?case unfolding sum.insert[OF insert(1-2)] hom_add hom_mult
	using insert(3-) * A B by auto
	qed simp
	also have "\<dots> = ?R $$ (i,j)" using A B * by auto
	finally
	show "?L $$ (i, j) = ?R $$ (i, j)" .
	qed auto
	qed

	lemma mult_mat_vec_hom: assumes A: "A \<in> carrier_mat nr n" and v: "v \<in> carrier_vec n"
	shows "vec\<^sub>h (A \<^sub>v v) = mat\<^sub>h A \<^sub>v vec\<^sub>h v"
	proof -
	let ?L = "vec\<^sub>h (A *\<^sub>v v)"
	let ?R = "mat\<^sub>h A *\<^sub>v vec\<^sub>h v"
	let ?A = "mat\<^sub>h A"
	let ?v = "vec\<^sub>h v"
	from A v have id:
	"dim_vec ?L = nr" "dim_vec ?R = nr"
	by auto
	show ?thesis
	proof (rule eq_vecI, unfold id)
	fix i
	assume *: "i < nr"
	define I where "I = {0 ..< n}"
	have id: "{0 ..< dim_vec v} = I" "{0 ..< dim_vec (vec\<^sub>h v)} = I"
	unfolding I_def using * v by auto
	have finite: "finite I" unfolding I_def by auto
	have I: "I \<subseteq> {0 ..< n}" unfolding I_def by auto
	have "?L $ i = hom (row A i \<bullet> v)" using A v * by auto
	also have "\<dots> = row ?A i \<bullet> ?v" unfolding scalar_prod_def id using finite I
	proof (induct I)
	case (insert k I)
	show ?case unfolding sum.insert[OF insert(1-2)] hom_add hom_mult
	using insert(3-) * A v by auto
	qed simp
	also have "\<dots> = ?R $ i" using A v * by auto
	finally
	show "?L $ i = ?R $ i" .
	qed auto
	qed
	end

	lemma vec_eq_iff: "(x = y) = (dim_vec x = dim_vec y \<and> (\<forall> i < dim_vec y. x $ i = y $ i))" (is "?l = ?r")
	proof
	assume ?r
	show ?l
	by (rule eq_vecI, insert \<open>?r\<close>, auto)
	qed simp

	lemma mat_eq_iff: "(x = y) = (dim_row x = dim_row y \<and> dim_col x = dim_col y \<and>
	(\<forall> i j. i < dim_row y \<longrightarrow> j < dim_col y \<longrightarrow> x $$ (i,j) = y $$ (i,j)))" (is "?l = ?r")
	proof
	assume ?r
	show ?l
	by (rule eq_matI, insert \<open>?r\<close>, auto)
	qed simp

	lemma (in inj_semiring_hom) vec_hom_zero_iff[simp]: "(vec\<^sub>h x = 0\<^sub>v n) = (x = 0\<^sub>v n)"
	proof -
	{
	fix i
	assume i: "i < n" "dim_vec x = n"
	hence "vec\<^sub>h x $ i = 0 \<longleftrightarrow> x $ i = 0"
	using index_map_vec(1)[of i x] by simp
	} note main = this
	show ?thesis unfolding vec_eq_iff by (simp, insert main, auto)
	qed

	lemma (in inj_semiring_hom) mat_hom_inj: "mat\<^sub>h A = mat\<^sub>h B \<Longrightarrow> A = B"
	unfolding mat_eq_iff by auto

	lemma (in inj_semiring_hom) vec_hom_inj: "vec\<^sub>h v = vec\<^sub>h w \<Longrightarrow> v = w"
	unfolding vec_eq_iff by auto

	lemma (in semiring_hom) mat_hom_pow: assumes A: "A \<in> carrier_mat n n"
	shows "mat\<^sub>h (A ^\<^sub>m k) = (mat\<^sub>h A) ^\<^sub>m k"
	proof (induct k)
	case (Suc k)
	thus ?case using mat_hom_mult[OF pow_carrier_mat[OF A, of k] A] by simp
	qed (simp add: mat_hom_one)

	lemma (in semiring_hom) hom_sum_mat: "hom (sum_mat A) = sum_mat (mat\<^sub>h A)"
	proof -
	obtain B where id: "?thesis = (hom (sum (($$) A) B) = sum (($$) (mat\<^sub>h A)) B)"
	and B: "B \<subseteq> {0..<dim_row A} \<times> {0..<dim_col A}"
	unfolding sum_mat_def by auto
	from B have "finite B"
	using finite_subset by blast
	thus ?thesis unfolding id using B
	proof (induct B)
	case (insert x F)
	show ?case unfolding sum.insert[OF insert(1-2)] hom_add
	using insert(3-) by auto
	qed simp
	qed

	lemma (in semiring_hom) vec_hom_smult: "vec\<^sub>h (ev \<cdot>\<^sub>v v) = hom ev \<cdot>\<^sub>v vec\<^sub>h v"
	by (rule eq_vecI, auto simp: hom_distribs)

	lemma minus_scalar_prod_distrib: fixes v\<^sub>1 :: "'a :: ring vec"
	assumes v: "v\<^sub>1 \<in> carrier_vec n" "v\<^sub>2 \<in> carrier_vec n" "v\<^sub>3 \<in> carrier_vec n"
	shows "(v\<^sub>1 - v\<^sub>2) \<bullet> v\<^sub>3 = v\<^sub>1 \<bullet> v\<^sub>3 - v\<^sub>2 \<bullet> v\<^sub>3"
	unfolding minus_add_uminus_vec[OF v(1-2)]
	by (subst add_scalar_prod_distrib[OF v(1)], insert v, auto)

	lemma scalar_prod_minus_distrib: fixes v\<^sub>1 :: "'a :: ring vec"
	assumes v: "v\<^sub>1 \<in> carrier_vec n" "v\<^sub>2 \<in> carrier_vec n" "v\<^sub>3 \<in> carrier_vec n"
	shows "v\<^sub>1 \<bullet> (v\<^sub>2 - v\<^sub>3) = v\<^sub>1 \<bullet> v\<^sub>2 - v\<^sub>1 \<bullet> v\<^sub>3"
	unfolding minus_add_uminus_vec[OF v(2-3)]
	by (subst scalar_prod_add_distrib[OF v(1)], insert v, auto)

	lemma uminus_add_minus_vec:
	assumes "l \<in> carrier_vec n" "r \<in> carrier_vec n"
	shows "- ((l::'a :: ab_group_add vec) + r) = (- l - r)"
	using assms by auto

	lemma minus_add_minus_vec: fixes u :: "'a :: ab_group_add vec"
	assumes "u \<in> carrier_vec n" "v \<in> carrier_vec n" "w \<in> carrier_vec n"
	shows "u - (v + w) = u - v - w"
	using assms by auto

	lemma uminus_add_minus_mat:
	assumes "l \<in> carrier_mat nr nc" "r \<in> carrier_mat nr nc"
	shows "- ((l::'a :: ab_group_add mat) + r) = (- l - r)"
	using assms by auto

	lemma minus_add_minus_mat: fixes u :: "'a :: ab_group_add mat"
	assumes "u \<in> carrier_mat nr nc" "v \<in> carrier_mat nr nc" "w \<in> carrier_mat nr nc"
	shows "u - (v + w) = u - v - w"
	using assms by auto

	lemma uminus_uminus_vec[simp]: "- (- (v::'a:: group_add vec)) = v"
	by auto

	lemma uminus_eq_vec[simp]: "- (v::'a:: group_add vec) = - w \<longleftrightarrow> v = w"
	by (metis uminus_uminus_vec)

	lemma uminus_uminus_mat[simp]: "- (- (A::'a:: group_add mat)) = A"
	by auto

	lemma uminus_eq_mat[simp]: "- (A::'a:: group_add mat) = - B \<longleftrightarrow> A = B"
	by (metis uminus_uminus_mat)

	lemma smult_zero_mat[simp]: "(k :: 'a :: mult_zero) \<cdot>\<^sub>m 0\<^sub>m nr nc = 0\<^sub>m nr nc"
	by (intro eq_matI, auto)

	lemma similar_mat_wit_smult: fixes A :: "'a :: comm_ring_1 mat"
	assumes "similar_mat_wit A B P Q"
	shows "similar_mat_wit (k \<cdot>\<^sub>m A) (k \<cdot>\<^sub>m B) P Q"
	proof -
	define n where "n = dim_row A"
	note main = similar_mat_witD[OF n_def assms]
	show ?thesis
	by (rule similar_mat_witI[OF main(1-2) _ _ _ main(6-7)], insert main(3-), auto
	simp: mult_smult_distrib mult_smult_assoc_mat[of _ n n _ n])
	qed

	lemma similar_mat_smult: fixes A :: "'a :: comm_ring_1 mat"
	assumes "similar_mat A B"
	shows "similar_mat (k \<cdot>\<^sub>m A) (k \<cdot>\<^sub>m B)"
	using similar_mat_wit_smult assms unfolding similar_mat_def by blast

	definition mat_diag :: "nat \<Rightarrow> (nat \<Rightarrow> 'a :: zero) \<Rightarrow> 'a mat" where
	"mat_diag n f = Matrix.mat n n (\<lambda> (i,j). if i = j then f j else 0)"

	lemma mat_diag_dim[simp]: "mat_diag n f \<in> carrier_mat n n"
	unfolding mat_diag_def by auto

	lemma mat_diag_mult_left: assumes A: "A \<in> carrier_mat n nr"
	shows "mat_diag n f * A = Matrix.mat n nr (\<lambda> (i,j). f i * A $$ (i,j))"
	proof (rule eq_matI, insert A, auto simp: mat_diag_def scalar_prod_def, goal_cases)
	case (1 i j)
	thus ?case by (subst sum.remove[of _ i], auto)
	qed

	lemma mat_diag_mult_right: assumes A: "A \<in> carrier_mat nr n"
	shows "A * mat_diag n f = Matrix.mat nr n (\<lambda> (i,j). A $$ (i,j) * f j)"
	proof (rule eq_matI, insert A, auto simp: mat_diag_def scalar_prod_def, goal_cases)
	case (1 i j)
	thus ?case by (subst sum.remove[of _ j], auto)
	qed

	lemma mat_diag_diag[simp]: "mat_diag n f * mat_diag n g = mat_diag n (\<lambda> i. f i * g i)"
	by (subst mat_diag_mult_left[of _ n n], auto simp: mat_diag_def)

	lemma mat_diag_one[simp]: "mat_diag n (\<lambda> x. 1) = 1\<^sub>m n" unfolding mat_diag_def by auto

	text \<open>Interpret vector as row-matrix\<close>

	definition "mat_of_row y = mat 1 (dim_vec y) (\<lambda> ij. y $ (snd ij))"

	lemma mat_of_row_carrier[simp,intro]:
	"y \<in> carrier_vec n \<Longrightarrow> mat_of_row y \<in> carrier_mat 1 n"
	"y \<in> carrier_vec n \<Longrightarrow> mat_of_row y \<in> carrier_mat (Suc 0) n"
	unfolding mat_of_row_def by auto

	lemma mat_of_row_dim[simp]: "dim_row (mat_of_row y) = 1"
	"dim_col (mat_of_row y) = dim_vec y"
	unfolding mat_of_row_def by auto

	lemma mat_of_row_index[simp]: "x < dim_vec y \<Longrightarrow> mat_of_row y $$ (0,x) = y $ x"
	unfolding mat_of_row_def by auto

	lemma row_mat_of_row[simp]: "row (mat_of_row y) 0 = y"
	by auto

	lemma mat_of_row_mult_append_rows: assumes y1: "y1 \<in> carrier_vec nr1"
	and y2: "y2 \<in> carrier_vec nr2"
	and A1: "A1 \<in> carrier_mat nr1 nc"
	and A2: "A2 \<in> carrier_mat nr2 nc"
	shows "mat_of_row (y1 @\<^sub>v y2) * (A1 @\<^sub>r A2) =
	mat_of_row y1 * A1 + mat_of_row y2 * A2"
	proof -
	from A1 A2 have dim: "dim_row A1 = nr1" "dim_row A2 = nr2" by auto
	let ?M1 = "mat_of_row y1"
	have M1: "?M1 \<in> carrier_mat 1 nr1" using y1 by auto
	let ?M2 = "mat_of_row y2"
	have M2: "?M2 \<in> carrier_mat 1 nr2" using y2 by auto
	let ?M3 = "0\<^sub>m 0 nr1"
	let ?M4 = "0\<^sub>m 0 nr2"
	note z = zero_carrier_mat
	have id: "mat_of_row (y1 @\<^sub>v y2) = four_block_mat
	?M1 ?M2 ?M3 ?M4" using y1 y2
	by (intro eq_matI, auto simp: mat_of_rows_def)
	show ?thesis
	unfolding id append_rows_def dim
	by (subst mult_four_block_mat[OF M1 M2 z z A1 z A2 z], insert A1 A2, auto)
	qed

	+lemma mat_of_row_uminus: "mat_of_row (- v) = - mat_of_row v"
	+ by auto
	+
	+

	text \<open>Allowing to construct and deconstruct vectors like lists\<close>
	abbreviation vNil where "vNil \<equiv> vec 0 ((!) [])"
	definition vCons where "vCons a v \<equiv> vec (Suc (dim_vec v)) (\<lambda>i. case i of 0 \<Rightarrow> a \| Suc i \<Rightarrow> v $ i)"

	lemma vec_index_vCons_0 [simp]: "vCons a v $ 0 = a"
	by (simp add: vCons_def)

	lemma vec_index_vCons_Suc [simp]:
	fixes v :: "'a vec"
	shows "vCons a v $ Suc n = v $ n"
	proof-
	have 1: "vec (Suc d) f $ Suc n = vec d (f \<circ> Suc) $ n" for d and f :: "nat \<Rightarrow> 'a"
	by (transfer, auto simp: mk_vec_def)
	show ?thesis
	apply (auto simp: 1 vCons_def o_def) apply transfer apply (auto simp: mk_vec_def)
	done
	qed

	lemma vec_index_vCons: "vCons a v $ n = (if n = 0 then a else v $ (n - 1))"
	by (cases n, auto)

	lemma dim_vec_vCons [simp]: "dim_vec (vCons a v) = Suc (dim_vec v)"
	by (simp add: vCons_def)

	lemma vCons_carrier_vec[simp]: "vCons a v \<in> carrier_vec (Suc n) \<longleftrightarrow> v \<in> carrier_vec n"
	by (auto dest!: carrier_vecD intro: carrier_vecI)

	lemma vec_Suc: "vec (Suc n) f = vCons (f 0) (vec n (f \<circ> Suc))" (is "?l = ?r")
	proof (unfold vec_eq_iff, intro conjI allI impI)
	fix i assume "i < dim_vec ?r"
	then show "?l $ i = ?r $ i" by (cases i, auto)
	qed simp

	declare Abs_vec_cases[cases del]

	lemma vec_cases [case_names vNil vCons, cases type: vec]:
	assumes "v = vNil \<Longrightarrow> thesis" and "\<And>a w. v = vCons a w \<Longrightarrow> thesis"
	shows "thesis"
	proof (cases "dim_vec v")
	case 0 then show thesis by (intro assms(1), auto)
	next
	case (Suc n)
	show thesis
	proof (rule assms(2))
	show v: "v = vCons (v $ 0) (vec n (\<lambda>i. v $ Suc i))" (is "v = ?r")
	proof (rule eq_vecI, unfold dim_vec_vCons dim_vec Suc)
	fix i
	assume "i < Suc n"
	then show "v $ i = ?r $ i" by (cases i, auto simp: vCons_def)
	qed simp
	qed
	qed

	lemma vec_induct [case_names vNil vCons, induct type: vec]:
	assumes "P vNil" and "\<And>a v. P v \<Longrightarrow> P (vCons a v)"
	shows "P v"
	proof (induct "dim_vec v" arbitrary:v)
	case 0 then show ?case by (cases v, auto intro: assms(1))
	next
	case (Suc n) then show ?case by (cases v, auto intro: assms(2))
	qed

	lemma carrier_vec_induct [consumes 1, case_names 0 Suc, induct set:carrier_vec]:
	assumes v: "v \<in> carrier_vec n"
	and 1: "P 0 vNil" and 2: "\<And>n a v. v \<in> carrier_vec n \<Longrightarrow> P n v \<Longrightarrow> P (Suc n) (vCons a v)"
	shows "P n v"
	proof (insert v, induct n arbitrary: v)
	case 0 then have "v = vec 0 ((!) [])" by auto
	with 1 show ?case by auto
	next
	case (Suc n) then show ?case by (cases v, auto dest!: carrier_vecD intro:2)
	qed

	lemma vec_of_list_Cons[simp]: "vec_of_list (a#as) = vCons a (vec_of_list as)"
	by (unfold vCons_def, transfer, auto simp:mk_vec_def split:nat.split)

	lemma vec_of_list_Nil[simp]: "vec_of_list [] = vNil"
	by (transfer', auto)

	lemma scalar_prod_vCons[simp]:
	"vCons a v \<bullet> vCons b w = a * b + v \<bullet> w"
	apply (unfold scalar_prod_def atLeast0_lessThan_Suc_eq_insert_0 dim_vec_vCons)
	apply (subst sum.insert) apply (simp,simp)
	apply (subst sum.reindex) apply force
	apply simp
	done

	lemma zero_vec_Suc: "0\<^sub>v (Suc n) = vCons 0 (0\<^sub>v n)"
	by (auto simp: zero_vec_def vec_Suc o_def)

	lemma zero_vec_zero[simp]: "0\<^sub>v 0 = vNil" by auto

	lemma vCons_eq_vCons[simp]: "vCons a v = vCons b w \<longleftrightarrow> a = b \<and> v = w" (is "?l \<longleftrightarrow> ?r")
	proof
	assume ?l
	note arg_cong[OF this]
	from this[of dim_vec] this[of "\<lambda>x. x$0"] this[of "\<lambda>x. x$Suc _"]
	show ?r by (auto simp: vec_eq_iff)
	qed simp

	lemma vec_carrier_vec[simp]: "vec n f \<in> carrier_vec m \<longleftrightarrow> n = m"
	unfolding carrier_vec_def by auto

	notation transpose_mat ("(_\<^sup>T)" [1000])

	lemma map_mat_transpose: "(map_mat f A)\<^sup>T = map_mat f A\<^sup>T" by auto

	lemma cols_transpose[simp]: "cols A\<^sup>T = rows A" unfolding cols_def rows_def by auto
	lemma rows_transpose[simp]: "rows A\<^sup>T = cols A" unfolding cols_def rows_def by auto
	lemma list_of_vec_vec [simp]: "list_of_vec (vec n f) = map f [0..<n]"
	by (transfer, auto simp: mk_vec_def)

	lemma list_of_vec_0 [simp]: "list_of_vec (0\<^sub>v n) = replicate n 0"
	by (simp add: zero_vec_def map_replicate_trivial)

	lemma diag_mat_map:
	assumes M_carrier: "M \<in> carrier_mat n n"
	shows "diag_mat (map_mat f M) = map f (diag_mat M)"
	proof -
	have dim_eq: "dim_row M = dim_col M" using M_carrier by auto
	have m: "map_mat f M $$ (i, i) = f (M $$ (i, i))" if i: "i < dim_row M" for i
	using dim_eq i by auto
	show ?thesis
	by (rule nth_equalityI, insert m, auto simp add: diag_mat_def M_carrier)
	qed

	lemma mat_of_rows_map [simp]:
	assumes x: "set vs \<subseteq> carrier_vec n"
	shows "mat_of_rows n (map (map_vec f) vs) = map_mat f (mat_of_rows n vs)"
	proof-
	have "\<forall>x\<in>set vs. dim_vec x = n" using x by auto
	then show ?thesis by (auto simp add: mat_eq_iff map_vec_def mat_of_rows_def)
	qed

	lemma mat_of_cols_map [simp]:
	assumes x: "set vs \<subseteq> carrier_vec n"
	shows "mat_of_cols n (map (map_vec f) vs) = map_mat f (mat_of_cols n vs)"
	proof-
	have "\<forall>x\<in>set vs. dim_vec x = n" using x by auto
	then show ?thesis by (auto simp add: mat_eq_iff map_vec_def mat_of_cols_def)
	qed

	lemma vec_of_list_map [simp]: "vec_of_list (map f xs) = map_vec f (vec_of_list xs)"
	unfolding map_vec_def by (transfer, auto simp add: mk_vec_def)

	lemma map_vec: "map_vec f (vec n g) = vec n (f o g)" by auto

	lemma mat_of_cols_Cons_index_0: "i < n \<Longrightarrow> mat_of_cols n (w # ws) $$ (i, 0) = w $ i"
	by (unfold mat_of_cols_def, transfer', auto simp: mk_mat_def)

	lemma nth_map_out_of_bound: "i \<ge> length xs \<Longrightarrow> map f xs ! i = [] ! (i - length xs)"
	by (induct xs arbitrary:i, auto)

	lemma mat_of_cols_Cons_index_Suc:
	"i < n \<Longrightarrow> mat_of_cols n (w # ws) $$ (i, Suc j) = mat_of_cols n ws $$ (i,j)"
	by (unfold mat_of_cols_def, transfer, auto simp: mk_mat_def undef_mat_def nth_append nth_map_out_of_bound)

	lemma mat_of_cols_index: "i < n \<Longrightarrow> j < length ws \<Longrightarrow> mat_of_cols n ws $$ (i,j) = ws ! j $ i"
	by (unfold mat_of_cols_def, auto)

	lemma mat_of_rows_index: "i < length rs \<Longrightarrow> j < n \<Longrightarrow> mat_of_rows n rs $$ (i,j) = rs ! i $ j"
	by (unfold mat_of_rows_def, auto)

	lemma transpose_mat_of_rows: "(mat_of_rows n vs)\<^sup>T = mat_of_cols n vs"
	by (auto intro!: eq_matI simp: mat_of_rows_index mat_of_cols_index)

	lemma transpose_mat_of_cols: "(mat_of_cols n vs)\<^sup>T = mat_of_rows n vs"
	by (auto intro!: eq_matI simp: mat_of_rows_index mat_of_cols_index)

	lemma nth_list_of_vec [simp]:
	assumes "i < dim_vec v" shows "list_of_vec v ! i = v $ i"
	using assms by (transfer, auto)

	lemma length_list_of_vec [simp]:
	"length (list_of_vec v) = dim_vec v" by (transfer, auto)

	lemma vec_eq_0_iff:
	"v = 0\<^sub>v n \<longleftrightarrow> n = dim_vec v \<and> (n = 0 \<or> set (list_of_vec v) = {0})" (is "?l \<longleftrightarrow> ?r")
	proof
	show "?l \<Longrightarrow> ?r" by auto
	show "?r \<Longrightarrow> ?l" by (intro iffI eq_vecI, force simp: set_conv_nth, force)
	qed

	lemma list_of_vec_vCons[simp]: "list_of_vec (vCons a v) = a # list_of_vec v" (is "?l = ?r")
	proof (intro nth_equalityI)
	fix i
	assume "i < length ?l"
	then show "?l ! i = ?r ! i" by (cases i, auto)
	qed simp

	lemma append_vec_vCons[simp]: "vCons a v @\<^sub>v w = vCons a (v @\<^sub>v w)" (is "?l = ?r")
	proof (unfold vec_eq_iff, intro conjI allI impI)
	fix i assume "i < dim_vec ?r"
	then show "?l $ i = ?r $ i" by (cases i; subst index_append_vec, auto)
	qed simp

	lemma append_vec_vNil[simp]: "vNil @\<^sub>v v = v"
	by (unfold vec_eq_iff, auto)

	lemma list_of_vec_append[simp]: "list_of_vec (v @\<^sub>v w) = list_of_vec v @ list_of_vec w"
	by (induct v, auto)

	lemma transpose_mat_eq[simp]: "A\<^sup>T = B\<^sup>T \<longleftrightarrow> A = B"
	using transpose_transpose by metis

	lemma mat_col_eqI: assumes cols: "\<And> i. i < dim_col B \<Longrightarrow> col A i = col B i"
	and dims: "dim_row A = dim_row B" "dim_col A = dim_col B"
	shows "A = B"
	by(subst transpose_mat_eq[symmetric], rule eq_rowI,insert assms,auto)

	lemma upper_triangular_imp_distinct:
	assumes A: "A \<in> carrier_mat n n"
	and tri: "upper_triangular A"
	and diag: "0 \<notin> set (diag_mat A)"
	shows "distinct (rows A)"
	proof-
	{ fix i and j
	assume eq: "rows A ! i = rows A ! j" and ij: "i < j" and jn: "j < n"
	from tri A ij jn have "rows A ! j $ i = 0" by (auto dest!:upper_triangularD)
	with eq have "rows A ! i $ i = 0" by auto
	with diag ij jn A have False by (auto simp: diag_mat_def)
	}
	with A show ?thesis by (force simp: distinct_conv_nth nat_neq_iff)
	qed

	lemma dim_vec_of_list[simp] :"dim_vec (vec_of_list as) = length as" by transfer auto

	lemma list_vec: "list_of_vec (vec_of_list xs) = xs"
	by (transfer, metis (mono_tags, lifting) atLeastLessThan_iff map_eq_conv map_nth mk_vec_def old.prod.case set_upt)

	lemma vec_list: "vec_of_list (list_of_vec v) = v"
	apply transfer unfolding mk_vec_def by auto

	lemma index_vec_of_list: "i<length xs \<Longrightarrow> (vec_of_list xs) $ i = xs ! i"
	by (metis vec.abs_eq index_vec vec_of_list.abs_eq)

	lemma vec_of_list_index: "vec_of_list xs $ j = xs ! j"
	apply transfer unfolding mk_vec_def unfolding undef_vec_def
	by (simp, metis append_Nil2 nth_append)

	lemma list_of_vec_index: "list_of_vec v ! j = v $ j"
	by (metis vec_list vec_of_list_index)

	lemma list_of_vec_map: "list_of_vec xs = map (($) xs) [0..<dim_vec xs]" by transfer auto

	definition "component_mult v w = vec (min (dim_vec v) (dim_vec w)) (\<lambda>i. v $ i * w $ i)"
	definition vec_set::"'a vec \<Rightarrow> 'a set" ("set\<^sub>v")
	where "vec_set v = vec_index v ` {..<dim_vec v}"

	lemma index_component_mult:
	assumes "i < dim_vec v" "i < dim_vec w"
	shows "component_mult v w $ i = v $ i * w $ i"
	unfolding component_mult_def using assms index_vec by auto

	lemma dim_component_mult:
	"dim_vec (component_mult v w) = min (dim_vec v) (dim_vec w)"
	unfolding component_mult_def using index_vec by auto

	lemma vec_setE:
	assumes "a \<in> set\<^sub>v v"
	obtains i where "v$i = a" "i<dim_vec v" using assms unfolding vec_set_def by blast

	lemma vec_setI:
	assumes "v$i = a" "i<dim_vec v"
	shows "a \<in> set\<^sub>v v" using assms unfolding vec_set_def using image_eqI lessThan_iff by blast

	lemma set_list_of_vec: "set (list_of_vec v) = set\<^sub>v v" unfolding vec_set_def by transfer auto


	instantiation vec :: (conjugate) conjugate
	begin

	definition conjugate_vec :: "'a :: conjugate vec \<Rightarrow> 'a vec"
	where "conjugate v = vec (dim_vec v) (\<lambda>i. conjugate (v $ i))"

	lemma conjugate_vCons [simp]:
	"conjugate (vCons a v) = vCons (conjugate a) (conjugate v)"
	by (auto simp: vec_Suc conjugate_vec_def)

	lemma dim_vec_conjugate[simp]: "dim_vec (conjugate v) = dim_vec v"
	unfolding conjugate_vec_def by auto

	lemma carrier_vec_conjugate[simp]: "v \<in> carrier_vec n \<Longrightarrow> conjugate v \<in> carrier_vec n"
	by (auto intro!: carrier_vecI)

	lemma vec_index_conjugate[simp]:
	shows "i < dim_vec v \<Longrightarrow> conjugate v $ i = conjugate (v $ i)"
	unfolding conjugate_vec_def by auto

	instance
	proof
	fix v w :: "'a vec"
	show "conjugate (conjugate v) = v" by (induct v, auto simp: conjugate_vec_def)
	let ?v = "conjugate v"
	let ?w = "conjugate w"
	show "conjugate v = conjugate w \<longleftrightarrow> v = w"
	proof(rule iffI)
	assume cvw: "?v = ?w" show "v = w"
	proof(rule)
	have "dim_vec ?v = dim_vec ?w" using cvw by auto
	then show dim: "dim_vec v = dim_vec w" by simp
	fix i assume i: "i < dim_vec w"
	then have "conjugate v $ i = conjugate w $ i" using cvw by auto
	then have "conjugate (v$i) = conjugate (w $ i)" using i dim by auto
	then show "v $ i = w $ i" by auto
	qed
	qed auto
	qed

	end

	lemma conjugate_add_vec:
	fixes v w :: "'a :: conjugatable_ring vec"
	assumes dim: "v : carrier_vec n" "w : carrier_vec n"
	shows "conjugate (v + w) = conjugate v + conjugate w"
	by (rule, insert dim, auto simp: conjugate_dist_add)

	lemma uminus_conjugate_vec:
	fixes v w :: "'a :: conjugatable_ring vec"
	shows "- (conjugate v) = conjugate (- v)"
	by (rule, auto simp:conjugate_neg)

	lemma conjugate_zero_vec[simp]:
	"conjugate (0\<^sub>v n :: 'a :: conjugatable_ring vec) = 0\<^sub>v n" by auto

	lemma conjugate_vec_0[simp]:
	"conjugate (vec 0 f) = vec 0 f" by auto

	lemma sprod_vec_0[simp]: "v \<bullet> vec 0 f = 0"
	by(auto simp: scalar_prod_def)

	lemma conjugate_zero_iff_vec[simp]:
	fixes v :: "'a :: conjugatable_ring vec"
	shows "conjugate v = 0\<^sub>v n \<longleftrightarrow> v = 0\<^sub>v n"
	using conjugate_cancel_iff[of _ "0\<^sub>v n :: 'a vec"] by auto

	lemma conjugate_smult_vec:
	fixes k :: "'a :: conjugatable_ring"
	shows "conjugate (k \<cdot>\<^sub>v v) = conjugate k \<cdot>\<^sub>v conjugate v"
	using conjugate_dist_mul by (intro eq_vecI, auto)

	lemma conjugate_sprod_vec:
	fixes v w :: "'a :: conjugatable_ring vec"
	assumes v: "v : carrier_vec n" and w: "w : carrier_vec n"
	shows "conjugate (v \<bullet> w) = conjugate v \<bullet> conjugate w"
	proof (insert w v, induct w arbitrary: v rule:carrier_vec_induct)
	case 0 then show ?case by (cases v, auto)
	next
	case (Suc n b w) then show ?case
	by (cases v, auto dest: carrier_vecD simp:conjugate_dist_add conjugate_dist_mul)
	qed

	abbreviation cscalar_prod :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a :: conjugatable_ring" (infix "\<bullet>c" 70)
	where "(\<bullet>c) \<equiv> \<lambda>v w. v \<bullet> conjugate w"

	lemma conjugate_conjugate_sprod[simp]:
	assumes v[simp]: "v : carrier_vec n" and w[simp]: "w : carrier_vec n"
	shows "conjugate (conjugate v \<bullet> w) = v \<bullet>c w"
	apply (subst conjugate_sprod_vec[of _ n]) by auto

	lemma conjugate_vec_sprod_comm:
	fixes v w :: "'a :: {conjugatable_ring, comm_ring} vec"
	assumes "v : carrier_vec n" and "w : carrier_vec n"
	shows "v \<bullet>c w = (conjugate w \<bullet> v)"
	unfolding scalar_prod_def using assms by(subst sum.ivl_cong, auto simp: ac_simps)

	lemma conjugate_square_ge_0_vec[intro!]:
	fixes v :: "'a :: conjugatable_ordered_ring vec"
	shows "v \<bullet>c v \<ge> 0"
	proof (induct v)
	case vNil
	then show ?case by auto
	next
	case (vCons a v)
	then show ?case using conjugate_square_positive[of a] by auto
	qed

	lemma conjugate_square_eq_0_vec[simp]:
	fixes v :: "'a :: {conjugatable_ordered_ring,semiring_no_zero_divisors} vec"
	assumes "v \<in> carrier_vec n"
	shows "v \<bullet>c v = 0 \<longleftrightarrow> v = 0\<^sub>v n"
	proof (insert assms, induct rule: carrier_vec_induct)
	case 0
	then show ?case by auto
	next
	case (Suc n a v)
	then show ?case
	using conjugate_square_positive[of a] conjugate_square_ge_0_vec[of v]
	by (auto simp: le_less add_nonneg_eq_0_iff zero_vec_Suc)
	qed

	lemma conjugate_square_greater_0_vec[simp]:
	fixes v :: "'a :: {conjugatable_ordered_ring,semiring_no_zero_divisors} vec"
	assumes "v \<in> carrier_vec n"
	shows "v \<bullet>c v > 0 \<longleftrightarrow> v \<noteq> 0\<^sub>v n"
	using assms by (auto simp: less_le)

	lemma vec_conjugate_rat[simp]: "(conjugate :: rat vec \<Rightarrow> rat vec) = (\<lambda>x. x)" by force
	lemma vec_conjugate_real[simp]: "(conjugate :: real vec \<Rightarrow> real vec) = (\<lambda>x. x)" by force


	end
	diff --git a/thys/LP_Duality/LP_Duality.thy b/thys/LP_Duality/LP_Duality.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/LP_Duality/LP_Duality.thy
	@@ -0,0 +1,581 @@
	+section \<open>Weak and Strong Duality of Linear Programming\<close>
	+
	+theory LP_Duality
	+ imports
	+ Linear_Inequalities.Farkas_Lemma
	+ Minimum_Maximum
	+begin
	+
	+lemma weak_duality_theorem:
	+ fixes A :: "'a :: linordered_comm_semiring_strict mat"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and x: "x \<in> carrier_vec nc"
	+ and Axb: "A *\<^sub>v x \<le> b"
	+ and y0: "y \<ge> 0\<^sub>v nr"
	+ and yA: "A\<^sup>T *\<^sub>v y = c"
	+ shows "c \<bullet> x \<le> b \<bullet> y"
	+proof -
	+ from y0 have y: "y \<in> carrier_vec nr" unfolding less_eq_vec_def by auto
	+ have "c \<bullet> x = (A\<^sup>T *\<^sub>v y) \<bullet> x" unfolding yA by simp
	+ also have "\<dots> = y \<bullet> (A *\<^sub>v x)" using x y A by (metis transpose_vec_mult_scalar)
	+ also have "\<dots> \<le> y \<bullet> b"
	+ unfolding scalar_prod_def using A b Axb y0
	+ by (auto intro!: sum_mono mult_left_mono simp: less_eq_vec_def)
	+ also have "\<dots> = b \<bullet> y" using y b by (metis comm_scalar_prod)
	+ finally show ?thesis .
	+qed
	+
	+corollary unbounded_primal_solutions:
	+ fixes A :: "'a :: linordered_idom mat"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and unbounded: "\<forall> v. \<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b \<and> c \<bullet> x \<ge> v"
	+ shows "\<not> (\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c)"
	+proof
	+ assume "(\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c)"
	+ then obtain y where y: "y \<ge> 0\<^sub>v nr" and Ayc: "A\<^sup>T *\<^sub>v y = c"
	+ by auto
	+ from unbounded[rule_format, of "b \<bullet> y + 1"]
	+ obtain x where x: "x \<in> carrier_vec nc" and Axb: "A *\<^sub>v x \<le> b"
	+ and le: "b \<bullet> y + 1 \<le> c \<bullet> x" by auto
	+ from weak_duality_theorem[OF A b c x Axb y Ayc]
	+ have "c \<bullet> x \<le> b \<bullet> y" by auto
	+ with le show False by auto
	+qed
	+
	+corollary unbounded_dual_solutions:
	+ fixes A :: "'a :: linordered_idom mat"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and unbounded: "\<forall> v. \<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and> b \<bullet> y \<le> v"
	+ shows "\<not> (\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b)"
	+proof
	+ assume "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
	+ then obtain x where x: "x \<in> carrier_vec nc" and Axb: "A *\<^sub>v x \<le> b" by auto
	+ from unbounded[rule_format, of "c \<bullet> x - 1"]
	+ obtain y where y: "y\<ge>0\<^sub>v nr" and Ayc: "A\<^sup>T *\<^sub>v y = c" and le: "b \<bullet> y \<le> c \<bullet> x - 1" by auto
	+ from weak_duality_theorem[OF A b c x Axb y Ayc]
	+ have "c \<bullet> x \<le> b \<bullet> y" by auto
	+ with le show False by auto
	+qed
	+
	+text \<open>A version of the strong duality theorem which demands
	+ that both primal and dual problem are solvable. At this point
	+ we do not use min- or max-operations\<close>
	+theorem strong_duality_theorem_both_sat:
	+ fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and primal: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
	+ and dual: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
	+ shows "\<exists> x y.
	+ x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b \<and>
	+ y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and>
	+ c \<bullet> x = b \<bullet> y"
	+proof -
	+ define M_up where "M_up = four_block_mat A (0\<^sub>m nr nr) (mat_of_row (- c)) (mat_of_row b)"
	+ define M_low where "M_low = four_block_mat (0\<^sub>m nc nc) (A\<^sup>T) (0\<^sub>m nc nc) (- (A\<^sup>T))"
	+ define M_last where "M_last = append_cols (0\<^sub>m nr nc) (- 1\<^sub>m nr :: 'a mat)"
	+ define M where "M = (M_up @\<^sub>r M_low) @\<^sub>r M_last"
	+ define bc where "bc = ((b @\<^sub>v 0\<^sub>v 1) @\<^sub>v (c @\<^sub>v -c)) @\<^sub>v (0\<^sub>v nr)"
	+ (* M = ( A 0) bc = ( b)
	+ (-c b) ( 0)
	+ ( 0 At) ( c)
	+ ( 0 -At) ( -c)
	+ ( 0 -I) ( 0) *)
	+ let ?nr = "((nr + 1) + (nc + nc)) + nr"
	+ let ?nc = "nc + nr"
	+ have M_up: "M_up \<in> carrier_mat (nr + 1) ?nc"
	+ unfolding M_up_def using A b c by auto
	+ have M_low: "M_low \<in> carrier_mat (nc + nc) ?nc"
	+ unfolding M_low_def using A by auto
	+ have M_last: "M_last \<in> carrier_mat nr ?nc"
	+ unfolding M_last_def by auto
	+ have M: "M \<in> carrier_mat ?nr ?nc"
	+ using carrier_append_rows[OF carrier_append_rows[OF M_up M_low] M_last]
	+ unfolding M_def by auto
	+ have bc: "bc \<in> carrier_vec ?nr" unfolding bc_def
	+ by (intro append_carrier_vec, insert b c, auto)
	+ have "(\<exists>xy. xy \<in> carrier_vec ?nc \<and> M *\<^sub>v xy \<le> bc)"
	+ proof (subst gram_schmidt.Farkas_Lemma'[OF M bc], intro allI impI, elim conjE)
	+ fix ulv
	+ assume ulv0: "0\<^sub>v ?nr \<le> ulv" and Mulv: "M\<^sup>T *\<^sub>v ulv = 0\<^sub>v ?nc"
	+ from ulv0[unfolded less_eq_vec_def]
	+ have ulv: "ulv \<in> carrier_vec ?nr" by auto
	+ define u1 where "u1 = vec_first ulv ((nr + 1) + (nc + nc))"
	+ define u2 where "u2 = vec_first u1 (nr + 1)"
	+ define u3 where "u3 = vec_last u1 (nc + nc)"
	+ define t where "t = vec_last ulv nr"
	+ have ulvid: "ulv = u1 @\<^sub>v t" using ulv
	+ unfolding u1_def t_def by auto
	+ have t: "t \<in> carrier_vec nr" unfolding t_def by auto
	+ have u1: "u1 \<in> carrier_vec ((nr + 1) + (nc + nc))"
	+ unfolding u1_def by auto
	+ have u1id: "u1 = u2 @\<^sub>v u3" using u1
	+ unfolding u2_def u3_def by auto
	+ have u2: "u2 \<in> carrier_vec (nr + 1)" unfolding u2_def by auto
	+ have u3: "u3 \<in> carrier_vec (nc + nc)" unfolding u3_def by auto
	+ define v where "v = vec_first u3 nc"
	+ define w where "w = vec_last u3 nc"
	+ have u3id: "u3 = v @\<^sub>v w" using u3
	+ unfolding v_def w_def by auto
	+ have v: "v \<in> carrier_vec nc" unfolding v_def by auto
	+ have w: "w \<in> carrier_vec nc" unfolding w_def by auto
	+
	+ define u where "u = vec_first u2 nr"
	+ define L where "L = vec_last u2 1"
	+ have u2id: "u2 = u @\<^sub>v L" using u2
	+ unfolding u_def L_def by auto
	+ have u: "u \<in> carrier_vec nr" unfolding u_def by auto
	+ have L: "L \<in> carrier_vec 1" unfolding L_def by auto
	+ define vec1 where "vec1 = A\<^sup>T \<^sub>v u + mat_of_col (- c) \<^sub>v L"
	+ have vec1: "vec1 \<in> carrier_vec nc"
	+ unfolding vec1_def mat_of_col_def using A u c L
	+ by (meson add_carrier_vec mat_of_row_carrier(1) mult_mat_vec_carrier transpose_carrier_mat uminus_carrier_vec)
	+ define vec2 where "vec2 = A *\<^sub>v (v - w)"
	+ have vec2: "vec2 \<in> carrier_vec nr"
	+ unfolding vec2_def using A v w by auto
	+ define vec3 where "vec3 = mat_of_col b *\<^sub>v L"
	+ have vec3: "vec3 \<in> carrier_vec nr"
	+ using A b L unfolding mat_of_col_def vec3_def
	+ by (meson add_carrier_vec mat_of_row_carrier(1) mult_mat_vec_carrier transpose_carrier_mat uminus_carrier_vec)
	+ have Mt: "M\<^sup>T = (M_up\<^sup>T @\<^sub>c M_low\<^sup>T) @\<^sub>c M_last\<^sup>T"
	+ unfolding M_def append_cols_def by simp
	+ have "M\<^sup>T \<^sub>v ulv = (M_up\<^sup>T @\<^sub>c M_low\<^sup>T) \<^sub>v u1 + M_last\<^sup>T *\<^sub>v t"
	+ unfolding Mt ulvid
	+ by (subst mat_mult_append_cols[OF carrier_append_cols _ u1 t],
	+ insert M_up M_low M_last, auto)
	+ also have "M_last\<^sup>T = 0\<^sub>m nc nr @\<^sub>r - 1\<^sub>m nr" unfolding M_last_def
	+ unfolding append_cols_def by (simp, subst transpose_uminus, auto)
	+ also have "\<dots> *\<^sub>v t = 0\<^sub>v nc @\<^sub>v - t"
	+ by (subst mat_mult_append[OF _ _ t], insert t, auto)
	+ also have "(M_up\<^sup>T @\<^sub>c M_low\<^sup>T) \<^sub>v u1 = (M_up\<^sup>T \<^sub>v u2) + (M_low\<^sup>T *\<^sub>v u3)"
	+ unfolding u1id
	+ by (rule mat_mult_append_cols[OF _ _ u2 u3], insert M_up M_low, auto)
	+ also have "M_low\<^sup>T = four_block_mat (0\<^sub>m nc nc) (0\<^sub>m nc nc) A (- A)"
	+ unfolding M_low_def
	+ by (subst transpose_four_block_mat, insert A, auto)
	+ also have "\<dots> \<^sub>v u3 = (0\<^sub>m nc nc \<^sub>v v + 0\<^sub>m nc nc \<^sub>v w) @\<^sub>v (A \<^sub>v v + - A *\<^sub>v w)" unfolding u3id
	+ by (subst four_block_mat_mult_vec[OF _ _ A _ v w], insert A, auto)
	+ also have "0\<^sub>m nc nc \<^sub>v v + 0\<^sub>m nc nc \<^sub>v w = 0\<^sub>v nc"
	+ using v w by auto
	+ also have "A \<^sub>v v + - A \<^sub>v w = vec2" unfolding vec2_def using A v w
	+ by (metis (full_types) carrier_matD(2) carrier_vecD minus_add_uminus_vec mult_mat_vec_carrier mult_minus_distrib_mat_vec uminus_mult_mat_vec)
	+ also have "M_up\<^sup>T = four_block_mat A\<^sup>T (mat_of_col (- c)) (0\<^sub>m nr nr) (mat_of_col b)"
	+ unfolding M_up_def mat_of_col_def
	+ by (subst transpose_four_block_mat[OF A], insert b c, auto)
	+ also have "\<dots> *\<^sub>v u2 = vec1 @\<^sub>v vec3"
	+ unfolding u2id vec1_def vec3_def
	+ by (subst four_block_mat_mult_vec[OF _ _ _ _ u L], insert A b c u, auto)
	+ also have "(vec1 @\<^sub>v vec3)
	+ + (0\<^sub>v nc @\<^sub>v vec2) + (0\<^sub>v nc @\<^sub>v - t) =
	+ (vec1 @\<^sub>v (vec3 + vec2 - t))"
	+ apply (subst append_vec_add[of _ nc _ _ nr, OF vec1 _ vec3 vec2])
	+ subgoal by force
	+ apply (subst append_vec_add[of _ nc _ _ nr])
	+ subgoal using vec1 by auto
	+ subgoal by auto
	+ subgoal using vec2 vec3 by auto
	+ subgoal using t by auto
	+ subgoal using vec1 by auto
	+ done
	+ finally have "vec1 @\<^sub>v (vec3 + vec2 - t) = 0\<^sub>v ?nc"
	+ unfolding Mulv by simp
	+ also have "\<dots> = 0\<^sub>v nc @\<^sub>v 0\<^sub>v nr" by auto
	+ finally have "vec1 = 0\<^sub>v nc \<and> vec3 + vec2 - t = 0\<^sub>v nr"
	+ by (subst (asm) append_vec_eq[OF vec1], auto)
	+ hence 01: "vec1 = 0\<^sub>v nc" and 02: "vec3 + vec2 - t = 0\<^sub>v nr" by auto
	+ from 01 have "vec1 + mat_of_col c \<^sub>v L = mat_of_col c \<^sub>v L"
	+ using c L vec1 unfolding mat_of_col_def by auto
	+ also have "vec1 + mat_of_col c \<^sub>v L = A\<^sup>T \<^sub>v u"
	+ unfolding vec1_def
	+ using A u c L unfolding mat_of_col_def mat_of_row_uminus transpose_uminus
	+ by (subst uminus_mult_mat_vec, auto)
	+ finally have As: "A\<^sup>T \<^sub>v u = mat_of_col c \<^sub>v L" .
	+ from 02 have "(vec3 + vec2 - t) + t = 0\<^sub>v nr + t"
	+ by simp
	+ also have "(vec3 + vec2 - t) + t = vec2 + vec3"
	+ using vec3 vec2 t by auto
	+ finally have t23: "t = vec2 + vec3" using t by auto
	+ have id0: "0\<^sub>v ?nr = ((0\<^sub>v nr @\<^sub>v 0\<^sub>v 1) @\<^sub>v (0\<^sub>v nc @\<^sub>v 0\<^sub>v nc)) @\<^sub>v 0\<^sub>v nr"
	+ by auto
	+ from ulv0[unfolded id0 ulvid u1id u2id u3id]
	+ have "0\<^sub>v nr \<le> u \<and> 0\<^sub>v 1 \<le> L \<and> 0\<^sub>v nc \<le> v \<and> 0\<^sub>v nc \<le> w \<and> 0\<^sub>v nr \<le> t"
	+ apply (subst (asm) append_vec_le[of _ "(nr + 1) + (nc + nc)"])
	+ subgoal by (intro append_carrier_vec, auto)
	+ subgoal by (intro append_carrier_vec u L v w)
	+ apply (subst (asm) append_vec_le[of _ "(nr + 1)"])
	+ subgoal by (intro append_carrier_vec, auto)
	+ subgoal by (intro append_carrier_vec u L v w)
	+ apply (subst (asm) append_vec_le[OF _ u], force)
	+ apply (subst (asm) append_vec_le[OF _ v], force)
	+ by auto
	+ hence ineqs: "0\<^sub>v nr \<le> u" "0\<^sub>v 1 \<le> L" "0\<^sub>v nc \<le> v" "0\<^sub>v nc \<le> w" "0\<^sub>v nr \<le> t"
	+ by auto
	+ have "ulv \<bullet> bc = u \<bullet> b + (v \<bullet> c + w \<bullet> (-c))"
	+ unfolding ulvid u1id u2id u3id bc_def
	+ apply (subst scalar_prod_append[OF _ t])
	+ apply (rule append_carrier_vec[OF append_carrier_vec[OF u L] append_carrier_vec[OF v w]])
	+ apply (rule append_carrier_vec[OF append_carrier_vec[OF b] append_carrier_vec]; use c in force)
	+ apply force
	+ apply (subst scalar_prod_append)
	+ apply (rule append_carrier_vec[OF u L])
	+ apply (rule append_carrier_vec[OF v w])
	+ subgoal by (rule append_carrier_vec, insert b, auto)
	+ subgoal by (rule append_carrier_vec, insert c, auto)
	+ apply (subst scalar_prod_append[OF u L b], force)
	+ apply (subst scalar_prod_append[OF v w c], use c in force)
	+ apply (insert L t, auto)
	+ done
	+ also have "v \<bullet> c + w \<bullet> (-c) = c \<bullet> v + (-c) \<bullet> w"
	+ by (subst (1 2) comm_scalar_prod, insert w c v, auto)
	+ also have "\<dots> = c \<bullet> v - (c \<bullet> w)" using c w by simp
	+ also have "\<dots> = c \<bullet> (v - w)" using c v w
	+ by (simp add: scalar_prod_minus_distrib)
	+ finally have ulvbc: "ulv \<bullet> bc = u \<bullet> b + c \<bullet> (v - w)" .
	+ define lam where "lam = L $ 0"
	+ from ineqs(2) L have lam0: "lam \<ge> 0" unfolding less_eq_vec_def lam_def by auto
	+ have As: "A\<^sup>T *\<^sub>v u = lam \<cdot>\<^sub>v c" unfolding As using c L
	+ unfolding lam_def mat_of_col_def
	+ by (intro eq_vecI, auto simp: scalar_prod_def)
	+ have vec3: "vec3 = lam \<cdot>\<^sub>v b" unfolding vec3_def using b L
	+ unfolding lam_def mat_of_col_def
	+ by (intro eq_vecI, auto simp: scalar_prod_def)
	+ note preconds = lam0 ineqs(1,3-)[unfolded t23[unfolded vec2_def vec3]] As
	+ have "0 \<le> u \<bullet> b + c \<bullet> (v - w)"
	+ proof (cases "lam > 0")
	+ case True
	+ hence "u \<bullet> b = inverse lam * (lam * (b \<bullet> u))"
	+ using comm_scalar_prod[OF b u] by simp
	+ also have "\<dots> = inverse lam * ((lam \<cdot>\<^sub>v b) \<bullet> u)"
	+ using b u by simp
	+ also have "\<dots> \<ge> inverse lam * (-(A *\<^sub>v (v - w)) \<bullet> u)"
	+ proof (intro mult_left_mono)
	+ show "0 \<le> inverse lam" using preconds by auto
	+ show "-(A *\<^sub>v (v - w)) \<bullet> u \<le> (lam \<cdot>\<^sub>v b) \<bullet> u"
	+ unfolding scalar_prod_def
	+ apply (rule sum_mono)
	+ subgoal for i
	+ using lesseq_vecD[OF _ preconds(2), of nr i] lesseq_vecD[OF _ preconds(5), of nr i] u v w b A
	+ by (intro mult_right_mono, auto)
	+ done
	+ qed
	+ also have "inverse lam * (-(A *\<^sub>v (v - w)) \<bullet> u) =
	+ - (inverse lam * ((A *\<^sub>v (v - w)) \<bullet> u))"
	+ by (subst scalar_prod_uminus_left, insert A u v w, auto)
	+ also have "(A \<^sub>v (v - w)) \<bullet> u = (A\<^sup>T \<^sub>v u) \<bullet> (v - w)"
	+ apply (subst transpose_vec_mult_scalar[OF A _ u])
	+ subgoal using v w by force
	+ by (rule comm_scalar_prod[OF _ u], insert A v w, auto)
	+ also have "inverse lam * \<dots> = c \<bullet> (v - w)" unfolding preconds(6)
	+ using True
	+ by (subst scalar_prod_smult_left, insert c v w, auto)
	+ finally show ?thesis by simp
	+ next
	+ case False
	+ with preconds have lam: "lam = 0" by auto
	+ from primal obtain x0 where x0: "x0 \<in> carrier_vec nc"
	+ and Ax0b: "A *\<^sub>v x0 \<le> b" by auto
	+ from dual obtain y0 where y00: "y0 \<ge> 0\<^sub>v nr"
	+ and Ay0c: "A\<^sup>T *\<^sub>v y0 = c" by auto
	+ from y00 have y0: "y0 \<in> carrier_vec nr"
	+ unfolding less_eq_vec_def by auto
	+ have Au: "A\<^sup>T *\<^sub>v u = 0\<^sub>v nc"
	+ unfolding preconds lam using c by auto
	+ have "0 = (A\<^sup>T *\<^sub>v u) \<bullet> x0" unfolding Au using x0 by auto
	+ also have "\<dots> = u \<bullet> (A *\<^sub>v x0)"
	+ by (rule transpose_vec_mult_scalar[OF A x0 u])
	+ also have "\<dots> \<le> u \<bullet> b"
	+ unfolding scalar_prod_def
	+ apply (use A x0 b in simp)
	+ apply (intro sum_mono)
	+ subgoal for i
	+ using lesseq_vecD[OF _ preconds(2), of nr i] lesseq_vecD[OF _ Ax0b, of nr i] u v w b A x0
	+ by (intro mult_left_mono, auto)
	+ done
	+ finally have ub: "0 \<le> u \<bullet> b" .
	+ have "c \<bullet> (v - w) = (A\<^sup>T *\<^sub>v y0) \<bullet> (v - w)" unfolding Ay0c by simp
	+ also have "\<dots> = y0 \<bullet> (A *\<^sub>v (v - w))"
	+ by (subst transpose_vec_mult_scalar[OF A _ y0], insert v w, auto)
	+ also have "\<dots> \<ge> 0"
	+ unfolding scalar_prod_def
	+ apply (use A v w in simp)
	+ apply (intro sum_nonneg)
	+ subgoal for i
	+ using lesseq_vecD[OF _ y00, of nr i] lesseq_vecD[OF _ preconds(5)[unfolded lam], of nr i] A y0 v w b
	+ by (intro mult_nonneg_nonneg, auto)
	+ done
	+ finally show ?thesis using ub by auto
	+ qed
	+ thus "0 \<le> ulv \<bullet> bc" unfolding ulvbc .
	+ qed
	+ then obtain xy where xy: "xy \<in> carrier_vec ?nc" and le: "M *\<^sub>v xy \<le> bc" by auto
	+ define x where "x = vec_first xy nc"
	+ define y where "y = vec_last xy nr"
	+ have xyid: "xy = x @\<^sub>v y" using xy
	+ unfolding x_def y_def by auto
	+ have x: "x \<in> carrier_vec nc" unfolding x_def by auto
	+ have y: "y \<in> carrier_vec nr" unfolding y_def by auto
	+ have At: "A\<^sup>T \<in> carrier_mat nc nr" using A by auto
	+ have Ax1: "A *\<^sub>v x @\<^sub>v vec 1 (\<lambda>_. b \<bullet> y - c \<bullet> x) \<in> carrier_vec (nr + 1)"
	+ using A x by fastforce
	+ have b0cc: "(b @\<^sub>v 0\<^sub>v 1) @\<^sub>v c @\<^sub>v - c \<in> carrier_vec ((nr + 1) + (nc + nc))"
	+ using b c
	+ by (intro append_carrier_vec, auto)
	+ have "M \<^sub>v xy = (M_up \<^sub>v xy @\<^sub>v M_low \<^sub>v xy) @\<^sub>v (M_last \<^sub>v xy)"
	+ unfolding M_def
	+ unfolding mat_mult_append[OF carrier_append_rows[OF M_up M_low] M_last xy]
	+ by (simp add: mat_mult_append[OF M_up M_low xy])
	+ also have "M_low \<^sub>v xy = (0\<^sub>m nc nc \<^sub>v x + A\<^sup>T \<^sub>v y) @\<^sub>v (0\<^sub>m nc nc \<^sub>v x + - A\<^sup>T *\<^sub>v y)"
	+ unfolding M_low_def xyid
	+ by (rule four_block_mat_mult_vec[OF _ At _ _ x y], insert A, auto)
	+ also have "0\<^sub>m nc nc \<^sub>v x + A\<^sup>T \<^sub>v y = A\<^sup>T *\<^sub>v y" using A x y by auto
	+ also have "0\<^sub>m nc nc \<^sub>v x + - A\<^sup>T \<^sub>v y = - A\<^sup>T *\<^sub>v y" using A x y by auto
	+ also have "M_up \<^sub>v xy = (A \<^sub>v x + 0\<^sub>m nr nr *\<^sub>v y) @\<^sub>v
	+ (mat_of_row (- c) \<^sub>v x + mat_of_row b \<^sub>v y)"
	+ unfolding M_up_def xyid
	+ by (rule four_block_mat_mult_vec[OF A _ _ _ x y], insert b c, auto)
	+ also have "A \<^sub>v x + 0\<^sub>m nr nr \<^sub>v y = A *\<^sub>v x" using A x y by auto
	+ also have "mat_of_row (- c) \<^sub>v x + mat_of_row b \<^sub>v y =
	+ vec 1 (\<lambda> _. b \<bullet> y - c \<bullet> x)"
	+ unfolding mult_mat_vec_def using c x by (intro eq_vecI, auto)
	+ also have "M_last *\<^sub>v xy = - y"
	+ unfolding M_last_def xyid using x y
	+ by (subst mat_mult_append_cols[OF _ _ x y], auto)
	+ finally have "((A \<^sub>v x @\<^sub>v vec 1 (\<lambda>_. b \<bullet> y - c \<bullet> x)) @\<^sub>v (A\<^sup>T \<^sub>v y @\<^sub>v - A\<^sup>T *\<^sub>v y)) @\<^sub>v -y
	+ = M *\<^sub>v xy" ..
	+ also have "\<dots> \<le> bc" by fact
	+ also have "\<dots> = ((b @\<^sub>v 0\<^sub>v 1) @\<^sub>v (c @\<^sub>v -c)) @\<^sub>v 0\<^sub>v nr" unfolding bc_def by auto
	+ finally have ineqs: "A *\<^sub>v x \<le> b \<and> vec 1 (\<lambda>_. b \<bullet> y - c \<bullet> x) \<le> 0\<^sub>v 1
	+ \<and> A\<^sup>T \<^sub>v y \<le> c \<and> - A\<^sup>T \<^sub>v y \<le> -c \<and> -y \<le> 0\<^sub>v nr"
	+ apply (subst (asm) append_vec_le[OF _ b0cc])
	+ subgoal using A x y by (intro append_carrier_vec, auto)
	+ apply (subst (asm) append_vec_le[OF Ax1], use b in fastforce)
	+ apply (subst (asm) append_vec_le[OF _ b], use A x in force)
	+ apply (subst (asm) append_vec_le[OF _ c], use A y in force)
	+ by auto
	+ show ?thesis
	+ proof (intro exI conjI)
	+ from ineqs show Axb: "A *\<^sub>v x \<le> b" by auto
	+ from ineqs have "- A\<^sup>T \<^sub>v y \<le> -c" "A\<^sup>T \<^sub>v y \<le> c" by auto
	+ hence "A\<^sup>T \<^sub>v y \<ge> c" "A\<^sup>T \<^sub>v y \<le> c" unfolding less_eq_vec_def using A y by auto
	+ then show Aty: "A\<^sup>T *\<^sub>v y = c" by simp
	+ from ineqs have "- y \<le> 0\<^sub>v nr" by simp
	+ then show y0: "0\<^sub>v nr \<le> y" unfolding less_eq_vec_def by auto
	+ from ineqs have "b \<bullet> y \<le> c \<bullet> x" unfolding less_eq_vec_def by auto
	+ with weak_duality_theorem[OF A b c x Axb y0 Aty]
	+ show "c \<bullet> x = b \<bullet> y" by auto
	+ qed (insert x)
	+qed
	+
	+text \<open>A version of the strong duality theorem which demands
	+ that the primal problem is solvable and the objective function
	+ is bounded.\<close>
	+theorem strong_duality_theorem_primal_sat_bounded:
	+ fixes bound :: "'a :: trivial_conjugatable_linordered_field"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and sat: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
	+ and bounded: "\<forall> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b \<longrightarrow> c \<bullet> x \<le> bound"
	+ shows "\<exists> x y.
	+ x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b \<and>
	+ y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and>
	+ c \<bullet> x = b \<bullet> y"
	+proof (rule strong_duality_theorem_both_sat[OF A b c sat])
	+ show "\<exists>y\<ge>0\<^sub>v nr. A\<^sup>T *\<^sub>v y = c"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "\<exists>y. y \<in> carrier_vec nc \<and> 0\<^sub>v nr \<le> A *\<^sub>v y \<and> 0 > y \<bullet> c"
	+ by (subst (asm) gram_schmidt.Farkas_Lemma[OF _ c], insert A, auto)
	+ then obtain y where y: "y \<in> carrier_vec nc"
	+ and Ay0: "A *\<^sub>v y \<ge> 0\<^sub>v nr" and yc0: "y \<bullet> c < 0" by auto
	+ from sat obtain x where x: "x \<in> carrier_vec nc"
	+ and Axb: "A *\<^sub>v x \<le> b" by auto
	+ define diff where "diff = bound + 1 - c \<bullet> x"
	+ from x Axb bounded have "c \<bullet> x < bound + 1" by auto
	+ hence diff: "diff > 0" unfolding diff_def by auto
	+ from yc0 have inv: "inverse (- (y \<bullet> c)) > 0" by auto
	+ define fact where "fact = diff * (inverse (- (y \<bullet> c)))"
	+ have fact: "fact > 0" unfolding fact_def using diff inv by (metis mult_pos_pos)
	+ define z where "z = x - fact \<cdot>\<^sub>v y"
	+ have "A \<^sub>v z = A \<^sub>v x - A *\<^sub>v (fact \<cdot>\<^sub>v y)"
	+ unfolding z_def using A x y by (meson mult_minus_distrib_mat_vec smult_carrier_vec)
	+ also have "\<dots> = A \<^sub>v x - fact \<cdot>\<^sub>v (A \<^sub>v y)" using A y by auto
	+ also have "\<dots> \<le> b"
	+ proof (intro lesseq_vecI[OF _ b])
	+ show "A \<^sub>v x - fact \<cdot>\<^sub>v (A \<^sub>v y) \<in> carrier_vec nr" using A x y by auto
	+ fix i
	+ assume i: "i < nr"
	+ have "(A \<^sub>v x - fact \<cdot>\<^sub>v (A \<^sub>v y)) $ i
	+ = (A \<^sub>v x) $ i - fact (A *\<^sub>v y) $ i"
	+ using i A x y by auto
	+ also have "\<dots> \<le> b $ i - fact * (A *\<^sub>v y) $ i"
	+ using lesseq_vecD[OF b Axb i] by auto
	+ also have "\<dots> \<le> b $ i - 0 * 0" using lesseq_vecD[OF _ Ay0 i] fact A y i
	+ by (intro diff_left_mono mult_monom, auto)
	+ finally show "(A \<^sub>v x - fact \<cdot>\<^sub>v (A \<^sub>v y)) $ i \<le> b $ i" by simp
	+ qed
	+ finally have Azb: "A *\<^sub>v z \<le> b" .
	+ have z: "z \<in> carrier_vec nc" using x y unfolding z_def by auto
	+ have "c \<bullet> z = c \<bullet> x - fact * (c \<bullet> y)" unfolding z_def
	+ using c x y by (simp add: scalar_prod_minus_distrib)
	+ also have "\<dots> = c \<bullet> x + diff"
	+ unfolding comm_scalar_prod[OF c y] fact_def using yc0 by simp
	+ also have "\<dots> = bound + 1" unfolding diff_def by simp
	+ also have "\<dots> > c \<bullet> z" using bounded Azb z by auto
	+ finally show False by simp
	+ qed
	+qed
	+
	+text \<open>A version of the strong duality theorem which demands
	+ that the dual problem is solvable and the objective function
	+ is bounded.\<close>
	+theorem strong_duality_theorem_dual_sat_bounded:
	+ fixes bound :: "'a :: trivial_conjugatable_linordered_field"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and sat: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
	+ and bounded: "\<forall> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<longrightarrow> bound \<le> b \<bullet> y"
	+ shows "\<exists> x y.
	+ x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b \<and>
	+ y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and>
	+ c \<bullet> x = b \<bullet> y"
	+proof (rule strong_duality_theorem_both_sat[OF A b c _ sat])
	+ show "\<exists>x\<in>carrier_vec nc. A *\<^sub>v x \<le> b"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "\<not> (\<exists>x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b)" by auto
	+ then obtain y where y0: "y \<ge> 0\<^sub>v nr" and Ay0: "A\<^sup>T *\<^sub>v y = 0\<^sub>v nc" and yb: "y \<bullet> b < 0"
	+ by (subst (asm) gram_schmidt.Farkas_Lemma'[OF A b], auto)
	+ from sat obtain x where x0: "x \<ge> 0\<^sub>v nr" and Axc: "A\<^sup>T *\<^sub>v x = c" by auto
	+ define diff where "diff = b \<bullet> x - (bound - 1)"
	+ from x0 Axc bounded have "bound \<le> b \<bullet> x" by auto
	+ hence diff: "diff > 0" unfolding diff_def by auto
	+ define fact where "fact = - inverse (y \<bullet> b) * diff"
	+ have fact: "fact > 0" unfolding fact_def using diff yb by (auto intro: mult_neg_pos)
	+ define z where "z = x + fact \<cdot>\<^sub>v y"
	+ from x0 have x: "x \<in> carrier_vec nr"
	+ unfolding less_eq_vec_def by auto
	+ from y0 have y: "y \<in> carrier_vec nr"
	+ unfolding less_eq_vec_def by auto
	+ have "A\<^sup>T \<^sub>v z = A\<^sup>T \<^sub>v x + A\<^sup>T *\<^sub>v (fact \<cdot>\<^sub>v y)"
	+ unfolding z_def using A x y by (simp add: mult_add_distrib_mat_vec)
	+ also have "\<dots> = A\<^sup>T \<^sub>v x + fact \<cdot>\<^sub>v (A\<^sup>T \<^sub>v y)" using A y by auto
	+ also have "\<dots> = c" unfolding Ay0 Axc using c by auto
	+ finally have Azc: "A\<^sup>T *\<^sub>v z = c" .
	+ have z0: "z \<ge> 0\<^sub>v nr" unfolding z_def
	+ by (intro lesseq_vecI[of _ nr], insert x y lesseq_vecD[OF _ x0, of nr] lesseq_vecD[OF _ y0, of nr] fact,
	+ auto intro!: add_nonneg_nonneg)
	+ from bounded Azc z0 have bz: "bound \<le> b \<bullet> z" by auto
	+ also have "\<dots> = b \<bullet> x + fact * (b \<bullet> y)" unfolding z_def using b x y
	+ by (simp add: scalar_prod_add_distrib)
	+ also have "\<dots> = diff + (bound - 1) + fact * (b \<bullet> y)"
	+ unfolding diff_def by auto
	+ also have "fact * (b \<bullet> y) = - diff" using yb
	+ unfolding fact_def comm_scalar_prod[OF y b] by auto
	+ finally show False by simp
	+ qed
	+qed
	+
	+
	+text \<open>Now the previous three duality theorems are formulated via min/max.\<close>
	+corollary strong_duality_theorem_min_max:
	+ fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and primal: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
	+ and dual: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
	+ shows "Maximum {c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}
	+ = Minimum {b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+ and "has_Maximum {c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
	+ and "has_Minimum {b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+proof -
	+ let ?Prim = "{c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
	+ let ?Dual = "{b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+ define Prim where "Prim = ?Prim"
	+ define Dual where "Dual = ?Dual"
	+ from strong_duality_theorem_both_sat[OF assms]
	+ obtain x y where x: "x \<in> carrier_vec nc" and Axb: "A *\<^sub>v x \<le> b"
	+ and y: "y \<ge> 0\<^sub>v nr" and Ayc: "A\<^sup>T *\<^sub>v y = c"
	+ and eq: "c \<bullet> x = b \<bullet> y" by auto
	+ have cxP: "c \<bullet> x \<in> Prim" unfolding Prim_def using x Axb by auto
	+ have cxD: "c \<bullet> x \<in> Dual" unfolding eq Dual_def using y Ayc by auto
	+ {
	+ fix z
	+ assume "z \<in> Prim"
	+ from this[unfolded Prim_def] obtain x' where x': "x' \<in> carrier_vec nc"
	+ and Axb': "A *\<^sub>v x' \<le> b" and z: "z = c \<bullet> x'" by auto
	+ from weak_duality_theorem[OF A b c x' Axb' y Ayc, folded eq]
	+ have "z \<le> c \<bullet> x" unfolding z .
	+ } note cxMax = this
	+ have max: "Maximum Prim = c \<bullet> x"
	+ by (intro eqMaximumI cxP cxMax)
	+ show "has_Maximum ?Prim"
	+ unfolding Prim_def[symmetric] has_Maximum_def using cxP cxMax by auto
	+ {
	+ fix z
	+ assume "z \<in> Dual"
	+ from this[unfolded Dual_def] obtain y' where y': "y' \<ge> 0\<^sub>v nr"
	+ and Ayc': "A\<^sup>T *\<^sub>v y' = c" and z: "z = b \<bullet> y'" by auto
	+ from weak_duality_theorem[OF A b c x Axb y' Ayc', folded z]
	+ have "c \<bullet> x \<le> z" .
	+ } note cxMin = this
	+ show "has_Minimum ?Dual"
	+ unfolding Dual_def[symmetric] has_Minimum_def using cxD cxMin by auto
	+ have min: "Minimum Dual = c \<bullet> x"
	+ by (intro eqMinimumI cxD cxMin)
	+ from min max show "Maximum ?Prim = Minimum ?Dual"
	+ unfolding Dual_def Prim_def by auto
	+qed
	+
	+corollary strong_duality_theorem_primal_sat_bounded_min_max:
	+ fixes bound :: "'a :: trivial_conjugatable_linordered_field"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and sat: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
	+ and bounded: "\<forall> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b \<longrightarrow> c \<bullet> x \<le> bound"
	+ shows "Maximum {c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}
	+ = Minimum {b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+ and "has_Maximum {c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
	+ and "has_Minimum {b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+proof -
	+ let ?Prim = "{c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
	+ let ?Dual = "{b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+ from strong_duality_theorem_primal_sat_bounded[OF assms]
	+ have "\<exists>y\<ge>0\<^sub>v nr. A\<^sup>T *\<^sub>v y = c" by blast
	+ from strong_duality_theorem_min_max[OF A b c sat this]
	+ show "Maximum ?Prim = Minimum ?Dual" "has_Maximum ?Prim" "has_Minimum ?Dual"
	+ by blast+
	+qed
	+
	+corollary strong_duality_theorem_dual_sat_bounded_min_max:
	+ fixes bound :: "'a :: trivial_conjugatable_linordered_field"
	+ assumes A: "A \<in> carrier_mat nr nc"
	+ and b: "b \<in> carrier_vec nr"
	+ and c: "c \<in> carrier_vec nc"
	+ and sat: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
	+ and bounded: "\<forall> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<longrightarrow> bound \<le> b \<bullet> y"
	+ shows "Maximum {c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}
	+ = Minimum {b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+ and "has_Maximum {c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
	+ and "has_Minimum {b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+proof -
	+ let ?Prim = "{c \<bullet> x \| x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
	+ let ?Dual = "{b \<bullet> y \| y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
	+ from strong_duality_theorem_dual_sat_bounded[OF assms]
	+ have "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b" by blast
	+ from strong_duality_theorem_min_max[OF A b c this sat]
	+ show "Maximum ?Prim = Minimum ?Dual" "has_Maximum ?Prim" "has_Minimum ?Dual"
	+ by blast+
	+qed
	+
	+end
	diff --git a/thys/LP_Duality/Minimum_Maximum.thy b/thys/LP_Duality/Minimum_Maximum.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/LP_Duality/Minimum_Maximum.thy
	@@ -0,0 +1,68 @@
	+section \<open>Minimum and Maximum of Potentially Infinite Sets\<close>
	+
	+theory Minimum_Maximum
	+ imports Main
	+begin
	+
	+text \<open>We define minima and maxima of sets. In contrast
	+ to the existing @{const Min} and @{const Max} operators,
	+ these operators are not restricted to finite sets \<close>
	+
	+definition Maximum :: "'a :: linorder set \<Rightarrow> 'a" where
	+ "Maximum S = (THE x. x \<in> S \<and> (\<forall> y \<in> S. y \<le> x))"
	+definition Minimum :: "'a :: linorder set \<Rightarrow> 'a" where
	+ "Minimum S = (THE x. x \<in> S \<and> (\<forall> y \<in> S. x \<le> y))"
	+
	+definition has_Maximum where "has_Maximum S = (\<exists> x. x \<in> S \<and> (\<forall> y \<in> S. y \<le> x))"
	+definition has_Minimum where "has_Minimum S = (\<exists> x. x \<in> S \<and> (\<forall> y \<in> S. x \<le> y))"
	+
	+lemma eqMaximumI:
	+ assumes "x \<in> S"
	+ and "\<And> y. y \<in> S \<Longrightarrow> y \<le> x"
	+shows "Maximum S = x"
	+ unfolding Maximum_def
	+ by (standard, insert assms, auto, fastforce)
	+
	+lemma eqMinimumI:
	+ assumes "x \<in> S"
	+ and "\<And> y. y \<in> S \<Longrightarrow> x \<le> y"
	+shows "Minimum S = x"
	+ unfolding Minimum_def
	+ by (standard, insert assms, auto, fastforce)
	+
	+lemma has_MaximumD:
	+ assumes "has_Maximum S"
	+ shows "Maximum S \<in> S"
	+ "x \<in> S \<Longrightarrow> x \<le> Maximum S"
	+proof -
	+ from assms[unfolded has_Maximum_def]
	+ obtain m where *: "m \<in> S" "\<And> y. y \<in> S \<Longrightarrow> y \<le> m" by auto
	+ have id: "Maximum S = m"
	+ by (rule eqMaximumI, insert *, auto)
	+ from * id show "Maximum S \<in> S" "x \<in> S \<Longrightarrow> x \<le> Maximum S" by auto
	+qed
	+
	+lemma has_MinimumD:
	+ assumes "has_Minimum S"
	+ shows "Minimum S \<in> S"
	+ "x \<in> S \<Longrightarrow> Minimum S \<le> x"
	+proof -
	+ from assms[unfolded has_Minimum_def]
	+ obtain m where *: "m \<in> S" "\<And> y. y \<in> S \<Longrightarrow> m \<le> y" by auto
	+ have id: "Minimum S = m"
	+ by (rule eqMinimumI, insert *, auto)
	+ from * id show "Minimum S \<in> S" "x \<in> S \<Longrightarrow> Minimum S \<le> x" by auto
	+qed
	+
	+text \<open>On non-empty finite sets, @{const Minimum} and @{const Min}
	+ coincide, and similarly @{const Maximum} and @{const Max}.\<close>
	+
	+lemma Minimum_Min: assumes "finite S" "S \<noteq> {}"
	+ shows "Minimum S = Min S"
	+ by (rule eqMinimumI, insert assms, auto)
	+
	+lemma Maximum_Max: assumes "finite S" "S \<noteq> {}"
	+ shows "Maximum S = Max S"
	+ by (rule eqMaximumI, insert assms, auto)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/LP_Duality/ROOT b/thys/LP_Duality/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/LP_Duality/ROOT
	@@ -0,0 +1,9 @@
	+chapter AFP
	+
	+session LP_Duality (AFP) = Linear_Inequalities +
	+ options [timeout = 600]
	+ theories
	+ LP_Duality
	+ document_files
	+ "root.tex"
	+ "root.bib"
	diff --git a/thys/LP_Duality/document/root.bib b/thys/LP_Duality/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/LP_Duality/document/root.bib
	@@ -0,0 +1,28 @@
	+@book{schrijver1998theory,
	+ title={Theory of linear and integer programming},
	+ author={Schrijver, Alexander},
	+ year={1998},
	+ publisher={John Wiley \& Sons}
	+}
	+
	+@article{Linear_Programming-AFP,
	+ author = {Julian Parsert and Cezary Kaliszyk},
	+ title = {Linear Programming},
	+ journal = {Archive of Formal Proofs},
	+ month = aug,
	+ year = 2019,
	+ note = {\url{https://isa-afp.org/entries/Linear_Programming.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+
	+@article{Linear_Inequalities-AFP,
	+ author = {Ralph Bottesch and Alban Reynaud and René Thiemann},
	+ title = {Linear Inequalities},
	+ journal = {Archive of Formal Proofs},
	+ month = jun,
	+ year = 2019,
	+ note = {\url{https://isa-afp.org/entries/Linear_Inequalities.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	diff --git a/thys/LP_Duality/document/root.tex b/thys/LP_Duality/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/LP_Duality/document/root.tex
	@@ -0,0 +1,92 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+
	+% further packages required for unusual symbols (see also
	+% isabellesym.sty), use only when needed
	+
	+\usepackage{amssymb}
	+ %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
	+ %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
	+ %\<triangleq>, \<yen>, \<lozenge>
	+
	+%\usepackage{eurosym}
	+ %for \<euro>
	+
	+%\usepackage[only,bigsqcap]{stmaryrd}
	+ %for \<Sqinter>
	+
	+%\usepackage{eufrak}
	+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
	+
	+%\usepackage{textcomp}
	+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	+ %\<currency>
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+% for uniform font size
	+%\renewcommand{\isastyle}{\isastyleminor}
	+
	+
	+\begin{document}
	+
	+\title{Duality of Linear Programming}
	+\author{René Thiemann}
	+
	+\maketitle
	+
	+\begin{abstract}
	+We formalize the weak and strong duality theorems of linear programming.
	+For the strong duality theorem we provide three sufficient
	+preconditions: both the primal problem and the dual problem are satisfiable,
	+the primal problem is satisfiable and bounded, or the dual problem
	+is satisfiable and bounded. The proofs are based on an existing formalization
	+of Farkas' Lemma.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+% sane default for proof documents
	+\parindent 0pt\parskip 0.5ex
	+
	+\section{Introduction}
	+The proofs are taken from a textbook on linear programming~\cite{schrijver1998theory}.
	+There clearly is already an related AFP entry on linear programming
	+\cite{Linear_Programming-AFP} and we briefly explain the relationship
	+between that entry and this one.
	+\begin{itemize}
	+\item The other AFP entry provides an algorithm for solving linear programs based
	+on an existing simplex implementation. Since the simplex implementation is
	+formulated only for rational numbers, several results are only available for
	+rational numbers. Moreover, the simplex algorithm internally works on sets
	+of inequalities that are represented by linear polynomials, and there are
	+conversions between matrix-vector inequalities and linear polynomial inequalities.
	+Finally, that AFP entry does not contain the strong duality theorem,
	+which is the essential result in this AFP entry.
	+\item This AFP entry has completely been formalized
	+ in the matrix-vector representation. It mainly consists of
	+ the strong duality theorems without any algorithms.
	+ The proof of these theorems are based on Farkas' Lemma which
	+ is provided in \cite{Linear_Inequalities-AFP} for arbitrary linearly ordered fields. Therefore, also the duality theorems are
	+proven in that generality without the restriction to rational numbers.
	+\end{itemize}
	+
	+% 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/List_Update/OPT2.thy b/thys/List_Update/OPT2.thy
	--- a/thys/List_Update/OPT2.thy
	+++ b/thys/List_Update/OPT2.thy
	@@ -1,866 +1,856 @@
	(* Title: Analysis of OPT2
	Author: Max Haslbeck
	*)

	section "OPT2"

	theory OPT2
	imports
	Partial_Cost_Model
	RExp_Var
	begin

	-lemma "(N::nat set) \<noteq> {} \<Longrightarrow> Inf N : N"
	-unfolding Inf_nat_def using LeastI[of "%x. x : N"] by force
	-
	-lemma nn_contains_Inf:
	- fixes S :: "nat set"
	- assumes nn: "S \<noteq> {}"
	- shows "Inf S \<in> S"
	-using assms Inf_nat_def LeastI by force
	-
	-
	subsection "Definition"

	fun OPT2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> (nat * nat list) list" where
	"OPT2 [] [x,y] = []"
	\| "OPT2 [a] [x,y] = [(0,[])]"
	\| "OPT2 (a#b#\<sigma>') [x,y] = (if a=x then (0,[]) # (OPT2 (b#\<sigma>') [x,y])
	else (if b=x then (0,[])# (OPT2 (b#\<sigma>') [x,y])
	else (1,[])# (OPT2 (b#\<sigma>') [y,x])))"


	lemma OPT2_length: "length (OPT2 \<sigma> [x, y]) = length \<sigma>"
	apply(induct \<sigma> arbitrary: x y)
	apply(simp)
	apply(case_tac \<sigma>) by(auto)

	lemma OPT2x: "OPT2 (x#\<sigma>') [x,y] = (0,[])#(OPT2 \<sigma>' [x,y])"
	apply(cases \<sigma>') by (simp_all)


	lemma swapOpt: "T\<^sub>p_opt [x,y] \<sigma> \<le> 1 + T\<^sub>p_opt [y,x] \<sigma>"
	proof -
	show ?thesis
	proof (cases "length \<sigma> > 0")
	case True

	have "T\<^sub>p_opt [y,x] \<sigma> \<in> {T\<^sub>p [y, x] \<sigma> as \|as. length as = length \<sigma>}"
	unfolding T_opt_def
	- apply(rule nn_contains_Inf)
	+ apply(rule Inf_nat_def1)
	apply(auto) by (rule Ex_list_of_length)

	then obtain asyx where costyx: "T\<^sub>p [y,x] \<sigma> asyx = T\<^sub>p_opt [y,x] \<sigma>"
	and lenyx: "length asyx = length \<sigma>"
	unfolding T_opt_def by auto

	from True lenyx have "length asyx > 0" by auto
	then obtain A asyx' where aa: "asyx = A # asyx'" using list.exhaust by blast
	then obtain m1 a1 where AA: "A = (m1,a1)" by fastforce

	let ?asxy = "(m1,a1@[0]) # asyx'"

	from True obtain q \<sigma>' where qq: "\<sigma> = q # \<sigma>'" using list.exhaust by blast

	have t: "t\<^sub>p [x, y] q (m1, a1@[0]) = Suc (t\<^sub>p [y, x] q (m1, a1))"
	unfolding t\<^sub>p_def
	apply(simp) unfolding swap_def by (simp)

	have s: "step [x, y] q (m1, a1 @ [0]) = step [y, x] q (m1, a1)"
	unfolding step_def mtf2_def by(simp add: swap_def)

	have T: "T\<^sub>p [x,y] \<sigma> ?asxy = 1 + T\<^sub>p [y,x] \<sigma> asyx" unfolding qq aa AA by(auto simp add: s t)

	have l: "1 + T\<^sub>p_opt [y,x] \<sigma> = T\<^sub>p [x, y] \<sigma> ?asxy" using T costyx by simp
	have "length ?asxy = length \<sigma>" using lenyx aa by auto
	then have inside: "?asxy \<in> {as. size as = size \<sigma>}" by force
	then have b: "T\<^sub>p [x, y] \<sigma> ?asxy \<in> {T\<^sub>p [x, y] \<sigma> as \| as. size as = size \<sigma>}" by auto

	then show ?thesis unfolding l unfolding T_opt_def
	apply(rule cInf_lower) by simp
	qed (simp add: T_opt_def)
	qed


	lemma tt: "a \<in> {x,y} \<Longrightarrow> OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))
	= tl (OPT2 (a # rest1) [x, y])"
	apply(cases rest1) by(auto simp add: step_def mtf2_def swap_def)

	lemma splitqsallg: "Strat \<noteq> [] \<Longrightarrow> a \<in> {x,y} \<Longrightarrow>
	t\<^sub>p [x, y] a (hd (Strat)) +
	(let L=step [x,y] a (hd (Strat))
	in T\<^sub>p L (rest1) (tl Strat)) = T\<^sub>p [x, y] (a # rest1) Strat"
	proof -
	assume ne: "Strat \<noteq> []"
	assume axy: "a \<in> {x,y}" (* not needed *)
	have "T\<^sub>p [x, y] (a # rest1) (Strat)
	= T\<^sub>p [x, y] (a # rest1) ((hd (Strat)) # (tl (Strat)))"
	by(simp only: List.list.collapse[OF ne])
	then show ?thesis by auto
	qed

	lemma splitqs: "a \<in> {x,y} \<Longrightarrow> T\<^sub>p [x, y] (a # rest1) (OPT2 (a # rest1) [x, y])
	= t\<^sub>p [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
	(let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y]))
	in T\<^sub>p L (rest1) (OPT2 (rest1) L))"
	proof -
	assume axy: "a \<in> {x,y}"
	have ne: "OPT2 (a # rest1) [x, y] \<noteq> []" apply(cases rest1) by(simp_all)
	have "T\<^sub>p [x, y] (a # rest1) (OPT2 (a # rest1) [x, y])
	= T\<^sub>p [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (tl (OPT2 (a # rest1) [x, y])))"
	by(simp only: List.list.collapse[OF ne])
	also have "\<dots> = T\<^sub>p [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))))"
	by(simp only: tt[OF axy])
	also have "\<dots> = t\<^sub>p [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
	(let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y]))
	in T\<^sub>p L (rest1) (OPT2 (rest1) L))" by(simp)
	finally show ?thesis .
	qed

	lemma tpx: "t\<^sub>p [x, y] x (hd (OPT2 (x # rest1) [x, y])) = 0"
	by (simp add: OPT2x t\<^sub>p_def)

	lemma yup: "T\<^sub>p [x, y] (x # rest1) (OPT2 (x # rest1) [x, y])
	= (let L=step [x,y] x (hd (OPT2 (x # rest1) [x, y]))
	in T\<^sub>p L (rest1) (OPT2 (rest1) L))"
	by (simp add: splitqs tpx)

	lemma swapsxy: "A \<in> { [x,y], [y,x]} \<Longrightarrow> swaps sws A \<in> { [x,y], [y,x]}"
	apply(induct sws)
	apply(simp)
	apply(simp) unfolding swap_def by auto

	lemma mtf2xy: "A \<in> { [x,y], [y,x]} \<Longrightarrow> r\<in>{x,y} \<Longrightarrow> mtf2 a r A \<in> { [x,y], [y,x]}"
	by (metis mtf2_def swapsxy)


	lemma stepxy: assumes "q \<in> {x,y}" "A \<in> { [x,y], [y,x]}"
	shows "step A q a \<in> { [x,y], [y,x]}"
	unfolding step_def apply(simp only: split_def Let_def)
	apply(rule mtf2xy)
	apply(rule swapsxy) by fact+


	subsection "Proof of Optimality"

	lemma OPT2_is_lb: "set \<sigma> \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] \<sigma> (OPT2 \<sigma> [x,y]) \<le> T\<^sub>p_opt [x,y] \<sigma>"
	proof (induct "length \<sigma>" arbitrary: x y \<sigma> rule: less_induct)
	case (less)
	show ?case
	proof (cases \<sigma>)
	case (Cons a \<sigma>')
	note Cons1=Cons
	show ?thesis unfolding Cons
	proof(cases "a=x") (* case that the element in front is requested *)
	case True
	from True Cons have qsform: "\<sigma> = x#\<sigma>'" by auto
	have up: "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (x # \<sigma>')"
	unfolding True
	unfolding T_opt_def apply(rule cInf_greatest)
	apply(simp add: Ex_list_of_length)
	proof -
	fix el
	assume "el \<in> {T\<^sub>p [x, y] (x # \<sigma>') as \|as. length as = length (x # \<sigma>')}"
	then obtain Strat where lStrat: "length Strat = length (x # \<sigma>')"
	and el: "T\<^sub>p [x, y] (x # \<sigma>') Strat = el" by auto
	then have ne: "Strat \<noteq> []" by auto
	let ?LA="step [x,y] x (hd (OPT2 (x # \<sigma>') [x, y]))"

	have E0: "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y])
	=T\<^sub>p ?LA (\<sigma>') (OPT2 (\<sigma>') ?LA)" using yup by auto
	also have E1: "\<dots> = T\<^sub>p [x,y] (\<sigma>') (OPT2 (\<sigma>') [x,y])" by (simp add: OPT2x step_def)
	also have E2: "\<dots> \<le> T\<^sub>p_opt [x,y] \<sigma>'" apply(rule less(1)) using Cons less(2,3) by auto
	also have "\<dots> \<le> T\<^sub>p [x, y] (x # \<sigma>') Strat"
	proof (cases "(step [x, y] x (hd Strat)) = [x,y]")
	case True
	have aha: "T\<^sub>p_opt [x, y] \<sigma>' \<le> T\<^sub>p [x, y] \<sigma>' (tl Strat)"
	unfolding T_opt_def apply(rule cInf_lower)
	apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto

	also have E4: "\<dots> \<le> t\<^sub>p [x, y] x (hd Strat) + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)"
	unfolding True by(simp)
	also have E5: "\<dots> = T\<^sub>p [x, y] (x # \<sigma>') Strat" using splitqsallg[of Strat x x y \<sigma>', OF ne, simplified]
	by (auto)
	finally show ?thesis by auto
	next
	case False
	have tp1: "t\<^sub>p [x, y] x (hd Strat) \<ge> 1"
	proof (rule ccontr)
	let ?a = "hd Strat"
	assume "\<not> 1 \<le> t\<^sub>p [x, y] x ?a"
	then have tp0: "t\<^sub>p [x, y] x ?a = 0" by auto
	then have "size (snd ?a) = 0" unfolding t\<^sub>p_def by(simp add: split_def)
	then have nopaid: "(snd ?a) = []" by auto
	have "step [x, y] x ?a = [x, y]"
	unfolding step_def apply(simp add: split_def nopaid)
	unfolding mtf2_def by(simp)
	then show "False" using False by auto
	qed

	from False have yx: "step [x, y] x (hd Strat) = [y, x]"
	using stepxy[where x=x and y=y and a="hd Strat"] by auto

	have E3: "T\<^sub>p_opt [x, y] \<sigma>' \<le> 1 + T\<^sub>p_opt [y, x] \<sigma>'" using swapOpt by auto
	also have E4: "\<dots> \<le> 1 + T\<^sub>p [y, x] \<sigma>' (tl Strat)"
	apply(simp) unfolding T_opt_def apply(rule cInf_lower)
	apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto
	also have E5: "\<dots> = 1 + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)" using yx by auto
	also have E6: "\<dots> \<le> t\<^sub>p [x, y] x (hd Strat) + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)" using tp1 by auto

	also have E7: "\<dots> = T\<^sub>p [x, y] (x # \<sigma>') Strat" using splitqsallg[of Strat x x y \<sigma>', OF ne, simplified]
	by (auto)
	finally show ?thesis by auto
	qed
	also have "\<dots> = el" using True el by simp
	finally show "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y]) \<le> el" by auto
	qed
	then show "T\<^sub>p [x, y] (a # \<sigma>') (OPT2 (a # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (a # \<sigma>')"
	using True by simp
	next


	case False (* case 2: element at back is requested first *)
	with less Cons have ay: "a=y" by auto
	show "T\<^sub>p [x, y] (a # \<sigma>') (OPT2 (a # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (a # \<sigma>')" unfolding ay
	proof(cases \<sigma>')
	case Nil
	have up: "T\<^sub>p_opt [x, y] [y] \<ge> 1"
	unfolding T_opt_def apply(rule cInf_greatest)
	apply(simp add: Ex_list_of_length)
	proof -
	fix el
	assume "el \<in> {T\<^sub>p [x, y] [y] as \|as. length as = length [y]}"
	then obtain Strat where Strat: "length Strat = length [y]" and
	el: "el = T\<^sub>p [x, y] [y] Strat " by auto
	from Strat obtain a where a: "Strat = [a]" by (metis Suc_length_conv length_0_conv)
	show "1 \<le> el" unfolding el a apply(simp) unfolding t\<^sub>p_def apply(simp add: split_def)
	apply(cases "snd a")
	apply(simp add: less(3))
	by(simp)
	qed

	show "T\<^sub>p [x, y] (y # \<sigma>') (OPT2 (y # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (y # \<sigma>')" unfolding Nil
	apply(simp add: t\<^sub>p_def) using less(3) apply(simp)
	using up by(simp)
	next
	case (Cons b rest2)

	show up: "T\<^sub>p [x, y] (y # \<sigma>') (OPT2 (y # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (y # \<sigma>')"
	unfolding Cons
	proof (cases "b=x")
	case True

	show "T\<^sub>p [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y]) \<le> T\<^sub>p_opt [x, y] (y # b # rest2)"
	unfolding True
	unfolding T_opt_def apply(rule cInf_greatest)
	apply(simp add: Ex_list_of_length)
	proof -
	fix el
	assume "el \<in> {T\<^sub>p [x, y] (y # x # rest2) as \|as. length as = length (y # x # rest2)}"
	then obtain Strat where lenStrat: "length Strat = length (y # x # rest2)" and
	Strat: "el = T\<^sub>p [x, y] (y # x # rest2) Strat" by auto
	have v: " set rest2 \<subseteq> {x, y}" using less(2)[unfolded Cons1 Cons] by auto

	let ?L1 = "(step [x, y] y (hd Strat))"
	let ?L2 = "(step ?L1 x (hd (tl Strat)))"

	(* lets work on how Strat can look like: *)
	let ?a1 = "hd Strat"
	let ?a2 = "hd (tl Strat)"
	let ?r = "tl (tl Strat)"

	have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)




	have 1: "T\<^sub>p [x, y] (y # x # rest2) Strat
	= t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
	+ T\<^sub>p ?L2 rest2 (tl (tl Strat))"
	proof -
	have a: "Strat \<noteq> []" using lenStrat by auto
	have b: "(tl Strat) \<noteq> []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

	have 1: "T\<^sub>p [x, y] (y # x # rest2) Strat
	= t\<^sub>p [x, y] y (hd Strat) + T\<^sub>p ?L1 (x # rest2) (tl Strat)"
	using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
	have tt: "step [x, y] y (hd Strat) \<noteq> [x, y] \<Longrightarrow> step [x, y] y (hd Strat) = [y,x]"
	using stepxy[where A="[x,y]"] by blast

	have 2: "T\<^sub>p ?L1 (x # rest2) (tl Strat) = t\<^sub>p ?L1 x (hd (tl Strat)) + T\<^sub>p ?L2 (rest2) (tl (tl Strat))"
	apply(cases "?L1=[x,y]")
	using splitqsallg[OF b, where a=x and x=x and y=y, simplified] apply(auto)
	using tt splitqsallg[OF b, where a=x and x=y and y=x, simplified] by auto
	from 1 2 show ?thesis by auto
	qed

	have " T\<^sub>p [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y])
	= 1 + T\<^sub>p [x, y] (rest2) (OPT2 (rest2) [x, y])"
	unfolding True
	using less(3) by(simp add: t\<^sub>p_def step_def OPT2x)
	also have "\<dots> \<le> 1 + T\<^sub>p_opt [x, y] (rest2)" apply(simp)
	apply(rule less(1))
	apply(simp add: less(2) Cons1 Cons)
	apply(fact) by fact
	also

	have "\<dots> \<le> T\<^sub>p [x, y] (y # x # rest2) Strat"
	proof (cases "?L2 = [x,y]")
	case True
	have 2: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
	+ T\<^sub>p [x,y] rest2 (tl (tl Strat)) \<ge> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
	+ T\<^sub>p_opt [x,y] rest2" apply(simp)
	unfolding T_opt_def apply(rule cInf_lower)
	apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
	have 3: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
	+ T\<^sub>p_opt [x,y] rest2 \<ge> 1 + T\<^sub>p_opt [x,y] rest2" apply(simp)
	proof -
	have "t\<^sub>p [x, y] y (hd Strat) \<ge> 1"
	unfolding t\<^sub>p_def apply(simp add: split_def)
	apply(cases "snd (hd Strat)") by (simp_all add: less(3))
	then show "Suc 0 \<le> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))" by auto
	qed
	from 1 2 3 True show ?thesis by auto
	next
	case False
	note L2F=this
	have L1: "?L1 \<in> {[x, y], [y, x]}" apply(rule stepxy) by simp_all
	have "?L2 \<in> {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
	with False have 2: "?L2 = [y,x]" by auto

	have k: "T\<^sub>p [x, y] (y # x # rest2) Strat
	= t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat)) +
	T\<^sub>p [y,x] rest2 (tl (tl Strat))" using 1 2 by auto

	have l: "t\<^sub>p [x, y] y (hd Strat) > 0"
	using less(3) unfolding t\<^sub>p_def apply(cases "snd (hd Strat) = []")
	by (simp_all add: split_def)

	have r: "T\<^sub>p [x, y] (y # x # rest2) Strat \<ge> 2 + T\<^sub>p [y,x] rest2 (tl (tl Strat))"
	proof (cases "?L1 = [x,y]")
	case True
	note T=this
	then have "t\<^sub>p ?L1 x (hd (tl Strat)) > 0" unfolding True
	proof(cases "snd (hd (tl Strat)) = []")
	case True
	have "?L2 = [x,y]" unfolding T apply(simp add: split_def step_def)
	unfolding True mtf2_def by(simp)
	with L2F have "False" by auto
	then show "0 < t\<^sub>p [x, y] x (hd (tl Strat))" ..
	next
	case False
	then show "0 < t\<^sub>p [x, y] x (hd (tl Strat))"
	unfolding t\<^sub>p_def by(simp add: split_def)
	qed
	with l have " t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat)) \<ge> 2" by auto
	with k show ?thesis by auto
	next
	case False
	from L1 False have 2: "?L1 = [y,x]" by auto
	{ fix k sws T
	have "T\<in>{[x,y],[y,x]} \<Longrightarrow> mtf2 k x T = [y,x] \<Longrightarrow> T = [y,x]"
	apply(rule ccontr) by (simp add: less(3) mtf2_def)
	}
	have t1: "t\<^sub>p [x, y] y (hd Strat) \<ge> 1" unfolding t\<^sub>p_def apply(simp add: split_def)
	apply(cases "(snd (hd Strat))") using \<open>x \<noteq> y\<close> by auto
	have t2: "t\<^sub>p [y,x] x (hd (tl Strat)) \<ge> 1" unfolding t\<^sub>p_def apply(simp add: split_def)
	apply(cases "(snd (hd (tl Strat)))") using \<open>x \<noteq> y\<close> by auto
	have "T\<^sub>p [x, y] (y # x # rest2) Strat
	= t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p (step [x, y] y (hd Strat)) x (hd (tl Strat)) + T\<^sub>p [y, x] rest2 (tl (tl Strat))"
	by(rule k)
	with t1 t2 2 show ?thesis by auto
	qed
	have t: "T\<^sub>p [y, x] rest2 (tl (tl Strat)) \<ge> T\<^sub>p_opt [y, x] rest2"
	unfolding T_opt_def apply(rule cInf_lower)
	apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
	show ?thesis
	proof -
	have "1 + T\<^sub>p_opt [x, y] rest2 \<le> 2 + T\<^sub>p_opt [y, x] rest2"
	using swapOpt by auto
	also have "\<dots> \<le> 2 + T\<^sub>p [y, x] rest2 (tl (tl Strat))" using t by auto
	also have "\<dots> \<le> T\<^sub>p [x, y] (y # x # rest2) Strat" using r by auto
	finally show ?thesis .
	qed

	qed
	also have "\<dots> = el" using Strat by auto
	finally show "T\<^sub>p [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y]) \<le> el" .
	qed


	next
	case False
	with Cons1 Cons less(2) have bisy: "b=y" by auto
	with less(3) have "OPT2 (y # b # rest2) [x, y] = (1,[])# (OPT2 (b#rest2) [y,x])" by simp
	show "T\<^sub>p [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y]) \<le> T\<^sub>p_opt [x, y] (y # b # rest2)"
	unfolding bisy
	unfolding T_opt_def apply(rule cInf_greatest)
	apply(simp add: Ex_list_of_length)
	proof -
	fix el
	assume "el \<in> {T\<^sub>p [x, y] (y # y # rest2) as \|as. length as = length (y # y # rest2)}"
	then obtain Strat where lenStrat: "length Strat = length (y # y # rest2)" and
	Strat: "el = T\<^sub>p [x, y] (y # y # rest2) Strat" by auto
	have v: " set rest2 \<subseteq> {x, y}" using less(2)[unfolded Cons1 Cons] by auto

	let ?L1 = "(step [x, y] y (hd Strat))"
	let ?L2 = "(step ?L1 y (hd (tl Strat)))"

	(* lets work on how Strat can look like: *)
	let ?a1 = "hd Strat"
	let ?a2 = "hd (tl Strat)"
	let ?r = "tl (tl Strat)"

	have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)




	have 1: "T\<^sub>p [x, y] (y # y # rest2) Strat
	= t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
	+ T\<^sub>p ?L2 rest2 (tl (tl Strat))"
	proof -
	have a: "Strat \<noteq> []" using lenStrat by auto
	have b: "(tl Strat) \<noteq> []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

	have 1: "T\<^sub>p [x, y] (y # y # rest2) Strat
	= t\<^sub>p [x, y] y (hd Strat) + T\<^sub>p ?L1 (y # rest2) (tl Strat)"
	using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
	have tt: "step [x, y] y (hd Strat) \<noteq> [x, y] \<Longrightarrow> step [x, y] y (hd Strat) = [y,x]"
	using stepxy[where A="[x,y]"] by blast

	have 2: "T\<^sub>p ?L1 (y # rest2) (tl Strat) = t\<^sub>p ?L1 y (hd (tl Strat)) + T\<^sub>p ?L2 (rest2) (tl (tl Strat))"
	apply(cases "?L1=[x,y]")
	using splitqsallg[OF b, where a=y and x=x and y=y, simplified] apply(auto)
	using tt splitqsallg[OF b, where a=y and x=y and y=x, simplified] by auto
	from 1 2 show ?thesis by auto
	qed

	have " T\<^sub>p [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y])
	= 1 + T\<^sub>p [y, x] (rest2) (OPT2 (rest2) [y, x])"
	using less(3) by(simp add: t\<^sub>p_def step_def mtf2_def swap_def OPT2x)
	also have "\<dots> \<le> 1 + T\<^sub>p_opt [y, x] (rest2)" apply(simp)
	apply(rule less(1))
	apply(simp add: less(2) Cons1 Cons)
	using v less(3) by(auto)
	also

	have "\<dots> \<le> T\<^sub>p [x, y] (y # y # rest2) Strat"
	proof (cases "?L2 = [y,x]")
	case True
	have 2: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
	+ T\<^sub>p [y,x] rest2 (tl (tl Strat)) \<ge> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
	+ T\<^sub>p_opt [y,x] rest2" apply(simp)
	unfolding T_opt_def apply(rule cInf_lower)
	apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
	have 3: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
	+ T\<^sub>p_opt [y,x] rest2 \<ge> 1 + T\<^sub>p_opt [y,x] rest2" apply(simp)
	proof -
	have "t\<^sub>p [x, y] y (hd Strat) \<ge> 1"
	unfolding t\<^sub>p_def apply(simp add: split_def)
	apply(cases "snd (hd Strat)") by (simp_all add: less(3))
	then show "Suc 0 \<le> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))" by auto
	qed
	from 1 2 3 True show ?thesis by auto
	next
	case False
	note L2F=this
	have L1: "?L1 \<in> {[x, y], [y, x]}" apply(rule stepxy) by simp_all
	have "?L2 \<in> {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
	with False have 2: "?L2 = [x,y]" by auto

	have k: "T\<^sub>p [x, y] (y # y # rest2) Strat
	= t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat)) +
	T\<^sub>p [x,y] rest2 (tl (tl Strat))" using 1 2 by auto

	have l: "t\<^sub>p [x, y] y (hd Strat) > 0"
	using less(3) unfolding t\<^sub>p_def apply(cases "snd (hd Strat) = []")
	by (simp_all add: split_def)

	have r: "T\<^sub>p [x, y] (y # y # rest2) Strat \<ge> 2 + T\<^sub>p [x,y] rest2 (tl (tl Strat))"
	proof (cases "?L1 = [y,x]")
	case False
	from L1 False have "?L1 = [x,y]" by auto
	note T=this
	then have "t\<^sub>p ?L1 y (hd (tl Strat)) > 0" unfolding T
	unfolding t\<^sub>p_def apply(simp add: split_def)
	apply(cases "snd (hd (tl Strat)) = []")
	using \<open>x \<noteq> y\<close> by auto
	with l k show ?thesis by auto
	next

	case True
	note T=this

	have "t\<^sub>p ?L1 y (hd (tl Strat)) > 0" unfolding T
	proof(cases "snd (hd (tl Strat)) = []")
	case True
	have "?L2 = [y,x]" unfolding T apply(simp add: split_def step_def)
	unfolding True mtf2_def by(simp)
	with L2F have "False" by auto
	then show "0 < t\<^sub>p [y, x] y (hd (tl Strat))" ..
	next
	case False
	then show "0 < t\<^sub>p [y, x] y (hd (tl Strat))"
	unfolding t\<^sub>p_def by(simp add: split_def)
	qed
	with l have " t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat)) \<ge> 2" by auto
	with k show ?thesis by auto

	qed
	have t: "T\<^sub>p [x, y] rest2 (tl (tl Strat)) \<ge> T\<^sub>p_opt [x, y] rest2"
	unfolding T_opt_def apply(rule cInf_lower)
	apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
	show ?thesis
	proof -
	have "1 + T\<^sub>p_opt [y, x] rest2 \<le> 2 + T\<^sub>p_opt [x, y] rest2"
	using swapOpt by auto
	also have "\<dots> \<le> 2 + T\<^sub>p [x, y] rest2 (tl (tl Strat))" using t by auto
	also have "\<dots> \<le> T\<^sub>p [x, y] (y # y # rest2) Strat" using r by auto
	finally show ?thesis .
	qed

	qed
	also have "\<dots> = el" using Strat by auto
	finally show "T\<^sub>p [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y]) \<le> el" .
	qed
	qed
	qed
	qed
	qed (simp add: T_opt_def)
	qed


	lemma OPT2_is_ub: "set qs \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) \<ge> T\<^sub>p_opt [x,y] qs"
	unfolding T_opt_def apply(rule cInf_lower)
	apply(simp) apply(rule exI[where x="(OPT2 qs [x, y])"])
	by (auto simp add: OPT2_length)



	lemma OPT2_is_opt: "set qs \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = T\<^sub>p_opt [x,y] qs"
	by (simp add: OPT2_is_lb OPT2_is_ub antisym)


	subsection "Performance on the four phase forms"

	lemma OPT2_A: assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
	shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = 1"
	proof -
	from assms(2) obtain u v where qs: "qs=u@v" and u: "u=[x] \<or> u=[]" and v: "v = [y,y]" by (auto simp: conc_def)
	from u have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
	apply(cases "u=[]")
	apply(simp)
	by(simp add: OPT2x t\<^sub>p_def step_def)

	have ende: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1" unfolding v using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

	from pref1 ende qs show ?thesis by auto
	qed


	lemma OPT2_A': assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
	shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = 1"
	using OPT2_A[OF assms] by simp


	lemma OPT2_B: assumes "x \<noteq> y" "qs=u@v" "u=[] \<or> u=[x]" "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
	proof -
	from assms(3) have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
	apply(cases "u=[]")
	apply(simp)
	by(simp add: OPT2x t\<^sub>p_def step_def)

	from assms(4) obtain a w where v: "v=a@w" and "a\<in>lang (Times (Atom y) (Atom x))" and w: "w\<in>lang (seq[Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto)
	from this(2) have aa: "a=[y,x]" by(simp add: conc_def)

	from assms(1) this v have pref2: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1 + T\<^sub>p [x,y] w (OPT2 w [x,y])"
	by(simp add: t\<^sub>p_def step_def OPT2x)

	from w obtain c d where w2: "w=c@d" and c: "c \<in> lang (Star (Times (Atom y) (Atom x)))" and d: "d \<in> lang (Times (Atom y) (Atom y))" by auto
	then have dd: "d=[y,y]" by auto

	from c[simplified] have star: "T\<^sub>p [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) + T\<^sub>p [x,y] d (OPT2 d [x,y])"
	proof(induct c rule: star_induct)
	case (append r s)
	then have r: "r=[y,x]" by auto
	then have "T\<^sub>p [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = T\<^sub>p [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
	also have "\<dots> = 1 + T\<^sub>p [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
	using assms(1) by(simp add: t\<^sub>p_def step_def OPT2x)
	also have "\<dots> = 1 + length s div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using append by simp
	also have "\<dots> = length (r @ s) div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using r by auto
	finally show ?case .
	qed simp

	have ende: "T\<^sub>p [x,y] d (OPT2 d [x,y]) = 1" unfolding dd using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

	have vv: "v = [y,x]@c@[y,y]" using w2 dd v aa by auto

	from pref1 pref2 star w2 ende have
	"T\<^sub>p [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2 + 1" unfolding assms(2) by auto
	also have "\<dots> = (length v div 2)" using vv by auto
	finally show ?thesis .
	qed

	lemma OPT2_B1: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = length qs / 2"
	proof -
	from assms(2) have qs: "qs \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
	by(simp add: conc_assoc)
	have "(length qs) mod 2 = 0"
	proof -
	from assms(2) have "qs \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
	then obtain p q r where pqr: "qs=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
	then have rr: "p = [y,x]" "r=[y,y]" by auto
	with pqr have a: "length qs = 4+length q" by auto
	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show ?thesis by auto
	qed
	with OPT2_B[where u="[]", OF assms(1) _ _ qs] show ?thesis by auto
	qed

	lemma OPT2_B2: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = ((length qs - 1) / 2)"
	proof -
	from assms(2) obtain v where
	qsv: "qs = [x]@v" and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by (auto simp add: conc_def)
	have "(length v) mod 2 = 0"
	proof -
	from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
	then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
	then have rr: "p = [y,x]" "r=[y,y]" by(auto simp add: conc_def)
	with pqr have a: "length v = 4+length q" by auto
	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show ?thesis by auto
	qed
	with OPT2_B[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis by(auto)
	qed

	lemma OPT2_C: assumes "x \<noteq> y" "qs=u@v" "u=[] \<or> u=[x]"
	and "v \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
	shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
	proof -
	from assms(3) have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
	apply(cases "u=[]")
	apply(simp)
	by(simp add: OPT2x t\<^sub>p_def step_def)

	from assms(4) obtain a w where v: "v=a@w" and aa: "a=[y,x]" and w: "w\<in>lang (seq[Star(Times (Atom y) (Atom x)), Atom x])" by(auto simp: conc_def)

	from assms(1) this v have pref2: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1 + T\<^sub>p [x,y] w (OPT2 w [x,y])"
	by(simp add: t\<^sub>p_def step_def OPT2x)

	from w obtain c d where w2: "w=c@d" and c: "c \<in> lang (Star (Times (Atom y) (Atom x)))" and d: "d \<in> lang (Atom x)" by auto
	then have dd: "d=[x]" by auto

	from c[simplified] have star: "T\<^sub>p [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) + T\<^sub>p [x,y] d (OPT2 d [x,y]) \<and> (length c) mod 2 = 0"
	proof(induct c rule: star_induct)
	case (append r s)
	from append have mod: "length s mod 2 = 0" by simp
	from append have r: "r=[y,x]" by auto
	then have "T\<^sub>p [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = T\<^sub>p [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
	also have "\<dots> = 1 + T\<^sub>p [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
	using assms(1) by(simp add: t\<^sub>p_def step_def OPT2x)
	also have "\<dots> = 1 + length s div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using append by simp
	also have "\<dots> = length (r @ s) div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using r by auto
	finally show ?case by(simp add: mod r)
	qed simp

	have ende: "T\<^sub>p [x,y] d (OPT2 d [x,y]) = 0" unfolding dd using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

	have vv: "v = [y,x]@c@[x]" using w2 dd v aa by auto

	from pref1 pref2 star w2 ende have
	"T\<^sub>p [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2" unfolding assms(2) by auto
	also have "\<dots> = (length v div 2)" using vv star by auto
	finally show ?thesis .
	qed

	lemma OPT2_C1: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
	shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = (length qs - 1) / 2"
	proof -
	from assms(2) have qs: "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
	by(simp add: conc_assoc)
	have "(length qs) mod 2 = 1"
	proof -
	from assms(2) have "qs \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
	then obtain p q r where pqr: "qs=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[x]}" by (metis concE)
	then have rr: "p = [y,x]" "r=[x]" by auto
	with pqr have a: "length qs = 3+length q" by auto
	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show ?thesis by auto
	qed
	with OPT2_C[where u="[]", OF assms(1) _ _ qs] show ?thesis apply auto
	by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral)
	qed

	lemma OPT2_C2: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
	shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = ((length qs - 2) / 2)"
	proof -
	from assms(2) obtain v where
	qsv: "qs = [x]@v" and vv: "v \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])" by (auto simp add: conc_def)
	have "(length v) mod 2 = 1"
	proof -
	from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
	then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[x]}" by (metis concE)
	then have rr: "p = [y,x]" "r=[x]" by(auto simp add: conc_def)
	with pqr have a: "length v = 3+length q" by auto
	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show ?thesis by auto
	qed
	with OPT2_C[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis apply(auto)
	by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral)
	qed



	lemma OPT2_ub: "set qs \<subseteq> {x,y} \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) \<le> length qs"
	proof(induct qs arbitrary: x y)
	case (Cons q qs)
	then have "set qs \<subseteq> {x,y}" "q\<in>{x,y}" by auto
	note Cons1=Cons this
	show ?case
	proof (cases qs)
	case Nil
	with Cons1 show "T\<^sub>p [x,y] (q # qs) (OPT2 (q # qs) [x,y]) \<le> length (q # qs)"
	apply(simp add: t\<^sub>p_def) by blast
	next
	case (Cons q' qs')
	with Cons1 have "q'\<in>{x,y}" by auto
	note Cons=Cons this

	from Cons1 Cons have T: "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) \<le> length qs"
	"T\<^sub>p [y, x] qs (OPT2 qs [y, x]) \<le> length qs" by auto
	show "T\<^sub>p [x,y] (q # qs) (OPT2 (q # qs) [x,y]) \<le> length (q # qs)"
	unfolding Cons apply(simp only: OPT2.simps)
	apply(split if_splits(1))
	apply(safe)
	proof (goal_cases)
	case 1
	have "T\<^sub>p [x, y] (x # q' # qs') ((0, []) # OPT2 (q' # qs') [x, y])
	= t\<^sub>p [x, y] x (0,[]) + T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
	by(simp add: step_def Cons)
	also have "\<dots> \<le> t\<^sub>p [x, y] x (0,[]) + length qs" using T by auto
	also have "\<dots> \<le> length (x # q' # qs')" using Cons by(simp add: t\<^sub>p_def)
	finally show ?case .
	next
	case 2
	with Cons1 Cons show ?case
	apply(split if_splits(1))
	apply(safe)
	proof (goal_cases)
	case 1
	then have "T\<^sub>p [x, y] (y # x # qs') ((0, []) # OPT2 (x # qs') [x, y])
	= t\<^sub>p [x, y] y (0,[]) + T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
	by(simp add: step_def)
	also have "\<dots> \<le> t\<^sub>p [x, y] y (0,[]) + length qs" using T by auto
	also have "\<dots> \<le> length (y # x # qs')" using Cons by(simp add: t\<^sub>p_def)
	finally show ?case .
	next
	case 2
	then have "T\<^sub>p [x, y] (y # y # qs') ((1, []) # OPT2 (y # qs') [y, x])
	= t\<^sub>p [x, y] y (1,[]) + T\<^sub>p [y, x] qs (OPT2 qs [y, x])"
	by(simp add: step_def mtf2_def swap_def)
	also have "\<dots> \<le> t\<^sub>p [x, y] y (1,[]) + length qs" using T by auto
	also have "\<dots> \<le> length (y # y # qs')" using Cons by(simp add: t\<^sub>p_def)
	finally show ?case .
	qed
	qed
	qed
	qed simp

	lemma OPT2_padded: "R\<in>{[x,y],[y,x]} \<Longrightarrow> set qs \<subseteq> {x,y}
	\<Longrightarrow> T\<^sub>p R (qs@[x,x]) (OPT2 (qs@[x,x]) R)
	\<le> T\<^sub>p R (qs@[x]) (OPT2 (qs@[x]) R) + 1"
	apply(induct qs arbitrary: R)
	apply(simp)
	apply(case_tac "R=[x,y]")
	apply(simp add: step_def t\<^sub>p_def )
	apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
	proof (goal_cases)
	case (1 a qs R)
	then have a: "a \<in> {x,y}" by auto
	with 1 show ?case
	apply(cases qs)
	apply(cases "a=x")
	apply(cases "R=[x,y]")
	apply(simp add: step_def t\<^sub>p_def)
	apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
	apply(cases "R=[x,y]")
	apply(simp add: step_def t\<^sub>p_def)
	apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
	proof (goal_cases)
	case (1 p ps)
	show ?case
	apply(cases "a=x")
	apply(cases "R=[x,y]")
	apply(simp add: OPT2x step_def) using 1 apply(simp)
	using 1(2) apply(simp)
	apply(cases qs)
	apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
	using 1 by(auto simp add: swap_def mtf2_def step_def)
	qed
	qed


	lemma OPT2_split11:
	assumes xy: "x\<noteq>y"
	shows "R\<in>{[x,y],[y,x]} \<Longrightarrow> set xs \<subseteq> {x,y} \<Longrightarrow> set ys \<subseteq> {x,y} \<Longrightarrow> OPT2 (xs@[x,x]@ys) R = OPT2 (xs@[x,x]) R @ OPT2 ys [x,y]"
	proof (induct xs arbitrary: R)
	case Nil
	then show ?case
	apply(simp)
	apply(cases ys)
	apply(simp)
	apply(cases "R=[x,y]")
	apply(simp)
	by(simp)
	next
	case (Cons a as)
	note iH=this
	then have AS: "set as \<subseteq> {x,y}" and A: "a \<in> {x,y}" by auto
	note iH=Cons(1)[where R="[y,x]", simplified, OF AS Cons(4)]
	note iH'=Cons(1)[where R="[x,y]", simplified, OF AS Cons(4)]
	show ?case
	proof (cases "R=[x,y]")
	case True
	note R=this
	from iH iH' show ?thesis
	apply(cases "a=x")
	apply(simp add: R OPT2x)
	using A apply(simp)
	apply(cases as)
	apply(simp add: R)
	using AS apply(simp)
	apply(case_tac "aa=x")
	by(simp_all add: R)
	next
	case False
	with Cons(2) have R: "R=[y,x]" by auto
	from iH iH' show ?thesis
	apply(cases "a=y")
	apply(simp add: R OPT2x)
	using A apply(simp)
	apply(cases as)
	apply(simp add: R)
	apply(case_tac "aa=y")
	by (simp_all add: R)
	qed
	qed

	subsection "The function steps"


	lemma steps_append: "length qs = length as \<Longrightarrow> steps s (qs@[q]) (as@[a]) = step (steps s qs as) q a"
	apply(induct qs as arbitrary: s rule: list_induct2) by simp_all

	end
	diff --git a/thys/List_Update/TS.thy b/thys/List_Update/TS.thy
	--- a/thys/List_Update/TS.thy
	+++ b/thys/List_Update/TS.thy
	@@ -1,2694 +1,2682 @@
	(* Title: Competitive Analysis of TS
	Author: Max Haslbeck
	*)

	section "TS: another 2-competitive Algorithm"

	theory TS
	imports
	OPT2
	Phase_Partitioning
	Move_to_Front
	List_Factoring
	RExp_Var
	begin



	subsection "Definition of TS"



	definition TS_step_d where
	"TS_step_d s q = ((
	(
	let li = index (snd s) q in
	(if li = length (snd s) then 0 \<comment> \<open>requested for first time\<close>
	else (let sincelast = take li (snd s)
	in (let S={x. x < q in (fst s) \<and> count_list sincelast x \<le> 1}
	in
	(if S={} then 0
	else
	(index (fst s) q) - Min ( (index (fst s)) ` S)))
	)
	)
	)
	,[]), q#(snd s))"


	(* FIXME: generalizing regular expressions equivalence checking
	enables relaxing the type here to 'a::linord *)
	definition rTS :: "nat list \<Rightarrow> (nat,nat list) alg_on" where "rTS h = ((\<lambda>s. h), TS_step_d)"

	fun TSstep where
	"TSstep qs n (is,s)
	= ((qs!n)#is,
	step s (qs!n) ((
	let li = index is (qs!n) in
	(if li = length is then 0 \<comment> \<open>requested for first time\<close>
	else (let sincelast = take li is
	in (let S={x. x < (qs!n) in s \<and> count_list sincelast x \<le> 1}
	in
	(if S={} then 0
	else
	(index s (qs!n)) - Min ( (index s) ` S)))
	)
	)
	),[]))"

	lemma TSnopaid: "(snd (fst (snd (rTS initH) is q))) = []"
	unfolding rTS_def by(simp add: TS_step_d_def)


	abbreviation TSdet where
	"TSdet init initH qs n == config (rTS initH) init (take n qs)"

	lemma TSdet_Suc: "Suc n \<le> length qs \<Longrightarrow> TSdet init initH qs (Suc n) = Step (rTS initH) (TSdet init initH qs n) (qs!n)"
	by(simp add: take_Suc_conv_app_nth config_snoc)

	(* now do the proof with TSdet *)

	definition s_TS where "s_TS init initH qs n = fst (TSdet init initH qs n)"

	lemma sndTSdet: "n\<le>length xs \<Longrightarrow> snd (TSdet init initH xs n) = rev (take n xs) @ initH"
	apply(induct n)
	apply(simp add: rTS_def)
	by(simp add: split_def TS_step_d_def take_Suc_conv_app_nth config'_snoc Step_def rTS_def)


	subsection "Behaviour of TS on lists of length 2"

	lemma
	fixes hs x y
	assumes "x\<noteq>y"
	shows oneTS_step : "TS_step_d ([x, y], x#y#hs) y = ((1, []), y # x # y # hs)"
	and oneTS_stepyyy: "TS_step_d ([x, y], y#x#hs) y = ((Suc 0, []), y#y#x#hs)"
	and oneTS_stepx: "TS_step_d ([x, y], x#x#hs) y = ((0, []), y # x # x # hs)"
	and oneTS_stepy: "TS_step_d ([x, y], []) y = ((0, []), [y])"
	and oneTS_stepxy: "TS_step_d ([x, y], [x]) y = ((0, []), [y, x])"
	and oneTS_stepyy: "TS_step_d ([x, y], [y]) y = ((Suc 0, []), [y, y])"
	and oneTS_stepyx: "TS_step_d ([x, y], hs) x = ((0, []), x # hs)"
	using assms by(auto simp add: step_def mtf2_def swap_def TS_step_d_def before_in_def)

	lemmas oneTS_steps = oneTS_stepx oneTS_stepxy oneTS_stepyx oneTS_stepy oneTS_stepyy oneTS_stepyyy oneTS_step

	subsection "Analysis of the Phases"

	definition "TS_inv c x i \<equiv> (\<exists>hs. c = return_pmf ((if x=hd i then i else rev i),[x,x]@hs) )
	\<or> c = return_pmf ((if x=hd i then i else rev i),[])"

	lemma TS_inv_sym: "a\<noteq>b \<Longrightarrow> {a,b}={x,y} \<Longrightarrow> z\<in>{x,y} \<Longrightarrow> TS_inv c z [a,b] = TS_inv c z [x,y]"
	unfolding TS_inv_def by auto

	abbreviation "TS_inv' s x i == TS_inv (return_pmf s) x i"

	lemma TS_inv'_det: "TS_inv' s x i = ((\<exists>hs. s = ((if x=hd i then i else rev i),[x,x]@hs) )
	\<or> s = ((if x=hd i then i else rev i),[]))"
	unfolding TS_inv_def by auto

	lemma TS_inv'_det2: "TS_inv' (s,h) x i = (\<exists>hs. (s,h) = ((if x=hd i then i else rev i),[x,x]@hs) )
	\<or> (s,h) = ((if x=hd i then i else rev i),[])"
	unfolding TS_inv_def by auto

	(*
	TS_A (x+1)yy \<rightarrow> Plus(Atom (x::nat)) One,(Atom y), (Atom y)]
	TS_B (x+1)yx(yx)*yy \<rightarrow> Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)]
	TS_C (x+1)yx(yx)*x \<rightarrow> Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)]
	TD_D xx \<rightarrow> seq[(Atom x),(Atom x)]
	*)

	subsubsection "(yx)*?"

	lemma TS_yx': assumes "x \<noteq> y" "qs \<in> lang (Star(Times (Atom y) (Atom x)))"
	"\<exists>hs. h=[x,y]@hs"
	shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs + T_on' (rTS h0) ([x,y],((rev qs) @h)) r
	\<and> (\<exists>hs. ((rev qs) @h) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y],h) qs = ([x,y],rev qs @ h)"
	proof -
	from assms have "qs \<in> star ({[y]} @@ {[x]})" by (simp)
	from this assms(3) show ?thesis
	proof (induct qs arbitrary: h rule: star_induct)
	case Nil
	then show ?case by(simp add: rTS_def)
	next
	case (append u v)
	then have uyx: "u = [y,x]" by auto
	from append obtain hs where a: "h = [x,y]@hs" by blast

	have "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r
	\<and> (\<exists>hs. rev v @ (rev u @ h) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))"
	apply(simp only: uyx) apply(rule append(3)) by simp
	then have yy: "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r"
	and history: "(\<exists>hs. rev v @ (rev u @ h) = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))" by auto

	have s0: "s_TS [x, y] h [y, x] 0 = [x,y]" unfolding s_TS_def by(simp)

	from assms(1) have hahah: " {xa. xa < y in [x, y] \<and> count_list [x] xa \<le> 1} = {x}"
	unfolding before_in_def by auto



	have "config' (rTS h0) ([x, y],h) u = ([x, y], x # y # x # y # hs)"
	apply(simp add: split_def rTS_def uyx a )
	using assms(1) by(auto simp add: Step_def oneTS_steps step_def mtf2_def swap_def)

	then have s2: "config' (rTS h0) ([x, y],h) u = ([x, y], ((rev u) @ h))"
	unfolding a uyx by simp

	have "config' (rTS h0) ([x, y], h) (u @ v) =
	config' (rTS h0) (Partial_Cost_Model.config' (rTS h0) ([x, y], h) u) v" by (rule config'_append2)
	also
	have "\<dots> = config' (rTS h0) ([x, y], ((rev u) @ h)) v" by(simp only: s2)
	also
	have "\<dots> = ([x, y], rev (u @ v) @ h)" by (simp add: state)
	finally
	have alles: "config' (rTS h0) ([x, y], h) (u @ v) = ([x, y], rev (u @ v) @ h)" .


	have ta: "T_on' (rTS h0) ([x,y],h) u = 2"
	unfolding rTS_def uyx a apply(simp only: T_on'.simps(2))
	using assms(1) apply(auto simp add: Step_def step_def mtf2_def swap_def oneTS_steps)
	by(simp add: t\<^sub>p_def)



	have "T_on' (rTS h0) ([x,y],h) ((u @ v) @ r)
	= T_on' (rTS h0) ([x,y],h) (u @ (v @ r))" by auto
	also have "\<dots>
	= T_on' (rTS h0) ([x,y],h) u
	+ T_on' (rTS h0) (config' (rTS h0) ([x, y],h) u) (v @ r)"
	by(rule T_on'_append)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u
	+ T_on' (rTS h0) ([x, y],(rev u @ h)) (v @ r)" by(simp only: s2)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: yy)
	also have "\<dots> = 2 + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: ta)
	also have "\<dots> = length (u @ v) + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" using uyx by auto
	also have "\<dots> = length (u @ v) + T_on' (rTS h0) ([x, y], (rev (u @ v) @ h)) r" by auto
	finally show ?case using history alles by simp
	qed
	qed

	subsubsection "?x"


	lemma TS_x': "T_on' (rTS h0) ([x,y],h) [x] = 0 \<and> config' (rTS h0) ([x, y],h) [x] = ([x,y], rev [x] @ h)"
	by(auto simp add: t\<^sub>p_def rTS_def TS_step_d_def Step_def step_def)

	subsubsection "?yy"

	lemma TS_yy': assumes "x \<noteq> y" "\<exists>hs. h = [x, y] @ hs"
	shows "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
	proof -
	from assms obtain hs where a: "h = [x,y]@hs" by blast

	from a show "T_on' (rTS h0) ([x,y],h) [y, y] = 1"
	unfolding rTS_def
	using assms(1) apply(auto simp add: oneTS_steps Step_def step_def mtf2_def swap_def)
	by(simp add: t\<^sub>p_def)

	show "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
	unfolding rTS_def a using assms(1)
	by(simp add: Step_def oneTS_steps step_def mtf2_def swap_def)
	qed

	subsubsection "yx(yx)*?"

	lemma TS_yxyx': assumes [simp]: "x \<noteq> y" and "qs \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
	"(\<exists>hs. h=[x,x]@hs) \<or> index h y = length h"
	shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r
	\<and> (\<exists>hs. (rev qs @ h) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y],h) qs = ([x,y], rev qs @ h)"
	proof -
	obtain u v where uu: "u \<in> lang (Times (Atom y) (Atom x))"
	and vv: "v \<in> lang (seq[ Star(Times (Atom y) (Atom x))])"
	and qsuv: "qs = u @ v"
	using assms(2)
	by (auto simp: conc_def)
	from uu have uyx: "u = [y,x]" by(auto)

	from qsuv uyx have vqs: "length v = length qs - 2" by auto
	from qsuv uyx have vqs2: "length v + 1 = length qs - 1" by auto

	have firststep: "TS_step_d ([x, y], h) y = ((0, []), y # h)"
	proof (cases "index h y = length h")
	case True
	then show ?thesis unfolding TS_step_d_def by(simp)
	next
	case False
	with assms(3) obtain hs where a: "h = [x,x]@hs" by auto
	then show ?thesis by(simp add: oneTS_steps)
	qed

	have s2: "config' (rTS h0) ([x,y],h) u = ([x, y], x # y # h)"
	unfolding rTS_def uyx apply(simp add: )
	unfolding Step_def by(simp add: firststep step_def oneTS_steps)

	have ta: "T_on' (rTS h0) ([x,y],h) u = 1"
	unfolding rTS_def uyx
	apply(simp)
	apply(simp add: firststep)
	unfolding Step_def
	using assms(1) by (simp add: firststep step_def oneTS_steps t\<^sub>p_def)

	have ttt:
	"T_on' (rTS h0) ([x,y],rev u @ h) (v@r) = length v + T_on' (rTS h0) ([x,y],((rev v) @(rev u @ h))) r
	\<and> (\<exists>hs. ((rev v) @(rev u @ h)) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y],(rev u @ h)) v = ([x,y],rev v @ (rev u @ h))"
	apply(rule TS_yx')
	apply(fact)
	using vv apply(simp)
	using uyx by(simp)
	then have tat: "T_on' (rTS h0) ([x,y], x # y # h) (v@r) =
	length v + T_on' (rTS h0) ([x,y],rev qs @ h) r"
	and history: "(\<exists>hs. (rev qs @ h) = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], x # y # h) v = ([x,y],rev qs @ h)" using qsuv uyx
	by auto

	have "config' (rTS h0) ([x, y], h) qs = config' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
	unfolding qsuv by (rule config'_append2)
	also
	have "\<dots> = ([x, y], rev qs @ h)" by(simp add: s2 state)
	finally
	have his: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)" .


	have "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],h) (u @ v @ r)" using qsuv by auto
	also have "\<dots>
	= T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) (config' (rTS h0) ([x,y],h) u) (v @ r)"
	by(rule T_on'_append)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) ([x, y], x # y # h) (v @ r)" by(simp only: s2)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by (simp only: tat)
	also have "\<dots> = 1 + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by(simp only: ta)
	also have "\<dots> = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r" using vqs2 by auto
	finally show ?thesis
	apply(safe)
	using history apply(simp)
	using his by auto
	qed




	lemma TS_xr': assumes "x \<noteq> y" "qs \<in> lang (Plus (Atom x) One)"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs) "
	shows "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],rev qs@h) r"
	"((\<exists>hs. (rev qs @ h) = [x, x] @ hs) \<or> (rev qs @ h) = [x] \<or> (rev qs @ h)=[]) "
	"config' (rTS h0) ([x,y],h) (qs@r) = config' (rTS h0) ([x,y],rev qs @ h) r"
	using assms
	by (auto simp add: T_on'_append Step_def rTS_def TS_step_d_def step_def t\<^sub>p_def)

	subsubsection "(x+1)yx(yx)*yy"

	lemma ts_b': assumes "x \<noteq> y"
	"v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
	\<and> (\<exists>hs. (rev v @ h) = [y,y]@hs) \<and> config' (rTS h0) ([x,y], h) v = ([y,x], rev v @ h)"
	proof -
	from assms have lenvmod: "length v mod 2 = 0" apply(simp)
	proof -
	assume "v \<in> ({[y]} @@ {[x]}) @@ star ({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}"
	then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in> {[y]} @@ {[y]}" by (metis concE)
	then have "p = [y,x]" "r=[y,y]" by auto
	with pqr have a: "length v = 4+length q" by auto

	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show ?thesis by auto
	qed

	with assms(1,3) have fall: "(\<exists>hs. h = [x, x] @ hs) \<or> index h y = length h"
	by(auto)

	from assms(2) have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
	@@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
	then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
	and "b \<in> lang (seq[Atom y, Atom y])"
	and vab: "v = a @ b"
	by(erule concE)
	then have bb: "b=[y,y]" by auto
	from aa have lena: "length a > 0" by auto

	from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
	length a - 1 + T_on' (rTS h0) ([x, y], rev a @ h) b"
	and history: "(\<exists>hs. rev a @ h = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], h) a = ([x,y],rev a @ h)" by auto
	(* "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)" *)
	have suffix: "T_on' (rTS h0) ([x, y], rev a @ h) b = 1"
	and jajajaj: "config' (rTS h0) ([x, y],rev a @ h) b = ([y,x],rev b @ rev a @ h)" unfolding bb
	using TS_yy' history assms(1) by auto

	from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a" using lena by auto
	then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto


	have grgr:"config' (rTS h0) ([x, y], h) v = ([y, x], rev v @ h)"
	unfolding vab
	apply(simp only: config'_append2 state jajajaj) by simp

	from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
	then obtain hs2 where reva: "rev a @ h = x # hs2" by auto

	show ?thesis using whatineed grgr
	by(auto simp add: reva vab bb)
	qed

	lemma TS_b'1: assumes "x \<noteq> y" "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	"qs \<in> lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)
	\<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	proof -
	have f: "qs \<in> lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	using assms(3) by(simp add: conc_assoc)

	from ts_b'[OF assms(1) f] assms(2) have
	T_star: "T_on' (rTS h0) ([x, y], h) qs = length qs - 2"
	and inv1: "config' (rTS h0) ([x, y], h) qs = ([y, x], rev qs @ h)"
	and inv2: "(\<exists>hs. rev qs @ h = [y, y] @ hs)" by auto

	from T_star have TS: "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)" by metis

	have lqs: "last qs = y" using assms(3) by force


	from inv1 have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
	apply(simp add: lqs)
	apply(subst TS_inv'_det)
	using assms(2) inv2 by(simp)


	show ?thesis unfolding TS
	apply(safe)
	by(fact inv)
	qed



	lemma TS_b1'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	then have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []" by blast
	from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_b'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note b1=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule b1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule b1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed


	lemma ts_b2': assumes "x \<noteq> y"
	"qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
	\<and> config' (rTS h0) ([x,y], h) qs = ([y,x],rev qs@h) \<and> (\<exists>hs. (rev qs @ h) = [y,y]@hs)"
	proof -
	from assms(2) obtain v where qs: "qs = [x]@v"
	and V: "v\<in>lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	by(auto simp add: conc_assoc)

	from assms(3) have 3: "(\<exists>hs. x#h = [x, x] @ hs) \<or> x#h = [x] \<or> x#h = []" by auto

	from ts_b'[OF assms(1) V 3]
	have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
	and C: "config' (rTS h0) ([x, y], x#h) v = ([y, x], rev v @ x#h)"
	and H: "(\<exists>hs. rev v @ x#h = [y, y] @ hs)" by auto

	have t: "t\<^sub>p [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
	by (simp add: step_def rTS_def TS_step_d_def t\<^sub>p_def)
	have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
	= ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

	show ?thesis
	unfolding qs apply(safe)
	apply(simp add: T_on'_append T c t)
	apply(simp add: config'_rand_append C c)
	using H by simp
	qed


	lemma TS_b2'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)

	from C have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = []" by blast

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_b2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note b2=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule b2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule b2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed



	lemma TS_b': assumes "x \<noteq> y" "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	"qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "T_on' (rTS h0) ([x, y], h) qs
	\<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y]) \<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	proof -
	obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
	and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	and qsuv: "qs = u @ v"
	using assms(3)
	by (auto simp: conc_def)

	from TS_xr'[OF assms(1) uu assms(2)] have
	T_pre: "T_on' (rTS h0) ([x, y], h) (u @ v) =
	T_on' (rTS h0) ([x, y], rev u @ h) v"
	and fall': "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> (rev u @ h) = [x] \<or> (rev u @ h)=[]"
	and conf: "config' (rTS h0) ([x,y],h) (u@v) = config' (rTS h0) ([x,y],rev u @ h) v"
	by auto

	with assms uu have fall: "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> index (rev u @ h) y = length (rev u @ h)"
	by(auto)

	from ts_b'[OF assms(1) vv fall'] have
	T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = length v - 2"
	and inv1: "config' (rTS h0) ([x, y], rev u @ h) v = ([y, x], rev v @ rev u @ h)"
	and inv2: "(\<exists>hs. rev v @ rev u @ h = [y, y] @ hs)" by auto

	from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

	(* OPT *)

	from uu have uuu: "u=[] \<or> u=[x]" by auto
	from vv have vvv: "v \<in> lang (seq
	[Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto simp: conc_def)
	have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_B) by(fact)+

	have lqs: "last qs = y" using assms(3) by force

	have "config' (rTS h0) ([x, y], h) qs = ([y, x], rev qs @ h)"
	unfolding qsuv conf inv1 by simp

	then have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
	apply(simp add: lqs)
	apply(subst TS_inv'_det)
	using assms(2) inv2 qsuv by(simp)


	show ?thesis unfolding TS OPT
	apply(safe)
	apply(simp)
	by(fact inv)
	qed


	subsubsection "(x+1)yy"


	lemma ts_a': assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	shows "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]
	\<and> T_on' (rTS h0) ([x, y], h) qs = 2"
	proof -
	obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
	and vv: "v \<in> lang (seq[Atom y, Atom y])"
	and qsuv: "qs = u @ v"
	using assms(2)
	by (auto simp: conc_def)

	from vv have vv2: "v = [y,y]" by auto

	from uu have TS_prefix: " T_on' (rTS h0) ([x, y], h) u = 0"
	using assms(1) by(auto simp add: rTS_def oneTS_steps t\<^sub>p_def)

	have h_split: "rev u @ h = [] \<or> rev u @ h = [x] \<or> (\<exists> hs. rev u @ h = [x,x]@hs)"
	using assms(3) uu by(auto)

	then have e: "T_on' (rTS h0) ([x,y],rev u @ h) [y,y] = 2"
	using assms(1)
	apply(auto simp add: rTS_def
	oneTS_steps
	Step_def step_def t\<^sub>p_def) done

	have conf: "config' (rTS h0) ([x, y], h) u = ([x,y], rev u @ h)"
	using uu by(auto simp add: Step_def rTS_def TS_step_d_def step_def)

	have "T_on' (rTS h0) ([x, y], h) qs = T_on' (rTS h0) ([x, y], h) (u @ v)" using qsuv by auto
	also have "\<dots>
	=T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
	by(rule T_on'_append)
	also have "\<dots>
	= T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) ([x,y],rev u @ h) [y,y]"
	by(simp add: conf vv2)
	also have "\<dots> = T_on' (rTS h0) ([x, y], h) u + 2" by (simp only: e)
	also have "\<dots> = 2" by (simp add: TS_prefix)
	finally have TS: "T_on' (rTS h0) ([x, y], h) qs= 2" .

	(* dannach *)

	have lqs: "last qs = y" using assms(2) by force

	from assms(1) have "config' (rTS h0) ([x, y], h) qs = ([y,x], rev qs @ h)"
	unfolding qsuv
	apply(simp only: config'_append2 conf vv2)
	using h_split
	apply(auto simp add: Step_def rTS_def
	oneTS_steps
	step_def)
	by(simp_all add: mtf2_def swap_def)

	with assms(1) have "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	apply(subst TS_inv'_det)
	by(simp add: qsuv vv2 lqs)

	show ?thesis unfolding TS apply(auto) by fact
	qed

	lemma TS_a': assumes "x \<noteq> y"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	and "qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y])"
	shows "T_on' (rTS h0) ([x, y], h) qs \<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])
	\<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]
	\<and> T_on' (rTS h0) ([x, y], h) qs = 2"
	proof -
	have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = 1" using OPT2_A[OF assms(1,3)] by auto
	show ?thesis using OPT ts_a'[OF assms(1,3,2)] by auto
	qed

	lemma TS_a'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
	shows
	"TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T\<^sub>p_on_rand' (embed (rTS h0)) s qs = 2"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto

	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	"qs \<in> lang (seq [question (Atom x), Atom y, Atom y])"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 2"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_a'[OF A] by auto
	} note b=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule b)
	using assms apply(simp)
	using assms apply(simp)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule b)
	using assms apply(simp)
	using assms apply(simp)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed

	subsubsection "x+yx(yx)*x"

	lemma ts_c': assumes "x \<noteq> y"
	"v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
	\<and> config' (rTS h0) ([x,y], h) v = ([x,y],rev v@h) \<and> (\<exists>hs. (rev v @ h) = [x,x]@hs)"
	proof -
	from assms have lenvmod: "length v mod 2 = 1" apply(simp)
	proof -
	assume "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}"
	then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in> {[x]}" by (metis concE)
	then have "p = [y,x]" "r=[x]" by auto
	with pqr have a: "length v = 3+length q" by auto

	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show "length v mod 2 = Suc 0" by auto
	qed

	with assms(1,3) have fall: "(\<exists>hs. h = [x, x] @ hs) \<or> index h y = length h"
	by(auto)



	from assms(2) have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
	@@ lang (seq[Atom x])" by (auto simp: conc_def)
	then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
	and "b \<in> lang (seq[Atom x])"
	and vab: "v = a @ b"
	by(erule concE)
	then have bb: "b=[x]" by auto
	from aa have lena: "length a > 0" by auto

	from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
	length a - 1 + T_on' (rTS h0) ([x, y],rev a @ h) b"
	and history: "(\<exists>hs. rev a @ h = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], h) a = ([x, y], rev a @ h)" by auto


	have suffix: "T_on' (rTS h0) ( [x, y],rev a @ h) b = 0"
	and suState: "config' (rTS h0) ([x, y], rev a @ h) b = ([x,y], rev b @ (rev a @ h))"
	unfolding bb using TS_x' by auto

	from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a - 1" by auto
	then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto

	have conf: "config' (rTS h0) ([x, y], h) v = ([x, y], rev v @ h)"
	by(simp add: vab config'_append2 state suState)


	from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
	then obtain hs2 where reva: "rev a @ h = x # hs2" by auto


	show ?thesis using whatineed
	apply(auto)
	using conf apply(simp)
	by(simp add: reva vab bb)
	qed


	lemma TS_c1'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	then have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []" by blast
	from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_c'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note c1=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule c1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule c1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed

	lemma ts_c2': assumes "x \<noteq> y"
	"qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
	\<and> config' (rTS h0) ([x,y], h) qs = ([x,y],rev qs@h) \<and> (\<exists>hs. (rev qs @ h) = [x,x]@hs)"
	proof -
	from assms(2) obtain v where qs: "qs = [x]@v"
	and V: "v\<in>lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	by(auto simp add: conc_assoc)

	from assms(3) have 3: "(\<exists>hs. x#h = [x, x] @ hs) \<or> x#h = [x] \<or> x#h = []" by auto

	from ts_c'[OF assms(1) V 3]
	have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
	and C: "config' (rTS h0) ([x, y], x#h) v = ([x, y], rev v @ x#h)"
	and H: "(\<exists>hs. rev v @ x#h = [x, x] @ hs)" by auto

	have t: "t\<^sub>p [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
	by (simp add: step_def rTS_def TS_step_d_def t\<^sub>p_def)
	have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
	= ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

	show ?thesis
	unfolding qs apply(safe)
	apply(simp add: T_on'_append T c t)
	apply(simp add: config'_rand_append C c)
	using H by simp
	qed


	lemma TS_c2'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)

	from C have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = []" by blast

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_c2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note c2=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule c2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule c2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed


	lemma TS_c': assumes "x \<noteq> y" "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	"qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
	shows "T_on' (rTS h0) ([x, y], h) qs
	\<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y]) \<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	proof -
	obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
	and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	and qsuv: "qs = u @ v"
	using assms(3)
	by (auto simp: conc_def)

	from TS_xr'[OF assms(1) uu assms(2)] have
	T_pre: "T_on' (rTS h0) ([x, y], h) (u@v) = T_on' (rTS h0) ([x, y], rev u @ h) v"
	and fall': "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> (rev u @ h) = [x] \<or> (rev u @ h)=[]"
	and conf': "config' (rTS h0) ([x, y], h) (u @ v) =
	config' (rTS h0) ([x, y], rev u @ h) v" by auto

	with assms uu have fall: "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> index (rev u @ h) y = length (rev u @ h)"
	by(auto)

	from ts_c'[OF assms(1) vv fall'] have
	T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = (length v - 2)"
	and inv1: "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ rev u @ h)"
	and inv2: "(\<exists>hs. rev v @ rev u @ h = [x, x] @ hs)" by auto

	from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

	(* OPT *)

	from uu have uuu: "u=[] \<or> u=[x]" by auto
	from vv have vvv: "v \<in> lang (seq
	[Atom y, Atom x,
	Star (Times (Atom y) (Atom x)),
	Atom x])" by(auto simp: conc_def)
	have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_C) by(fact)+

	have lqs: "last qs = x" using assms(3) by force

	have conf: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)"
	by(simp add: qsuv conf' inv1)
	then have conf: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	apply(simp add: lqs)
	apply( subst TS_inv'_det)
	using inv2 qsuv by(simp)

	show ?thesis unfolding TS OPT
	by (auto simp add: conf)
	qed



	subsubsection "xx"

	lemma request_first: "x\<noteq>y \<Longrightarrow> Step (rTS h) ([x, y], is) x = ([x,y],x#is)"
	unfolding rTS_def Step_def by(simp add: split_def TS_step_d_def step_def)

	lemma ts_d': "qs \<in> Lxx x y \<Longrightarrow>
	x \<noteq> y \<Longrightarrow>
	h = [] \<or> (\<exists>hs. h = [x, x] @ hs) \<Longrightarrow>
	qs \<in> lang (seq [Atom x, Atom x]) \<Longrightarrow>
	T_on' (rTS h0) ([x, y], h) qs = 0 \<and>
	TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x,y]"
	proof -
	assume xny: "x \<noteq> y"
	assume "qs \<in> lang (seq [Atom x, Atom x])"
	then have xx: "qs = [x,x]" by auto

	from xny have TS: "T_on' (rTS h0) ([x, y], h) qs = 0" unfolding xx
	by(auto simp add: Step_def step_def oneTS_steps rTS_def t\<^sub>p_def)

	from xny have "config' (rTS h0) ([x, y], h) qs = ([x, y], x # x # h) "
	by(auto simp add: xx Step_def rTS_def oneTS_steps step_def)

	then have " TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x, y]"
	by(simp add: TS_inv'_det)

	with TS show ?thesis by simp
	qed



	lemma TS_d': assumes xny: "x \<noteq> y" and "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	and qsis: "qs \<in> lang (seq [Atom x, Atom x])"
	shows "T_on' (rTS h0) ([x,y],h) qs \<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y]) "
	and "TS_inv' (config' (rTS h0) ([x,y],h) qs) (last qs) [x, y]"
	and "T_on' (rTS h0) ([x,y],h) qs = 0"
	proof -
	from qsis have xx: "qs = [x,x]" by auto

	show TS: "T_on' (rTS h0) ([x,y],h) qs = 0"
	using assms(1) by (auto simp add: xx t\<^sub>p_def rTS_def Step_def oneTS_steps step_def)
	then show "T_on' (rTS h0) ([x,y],h) qs \<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])" by simp

	show "TS_inv' (config' (rTS h0) ([x,y],h) qs) (last qs) [x, y]"
	unfolding TS_inv_def
	by(simp add: xx request_first[OF xny])
	qed


	lemma TS_d'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom x, Atom x])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = 0"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq [Atom x, Atom x])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)


	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 0"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using TS_d'[OF A C B ] A lqs unfolding TS_inv'_det by auto
	} note d=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule d)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule d)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed



	subsection "Phase Partitioning"

	lemma D': assumes "\<sigma>' \<in> Lxx x y" and "x \<noteq> y" and "TS_inv' ([x, y], h) x [x, y]"
	shows "T_on' (rTS h0) ([x, y], h) \<sigma>' \<le> 2 * T\<^sub>p [x, y] \<sigma>' (OPT2 \<sigma>' [x, y])
	\<and> TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) \<sigma>') (last \<sigma>') [x, y]"
	proof -

	from config'_embed have " config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) \<sigma>'
	= return_pmf (Partial_Cost_Model.config' (rTS h0) ([x, y], h) \<sigma>')" by blast

	then have L: "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) \<sigma>') (last \<sigma>') [x, y]
	= TS_inv' (config' (rTS h0) ([x, y], h) \<sigma>') (last \<sigma>') [x, y]" by auto

	from assms(3) have
	h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	by(auto simp add: TS_inv'_det)

	have "T_on' (rTS h0) ([x, y], h) \<sigma>' \<le> 2 * T\<^sub>p [x, y] \<sigma>' (OPT2 \<sigma>' [x, y])
	\<and> TS_inv' (config' (rTS h0) ([x, y], h) \<sigma>') (last \<sigma>') [x, y]"
	apply(rule LxxE[OF assms(1)])
	using TS_d'[OF assms(2) h, of "\<sigma>'"] apply(simp)
	using TS_b'[OF assms(2) h] apply(simp)
	using TS_c'[OF assms(2) h] apply(simp)
	using TS_a'[OF assms(2) h] apply fast
	done

	then show ?thesis using L by auto
	qed

	theorem TS_OPT2': "(x::nat) \<noteq> y \<Longrightarrow> set \<sigma> \<subseteq> {x,y}
	\<Longrightarrow> T\<^sub>p_on (rTS []) [x,y] \<sigma> \<le> 2 * real (T\<^sub>p_opt [x,y] \<sigma>) + 2"
	apply(subst T_on_embed)
	apply(rule Phase_partitioning_general[where P=TS_inv])
	apply(simp)
	apply(simp)
	apply(simp)
	apply(simp add: TS_inv_def rTS_def)
	proof (goal_cases)
	case (1 a b \<sigma>' s)
	from 1(6) obtain h hist' where s: "s = return_pmf ([a, b], h)"
	and "h = [] \<or> h = [a,a]@hist'"
	unfolding TS_inv_def apply(cases "a=hd [x,y]")
	apply(simp) using 1 apply fast
	apply(simp) using 1 by blast

	from 1 have xyab: "TS_inv' ([a, b], h) a [x, y]
	= TS_inv' ([a, b], h) a [a, b]"
	by(auto simp add: TS_inv'_det)

	with 1(6) s have inv: "TS_inv' ([a, b], h) a [a, b]" by simp

	from \<open>\<sigma>' \<in> Lxx a b\<close> have "\<sigma>' \<noteq> []" using Lxx1 by fastforce
	then have l: "last \<sigma>' \<in> {x,y}" using 1(5,7) last_in_set by blast

	show ?case unfolding s T_on'_embed[symmetric]
	using D'[OF 1(3,4) inv, of "[]"]
	apply(safe)
	apply linarith
	using TS_inv_sym[OF 1(4,5)] l apply blast
	done
	qed

	subsection "TS is pairwise"



	lemma config'_distinct[simp]:
	shows "distinct (fst (config' A S qs)) = distinct (fst S)"
	apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def distinct_step)

	lemma config'_set[simp]:
	shows "set (fst (config' A S qs)) = set (fst S)"
	apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def set_step)

	lemma s_TS_append: "i\<le>length as \<Longrightarrow>s_TS init h (as@bs) i = s_TS init h as i"
	by (simp add: s_TS_def)

	lemma s_TS_distinct: "distinct init \<Longrightarrow> i<length qs \<Longrightarrow> distinct (fst (TSdet init h qs i))"
	by(simp_all add: config_config_distinct)

	lemma othersdontinterfere: "distinct init \<Longrightarrow> i < length qs \<Longrightarrow> a\<in>set init \<Longrightarrow> b\<in>set init
	\<Longrightarrow> set qs \<subseteq> set init \<Longrightarrow> qs!i\<notin>{a,b} \<Longrightarrow> a < b in s_TS init h qs i \<Longrightarrow> a < b in s_TS init h qs (Suc i)"
	apply(simp add: s_TS_def split_def take_Suc_conv_app_nth config_append Step_def step_def)
	apply(subst x_stays_before_y_if_y_not_moved_to_front)
	apply(simp_all add: config_config_distinct config_config_set)
	by(auto simp: rTS_def TS_step_d_def)

	lemma TS_mono:
	fixes l::nat
	assumes 1: "x < y in s_TS init h xs (length xs)"
	and l_in_cs: "l \<le> length cs"
	and firstocc: "\<forall>j<l. cs ! j \<noteq> y"
	and "x \<notin> set cs"
	and di: "distinct init"
	and inin: "set (xs @ cs) \<subseteq> set init"
	shows "x < y in s_TS init h (xs@cs) (length (xs)+l)"
	proof -
	from before_in_setD2[OF 1] have y: "y : set init" unfolding s_TS_def by(simp add: config_config_set)
	from before_in_setD1[OF 1] have x: "x : set init" unfolding s_TS_def by(simp add: config_config_set)

	{
	fix n
	assume "n\<le>l"
	then have "x < y in s_TS init h ((xs)@cs) (length (xs)+n)"
	proof(induct n)
	case 0
	show ?case apply (simp only: s_TS_append ) using 1 by(simp)
	next
	case (Suc n)
	then have n_lt_l: "n<l" by auto
	show ?case apply(simp)
	apply(rule othersdontinterfere)
	apply(rule di)
	using n_lt_l l_in_cs apply(simp)
	apply(fact x)
	apply(fact y)
	apply(fact inin)
	apply(simp add: nth_append) apply(safe)
	using assms(4) n_lt_l l_in_cs apply fastforce
	using firstocc n_lt_l apply blast
	using Suc(1) n_lt_l by(simp)
	qed
	}
	\<comment> \<open>before the request to y, x is in front of y\<close>
	then show "x < y in s_TS init h (xs@cs) (length (xs)+l)"
	by blast
	qed

	lemma step_no_action: "step s q (0,[]) = s"
	unfolding step_def mtf2_def by simp

	lemma s_TS_set: "i \<le> length qs \<Longrightarrow> set (s_TS init h qs i) = set init"
	apply(induct i)
	apply(simp add: s_TS_def )
	apply(simp add: s_TS_def TSdet_Suc)
	by(simp add: split_def rTS_def Step_def step_def)

	lemma count_notin2: "count_list xs x = 0 \<Longrightarrow> x \<notin> set xs"
	-apply (induction xs) apply (auto del: count_notin)
	- apply(case_tac "a=x") by(simp_all)+
	+by (simp add: count_list_0_iff)

	-lemma count_append: "count_list (xs@ys) x = count_list xs x + count_list ys x"
	-apply(induct xs) by(simp_all)
	-
	-lemma count_rev: "count_list (rev xs) x = count_list xs x"
	-apply(induct xs) by(simp_all add: count_append )
	-
	lemma mtf2_q_passes: assumes "q \<in> set xs" "distinct xs"
	and "index xs q - n \<le> index xs x" "index xs x < index xs q"
	shows "q < x in (mtf2 n q xs)"
	proof -
	from assms have "index xs q < length xs" by auto
	with assms(4) have ind_x: "index xs x < length xs" by auto
	then have xinxs: "x\<in>set xs" using index_less_size_conv by metis

	have B: "index (mtf2 n q xs) q = index xs q - n"
	apply(rule mtf2_q_after)
	by(fact)+
	also from ind_x mtf2_forward_effect3'[OF assms]
	have A: "\<dots> < index (mtf2 n q xs) x" by auto
	finally show ?thesis unfolding before_in_def using xinxs by force
	qed

	lemma twotox:
	assumes "count_list bs y \<le> 1"
	and "distinct init"
	and "x \<in> set init"
	and "y : set init"
	and "x \<notin> set bs"
	and "x\<noteq>y"
	shows "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
	proof -
	have aa: "snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))
	= rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h"
	apply(rule sndTSdet) by(simp)
	then have aa': "snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))
	= rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h" by auto
	have lasocc_x: "index (snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))) x = length bs"
	unfolding aa
	apply(simp add: del: config'.simps)
	using assms(5) by(simp add: index_append)
	then have lasocc_x': "(index (snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x) = length bs" by auto

	let ?sincelast = "take (length bs)
	(snd (TSdet init h ((as @ x # bs) @ [x])
	(Suc (length as + length bs))))"
	have sl: "?sincelast = rev bs" unfolding aa by(simp)
	let ?S = "{xa. xa < x in fst (TSdet init h (as @ x # bs @ [x])
	(Suc (length as + length bs))) \<and>
	count_list ?sincelast xa \<le> 1}"

	have y: "y \<in> ?S \<or> ~ y < x in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))"
	- unfolding sl unfolding s_TS_def using assms(1) by(simp add: count_rev del: config'.simps)
	+ unfolding sl unfolding s_TS_def using assms(1) by(simp del: config'.simps)

	have eklr: "length (as@[x]@bs@[x]) = Suc (length (as@[x]@bs))" by simp
	have 1: "s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))
	= fst (Partial_Cost_Model.Step (rTS h)
	(TSdet init h (as @ [x] @ bs @ [x])
	(length (as @ [x] @ bs)))
	((as @ [x] @ bs @ [x]) ! length (as @ [x] @ bs)))" unfolding s_TS_def unfolding eklr apply(subst TSdet_Suc)
	by(simp_all add: split_def)

	have brrr: "x\<in> set (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
	apply(subst s_TS_set[unfolded s_TS_def])
	apply(simp) by fact
	have ydrin: "y\<in>set (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
	apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact
	have dbrrr: "distinct (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
	apply(subst s_TS_distinct[unfolded s_TS_def]) using assms(2) by(simp_all)

	show ?thesis
	proof (cases "y < x in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))")
	case True
	with y have yS: "y\<in>?S" by auto
	then have minsteps: "Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)
	\<le> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y"
	by auto
	let ?entf = "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x -
	Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)"
	from minsteps have br: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
	\<le> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y"
	by presburger
	have brr: "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
	< index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x"
	using True unfolding before_in_def s_TS_def by auto

	from br brr have klo: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
	\<le> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
	\<and> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
	< index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x" by metis


	let ?result ="(mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))"

	have whatsthat: "s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))
	= ?result"
	unfolding 1 apply(simp add: split_def step_def rTS_def Step_def TS_step_d_def del: config'.simps)
	apply(simp add: nth_append del: config'.simps)
	using lasocc_x'[unfolded rTS_def] aa'[unfolded rTS_def]
	apply(simp add: del: config'.simps)
	using yS[unfolded sl rTS_def] by auto


	have ydrinee: " y \<in> set (mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))"
	apply(subst set_mtf2)
	apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact

	show ?thesis unfolding whatsthat apply(rule mtf2_q_passes) by(fact)+
	next
	case False
	then have 2: "x < y in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))"
	using brrr ydrin not_before_in assms(6) unfolding s_TS_def by metis
	{
	fix e
	have "x < y in mtf2 e x (s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs)))"
	apply(rule x_stays_before_y_if_y_not_moved_to_front)
	unfolding s_TS_def
	apply(fact)+
	using assms(6) apply(simp)
	using 2 unfolding s_TS_def by simp
	} note bratz=this
	show ?thesis unfolding 1 apply(simp add: TSnopaid split_def Step_def s_TS_def TS_step_d_def step_def nth_append del: config'.simps)
	using bratz[unfolded s_TS_def] by simp
	qed

	qed

	lemma count_drop: "count_list (drop n cs) x \<le> count_list cs x"
	proof -
	have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
	- also have "\<dots> = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_append)
	+ also have "\<dots> = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_list_append)
	also have "\<dots> \<ge> count_list (drop n cs) x" by auto
	finally show ?thesis .
	qed

	lemma count_take_less: assumes "n\<le>m"
	shows "count_list (take n cs) x \<le> count_list (take m cs) x"
	proof -
	from assms have "count_list (take n cs) x = count_list (take n (take m cs)) x" by auto
	- also have "\<dots> \<le> count_list (take n (take m cs) @ drop n (take m cs)) x" by (simp only: count_append)
	+ also have "\<dots> \<le> count_list (take n (take m cs) @ drop n (take m cs)) x" by (simp)
	also have "\<dots> = count_list (take m cs) x"
	by(simp only: append_take_drop_id)
	finally show ?thesis .
	qed

	lemma count_take: "count_list (take n cs) x \<le> count_list cs x"
	proof -
	have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
	- also have "\<dots> = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_append)
	+ also have "\<dots> = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_list_append)
	also have "\<dots> \<ge> count_list (take n cs) x" by auto
	finally show ?thesis .
	qed

	lemma casexxy: assumes "\<sigma>=as@[x]@bs@[x]@cs"
	and "x \<notin> set cs"
	and "set cs \<subseteq> set init"
	and "x \<in> set init"
	and "distinct init"
	and "x \<notin> set bs"
	and "set as \<subseteq> set init"
	and "set bs \<subseteq> set init"
	shows "(%i. i<length cs \<longrightarrow> (\<forall>j<i. cs!j\<noteq>cs!i) \<longrightarrow> cs!i\<noteq>x
	\<longrightarrow> (cs!i) \<notin> set bs
	\<longrightarrow> x < (cs!i) in (s_TS init h \<sigma> (length (as@[x]@bs@[x]) + i+1))) i"
	proof (rule infinite_descent[where P="(%i. i<length cs \<longrightarrow> (\<forall>j<i. cs!j\<noteq>cs!i) \<longrightarrow> cs!i\<noteq>x
	\<longrightarrow> (cs!i) \<notin> set bs
	\<longrightarrow> x < (cs!i) in (s_TS init h \<sigma> (length (as@[x]@bs@[x]) + i+1)))"], goal_cases)
	case (1 i)
	let ?y = "cs!i"
	from 1 have i_in_cs: "i < length cs" and
	firstocc: "(\<forall>j<i. cs ! j \<noteq> cs ! i)"
	and ynx: "cs ! i \<noteq> x"
	and ynotinbs: "cs ! i \<notin> set bs"
	and y_before_x': "~x < cs ! i in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)" by auto

	have ss: "set (s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)) = set init" using assms(1) i_in_cs by(simp add: s_TS_set)
	then have "cs ! i \<in> set (s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1))"
	unfolding ss using assms(3) i_in_cs by fastforce
	moreover have "x : set (s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1))"
	unfolding ss using assms(4) by fastforce

	\<comment> \<open>after the request to y, y is in front of x\<close>
	ultimately have y_before_x_Suct3: "?y < x in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)"
	using y_before_x' ynx not_before_in by metis

	from ynotinbs have yatmostonceinbs: "count_list bs (cs!i) \<le> 1" by simp


	let ?y = "cs!i"
	have yininit: "?y \<in> set init" using assms(3) i_in_cs by fastforce
	{
	fix y
	assume "y \<in> set init"
	assume "x\<noteq>y"
	assume "count_list bs y \<le> 1"
	then have "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
	apply(rule twotox) by(fact)+
	} note xgoestofront=this
	with yatmostonceinbs ynx yininit have zeitpunktt2: "x < ?y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))" by blast

	have "i \<le> length cs" using i_in_cs by auto
	have x_before_y_t3: "x < ?y in s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+i)"
	apply(rule TS_mono)
	apply(fact)+
	using assms by simp
	\<comment> \<open>so x and y swap positions when y is requested, that means that y was inserted infront of
	some elment z (which cannot be x, has only been requested at most once since last request of y
	but is in front of x)\<close>

	\<comment> \<open>first show that y must have been requested in as\<close>

	have "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) =
	rev (take (length (as @ [x] @ bs @ [x]) + i) (as @ [x] @ bs @ [x] @ cs)) @ h"
	apply(rule sndTSdet) using i_in_cs by simp
	also have "\<dots> = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by simp
	finally have fstTS_t3: "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) =
	(rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" .
	then have fstTS_t3': "(snd (TSdet init h \<sigma> (Suc (Suc (length as + length bs + i))))) =
	(rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" using assms(1) by auto

	let ?is = "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	let ?is' = "snd (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
	let ?s = "fst (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	let ?s' = "fst (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
	let ?s_Suct3="s_TS init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i+1)"

	let ?S = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s \<and>
	count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) xa \<le> 1) }"
	let ?S' = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s' \<and>
	count_list (take (index ?is' ((cs!i))) ?is') xa \<le> 1) }"

	have isis': "?is = ?is'" by(simp)
	have ss': "?s = ?s'" by(simp)
	then have SS': "?S = ?S'" using i_in_cs by(simp add: nth_append)


	(* unfold TSdet once *)
	have once: "TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i))))
	= Step (rTS h) (config\<^sub>p (rTS h) init (as @ x # bs @ x # take i cs)) (cs ! i)"
	apply(subst TSdet_Suc)
	using i_in_cs apply(simp)
	by(simp add: nth_append)

	have aha: "(index ?is (cs ! i) \<noteq> length ?is)
	\<and> ?S \<noteq> {}"
	proof (rule ccontr, goal_cases)
	case 1
	then have "(index ?is (cs ! i) = length ?is) \<or> ?S = {}" by(simp)
	then have alters: "(index ?is' (cs ! i) = length ?is') \<or> ?S' = {}"
	apply(simp only: SS') by(simp only: isis')
	\<comment> \<open>wenn (cs ! i) noch nie requested wurde, dann kann es gar nicht nach vorne gebracht werden!
	also widerspruch mit @{text y_before_x'}\<close>
	have "?s_Suct3 = fst (config (rTS h) init ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)))"
	unfolding s_TS_def
	apply(simp only: length_append)
	apply(subst take_append)
	apply(subst take_append)
	apply(subst take_append)
	apply(subst take_append)
	by(simp)
	also have "\<dots> = fst (config (rTS h) init (((as @ [x] @ bs @ [x]) @ (take i cs)) @ [cs!i]))"
	using i_in_cs by(simp add: take_Suc_conv_app_nth)
	also have "\<dots> = step ?s' ?y (0, [])"
	proof (cases "index ?is' (cs ! i) = length ?is'")
	case True
	show ?thesis
	apply(subst config_append)
	using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
	apply(subst TS_step_d_def)
	apply(simp only: True[unfolded rTS_def,simplified])
	by(simp)
	next
	case False
	with alters have S': "?S' = {}" by simp

	have 1 : "{xa. xa < cs ! i
	in fst (Partial_Cost_Model.config' (\<lambda>s. h, TS_step_d) (init, h)
	(as @ x # bs @ x # take i cs)) \<and>
	count_list (take (index
	(snd
	(Partial_Cost_Model.config'
	(\<lambda>s. h, TS_step_d) (init, h)
	(as @ x # bs @ x # take i cs)))
	(cs ! i))
	(snd
	(Partial_Cost_Model.config'
	(\<lambda>s. h, TS_step_d) (init, h)
	(as @ x # bs @ x # take i cs)))) xa \<le> 1} = {}" using S' by(simp add: rTS_def nth_append)

	show ?thesis
	apply(subst config_append)
	using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
	apply(subst TS_step_d_def)
	apply(simp only: 1 Let_def)
	by(simp)
	qed
	finally have "?s_Suct3 = step ?s ?y (0, [])" using ss' by simp
	then have e: "?s_Suct3 = ?s" by(simp only: step_no_action)
	from x_before_y_t3 have "x < cs ! i in ?s_Suct3" unfolding e unfolding s_TS_def by simp
	with y_before_x' show "False" unfolding assms(1) by auto
	qed
	then have aha': "index (snd (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))
	(cs ! i) \<noteq>
	length (snd (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))"
	and
	aha2: "?S \<noteq> {}" by auto


	from fstTS_t3' assms(1) have is_: "?is = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by auto

	have minlencsi: " min (length cs) i = i" using i_in_cs by linarith

	let ?lastoccy="(index (rev (take i cs) @ x # rev bs @ x # rev as @ h) (cs ! i))"
	have "?y \<notin> set (rev (take i cs))" using firstocc by (simp add: in_set_conv_nth)
	then have lastoccy: "?lastoccy \<ge>
	i + 1 + length bs + 1" using ynx ynotinbs minlencsi by(simp add: index_append)

	(* x is not in S, because it is requested at least twice since the last request to y*)
	have x_nin_S: "x\<notin>?S"
	using is_ apply(simp add: split_def nth_append del: config'.simps)
	proof (goal_cases)
	case 1
	have " count_list (take ?lastoccy (rev (take i cs))) x \<le>
	count_list (drop (length cs - i) (rev cs)) x" by (simp add: count_take rev_take)
	- also have "\<dots> \<le> count_list (rev cs) x" by(simp add: count_drop )
	- also have "\<dots> = 0" using assms(2) by(simp add: count_rev)
	+ also have "\<dots> \<le> count_list (rev cs) x" by (meson count_drop)
	+ also have "\<dots> = 0" using assms(2) by(simp)
	finally have " count_list (take ?lastoccy (rev (take i cs))) x = 0" by auto
	have"
	2 \<le>
	- count_list ([x] @ rev bs @ [x]) x " apply(simp only: count_append) by(simp)
	+ count_list ([x] @ rev bs @ [x]) x " by(simp)
	also have "\<dots> = count_list (take (1 + length bs + 1) (x # rev bs @ x # rev as @ h)) x" by auto
	also have "\<dots> \<le> count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x"
	apply(rule count_take_less)
	using lastoccy by linarith
	also have "\<dots> \<le> count_list (take ?lastoccy (rev (take i cs))) x
	+ count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x" by auto
	- also have "\<dots> = count_list (take ?lastoccy (rev (take i cs))
	- @ take (?lastoccy - min (length cs) i)
	- (x # rev bs @ x # rev as @ h)) x"
	- by(simp add: minlencsi count_append)
	- finally show ?case by presburger
	+ finally show ?case by(simp add: minlencsi)
	qed

	have "Min (index ?s ` ?S) \<in> (index ?s ` ?S)" apply(rule Min_in) using aha2 by (simp_all)
	then obtain z where zminimal: "index ?s z = Min (index ?s ` ?S)"and z_in_S: "z \<in> ?S" by auto
	then have bef: "z < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s"
	and "count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) z \<le> 1" by(blast)+

	with zminimal have zbeforey: "z < cs ! i in ?s"
	and zatmostonce: "count_list (take (index ?is (cs ! i)) ?is) z \<le> 1"
	and isminimal: "index ?s z = Min (index ?s ` ?S)" by(simp_all add: nth_append)
	have elemins: "z \<in> set ?s" unfolding before_in_def by (meson zbeforey before_in_setD1)
	then have zininit: "z \<in> set init"
	using i_in_cs by(simp add: s_TS_set[unfolded s_TS_def] del: config'.simps)

	from zbeforey have zbeforey_ind: "index ?s z < index ?s ?y" unfolding before_in_def by auto
	then have el_n_y: "z \<noteq> ?y" by auto

	have el_n_x: "z \<noteq> x" using x_nin_S z_in_S by blast

	(* and because it is JUST before that element, z must be before x *)
	{ fix s q
	have TS_step_d2: "TS_step_d s q =
	(let V\<^sub>r={x. x < q in fst s \<and> count_list (take (index (snd s) q) (snd s)) x \<le> 1}
	in ((if index (snd s) q \<noteq> length (snd s) \<and> V\<^sub>r \<noteq> {}
	then index (fst s) q - Min ( (index (fst s)) ` V\<^sub>r)
	else 0,[]),q#(snd s)))"
	unfolding TS_step_d_def
	apply(cases "index (snd s) q < length (snd s)")
	using index_le_size apply(simp split: prod.split) apply blast
	by(auto simp add: index_less_size_conv split: prod.split)
	} note alt_chara=this

	have iF: "(index (snd (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i)
	\<noteq> length (snd (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) \<and>
	{xa. xa < cs ! i in fst (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs)) \<and>
	count_list
	(take (index (snd (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i))
	(snd (Partial_Cost_Model.config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))))
	xa
	\<le> 1} \<noteq>
	{}) = True" using aha[unfolded rTS_def] ss' SS' by(simp add: nth_append)

	have "?s_Suct3 = fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i)))))"
	by(auto simp add: s_TS_def)
	also have "\<dots> = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])"
	apply(simp only: once[unfolded assms(1)])
	apply(simp add: Step_def split_def rTS_def del: config'.simps)
	apply(subst alt_chara)
	apply(simp only: Let_def )
	apply(simp only: iF)
	by(simp add: nth_append)
	finally have "?s_Suct3 = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])" .
	with isminimal have state_dannach: "?s_Suct3 = step ?s ?y (index ?s ?y - index ?s z, [])" by presburger


	\<comment> \<open>so y is moved in front of z, that means:\<close>
	have yinfrontofz: "?y < z in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)"
	unfolding assms(1) state_dannach apply(simp add: step_def del: config'.simps)
	apply(rule mtf2_q_passes)
	using i_in_cs assms(5) apply(simp_all add: s_TS_distinct[unfolded s_TS_def] s_TS_set[unfolded s_TS_def])
	using yininit apply(simp)
	using zbeforey_ind by simp




	have yins: "?y \<in> set ?s"
	using i_in_cs assms(3,5) apply(simp_all add: s_TS_set[unfolded s_TS_def] del: config'.simps)
	by fastforce

	have "index ?s_Suct3 ?y = index ?s z"
	and "index ?s_Suct3 z = Suc (index ?s z)"
	proof -
	let ?xs = "(fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))"
	have setxs: "set ?xs = set init"
	apply(rule s_TS_set[unfolded s_TS_def])
	using i_in_cs by auto
	then have yinxs: "cs ! i \<in> set ?xs"
	apply(simp add: setxs del: config'.simps)
	using assms(3) i_in_cs by fastforce

	have distinctxs: "distinct ?xs"
	apply(rule s_TS_distinct[unfolded s_TS_def])
	using i_in_cs assms(5) by auto


	let ?n = "(index
	(fst (TSdet init h (as @ x # bs @ x # cs)
	(Suc (Suc (length as + length bs + i)))))
	(cs ! i) -
	index
	(fst (TSdet init h (as @ x # bs @ x # cs)
	(Suc (Suc (length as + length bs + i)))))
	z)"

	have "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n\<and>
	index ?xs ?y - ?n = index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y )"
	apply(rule mtf2_forward_effect2)
	apply(fact)
	apply(fact)
	by simp

	then have "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n" by metis
	also have "\<dots> = index ?s z" using zbeforey_ind by force
	finally have A: "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?s z" .

	have aa: "index ?xs ?y - ?n \<le> index ?xs z" "index ?xs z < index ?xs ?y"
	apply(simp)
	using zbeforey_ind by fastforce

	from mtf2_forward_effect3'[OF yinxs distinctxs aa]
	have B: "index (mtf2 ?n ?y ?xs) z = Suc (index ?xs z)"
	using elemins yins by(simp add: nth_append split_def del: config'.simps)

	show "index ?s_Suct3 ?y = index ?s z"
	unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps)
	using A yins by(simp add: nth_append del: config'.simps)

	show "index ?s_Suct3 z = Suc (index ?s z)"
	unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps)
	using B yins by(simp add: nth_append del: config'.simps)
	qed

	then have are: "Suc (index ?s_Suct3 ?y) = index ?s_Suct3 z" by presburger





	from are before_in_def y_before_x_Suct3 el_n_x assms(1) have z_before_x: "z < x in ?s_Suct3"
	by (metis Suc_lessI not_before_in yinfrontofz)


	have xSuct3: "x\<in>set ?s_Suct3" using assms(4) i_in_cs by(simp add: s_TS_set)
	have elSuct3: "z\<in>set ?s_Suct3" using zininit i_in_cs by(simp add: s_TS_set)

	have xt3: "x\<in>set ?s " apply(subst config_config_set) by fact

	note elt3=elemins

	have z_s: "z < x in ?s"
	proof(rule ccontr, goal_cases)
	case 1
	then have "x < z in ?s" using not_before_in[OF xt3 elt3] el_n_x unfolding s_TS_def by blast
	then have "x < z in ?s_Suct3"
	apply (simp only: state_dannach)
	apply (simp only: step_def)
	apply(simp add: nth_append del: config'.simps)
	apply(rule x_stays_before_y_if_y_not_moved_to_front)
	apply(subst config_config_set) using i_in_cs assms(3) apply fastforce
	apply(subst config_config_distinct) using assms(5) apply fastforce
	apply(subst config_config_set) using assms(4) apply fastforce
	apply(subst config_config_set) using zininit apply fastforce
	using el_n_y apply(simp)
	by(simp)

	then show "False" using z_before_x not_before_in[OF xSuct3 elSuct3] by blast
	qed


	have mind: "(index ?is (cs ! i)) \<ge> i + 1 + length bs + 1 " using lastoccy
	using i_in_cs fstTS_t3'[unfolded assms(1)] by(simp add: split_def nth_append del: config'.simps)

	have "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z=
	count_list (take (i + 1 + length bs + 1) ?is) z" unfolding is_
	- using el_n_x by(simp add: minlencsi count_append )
	+ using el_n_x by(simp add: minlencsi)
	also from mind have "\<dots>
	\<le> count_list (take (index ?is (cs ! i)) ?is) z"
	by(rule count_take_less)
	also have "\<dots> \<le> 1" using zatmostonce by metis
	finally have aaa: "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z \<le> 1" .
	with el_n_x have "count_list bs z + count_list (take i cs) z \<le> 1"
	- by(simp add: count_append count_rev)
	+ by(simp)
	moreover have "count_list (take (Suc i) cs) z = count_list (take i cs) z"
	- using i_in_cs el_n_y by(simp add: take_Suc_conv_app_nth count_append)
	+ using i_in_cs el_n_y by(simp add: take_Suc_conv_app_nth)
	ultimately have aaaa: "count_list bs z + count_list (take (Suc i) cs) z \<le> 1" by simp

	have z_occurs_once_in_cs: "count_list (take (Suc i) cs) z = 1"
	proof (rule ccontr, goal_cases)
	case 1
	with aaaa have atmost1: "count_list bs z \<le> 1" and "count_list (take (Suc i) cs) z = 0" by force+
	have yeah: "z \<notin> set (take (Suc i) cs)" apply(rule count_notin2) by fact

	\<comment> \<open>now we know that x is in front of z after 2nd request to x, and that z is not requested any more,
	that means it stays behind x, which leads to a contradiction with @{text z_before_x}\<close>

	have xin123: "x \<in> set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"
	using i_in_cs assms(4) by(simp add: s_TS_set)
	have zin123: "z \<in> set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"
	using i_in_cs elemins by(simp add: s_TS_set del: config'.simps)

	have "x < z in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i + 1))"
	apply(rule TS_mono)
	apply(rule xgoestofront)
	apply(fact) using el_n_x apply(simp) apply(fact)
	using i_in_cs apply(simp)
	using yeah i_in_cs length_take nth_mem
	apply (metis Suc_eq_plus1 Suc_leI min_absorb2)
	using set_take_subset assms(2) apply fast
	using assms i_in_cs apply(simp_all ) using set_take_subset by fast
	then have ge: "\<not> z < x in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
	using not_before_in[OF zin123 xin123] el_n_x by blast

	have " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
	= s_TS init h ((as @ [x] @ bs @ [x] @ (take (i+1) cs)) @ (drop (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" by auto
	also have "\<dots>
	= s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
	apply(rule s_TS_append)
	using i_in_cs by(simp)
	finally have aaa: " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
	= s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" .

	from ge z_before_x show "False" unfolding assms(1) using aaa by auto
	qed
	from z_occurs_once_in_cs have kinSuci: "z \<in> set (take (Suc i) cs)" by (metis One_nat_def count_notin n_not_Suc_n)
	then have zincs: "z\<in>set cs" using set_take_subset by fast
	from z_occurs_once_in_cs obtain k where k_def: "k=index (take (Suc i) cs) z" by blast


	then have "k=index cs z" using kinSuci by (simp add: index_take_if_set)
	then have zcsk: "z = cs!k" using zincs by simp




	have era: " cs ! index (take (Suc i) cs) z = z" using kinSuci in_set_takeD index_take_if_set by fastforce
	have ki: "k<i" unfolding k_def using kinSuci el_n_y
	by (metis i_in_cs index_take index_take_if_set le_neq_implies_less not_less_eq_eq yes)
	have zmustbebeforex: "cs!k < x in ?s"
	unfolding k_def era by (fact z_s)

	\<comment> \<open>before the request to z, x is in front of z, analog zu oben, vllt generell machen?\<close>


	\<comment> \<open>element z does not occur between t1 and position k\<close>
	have z_notinbs: "cs ! k \<notin> set bs"
	proof -
	from z_occurs_once_in_cs aaaa have "count_list bs z = 0" by auto
	then show ?thesis using zcsk count_notin2 by metis
	qed


	have "count_list bs z \<le> 1" using aaaa by linarith
	with xgoestofront[OF zininit el_n_x[symmetric]] have xbeforez: "x < z in s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))" by auto

	obtain cs1 cs2 where v: "cs1 @ cs2 = cs" and cs1: "cs1 = take (Suc k) cs" and cs2: "cs2 = drop (Suc k) cs" by auto

	have z_firstocc: "\<forall>j<k. cs ! j \<noteq> cs ! k"
	and z_lastocc: "\<forall>j<i-k-1. cs2 ! j \<noteq> cs ! k"
	proof (safe, goal_cases)
	case (1 j)
	with ki i_in_cs have 2: "j < length (take k cs)" by auto
	have un1: "(take (Suc i) cs)!k = cs!k" apply(rule nth_take) using ki by auto
	have un2: "(take k cs)!j = cs!j" apply(rule nth_take) using 1(1) ki by auto

	from i_in_cs ki have f1: "k < length (take (Suc i) cs)" by auto
	then have "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
	by(rule id_take_nth_drop)
	also have "(take k (take (Suc i) cs)) = take k cs" using i_in_cs ki by (simp add: min_def)
	also have "... = (take j (take k cs)) @ (take k cs)!j # (drop (Suc j) (take k cs))"
	using 2 by(rule id_take_nth_drop)
	finally have "take (Suc i) cs
	= (take j (take k cs)) @ [(take k cs)!j] @ (drop (Suc j) (take k cs))
	@ [(take (Suc i) cs)!k] @ (drop (Suc k) (take (Suc i) cs))"
	by(simp)
	then have A: "take (Suc i) cs
	= (take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs))
	@ [cs!k] @ (drop (Suc k) (take (Suc i) cs))"
	unfolding un1 un2 by simp
	have "count_list ((take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs))
	@ [cs!k] @ (drop (Suc k) (take (Suc i) cs))) z \<ge> 2"
	- apply(simp add: count_append)
	using zcsk 1(2) by(simp)
	with A have "count_list (take (Suc i) cs) z \<ge> 2" by auto
	with z_occurs_once_in_cs show "False" by auto
	next
	case (2 j)
	then have 1: "Suc k+j < i" by auto
	then have f2: "j < length (drop (Suc k) (take (Suc i) cs))" using i_in_cs by simp
	have 3: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
	@ (drop (Suc k) (take (Suc i) cs))! j
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))"
	using f2 by(rule id_take_nth_drop)
	have "(drop (Suc k) (take (Suc i) cs))! j = (take (Suc i) cs) ! (Suc k+j)"
	apply(rule nth_drop) using i_in_cs 1 by auto
	also have "\<dots> = cs ! (Suc k+j)" apply(rule nth_take) using 1 by auto
	finally have 4: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
	@ cs! (Suc k +j)
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))"
	using 3 by auto
	have 5: "cs2 ! j = cs! (Suc k +j)" unfolding cs2
	apply(rule nth_drop) using i_in_cs 1 by auto

	from 4 5 2(2) have 6: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
	@ cs! k
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))" by auto

	from i_in_cs ki have 1: "k < length (take (Suc i) cs)" by auto
	then have 7: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
	by(rule id_take_nth_drop)
	have 9: "(take (Suc i) cs)!k = z" unfolding zcsk apply(rule nth_take) using ki by auto
	from 6 7 have A: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
	@ z
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))" using ki 9 by auto

	have "count_list ((take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
	@ z
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))) z
	\<ge> 2"
	- by(simp add: count_append)
	+ by(simp)
	with A have "count_list (take (Suc i) cs) z \<ge> 2" by auto
	with z_occurs_once_in_cs show "False" by auto
	qed


	have k_in_cs: "k < length cs" using ki i_in_cs by auto
	with cs1 have lenkk: "length cs1 = k+1" by auto
	from k_in_cs have mincsk: "min (length cs) (Suc k) = Suc k" by auto

	have "s_TS init h (((as@[x]@bs@[x])@cs1) @ cs2) (length (as@[x]@bs@[x])+k+1)
	= s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x])+k+1)"
	apply(rule s_TS_append)
	using cs1 cs2 k_in_cs by(simp)
	then have spliter: "s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))
	= s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+k+1) "
	using lenkk v cs1 apply(auto) by (simp add: add.commute add.left_commute)

	from cs2 have "length cs2 = length cs - (Suc k)" by auto

	have notxbeforez: "~ x < z in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + k + 1)"
	proof (rule ccontr, goal_cases)
	case 1
	then have a: "x < z in s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))"
	unfolding spliter assms(1) by auto

	have 41: "x \<in> set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	using i_in_cs assms(4) by(simp add: s_TS_set)
	have 42: "z \<in> set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	using i_in_cs zininit by(simp add: s_TS_set)

	have rewr: "s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1)) =
	s_TS init h (as@[x]@bs@[x]@cs) (length (as@[x]@bs@[x])+i)"
	using cs1 v ki apply(simp add: mincsk) by (simp add: add.commute add.left_commute)

	have "x < z in s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1))"
	apply(rule TS_mono)
	using a apply(simp)
	using cs2 i_in_cs ki v cs1 apply(simp)
	using z_lastocc zcsk apply(simp)
	using v assms(2) apply force
	using assms by(simp_all add: cs1 cs2)

	(* "contradiction to zmustbebeforex" *)
	from zmustbebeforex this[unfolded rewr ] el_n_x zcsk 41 42 not_before_in show "False"
	unfolding s_TS_def by fastforce
	qed

	have 1: "k < length cs"
	"(\<forall>j<k. cs ! j \<noteq> cs ! k)"
	"cs ! k \<noteq> x" "cs ! k \<notin> set bs"
	"~ x < z in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + k + 1)"
	apply(safe)
	using ki i_in_cs apply(simp)
	using z_firstocc apply(simp)
	using assms(2) ki i_in_cs apply(fastforce)
	using z_notinbs apply(simp)
	using notxbeforez by auto



	show ?case apply(simp only: ex_nat_less_eq)
	apply(rule bexI[where x=k])
	using 1 zcsk apply(simp)
	using ki by simp
	qed

	lemma nopaid: "snd (fst (TS_step_d s q)) = []" unfolding TS_step_d_def by simp

	lemma staysuntouched:
	assumes d[simp]: "distinct (fst S)"
	and x: "x \<in> set (fst S)"
	and y: "y \<in> set (fst S)"
	shows "set qs \<subseteq> set (fst S) \<Longrightarrow> x \<notin> set qs \<Longrightarrow> y \<notin> set qs
	\<Longrightarrow> x < y in fst (config' (rTS []) S qs) = x < y in fst S"
	proof(induct qs rule: rev_induct)
	case (snoc q qs)
	have "x < y in fst (config' (rTS []) S (qs @ [q])) =
	x < y in fst (config' (rTS []) S qs)"
	apply(simp add: config'_snoc Step_def split_def step_def rTS_def nopaid)
	apply(rule xy_relativorder_mtf2)
	using snoc by(simp_all add: x y )
	also have "\<dots> = x < y in fst S"
	apply(rule snoc)
	using snoc by simp_all
	finally show ?case .
	qed simp

	lemma staysuntouched':
	assumes d[simp]: "distinct init"
	and x: "x \<in> set init"
	and y: "y \<in> set init"
	and "set qs \<subseteq> set init"
	and "x \<notin> set qs" and "y \<notin> set qs"
	shows "x < y in fst (config (rTS []) init qs) = x < y in init"
	proof -
	let ?S="(init, fst (rTS []) init)"
	have "x < y in fst (config' (rTS []) ?S qs) = x < y in fst ?S"
	apply(rule staysuntouched)
	using assms by(simp_all)
	then show ?thesis by simp
	qed

	lemma projEmpty: "Lxy qs S = [] \<Longrightarrow> x \<in> S \<Longrightarrow> x \<notin> set qs"
	unfolding Lxy_def by (metis filter_empty_conv)

	lemma Lxy_index_mono:
	assumes "x\<in>S" "y\<in>S"
	and "index xs x < index xs y"
	and "index xs y < length xs"
	and "x\<noteq>y"
	shows "index (Lxy xs S) x < index (Lxy xs S) y"
	proof -
	from assms have ij: "index xs x < index xs y"
	and xinxs: "index xs x < length xs"
	and yinxs: "index xs y < length xs" by auto
	then have inset: "x\<in>set xs" "y\<in>set xs" using index_less_size_conv by fast+
	from xinxs obtain a as where dec1: "a @ [xs!index xs x] @ as = xs"
	and a: "a = take (index xs x) xs" and "as = drop (Suc (index xs x)) xs"
	and length_a: "length a = index xs x" and length_as: "length as = length xs - index xs x- 1"
	using id_take_nth_drop by fastforce
	have "index xs y\<ge>length (a @ [xs!index xs x])" using length_a ij by auto
	then have "((a @ [xs!index xs x]) @ as) ! index xs y = as ! (index xs y-length (a @ [xs ! index xs x]))" using nth_append[where xs="a @ [xs!index xs x]" and ys="as"]
	by(simp)
	then have xsj: "xs ! index xs y = as ! (index xs y-index xs x-1)" using dec1 length_a by auto
	have las: "(index xs y-index xs x-1) < length as" using length_as yinxs ij by simp
	obtain b c where dec2: "b @ [xs!index xs y] @ c = as"
	and "b = take (index xs y-index xs x-1) as" "c=drop (Suc (index xs y-index xs x-1)) as"
	and length_b: "length b = index xs y-index xs x-1" using id_take_nth_drop[OF las] xsj by force

	have xs_dec: "a @ [xs!index xs x] @ b @ [xs!index xs y] @ c = xs" using dec1 dec2 by auto


	then have "Lxy xs S = Lxy (a @ [xs!index xs x] @ b @ [xs!index xs y] @ c) S"
	by(simp add: xs_dec)
	also have "\<dots> = Lxy a S @ Lxy [x] S @ Lxy b S @ Lxy [y] S @ Lxy c S"
	by(simp add: Lxy_append Lxy_def assms inset)
	finally have gr: "Lxy xs S = Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S"
	using assms by(simp add: Lxy_def)

	have "y \<notin> set (take (index xs x) xs)"
	apply(rule index_take) using assms by simp
	then have "y \<notin> set (Lxy (take (index xs x) xs) S )"
	apply(subst Lxy_set_filter) by blast
	with a have ynot: "y \<notin> set (Lxy a S)" by simp
	have "index (Lxy xs S) y =
	index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) y"
	by(simp add: gr)
	also have "\<dots> \<ge> length (Lxy a S) + 1"
	using assms(5) ynot by(simp add: index_append)
	finally have 1: "index (Lxy xs S) y \<ge> length (Lxy a S) + 1" .

	have "index (Lxy xs S) x = index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) x"
	by (simp add: gr)
	also have "\<dots> \<le> length (Lxy a S)"
	apply(simp add: index_append)
	apply(subst index_less_size_conv[symmetric]) by simp
	finally have 2: "index (Lxy xs S) x \<le> length (Lxy a S)" .

	from 1 2 show ?thesis by linarith
	qed

	lemma proj_Cons:
	assumes filterd_cons: "Lxy qs S = a#as"
	and a_filter: "a\<in>S"
	obtains pre suf where "qs = pre @ [a] @ suf" and "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set pre"
	and "Lxy suf S = as"
	proof -
	have "set (Lxy qs S) \<subseteq> set qs" using Lxy_set_filter by fast
	with filterd_cons have a_inq: "a \<in> set qs" by simp
	then have "index qs a < length qs" by(simp)
	{ fix e
	assume eS:"e\<in>S"
	assume "e\<noteq>a"
	have "index qs a \<le> index qs e"
	proof (rule ccontr)
	assume "\<not> index qs a \<le> index qs e"
	then have 1: "index qs e < index qs a" by simp
	have 0: "index (Lxy qs S) a = 0" unfolding filterd_cons by simp
	have 2: "index (Lxy qs S) e < index (Lxy qs S) a"
	apply(rule Lxy_index_mono)
	by(fact)+
	from 0 2 show "False" by linarith
	qed
	} note atfront=this


	let ?lastInd="index qs a"
	have "qs = take ?lastInd qs @ qs!?lastInd # drop (Suc ?lastInd) qs"
	apply(rule id_take_nth_drop)
	using a_inq by simp
	also have "\<dots> = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs"
	using a_inq by simp
	finally have split: "qs = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs" .

	have nothingin: "\<And>s. s\<in>S \<Longrightarrow> s \<notin> set (take ?lastInd qs)"
	apply(rule index_take)
	apply(case_tac "a=s")
	apply(simp)
	by (rule atfront) simp_all
	then have "set (Lxy (take ?lastInd qs) S) = {}"
	apply(subst Lxy_set_filter) by blast
	then have emptyPre: "Lxy (take ?lastInd qs) S = []" by blast


	have "a#as = Lxy qs S"
	using filterd_cons by simp
	also have "\<dots> = Lxy (take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs) S"
	using split by simp
	also have "\<dots> = Lxy (take ?lastInd qs) S @ (Lxy [a] S) @ Lxy (drop (Suc ?lastInd) qs) S"
	by(simp add: Lxy_append Lxy_def)
	also have "\<dots> = a#Lxy (drop (Suc ?lastInd) qs) S"
	unfolding emptyPre by(simp add: Lxy_def a_filter)
	finally have suf: "Lxy (drop (Suc ?lastInd) qs) S = as" by simp

	from split nothingin suf show ?thesis ..
	qed

	lemma Lxy_rev: "rev (Lxy qs S) = Lxy (rev qs) S"
	apply(induct qs)
	by(simp_all add: Lxy_def)

	lemma proj_Snoc:
	assumes filterd_cons: "Lxy qs S = as@[a]"
	and a_filter: "a\<in>S"
	obtains pre suf where "qs = pre @ [a] @ suf" and "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set suf"
	and "Lxy pre S = as"
	proof -
	have "Lxy (rev qs) S = rev (Lxy qs S)" by(simp add: Lxy_rev)
	also have "\<dots> = a#(rev as)" unfolding filterd_cons by simp
	finally have "Lxy (rev qs) S = a # (rev as)" .
	with a_filter
	obtain pre' suf' where 1: "rev qs = pre' @[a] @ suf'"
	and 2: "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set pre'"
	and 3: "Lxy suf' S = rev as"
	using proj_Cons by metis
	have "qs = rev (rev qs)" by simp
	also have "\<dots> = rev suf' @ [a] @ rev pre'" using 1 by simp
	finally have a1: "qs = rev suf' @ [a] @ rev pre'" .

	have "Lxy (rev suf') S = rev (Lxy suf' S)" by(simp add: Lxy_rev)
	also have "\<dots> = as" using 3 by simp
	finally have a3: "Lxy (rev suf') S = as" .

	have a2: "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set (rev pre')" using 2 by simp

	from a1 a2 a3 show ?thesis ..
	qed

	lemma sndTSconfig': "snd (config' (rTS initH) (init,[]) qs) = rev qs @ []"
	apply(induct qs rule: rev_induct)
	apply(simp add: rTS_def)
	by(simp add: split_def TS_step_d_def config'_snoc Step_def rTS_def)

	lemma projxx:
	fixes e a bs
	assumes axy: "a\<in>{x,y}"
	assumes ane: "a\<noteq>e"
	assumes exy: "e\<in>{x,y}"
	assumes add: "f\<in>{[],[e]}"
	assumes bsaxy: "set (bs @ [a] @ f) \<subseteq> {x,y}"
	assumes Lxyinitxy: "Lxy init {x, y} \<in> {[x,y],[y,x]}"
	shows "a < e in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
	proof -
	have aexy: "{a,e}={x,y}" using exy axy ane by blast

	let ?h="snd (Partial_Cost_Model.config' (\<lambda>s. [], TS_step_d)
	(Lxy init {x, y}, []) (bs @ a # f))"
	have history: "?h = (rev f)@a#(rev bs)"
	using sndTSdet[of "length (bs@a#f)" "bs@a#f", unfolded rTS_def] by(simp)

	{ fix xs s
	assume sinit: "s:{[a,e],[e,a]}"
	assume "set xs \<subseteq> {a,e}"
	then have "fst (config' (\<lambda>s. [], TS_step_d) (s, []) xs) \<in> {[a,e], [e,a]}"
	apply (induct xs rule: rev_induct)
	using sinit apply(simp)
	apply(subst config'_append2)
	apply(simp only: Step_def config'.simps Let_def split_def fst_conv)
	apply(rule stepxy) by simp_all
	} note staysae=this

	have opt: "fst (config' (\<lambda>s. [], TS_step_d)
	(Lxy init {x, y}, []) (bs @ [a] @ f)) \<in> {[a,e], [e,a]}"
	apply(rule staysae)
	using Lxyinitxy exy axy ane apply fast
	unfolding aexy by(fact bsaxy)

	have contr: " (\<forall>x. 0 < (if e = x then 0 else index [a] x + 1)) = False"
	proof (rule ccontr, goal_cases)
	case 1
	then have "\<And>x. 0 < (if e = x then 0 else index [a] x + 1)" by simp
	then have "0 < (if e = e then 0 else index [a] e + 1)" by blast
	then have "0<0" by simp
	then show "False" by auto
	qed


	show "a < e in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(subst TS_step_d_def)
	apply(simp only: history)
	using opt ane add
	apply(auto simp: step_def)
	apply(simp add: before_in_def)
	apply(simp add: before_in_def)
	apply(simp add: before_in_def contr)
	apply(simp add: mtf2_def swap_def before_in_def)
	apply(auto simp add: before_in_def contr)
	apply (metis One_nat_def add_is_1 count_list.simps(1) le_Suc_eq)
	by(simp add: mtf2_def swap_def)
	qed

	lemma oneposs:
	assumes "set xs = {x,y}"
	assumes "x\<noteq>y"
	assumes "distinct xs"
	assumes True: "x<y in xs"
	shows "xs = [x,y]"
	proof -
	from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
	from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
	by simp_all
	then have f: "index xs x = 0 \<and> index xs y = 1" using len2 by linarith
	have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = take 1 xs @ [xs!1]" using len2 by simp
	also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = [xs!0]" by(simp)
	finally have "xs = [xs!0, xs!1]" by simp
	also have "\<dots> = [xs!(index xs x), xs!index xs y]" using f by simp
	also have "\<dots> = [x,y]" using assms by(simp)
	finally show "xs = [x,y]" .
	qed

	lemma twoposs:
	assumes "set xs = {x,y}"
	assumes "x\<noteq>y"
	assumes "distinct xs"
	shows "xs \<in> {[x,y], [y,x]}"
	proof (cases "x<y in xs")
	case True
	from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
	from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
	by simp_all
	then have f: "index xs x = 0 \<and> index xs y = 1" using len2 by linarith
	have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = take 1 xs @ [xs!1]" using len2 by simp
	also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = [xs!0]" by(simp)
	finally have "xs = [xs!0, xs!1]" by simp
	also have "\<dots> = [xs!(index xs x), xs!index xs y]" using f by simp
	also have "\<dots> = [x,y]" using assms by(simp)
	finally have "xs = [x,y]" .
	then show ?thesis by simp
	next
	case False
	from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
	from False have "y<x in xs" using not_before_in assms(1,2) by fastforce
	then have "index xs y < index xs x" "index xs x < length xs" unfolding before_in_def using assms
	by simp_all
	then have f: "index xs y = 0 \<and> index xs x = 1" using len2 by linarith
	have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = take 1 xs @ [xs!1]" using len2 by simp
	also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = [xs!0]" by(simp)
	finally have "xs = [xs!0, xs!1]" by simp
	also have "\<dots> = [xs!(index xs y), xs!index xs x]" using f by simp
	also have "\<dots> = [y,x]" using assms by(simp)
	finally have "xs = [y,x]" .
	then show ?thesis by simp
	qed

	lemma TS_pairwise': assumes "qs \<in> {xs. set xs \<subseteq> set init}"
	"(x, y) \<in> {(x, y). x \<in> set init \<and> y \<in> set init \<and> x \<noteq> y}"
	"x \<noteq> y" "distinct init"
	shows "Pbefore_in x y (embed (rTS [])) qs init =
	Pbefore_in x y (embed (rTS [])) (Lxy qs {x, y}) (Lxy init {x, y})"
	proof -
	from assms have xyininit: "{x, y} \<subseteq> set init"
	and qsininit: "set qs \<subseteq> set init" by auto
	note dinit=assms(4)
	from assms have xny: "x\<noteq>y" by simp
	have Lxyinitxy: "Lxy init {x, y} \<in> {[x, y], [y, x]}"
	apply(rule twoposs)
	apply(subst Lxy_set_filter) using xyininit apply fast
	using xny Lxy_distinct[OF dinit] by simp_all

	have lq_s: "set (Lxy qs {x, y}) \<subseteq> {x,y}" by (simp add: Lxy_set_filter)

	(* projected history *)
	let ?pH = "snd (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	have "?pH =snd (TSdet (Lxy init {x, y}) [] (Lxy qs {x, y}) (length (Lxy qs {x, y})))"
	by(simp)
	also have "\<dots> = rev (take (length (Lxy qs {x, y})) (Lxy qs {x, y})) @ []"
	apply(rule sndTSdet) by simp
	finally have pH: "?pH = rev (Lxy qs {x, y})" by simp

	let ?pQs = "(Lxy qs {x, y})"

	have A: " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	proof(cases "?pQs" rule: rev_cases)
	case Nil
	then have xqs: "x \<notin> set qs" and yqs: "y \<notin> set qs" by(simp_all add: projEmpty)
	have " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in init" apply(rule staysuntouched') using assms xqs yqs by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	unfolding Nil apply(simp) apply(rule Lxy_mono) using xyininit dinit by(simp_all)
	finally show ?thesis .
	next
	case (snoc as a)
	then have "a\<in>set (Lxy qs {x, y})" by (simp)
	then have axy: "a\<in>{x,y}" by(simp add: Lxy_set_filter)
	with xyininit have ainit: "a\<in>set init" by auto
	note a=snoc
	from a axy obtain pre suf where qs: "qs = pre @ [a] @ suf"
	and nosuf: "\<And>e. e \<in> {x,y} \<Longrightarrow> e \<notin> set suf"
	and pre: "Lxy pre {x,y} = as"
	using proj_Snoc by metis
	show ?thesis
	proof (cases "as" rule: rev_cases)
	case Nil
	from pre Nil have xqs: "x \<notin> set pre" and yqs: "y \<notin> set pre" by(simp_all add: projEmpty)
	from xqs yqs axy have "a \<notin> set pre" by blast
	then have noocc: "index (rev pre) a = length (rev pre)" by simp
	have " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in fst (config\<^sub>p (rTS []) init ((pre @ [a]) @ suf))" by(simp add: qs)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (pre @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init pre)"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(simp only: TS_step_d_def)
	apply(simp only: sndTSconfig'[unfolded rTS_def])
	by(simp add: noocc step_def)
	also have "\<dots> = x < y in init"
	apply(rule staysuntouched') using assms xqs yqs qs by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	unfolding a Nil apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def)
	apply(rule Lxy_mono) using xyininit dinit by(simp_all)
	finally show ?thesis .
	next
	case (snoc bs b)
	note b=this
	with a have "b\<in>set (Lxy qs {x, y})" by (simp)
	then have bxy: "b\<in>{x,y}" by(simp add: Lxy_set_filter)
	with xyininit have binit: "b\<in>set init" by auto
	from b pre have "Lxy pre {x,y} = bs @ [b]" by simp
	with bxy obtain pre2 suf2 where bs: "pre = pre2 @ [b] @ suf2"
	and nosuf2: "\<And>e. e \<in> {x,y} \<Longrightarrow> e \<notin> set suf2"
	and pre2: "Lxy pre2 {x,y} = bs"
	using proj_Snoc by metis

	from bs qs have qs2: "qs = pre2 @ [b] @ suf2 @ [a] @ suf" by simp

	show ?thesis
	proof (cases "a=b")
	case True
	note ab=this

	let ?qs ="(pre2 @ [a] @ suf2 @ [a]) @ suf"
	{
	fix e
	assume ane: "a\<noteq>e"
	assume exy: "e\<in>{x,y}"
	have "a < e in fst (config\<^sub>p (rTS []) init qs)
	= a < e in fst (config\<^sub>p (rTS []) init ?qs)" using True qs2 by(simp)
	also have "\<dots> = a < e in fst (config\<^sub>p (rTS []) init (pre2 @ [a] @ suf2 @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
	using exy xyininit apply fast
	using nosuf axy apply(simp)
	using nosuf exy by simp
	also have "\<dots>"
	apply(simp)
	apply(rule twotox[unfolded s_TS_def, simplified])
	using nosuf2 exy apply(simp)
	using assms apply(simp_all)
	using axy xyininit apply fast
	using exy xyininit apply fast
	using nosuf2 axy apply(simp)
	using ane by simp
	finally have "a < e in fst (config\<^sub>p (rTS []) init qs)" by simp
	} note full=this

	have "set (bs @ [a]) \<subseteq> set (Lxy qs {x, y})" using a b by auto
	also have "\<dots> = {x,y} \<inter> set qs" by (rule Lxy_set_filter)
	also have "\<dots> \<subseteq> {x,y}" by simp
	finally have bsaxy: "set (bs @ [a]) \<subseteq> {x,y}" .

	with xny show ?thesis
	proof(cases "x=a")
	case True
	have 1: "a < y in fst (config\<^sub>p (rTS []) init qs)"
	apply(rule full)
	using True xny apply blast
	by simp


	have "a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
	using a b ab by simp
	also have "\<dots>"
	apply(rule projxx[where bs=bs and f="[]"])
	using True apply blast
	using a b True ab xny Lxyinitxy bsaxy by(simp_all)
	finally show ?thesis using True 1 by simp
	next
	case False
	with axy have ay: "a=y" by blast
	have 1: "a < x in fst (config\<^sub>p (rTS []) init qs)"
	apply(rule full)
	using False xny apply blast
	by simp
	have "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
	using a b ab by simp
	also have "\<dots>"
	apply(rule projxx[where bs=bs and f="[]"])
	using True axy apply blast
	using a b True ab xny Lxyinitxy ay bsaxy by(simp_all)
	finally have 2: "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

	have "x < y in fst (config\<^sub>p (rTS []) init qs) =
	(\<not> y < x in fst (config\<^sub>p (rTS []) init qs))"
	apply(subst not_before_in)
	using assms by(simp_all)
	also have "\<dots> = False" using 1 ay by simp
	also have "\<dots> = (\<not> y < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
	using 2 ay by simp
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	apply(subst not_before_in)
	using assms by(simp_all add: Lxy_set_filter)
	finally show ?thesis .
	qed
	next
	case False
	note ab=this

	show ?thesis
	proof (cases "bs" rule: rev_cases)
	case Nil
	with a b have "Lxy qs {x, y} = [b,a]" by simp
	from pre2 Nil have xqs: "x \<notin> set pre2" and yqs: "y \<notin> set pre2" by(simp_all add: projEmpty)
	from xqs yqs bxy have "b \<notin> set pre2" by blast
	then have noocc2: "index (rev pre2) b = length (rev pre2)" by simp
	from axy nosuf2 have "a \<notin> set suf2" by blast
	with xqs yqs axy False have "a \<notin> set ((pre2 @ b # suf2))" by(auto)
	then have noocc: "index (rev (pre2 @ b # suf2) @ []) a = length (rev (pre2 @ b # suf2))" by simp
	have " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in fst (config\<^sub>p (rTS []) init ((((pre2 @ [b]) @ suf2) @ [a]) @ suf))" by(simp add: qs2)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (((pre2 @ [b]) @ suf2) @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init ((pre2 @ [b]) @ suf2))"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(simp only: TS_step_d_def)
	apply(simp only: sndTSconfig'[unfolded rTS_def])
	apply(simp only: noocc) by (simp add: step_def)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (pre2 @ [b]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms xqs yqs qs2 nosuf2 by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (pre2))"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(simp only: TS_step_d_def)
	apply(simp only: sndTSconfig'[unfolded rTS_def])
	by(simp add: noocc2 step_def)
	also have "\<dots> = x < y in init"
	apply(rule staysuntouched') using assms xqs yqs qs2 by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	unfolding a b Nil
	using False
	apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def)
	apply(rule Lxy_mono) using xyininit dinit by(simp_all)
	finally show ?thesis .
	next
	case (snoc cs c)
	note c=this
	with a b have "c\<in>set (Lxy qs {x, y})" by (simp)
	then have cxy: "c\<in>{x,y}" by(simp add: Lxy_set_filter)
	from c pre2 have "Lxy pre2 {x,y} = cs @ [c]" by simp
	with cxy obtain pre3 suf3 where cs: "pre2 = pre3 @ [c] @ suf3"
	and nosuf3: "\<And>e. e \<in> {x,y} \<Longrightarrow> e \<notin> set suf3"
	and pre3: "Lxy pre3 {x,y} = cs"
	using proj_Snoc by metis

	let ?qs=" pre3 @ [c] @ suf3 @ [b] @ suf2 @ [a] @ suf"
	from bs cs qs have qs2: "qs = ?qs" by simp

	show ?thesis
	proof(cases "c=a")
	case True (* aba *)
	note ca=this

	have "a < b in fst (config\<^sub>p (rTS []) init qs)
	= a < b in fst (config\<^sub>p (rTS []) init ((pre3 @ a # (suf3 @ [b] @ suf2) @ [a]) @ suf))"
	using qs2 True by simp
	also have "\<dots> = a < b in fst (config\<^sub>p (rTS []) init (pre3 @ a # (suf3 @ [b] @ suf2) @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
	using bxy xyininit apply(fast)
	using nosuf axy bxy by(simp_all)
	also have "..."
	apply(rule twotox[unfolded s_TS_def, simplified])
	- using nosuf2 nosuf3 bxy apply(simp add: count_append)
	+ using nosuf2 nosuf3 bxy apply(simp)
	using assms apply(simp_all)
	using axy xyininit apply(fast)
	using bxy xyininit apply(fast)
	using ab nosuf2 nosuf3 axy apply(simp)
	using ab by simp
	finally have full: "a < b in fst (config\<^sub>p (rTS []) init qs)" by simp


	have "set (cs @ [a] @ [b]) \<subseteq> set (Lxy qs {x, y})" using a b c by auto
	also have "\<dots> = {x,y} \<inter> set qs" by (rule Lxy_set_filter)
	also have "\<dots> \<subseteq> {x,y}" by simp
	finally have csabxy: "set (cs @ [a] @ [b]) \<subseteq> {x,y}" .

	with xny show ?thesis
	proof(cases "x=a")
	case True
	with xny ab bxy have bisy: "b=y" by blast
	have 1: "x < y in fst (config\<^sub>p (rTS []) init qs)"
	using full True bisy by simp

	have "a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
	using a b c ca ab by simp
	also have "\<dots>"
	apply(rule projxx)
	using True apply blast
	using a b True ab xny Lxyinitxy csabxy by(simp_all)
	finally show ?thesis using 1 True by simp
	next
	case False
	with axy have ay: "a=y" by blast
	with xny ab bxy have bisx: "b=x" by blast
	have 1: "y < x in fst (config\<^sub>p (rTS []) init qs)"
	using full ay bisx by simp

	have "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
	using a b c ca ab by simp
	also have "\<dots>"
	apply(rule projxx)
	using a b True ab xny Lxyinitxy csabxy False by(simp_all)
	finally have 2: "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

	have "x < y in fst (config\<^sub>p (rTS []) init qs) =
	(\<not> y < x in fst (config\<^sub>p (rTS []) init qs))"
	apply(subst not_before_in)
	using assms by(simp_all)
	also have "\<dots> = False" using 1 ay by simp
	also have "\<dots> = (\<not> y < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
	using 2 ay by simp
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	apply(subst not_before_in)
	using assms by(simp_all add: Lxy_set_filter)
	finally show ?thesis .
	qed
	next
	case False (* bba *)
	then have cb: "c=b" using bxy cxy axy ab by blast

	let ?cs = "suf2 @ [a] @ suf"
	let ?i = "index ?cs a"


	have aed: "(\<forall>j<index (suf2 @ a # suf) a. (suf2 @ a # suf) ! j \<noteq> a)"
	by (metis add.right_neutral axy index_Cons index_append nosuf2 nth_append nth_mem)

	have "?i < length ?cs
	\<longrightarrow> (\<forall>j<?i. ?cs ! j \<noteq> ?cs ! ?i) \<longrightarrow> ?cs ! ?i \<noteq> b
	\<longrightarrow> ?cs ! ?i \<notin> set suf3
	\<longrightarrow> b < ?cs ! ?i in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
	apply(rule casexxy)
	using cb qs2 apply(simp)
	using bxy ab nosuf2 nosuf apply(simp)
	using bs qs qsininit apply(simp)
	using bxy xyininit apply(blast)
	apply(fact)
	using nosuf3 bxy apply(simp)
	using cs bs qs qsininit by(simp_all)

	then have inner: "b < a in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
	using ab nosuf3 axy bxy aed
	by(simp)
	let ?n = "(length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
	let ?inner="(config\<^sub>p (rTS []) init (take (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1) ?qs))"

	have "b < a in fst (config\<^sub>p (rTS []) init qs)
	= b < a in fst (config\<^sub>p (rTS []) init (take ?n ?qs @ drop ?n ?qs))" using qs2 by simp
	also have "\<dots> = b < a in fst (config' (rTS []) ?inner suf)" apply(simp only: config_append drop_append)
	using nosuf2 axy by(simp add: index_append config_append)
	also have "\<dots> = b < a in fst ?inner"
	apply(rule staysuntouched) using assms bxy xyininit qs nosuf apply(simp_all)
	using bxy xyininit apply(blast)
	using axy xyininit by (blast)
	also have "\<dots> = True" using inner by(simp add: s_TS_def qs2)
	finally have full: "b < a in fst (config\<^sub>p (rTS []) init qs)" by simp

	have "set (cs @ [b] @ []) \<subseteq> set (Lxy qs {x, y})" using a b c by auto
	also have "\<dots> = {x,y} \<inter> set qs" by (rule Lxy_set_filter)
	also have "\<dots> \<subseteq> {x,y}" by simp
	finally have csbxy: "set (cs @ [b] @ []) \<subseteq> {x,y}" .

	have "set (Lxy init {x, y}) = {x,y} \<inter> set init"
	by(rule Lxy_set_filter)
	also have "\<dots> = {x,y}" using xyininit by fast
	also have "\<dots> = {b,a}" using axy bxy ab by fast
	finally have r: "set (Lxy init {x, y}) = {b, a}" .

	let ?confbef="(config\<^sub>p (rTS []) (Lxy init {x, y}) ((cs @ [b] @ []) @ [b]))"
	have f1: "b < a in fst ?confbef"
	apply(rule projxx)
	using bxy ab axy a b c csbxy Lxyinitxy by(simp_all)
	have 1: "fst ?confbef = [b,a]"
	apply(rule oneposs)
	using ab axy bxy xyininit Lxy_distinct[OF dinit] f1 r by(simp_all)
	have 2: "snd (Partial_Cost_Model.config'
	(\<lambda>s. [], TS_step_d)
	(Lxy init {x, y}, [])
	(cs @ [b, b])) = [b,b]@(rev cs)"
	using sndTSdet[of "length (cs @ [b, b])" "(cs @ [b, b])", unfolded rTS_def] by(simp)
	have "b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (((cs @ [b] @ []) @ [b])@[a]))"
	using a b c cb by(simp)
	also have "\<dots>"
	apply(subst config_append)
	using 1 2 ab apply(simp add: step_def Step_def split_def rTS_def TS_step_d_def)
	by(simp add: before_in_def)
	finally have projected: "b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .


	have 1: "{x,y} = {a,b}" using ab axy bxy by fast
	with xny show ?thesis
	proof(cases "x=a")
	case True
	with 1 xny have y: "y=b" by fast
	have "a < b in fst (config\<^sub>p (rTS []) init qs) =
	(\<not> b < a in fst (config\<^sub>p (rTS []) init qs))"
	apply(subst not_before_in)
	using binit ainit ab by(simp_all)
	also have "\<dots> = False" using full by simp
	also have "\<dots> = (\<not> b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
	using projected by simp
	also have "\<dots> = a < b in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	apply(subst not_before_in)
	using binit ainit ab axy bxy by(simp_all add: Lxy_set_filter)
	finally show ?thesis using True y by simp
	next
	case False
	with 1 xny have y: "y=a" "x=b" by fast+
	with full projected show ?thesis by fast
	qed
	qed (* end of (c=a) *)
	qed (* end of snoc cs c *)
	qed (* end of (a=b) *)
	qed (* end snoc bs b *)
	qed (* end snoc as a *)




	show ?thesis unfolding Pbefore_in_def
	apply(subst config_embed)
	apply(subst config_embed)
	apply(simp) by (rule A)
	qed

	theorem TS_pairwise: "pairwise (embed (rTS []))"
	apply(rule pairwise_property_lemma)
	apply(rule TS_pairwise') by (simp_all add: rTS_def TS_step_d_def)


	subsection "TS is 2-compet"


	lemma TS_compet': "pairwise (embed (rTS [])) \<Longrightarrow>
	\<forall>s0\<in>{init::(nat list). distinct init \<and> init\<noteq>[]}. \<exists>b\<ge>0. \<forall>qs\<in>{x. set x \<subseteq> set s0}. T\<^sub>p_on_rand (embed (rTS [])) s0 qs \<le> (2::real) * T\<^sub>p_opt s0 qs + b"
	unfolding rTS_def
	proof (rule factoringlemma_withconstant, goal_cases)
	case 5
	show ?case
	proof (safe, goal_cases)
	case (1 init)
	note out=this
	show ?case
	apply(rule exI[where x=2])
	apply(simp)
	proof (safe, goal_cases)
	case (1 qs a b)
	then have a: "a\<noteq>b" by simp
	have twist: "{a,b}={b, a}" by auto
	have b1: "set (Lxy qs {a, b}) \<subseteq> {a, b}" unfolding Lxy_def by auto
	with this[unfolded twist] have b2: "set (Lxy qs {b, a}) \<subseteq> {b, a}" by(auto)

	have "set (Lxy init {a, b}) = {a,b} \<inter> (set init)" apply(induct init)
	unfolding Lxy_def by(auto)
	with 1 have A: "set (Lxy init {a, b}) = {a,b}" by auto
	have "finite {a,b}" by auto
	from out have B: "distinct (Lxy init {a, b})" unfolding Lxy_def by auto
	have C: "length (Lxy init {a, b}) = 2"
	using distinct_card[OF B, unfolded A] using a by auto

	have "{xs. set xs = {a,b} \<and> distinct xs \<and> length xs =(2::nat)}
	= { [a,b], [b,a] }"
	apply(auto simp: a a[symmetric])
	proof (goal_cases)
	case (1 xs)
	from 1(4) obtain x xs' where r:"xs=x#xs'" by (metis Suc_length_conv add_2_eq_Suc' append_Nil length_append)
	with 1(4) have "length xs' = 1" by auto
	then obtain y where s: "[y] = xs'" by (metis One_nat_def length_0_conv length_Suc_conv)
	from r s have t: "[x,y] = xs" by auto
	moreover from t 1(1) have "x=b" using doubleton_eq_iff 1(2) by fastforce
	moreover from t 1(1) have "y=a" using doubleton_eq_iff 1(2) by fastforce
	ultimately show ?case by auto
	qed

	with A B C have pos: "(Lxy init {a, b}) = [a,b]
	\<or> (Lxy init {a, b}) = [b,a]" by auto

	{ fix a::nat
	fix b::nat
	fix qs
	assume as: "a \<noteq> b" "set qs \<subseteq> {a, b}"
	have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b] \<bind> (\<lambda>is. return_pmf ([a,b], is))) qs
	= T\<^sub>p_on (rTS []) [a, b] qs" by (rule T_on_embed[symmetric])
	also from as have "\<dots> \<le> 2 * T\<^sub>p_opt [a, b] qs + 2" using TS_OPT2' by fastforce
	finally have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b] \<bind> (\<lambda>is. return_pmf ([a,b], is))) qs
	\<le> 2 * T\<^sub>p_opt [a, b] qs + 2" .
	} note ye=this

	show ?case
	apply(cases "(Lxy init {a, b}) = [a,b]")
	using ye[OF a b1, unfolded rTS_def] apply(simp)
	using pos ye[OF a[symmetric] b2, unfolded rTS_def] by(simp add: twist)
	qed
	qed
	next
	case 6
	show ?case unfolding TS_step_d_def by (simp add: split_def TS_step_d_def)
	next
	case (7 init qs x)
	then show ?case
	apply(induct x)
	by (simp_all add: rTS_def split_def take_Suc_conv_app_nth config'_rand_snoc )
	next
	case 4 then show ?case by simp
	qed (simp_all)


	lemma TS_compet: "compet_rand (embed (rTS [])) 2 {init. distinct init \<and> init \<noteq> []}"
	unfolding compet_rand_def static_def
	using TS_compet'[OF TS_pairwise] by simp

	end
	diff --git a/thys/Median_Method/Median.thy b/thys/Median_Method/Median.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Median_Method/Median.thy
	@@ -0,0 +1,643 @@
	+section \<open>Intervals are Borel measurable\<close>
	+
	+theory Median
	+ imports "HOL-Probability.Hoeffding" "HOL-Library.Multiset"
	+begin
	+
	+text \<open>This section contains a proof that intervals are Borel measurable, where an interval is
	+defined as a convex subset of linearly ordered space, more precisely, a set is an interval, if
	+for each triple of points $x < y < z$: If $x$ and $z$ are in the set so is $y$.
	+This includes ordinary intervals like @{term "{a..b}"}, @{term "{a<..<b}"} but also for example
	+@{term [show_types] "{(x::rat). x * x < 2}"} which cannot be expressed in the standard notation.
	+
	+In the @{theory "HOL-Analysis.Borel_Space"} there are proofs for the measurability of each specific
	+type of interval, but those unfortunately do not help if we want to express the result about the
	+median bound for arbitrary types of intervals.\<close>
	+
	+definition interval :: "('a :: linorder) set \<Rightarrow> bool" where
	+ "interval I = (\<forall>x y z. x \<in> I \<longrightarrow> z \<in> I \<longrightarrow> x \<le> y \<longrightarrow> y \<le> z \<longrightarrow> y \<in> I)"
	+
	+definition up_ray :: "('a :: linorder) set \<Rightarrow> bool" where
	+ "up_ray I = (\<forall>x y. x \<in> I \<longrightarrow> x \<le> y \<longrightarrow> y \<in> I)"
	+
	+lemma up_ray_borel:
	+ assumes "up_ray (I :: (('a :: linorder_topology) set))"
	+ shows "I \<in> borel"
	+proof (cases "closed I")
	+ case True
	+ then show ?thesis using borel_closed by blast
	+next
	+ case False
	+ hence b:"\<not> closed I" by blast
	+
	+ have "open I"
	+ proof (rule Topological_Spaces.openI)
	+ fix x
	+ assume c:"x \<in> I"
	+ show "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> I"
	+ proof (cases "\<exists>y. y < x \<and> y \<in> I")
	+ case True
	+ then obtain y where a:"y < x \<and> y \<in> I" by blast
	+ have "open {y<..}" by simp
	+ moreover have "x \<in> {y<..}" using a by simp
	+ moreover have "{y<..} \<subseteq> I"
	+ apply (rule subsetI)
	+ using a assms(1) apply (simp add: up_ray_def)
	+ by (metis less_le_not_le)
	+ ultimately show ?thesis by blast
	+ next
	+ case False
	+ hence "I \<subseteq> {x..}" using linorder_not_less by auto
	+ moreover have "{x..} \<subseteq> I"
	+ using c assms(1) apply (simp add: up_ray_def)
	+ by blast
	+ ultimately have "I = {x..}"
	+ by (rule order_antisym)
	+ moreover have "closed {x..}" by simp
	+ ultimately have "False" using b by auto
	+ then show ?thesis by simp
	+ qed
	+ qed
	+ then show ?thesis by simp
	+qed
	+
	+definition down_ray :: "('a :: linorder) set \<Rightarrow> bool" where
	+ "down_ray I = (\<forall>x y. y \<in> I \<longrightarrow> x \<le> y \<longrightarrow> x \<in> I)"
	+
	+lemma down_ray_borel:
	+ assumes "down_ray (I :: (('a :: linorder_topology) set))"
	+ shows "I \<in> borel"
	+proof -
	+ have "up_ray (-I)" using assms
	+ by (simp add: up_ray_def down_ray_def, blast)
	+ hence "(-I) \<in> borel" using up_ray_borel by blast
	+ thus "I \<in> borel"
	+ by (metis borel_comp double_complement)
	+qed
	+
	+text \<open>Main result of this section:\<close>
	+
	+lemma interval_borel:
	+ assumes "interval (I :: (('a :: linorder_topology) set))"
	+ shows "I \<in> borel"
	+proof (cases "I = {}")
	+ case True
	+ then show ?thesis by simp
	+next
	+ case False
	+ then obtain x where a:"x \<in> I" by blast
	+ have "\<And>y z. y \<in> I \<union> {x..} \<Longrightarrow> y \<le> z \<Longrightarrow> z \<in> I \<union> {x..}"
	+ by (metis assms a interval_def IntE UnE Un_Int_eq(1) Un_Int_eq(2) atLeast_iff nle_le order.trans)
	+ hence "up_ray (I \<union> {x..})"
	+ using up_ray_def by blast
	+ hence b:"I \<union> {x..} \<in> borel"
	+ using up_ray_borel by blast
	+
	+ have "\<And>y z. y \<in> I \<union> {..x} \<Longrightarrow> z \<le> y \<Longrightarrow> z \<in> I \<union> {..x}"
	+ by (metis assms a interval_def UnE UnI1 UnI2 atMost_iff dual_order.trans linorder_le_cases)
	+ hence "down_ray (I \<union> {..x})"
	+ using down_ray_def by blast
	+ hence c:"I \<union> {..x} \<in> borel"
	+ using down_ray_borel by blast
	+
	+ have "I = (I \<union> {x..}) \<inter> (I \<union> {..x})"
	+ using a by fastforce
	+
	+ then show ?thesis using b c
	+ by (metis sets.Int)
	+qed
	+
	+section \<open>Order statistics are Borel measurable\<close>
	+
	+text \<open>This section contains a proof that order statistics of Borel measurable random variables are
	+themselves Borel measurable.
	+
	+The proof relies on the existence of branch-free comparison-sort algorithms. Given a sequence length
	+these algorithms perform compare-swap operations on predefined pairs of positions. In particular the
	+result of a comparison does not affect future operations. An example for a branch-free comparison
	+sort algorithm is shell-sort and also bubble-sort without the early exit.
	+
	+The advantage of using such a comparison-sort algorithm is that it can be lifted to work on random
	+variables, where the result of a comparison-swap operation on two random variables @{term"X"} and
	+@{term"Y"} can be represented as the expressions @{term "\<lambda>\<omega>. min (X \<omega>) (Y \<omega>)"} and
	+@{term "\<lambda>\<omega>. max (X \<omega>) (Y \<omega>)"}.
	+
	+Because taking the point-wise minimum (resp. maximum) of two random variables is still
	+Borel measurable, and because the entire sorting operation can be represented using such
	+compare-swap operations, we can show that all order statistics are Borel measuable.\<close>
	+
	+fun sort_primitive where
	+ "sort_primitive i j f k = (if k = i then min (f i) (f j) else (if k = j then max (f i) (f j) else f k))"
	+
	+fun sort_map where
	+ "sort_map f n = fold id [sort_primitive j i. i <- [0..<n], j <- [0..<i]] f"
	+
	+lemma sort_map_ind:
	+ "sort_map f (Suc n) = fold id [sort_primitive j n. j <- [0..<n]] (sort_map f n)"
	+ by simp
	+
	+lemma sort_map_strict_mono:
	+ fixes f :: "nat \<Rightarrow> 'b :: linorder"
	+ shows "j < n \<Longrightarrow> i < j \<Longrightarrow> sort_map f n i \<le> sort_map f n j"
	+proof (induction n arbitrary: i j)
	+ case 0
	+ then show ?case by simp
	+next
	+ case (Suc n)
	+ define g where "g = (\<lambda>k. fold id [sort_primitive j n. j <- [0..<k]] (sort_map f n))"
	+ define k where "k = n"
	+ have a:"(\<forall>i j. j < n \<longrightarrow> i < j \<longrightarrow> g k i \<le> g k j) \<and> (\<forall>l. l < k \<longrightarrow> g k l \<le> g k n)"
	+ proof (induction k)
	+ case 0
	+ then show ?case using Suc by (simp add:g_def del:sort_map.simps)
	+ next
	+ case (Suc k)
	+ have "g (Suc k) = sort_primitive k n (g k)"
	+ by (simp add:g_def)
	+ then show ?case using Suc
	+ apply (cases "g k k \<le> g k n")
	+ apply (simp add:min_def max_def)
	+ using less_antisym apply blast
	+ apply (cases "g k n \<le> g k k")
	+ apply (simp add:min_def max_def)
	+ apply (metis less_antisym max.coboundedI2 max.orderE)
	+ by simp
	+ qed
	+
	+ hence "\<And>i j. j < Suc n \<Longrightarrow> i < j \<Longrightarrow> g n i \<le> g n j"
	+ apply (simp add:k_def) using less_antisym by blast
	+ moreover have "sort_map f (Suc n) = g n"
	+ by (simp add:sort_map_ind g_def del:sort_map.simps)
	+ ultimately show ?case
	+ apply (simp del:sort_map.simps)
	+ using Suc by blast
	+qed
	+
	+lemma sort_map_mono:
	+ fixes f :: "nat \<Rightarrow> 'b :: linorder"
	+ shows "j < n \<Longrightarrow> i \<le> j \<Longrightarrow> sort_map f n i \<le> sort_map f n j"
	+ by (metis sort_map_strict_mono eq_iff le_imp_less_or_eq)
	+
	+lemma sort_map_perm:
	+ fixes f :: "nat \<Rightarrow> 'b :: linorder"
	+ shows "image_mset (sort_map f n) (mset [0..<n]) = image_mset f (mset [0..<n])"
	+proof -
	+ define is_swap where "is_swap = (\<lambda>(ts :: ((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b)). \<exists>i < n. \<exists>j < n. ts = sort_primitive i j)"
	+ define t :: "((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b) list"
	+ where "t = [sort_primitive j i. i <- [0..<n], j <- [0..<i]]"
	+
	+ have a: "\<And>x f. is_swap x \<Longrightarrow> image_mset (x f) (mset_set {0..<n}) = image_mset f (mset_set {0..<n})"
	+ proof -
	+ fix x
	+ fix f :: "nat \<Rightarrow> 'b :: linorder"
	+ assume "is_swap x"
	+ then obtain i j where x_def: "x = sort_primitive i j" and i_bound: "i < n" and j_bound:"j < n"
	+ using is_swap_def by blast
	+ define inv where "inv = mset_set {k. k < n \<and> k \<noteq> i \<and> k \<noteq> j}"
	+ have b:"{0..<n} = {k. k < n \<and> k \<noteq> i \<and> k \<noteq> j} \<union> {i,j}"
	+ apply (rule order_antisym, rule subsetI, simp, blast, rule subsetI, simp)
	+ using i_bound j_bound by meson
	+ have c:"\<And>k. k \<in># inv \<Longrightarrow> (x f) k = f k"
	+ by (simp add:x_def inv_def)
	+ have "image_mset (x f) inv = image_mset f inv"
	+ apply (rule multiset_eqI)
	+ using c multiset.map_cong0 by force
	+ moreover have "image_mset (x f) (mset_set {i,j}) = image_mset f (mset_set {i,j})"
	+ apply (cases "i = j")
	+ by (simp add:x_def max_def min_def)+
	+ moreover have "mset_set {0..<n} = inv + mset_set {i,j}"
	+ by (simp only:inv_def b, rule mset_set_Union, simp, simp, simp)
	+ ultimately show "image_mset (x f) (mset_set {0..<n}) = image_mset f (mset_set {0..<n})"
	+ by simp
	+ qed
	+
	+ have "(\<forall>x \<in> set t. is_swap x) \<Longrightarrow> image_mset (fold id t f) (mset [0..<n]) = image_mset f (mset [0..<n])"
	+ by (induction t arbitrary:f, simp, simp add:a)
	+ moreover have "\<And>x. x \<in> set t \<Longrightarrow> is_swap x"
	+ apply (simp add:t_def is_swap_def)
	+ by (meson atLeastLessThan_iff imageE less_imp_le less_le_trans)
	+ ultimately have "image_mset (fold id t f) (mset [0..<n]) = image_mset f (mset [0..<n])" by blast
	+ then show ?thesis by (simp add:t_def)
	+qed
	+
	+lemma list_eq_iff:
	+ assumes "mset xs = mset ys"
	+ assumes "sorted xs"
	+ assumes "sorted ys"
	+ shows "xs = ys"
	+ using assms properties_for_sort by blast
	+
	+lemma sort_map_eq_sort:
	+ fixes f :: "nat \<Rightarrow> ('b :: linorder)"
	+ shows "map (sort_map f n) [0..<n] = sort (map f [0..<n])" (is "?A = ?B")
	+proof -
	+ have "mset ?A = mset ?B"
	+ using sort_map_perm[where f="f" and n="n"]
	+ by (simp del:sort_map.simps)
	+ moreover have "sorted ?B"
	+ by simp
	+ moreover have "sorted ?A"
	+ apply (subst sorted_wrt_iff_nth_less)
	+ apply (simp del:sort_map.simps)
	+ by (metis sort_map_mono nat_less_le)
	+ ultimately show "?A = ?B"
	+ using list_eq_iff by blast
	+qed
	+
	+lemma order_statistics_measurable_aux:
	+ fixes X :: "nat \<Rightarrow> 'a \<Rightarrow> ('b :: {linorder_topology, second_countable_topology})"
	+ assumes "n \<ge> 1"
	+ assumes "j < n"
	+ assumes "\<And>i. i < n \<Longrightarrow> X i \<in> measurable M borel"
	+ shows "(\<lambda>x. (sort_map (\<lambda>i. X i x) n) j) \<in> measurable M borel"
	+proof -
	+ have n_ge_0:"n > 0" using assms by simp
	+ define is_swap where "is_swap = (\<lambda>(ts :: ((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b)). \<exists>i < n. \<exists>j < n. ts = sort_primitive i j)"
	+ define t :: "((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b) list"
	+ where "t = [sort_primitive j i. i <- [0..<n], j <- [0..<i]]"
	+
	+ define meas_ptw :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
	+ where "meas_ptw = (\<lambda>f. (\<forall>k. k < n \<longrightarrow> f k \<in> borel_measurable M))"
	+
	+ have ind_step:
	+ "\<And>x (g :: nat \<Rightarrow> 'a \<Rightarrow> 'b). meas_ptw g \<Longrightarrow> is_swap x \<Longrightarrow> meas_ptw (\<lambda>k \<omega>. x (\<lambda>i. g i \<omega>) k)"
	+ proof -
	+ fix x g
	+ assume "meas_ptw g"
	+ hence a:"\<And>k. k < n \<Longrightarrow> g k \<in> borel_measurable M" by (simp add:meas_ptw_def)
	+ assume "is_swap x"
	+ then obtain i j where x_def:"x=sort_primitive i j" and i_le:"i < n" and j_le:"j < n"
	+ by (simp add:is_swap_def, blast)
	+ have "\<And>k. k < n \<Longrightarrow> (\<lambda>\<omega>. x (\<lambda>i. g i \<omega>) k) \<in> borel_measurable M"
	+ proof -
	+ fix k
	+ assume "k < n"
	+ thus " (\<lambda>\<omega>. x (\<lambda>i. g i \<omega>) k) \<in> borel_measurable M"
	+ apply (simp add:x_def)
	+ apply (cases "k = i", simp)
	+ using a i_le j_le borel_measurable_min apply blast
	+ apply (cases "k = j", simp)
	+ using a i_le j_le borel_measurable_max apply blast
	+ using a by simp
	+ qed
	+ thus "meas_ptw (\<lambda>k \<omega>. x (\<lambda>i. g i \<omega>) k)"
	+ by (simp add:meas_ptw_def)
	+ qed
	+
	+ have "(\<forall>x \<in> set t. is_swap x) \<Longrightarrow> meas_ptw (\<lambda> k \<omega>. (fold id t (\<lambda>k. X k \<omega>)) k)"
	+ proof (induction t rule:rev_induct)
	+ case Nil
	+ then show ?case using assms by (simp add:meas_ptw_def)
	+ next
	+ case (snoc x xs)
	+ have a:"meas_ptw (\<lambda>k \<omega>. fold (\<lambda>a. a) xs (\<lambda>k. X k \<omega>) k)" using snoc by simp
	+ have b:"is_swap x" using snoc by simp
	+ show ?case using ind_step[OF a b] by simp
	+ qed
	+ moreover have "\<And>x. x \<in> set t \<Longrightarrow> is_swap x"
	+ apply (simp add:t_def is_swap_def)
	+ by (meson atLeastLessThan_iff imageE less_imp_le less_le_trans)
	+ ultimately show ?thesis using assms
	+ by (simp add:t_def[symmetric] meas_ptw_def)
	+qed
	+
	+text \<open>Main results of this section:\<close>
	+
	+lemma order_statistics_measurable:
	+ fixes X :: "nat \<Rightarrow> 'a \<Rightarrow> ('b :: {linorder_topology, second_countable_topology})"
	+ assumes "n \<ge> 1"
	+ assumes "j < n"
	+ assumes "\<And>i. i < n \<Longrightarrow> X i \<in> measurable M borel"
	+ shows "(\<lambda>x. (sort (map (\<lambda>i. X i x) [0..<n])) ! j) \<in> measurable M borel"
	+ apply (subst sort_map_eq_sort[symmetric])
	+ using assms by (simp add:order_statistics_measurable_aux del:sort_map.simps)
	+
	+definition median where
	+ "median n f = sort (map f [0..<n]) ! (n div 2)"
	+
	+lemma median_measurable:
	+ fixes X :: "nat \<Rightarrow> 'a \<Rightarrow> ('b :: {linorder_topology, second_countable_topology})"
	+ assumes "n \<ge> 1"
	+ assumes "\<And>i. i < n \<Longrightarrow> X i \<in> measurable M borel"
	+ shows "(\<lambda>x. median n (\<lambda>i. X i x)) \<in> measurable M borel"
	+ apply (simp add:median_def)
	+ apply (rule order_statistics_measurable[OF assms(1) _ assms(2)])
	+ using assms(1) by force+
	+
	+section \<open>The Median Method\<close>
	+
	+text \<open>This section contains the proof for the probability that the median of independent random
	+variables will be in an interval with high probability if the individual variables are in the
	+same interval with probability larger than $\frac{1}{2}$.
	+
	+The proof starts with the elementary observation that the median of a seqeuence with $n$ elements
	+is in an interval $I$ if at least half of them are in $I$. This works because after sorting the
	+sequence the elements that will be in the interval must necessarily form a consecutive subsequence,
	+if its length is larger than $\frac{n}{2}$ the median must be in it.
	+
	+The remainder follows the proof in \cite[\textsection 2.1]{alon1999} using the Hoeffding inequality
	+to estimate the probability that at least half of the sequence elements will be in the interval $I$.\<close>
	+
	+lemma interval_rule:
	+ assumes "interval I"
	+ assumes "a \<le> x" "x \<le> b"
	+ assumes "a \<in> I"
	+ assumes "b \<in> I"
	+ shows "x \<in> I"
	+ using assms(1) apply (simp add:interval_def)
	+ using assms by blast
	+
	+lemma sorted_int:
	+ assumes "interval I"
	+ assumes "sorted xs"
	+ assumes "k < length xs" "i \<le> j" "j \<le> k "
	+ assumes "xs ! i \<in> I" "xs ! k \<in> I"
	+ shows "xs ! j \<in> I"
	+ apply (rule interval_rule[where a="xs ! i" and b="xs ! k"])
	+ using assms by (simp add: sorted_nth_mono)+
	+
	+lemma mid_in_interval:
	+ assumes "2*length (filter (\<lambda>x. x \<in> I) xs) > length xs"
	+ assumes "interval I"
	+ assumes "sorted xs"
	+ shows "xs ! (length xs div 2) \<in> I"
	+proof -
	+ have "length (filter (\<lambda>x. x \<in> I) xs) > 0" using assms(1) by linarith
	+ then obtain v where v_1: "v < length xs" and v_2: "xs ! v \<in> I"
	+ by (metis filter_False in_set_conv_nth length_greater_0_conv)
	+
	+ define J where "J = {k. k < length xs \<and> xs ! k \<in> I}"
	+
	+ have card_J_min: "2*card J > length xs"
	+ using assms(1) by (simp add:J_def length_filter_conv_card)
	+
	+ consider
	+ (a) "xs ! (length xs div 2) \<in> I" \|
	+ (b) "xs ! (length xs div 2) \<notin> I \<and> v > (length xs div 2)" \|
	+ (c) "xs ! (length xs div 2) \<notin> I \<and> v < (length xs div 2)"
	+ by (metis linorder_cases v_2)
	+ thus ?thesis
	+ proof (cases)
	+ case a
	+ then show ?thesis by simp
	+ next
	+ case b
	+ have p:"\<And>k. k \<le> length xs div 2 \<Longrightarrow> xs ! k \<notin> I"
	+ using b v_2 sorted_int[OF assms(2) assms(3) v_1, where j="length xs div 2"] apply simp by blast
	+ have "card J \<le> card {Suc (length xs div 2)..<length xs}"
	+ apply (rule card_mono, simp)
	+ apply (rule subsetI, simp add:J_def not_less_eq_eq[symmetric])
	+ using p by metis
	+ hence "card J \<le> length xs - (Suc (length xs div 2))"
	+ using card_atLeastLessThan by metis
	+ hence "length xs \<le> 2*( length xs - (Suc (length xs div 2)))"
	+ using card_J_min by linarith
	+ hence "False"
	+ apply (simp add:nat_distrib)
	+ apply (subst (asm) le_diff_conv2) using b v_1 apply linarith
	+ by simp
	+ then show ?thesis by simp
	+ next
	+ case c
	+ have p:"\<And>k. k \<ge> length xs div 2 \<Longrightarrow> k < length xs \<Longrightarrow> xs ! k \<notin> I"
	+ using c v_1 v_2 sorted_int[OF assms(2) assms(3), where i ="v" and j="length xs div 2"] apply simp by blast
	+ have "card J \<le> card {0..<(length xs div 2)}"
	+ apply (rule card_mono, simp)
	+ apply (rule subsetI, simp add:J_def not_less_eq_eq[symmetric])
	+ using p linorder_le_less_linear by blast
	+ hence "card J \<le> (length xs div 2)"
	+ using card_atLeastLessThan by simp
	+ then show ?thesis using card_J_min by linarith
	+ qed
	+qed
	+
	+lemma median_est:
	+ assumes "interval I"
	+ assumes "2*card {k. k < n \<and> f k \<in> I} > n"
	+ shows "median n f \<in> I"
	+proof -
	+ have a:"{k. k < n \<and> f k \<in> I} = {i. i < n \<and> map f [0..<n] ! i \<in> I}"
	+ apply (rule order_antisym, rule subsetI, simp)
	+ by (rule subsetI, simp, metis add_0 diff_zero nth_map_upt)
	+
	+ show ?thesis
	+ apply (simp add:median_def)
	+ apply (rule mid_in_interval[where I="I" and xs="sort (map f [0..<n])", simplified])
	+ using assms a apply (simp add:filter_sort comp_def length_filter_conv_card)
	+ by (simp add:assms)
	+qed
	+
	+text \<open>Main results of this section:\<close>
	+
	+theorem (in prob_space) median_bound:
	+ fixes n :: nat
	+ fixes I :: "('b :: {linorder_topology, second_countable_topology}) set"
	+ assumes "interval I"
	+ assumes "\<alpha> > 0"
	+ assumes "\<epsilon> \<in> {0<..<1}"
	+ assumes "indep_vars (\<lambda>_. borel) X {0..<n}"
	+ assumes "n \<ge> - ln \<epsilon> / (2 * \<alpha>\<^sup>2)"
	+ assumes "\<And>i. i < n \<Longrightarrow> \<P>(\<omega> in M. X i \<omega> \<in> I) \<ge> 1/2+\<alpha>"
	+ shows "\<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> I) \<ge> 1-\<epsilon>"
	+proof -
	+ define Y :: "nat \<Rightarrow> 'a \<Rightarrow> real" where "Y = (\<lambda>i. indicator I \<circ> (X i))"
	+
	+ define t where "t = (\<Sum>i = 0..<n. expectation (Y i)) - n/2"
	+ have "0 < -ln \<epsilon> / (2 * \<alpha>\<^sup>2)"
	+ apply (rule divide_pos_pos)
	+ apply (simp, subst ln_less_zero_iff)
	+ using assms by auto
	+ also have "... \<le> real n" using assms by simp
	+ finally have "real n > 0" by simp
	+ hence n_ge_1:"n \<ge> 1" by linarith
	+ hence n_ge_0:"n > 0" by simp
	+
	+ have ind_comp: "\<And>i. indicator I \<circ> (X i) = indicator {\<omega>. X i \<omega> \<in> I}"
	+ by (rule ext, simp add:indicator_def comp_def)
	+
	+ have "\<alpha> * n \<le> (\<Sum> i =0..<n. 1/2 + \<alpha>) - n/2"
	+ by (simp add:algebra_simps)
	+ also have "... \<le> (\<Sum> i = 0..<n. expectation (Y i)) - n/2"
	+ apply (rule diff_right_mono, rule sum_mono)
	+ using assms(6) by (simp add:Y_def ind_comp Collect_conj_eq inf_commute)
	+ also have "... = t" by (simp add:t_def)
	+ finally have t_ge_a: "t \<ge> \<alpha> * n" by simp
	+
	+ have d: "0 \<le> \<alpha> * n"
	+ apply (rule mult_nonneg_nonneg)
	+ using assms(2) n_ge_0 by simp+
	+ also have "... \<le> t" using t_ge_a by simp
	+ finally have t_ge_0: "t \<ge> 0" by simp
	+
	+ have "(\<alpha> * n)\<^sup>2 \<le> t\<^sup>2" using t_ge_a d power_mono by blast
	+ hence t_ge_a_sq: "\<alpha>\<^sup>2 * real n * real n \<le> t\<^sup>2"
	+ by (simp add:algebra_simps power2_eq_square)
	+
	+ have Y_indep: "indep_vars (\<lambda>_. borel) Y {0..<n}"
	+ apply (subst Y_def)
	+ apply (rule indep_vars_compose[where M'="(\<lambda>_. borel)", OF assms(4)])
	+ using interval_borel[OF assms(1)] by simp
	+
	+ hence b:"Hoeffding_ineq M {0..<n} Y (\<lambda>i. 0) (\<lambda>i. 1)"
	+ apply (simp add:Hoeffding_ineq_def indep_interval_bounded_random_variables_def)
	+ by (simp add:prob_space_axioms indep_interval_bounded_random_variables_axioms_def Y_def Y_indep)
	+
	+ have c: "\<And>\<omega>. (\<Sum>i = 0..<n. Y i \<omega>) > n/2 \<Longrightarrow> median n (\<lambda>i. X i \<omega>) \<in> I"
	+ proof -
	+ fix \<omega>
	+ assume "(\<Sum>i = 0..<n. Y i \<omega>) > n/2"
	+ hence "n < 2 * card ({0..<n} \<inter> {i. X i \<omega> \<in> I})"
	+ by (simp add:Y_def indicator_def)
	+ also have "... = 2 * card {i. i < n \<and> X i \<omega> \<in> I}"
	+ apply (simp, rule arg_cong[where f="card"])
	+ by (rule order_antisym, rule subsetI, simp, rule subsetI, simp)
	+ finally have "2 * card {i. i < n \<and> X i \<omega> \<in> I} > n" by simp
	+ thus "median n (\<lambda>i. X i \<omega>) \<in> I"
	+ using median_est[OF assms(1)] by simp
	+ qed
	+
	+ have "1 - \<epsilon> \<le> 1- exp (- (2 * \<alpha>\<^sup>2 * real n))"
	+ apply (simp, subst ln_ge_iff[symmetric])
	+ using assms(3) apply simp
	+ using assms(5) apply (subst (asm) pos_divide_le_eq)
	+ apply (simp add: assms(2) power2_eq_square)
	+ by (simp add: mult_of_nat_commute)
	+ also have "... \<le> 1- exp (- (2 * t\<^sup>2 / real n))"
	+ apply simp
	+ apply (subst pos_le_divide_eq) using n_ge_0 apply simp
	+ using t_ge_a_sq by linarith
	+ also have "... \<le> 1 - \<P>(\<omega> in M. (\<Sum>i = 0..<n. Y i \<omega>) \<le> n/2)"
	+ using Hoeffding_ineq.Hoeffding_ineq_le[OF b, where \<epsilon>="t", simplified] n_ge_0 t_ge_0
	+ by (simp add:t_def)
	+ also have "... = \<P>(\<omega> in M. (\<Sum>i = 0..<n. Y i \<omega>) > n/2)"
	+ apply (subst prob_compl[symmetric])
	+ apply measurable
	+ using Y_indep apply (simp add:indep_vars_def)
	+ apply (rule arg_cong2[where f="measure"], simp)
	+ by (rule order_antisym, rule subsetI, simp add:not_le, rule subsetI, simp add:not_le)
	+ also have "... \<le> \<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> I)"
	+ apply (rule finite_measure_mono)
	+ apply (rule subsetI) using c apply simp
	+ using interval_borel[OF assms(1)] apply measurable
	+ apply (rule median_measurable[OF n_ge_1])
	+ using assms(4) by (simp add:indep_vars_def)
	+ finally show ?thesis by simp
	+qed
	+
	+text \<open>This is a specialization of the above to closed real intervals.\<close>
	+
	+corollary (in prob_space) median_bound_1:
	+ assumes "\<alpha> > 0"
	+ assumes "\<epsilon> \<in> {0<..<1}"
	+ assumes "indep_vars (\<lambda>_. borel) X {0..<n}"
	+ assumes "n \<ge> - ln \<epsilon> / (2 * \<alpha>\<^sup>2)"
	+ assumes "\<forall>i \<in> {0..<n}. \<P>(\<omega> in M. X i \<omega> \<in> ({a..b} :: real set)) \<ge> 1/2+\<alpha>"
	+ shows "\<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> {a..b}) \<ge> 1-\<epsilon>"
	+ apply (rule median_bound[OF _ assms(1) assms(2) assms(3) assms(4)])
	+ apply (simp add:interval_def)
	+ using assms(5) by auto
	+
	+text \<open>This is a specialization of the above, where $\alpha = \frac{1}{6}$ and the interval is described
	+using a mid point @{term "\<mu>"} and radius @{term "\<delta>"}. The choice of $\alpha = \frac{1}{6}$ implies
	+a success probability per random variable of $\frac{2}{3}$. It is a commonly chosen success
	+probability for Monte-Carlo algorithms (cf. \cite[\textsection 4]{baryossef2002} or
	+\cite[\textsection 1]{kane2010}).\<close>
	+
	+corollary (in prob_space) median_bound_2:
	+ fixes \<mu> \<delta> :: real
	+ assumes "\<epsilon> \<in> {0<..<1}"
	+ assumes "indep_vars (\<lambda>_. borel) X {0..<n}"
	+ assumes "n \<ge> -18 * ln \<epsilon>"
	+ assumes "\<And>i. i < n \<Longrightarrow> \<P>(\<omega> in M. abs (X i \<omega> - \<mu>) > \<delta>) \<le> 1/3"
	+ shows "\<P>(\<omega> in M. abs (median n (\<lambda>i. X i \<omega>) - \<mu>) \<le> \<delta>) \<ge> 1-\<epsilon>"
	+proof -
	+ have b:"\<And>i. i < n \<Longrightarrow> space M - {\<omega> \<in> space M. X i \<omega> \<in> {\<mu> - \<delta>..\<mu> + \<delta>}} = {\<omega> \<in> space M. abs (X i \<omega> - \<mu>) > \<delta>}"
	+ apply (rule order_antisym, rule subsetI, simp, linarith)
	+ by (rule subsetI, simp, linarith)
	+
	+ have "\<And>i. i < n \<Longrightarrow> 1 - \<P>(\<omega> in M. X i \<omega> \<in> {\<mu>- \<delta>..\<mu>+\<delta>}) \<le> 1/3"
	+ apply (subst prob_compl[symmetric])
	+ apply (measurable)
	+ using assms(2) apply (simp add:indep_vars_def)
	+ apply (subst b, simp)
	+ using assms(4) by simp
	+
	+ hence a:"\<And>i. i < n \<Longrightarrow> \<P>(\<omega> in M. X i \<omega> \<in> {\<mu>- \<delta>..\<mu>+\<delta>}) \<ge> 2/3" by simp
	+
	+ have "1-\<epsilon> \<le> \<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> {\<mu>-\<delta>..\<mu>+\<delta>})"
	+ apply (rule median_bound_1[OF _ assms(1) assms(2), where \<alpha>="1/6"], simp)
	+ using assms(3) apply (simp add:power2_eq_square)
	+ using a by simp
	+ also have "... = \<P>(\<omega> in M. abs (median n (\<lambda>i. X i \<omega>) - \<mu>) \<le> \<delta>)"
	+ apply (rule arg_cong2[where f="measure"], simp)
	+ apply (rule order_antisym, rule subsetI, simp, linarith)
	+ by (rule subsetI, simp, linarith)
	+ finally show ?thesis by simp
	+qed
	+
	+section \<open>Some additional results about the median\<close>
	+
	+lemma sorted_mono_map:
	+ assumes "sorted xs"
	+ assumes "mono f"
	+ shows "sorted (map f xs)"
	+ using assms apply (simp add:sorted_wrt_map)
	+ apply (rule sorted_wrt_mono_rel[where P="(\<le>)"])
	+ by (simp add:mono_def, simp)
	+
	+text \<open>This could be added to @{theory "HOL.List"}:\<close>
	+lemma map_sort:
	+ assumes "mono f"
	+ shows "sort (map f xs) = map f (sort xs)"
	+ apply (rule properties_for_sort)
	+ apply simp
	+ by (rule sorted_mono_map, simp, simp add:assms)
	+
	+lemma median_cong:
	+ assumes "\<And>i. i < n \<Longrightarrow> f i = g i"
	+ shows "median n f = median n g"
	+ apply (cases "n = 0", simp add:median_def)
	+ apply (simp add:median_def)
	+ apply (rule arg_cong2[where f="(!)"])
	+ apply (rule arg_cong[where f="sort"], rule map_cong, simp, simp add:assms)
	+ by simp
	+
	+lemma median_restrict:
	+ "median n (\<lambda>i \<in> {0..<n}.f i) = median n f"
	+ by (rule median_cong, simp)
	+
	+lemma median_commute_mono:
	+ assumes "n > 0"
	+ assumes "mono g"
	+ shows "g (median n f) = median n (g \<circ> f)"
	+ apply (simp add: median_def del:map_map)
	+ apply (subst map_map[symmetric])
	+ apply (subst map_sort[OF assms(2)])
	+ apply (subst nth_map, simp) using assms apply fastforce
	+ by simp
	+
	+lemma median_rat:
	+ assumes "n > 0"
	+ shows "real_of_rat (median n f) = median n (\<lambda>i. real_of_rat (f i))"
	+ apply (subst (2) comp_def[where g="f", symmetric])
	+ apply (rule median_commute_mono[OF assms(1)])
	+ by (simp add: mono_def of_rat_less_eq)
	+
	+lemma median_const:
	+ assumes "k > 0"
	+ shows "median k (\<lambda>i \<in> {0..<k}. a) = a"
	+proof -
	+ have b: "sorted (map (\<lambda>_. a) [0..<k])"
	+ by (subst sorted_wrt_map, simp)
	+ have a: "sort (map (\<lambda>_. a) [0..<k]) = map (\<lambda>_. a) [0..<k]"
	+ by (subst sorted_sort_id[OF b], simp)
	+ have "median k (\<lambda>i \<in> {0..<k}. a) = median k (\<lambda>_. a)"
	+ by (subst median_restrict, simp)
	+ also have "... = a"
	+ apply (simp add:median_def a)
	+ apply (subst nth_map)
	+ using assms by simp+
	+ finally show ?thesis by simp
	+qed
	+
	+end
	diff --git a/thys/Median_Method/ROOT b/thys/Median_Method/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Median_Method/ROOT
	@@ -0,0 +1,11 @@
	+chapter AFP
	+
	+session Median_Method (AFP) = "HOL-Probability" +
	+ options [timeout = 300]
	+ sessions
	+ "HOL-Library"
	+ theories
	+ Median
	+ document_files
	+ "root.tex"
	+ "root.bib"
	diff --git a/thys/Median_Method/document/root.bib b/thys/Median_Method/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Median_Method/document/root.bib
	@@ -0,0 +1,46 @@
	+@article{alon1999,
	+ title = {The Space Complexity of Approximating the Frequency Moments},
	+ journal = {Journal of Computer and System Sciences},
	+ volume = {58},
	+ number = {1},
	+ pages = {137-147},
	+ year = {1999},
	+ issn = {0022-0000},
	+ _doi = {https://doi.org/10.1006/jcss.1997.1545},
	+ _url = {https://www.sciencedirect.com/science/article/pii/S0022000097915452},
	+ author = {Noga Alon and Yossi Matias and Mario Szegedy},
	+}
	+
	+@InProceedings{baryossef2002,
	+ author="Bar-Yossef, Ziv
	+ and Jayram, T. S.
	+ and Kumar, Ravi
	+ and Sivakumar, D.
	+ and Trevisan, Luca",
	+ _editor="Rolim, Jos{\'e} D. P.
	+ and Vadhan, Salil",
	+ title="Counting Distinct Elements in a Data Stream",
	+ booktitle="Randomization and Approximation Techniques in Computer Science",
	+ year="2002",
	+ publisher="Springer Berlin Heidelberg",
	+ _address="Berlin, Heidelberg",
	+ pages="1--10",
	+}
	+
	+@inproceedings{kane2010,
	+ author = {Kane, Daniel M. and Nelson, Jelani and Woodruff, David P.},
	+ title = {An Optimal Algorithm for the Distinct Elements Problem},
	+ year = {2010},
	+ isbn = {9781450300339},
	+ _publisher = {Association for Computing Machinery},
	+ address = {New York},
	+ _url = {https://doi.org/10.1145/1807085.1807094},
	+ _doi = {10.1145/1807085.1807094},
	+ abstract = {We give the first optimal algorithm for estimating the number of distinct elements in a data stream, closing a long line of theoretical research on this problem begun by Flajolet and Martin in their seminal paper in FOCS 1983. This problem has applications to query optimization, Internet routing, network topology, and data mining. For a stream of indices in {1,...,n}, our algorithm computes a (1 \<plusminus> \<epsilon>)-approximation using an optimal O(1/\<epsilon>-2 + log(n)) bits of space with 2/3 success probability, where 0<\<epsilon><1 is given. This probability can be amplified by independent repetition. Furthermore, our algorithm processes each stream update in O(1) worst-case time, and can report an estimate at any point midstream in O(1) worst-case time, thus settling both the space and time complexities simultaneously.We also give an algorithm to estimate the Hamming norm of a stream, a generalization of the number of distinct elements, which is useful in data cleaning, packet tracing, and database auditing. Our algorithm uses nearly optimal space, and has optimal O(1) update and reporting times.},
	+ booktitle = {Proceedings of the Twenty-Ninth ACM SIGMOD-SIGACT-SIGART Symposium on Principles of Database Systems},
	+ pages = {41--52},
	+ numpages = {12},
	+ keywords = {streaming, query optimization, distinct elements, data mining},
	+ location = {Indianapolis, Indiana, USA},
	+ series = {PODS '10}
	+}
	diff --git a/thys/Median_Method/document/root.tex b/thys/Median_Method/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Median_Method/document/root.tex
	@@ -0,0 +1,73 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amsmath}
	+
	+% further packages required for unusual symbols (see also
	+% isabellesym.sty), use only when needed
	+
	+%\usepackage{amssymb}
	+ %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
	+ %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
	+ %\<triangleq>, \<yen>, \<lozenge>
	+
	+%\usepackage{eurosym}
	+ %for \<euro>
	+
	+%\usepackage[only,bigsqcap,bigparallel,fatsemi,interleave,sslash]{stmaryrd}
	+ %for \<Sqinter>, \<Parallel>, \<Zsemi>, \<Parallel>, \<sslash>
	+
	+%\usepackage{eufrak}
	+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
	+
	+%\usepackage{textcomp}
	+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	+ %\<currency>
	+
	+% 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{The Median Method}
	+\author{Emin Karayel}
	+\maketitle
	+\begin{abstract}
	+The median method is an amplification result for randomized approximation algorithms described in \cite{alon1999}.
	+Given an algorithm whose result is in a desired interval with a probability larger than
	+$\frac{1}{2}$, it is possible to improve the success probability, by running the algorithm multiple
	+times independently and using the median. In contrast to using the mean, the amplification of the
	+success probability grows exponentially with the number of independent runs.
	+
	+This entry contains a formalization of the underlying theorem:
	+Given a sequence of $n$ independent random variables, which are in a desired interval with a
	+probability $\frac{1}{2} + \alpha$. Then their median will be in the desired interval with a
	+probability of $1 - \exp (-2 \alpha^2 n)$. In particular, the success probability approaches $1$
	+exponentially with the number of variables.
	+
	+In addition to that, this entry also contains a proof that order-statistics of Borel-measurable
	+random variables are themselves measurable and that generalized intervals in linearly ordered
	+Borel-spaces are measurable.
	+\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/Mersenne_Primes/Lucas_Lehmer_Code.thy b/thys/Mersenne_Primes/Lucas_Lehmer_Code.thy
	--- a/thys/Mersenne_Primes/Lucas_Lehmer_Code.thy
	+++ b/thys/Mersenne_Primes/Lucas_Lehmer_Code.thy
	@@ -1,268 +1,268 @@
	section \<open>Efficient code for testing Mersenne primes\<close>
	theory Lucas_Lehmer_Code
	imports
	Lucas_Lehmer
	"HOL-Library.Code_Target_Numeral"
	- "Native_Word.Code_Target_Bits_Int"
	+ "Native_Word.Code_Target_Int_Bit"
	begin

	subsection \<open>Efficient computation of remainders modulo a Mersenne number\<close>

	text \<open>
	We have $k = k\ \text{mod}\ 2^n + k\ \text{div}\ 2^n\ \ (\text{mod}\ (2^n - 1))$,
	and $k\ \text{mod}\ 2^n = k\, \&\, (2^n - 1)$ and $k\ \text{div}\ 2^n = k \gg n$.
	Therefore, we can reduce $k$ modulo $2^n - 1$ using only bitwise operations, addition, and
	bit shifts.
	\<close>
	lemma cong_mersenne_number_int:
	fixes k :: int
	shows "[k mod 2 ^ n + k div 2 ^ n = k] (mod (2 ^ n - 1))"
	proof -
	have "k = (2 ^ n - 1 + 1) * (k div 2 ^ n) + (k mod 2 ^ n)"
	by simp
	also have "[\<dots> = (0 + 1) * (k div 2 ^ n) + (k mod 2 ^ n)] (mod (2 ^ n - 1))"
	by (intro cong_add cong_mult cong_refl) (auto simp: cong_def)
	finally show ?thesis by (simp add: cong_sym add_ac)
	qed

	text \<open>
	We encapsulate a single reduction step in the following operation. Note, however,
	that the result is not, in general, the same as $k\ \text{mod}\ (2^n - 1)$. Multiple
	reductions might be required in order to reduce it below $2^n$, and a multiple of $2 ^ n - 1$
	can be reduced to $2 ^ n - 1$, which is invariant to further reduction steps.
	\<close>
	definition mersenne_mod :: "int \<Rightarrow> nat \<Rightarrow> int" where
	"mersenne_mod k n = k mod 2 ^ n + k div 2 ^ n"

	lemma mersenne_mod_code [code]:
	"mersenne_mod k n = take_bit n k + drop_bit n k"
	by (simp add: mersenne_mod_def flip: take_bit_eq_mod drop_bit_eq_div)

	lemma cong_mersenne_mod: "[mersenne_mod k n = k] (mod (2 ^ n - 1))"
	unfolding mersenne_mod_def by (rule cong_mersenne_number_int)

	lemma mersenne_mod_nonneg [simp]: "k \<ge> 0 \<Longrightarrow> mersenne_mod k n \<ge> 0"
	unfolding mersenne_mod_def by (intro add_nonneg_nonneg) (simp_all add: pos_imp_zdiv_nonneg_iff)

	lemma mersenne_mod_less:
	assumes "k \<le> 2 ^ m" "m \<ge> n"
	shows "mersenne_mod k n < 2 ^ n + 2 ^ (m - n)"
	proof -
	have "mersenne_mod k n = k mod 2 ^ n + k div 2 ^ n"
	by (simp add: mersenne_mod_def)
	also have "k mod 2 ^ n < 2 ^ n"
	by simp
	also {
	have "k div 2 ^ n * 2 ^ n + 0 \<le> k div 2 ^ n * 2 ^ n + k mod (2 ^ n)"
	by (intro add_mono) auto
	also have "\<dots> = k"
	by (subst mult.commute) auto
	also have "\<dots> \<le> 2 ^ m"
	using assms by simp
	also have "\<dots> = 2 ^ (m - n) * 2 ^ n"
	using assms by (simp flip: power_add)
	finally have "k div 2 ^ n \<le> 2 ^ (m - n)"
	by simp
	}
	finally show ?thesis by simp
	qed

	lemma mersenne_mod_less':
	assumes "k \<le> 5 * 2 ^ n"
	shows "mersenne_mod k n < 2 ^ n + 5"
	proof -
	have "mersenne_mod k n = k mod 2 ^ n + k div 2 ^ n"
	by (simp add: mersenne_mod_def)
	also have "k mod 2 ^ n < 2 ^ n"
	by simp
	also {
	have "k div 2 ^ n * 2 ^ n + 0 \<le> k div 2 ^ n * 2 ^ n + k mod (2 ^ n)"
	by (intro add_mono) auto
	also have "\<dots> = k"
	by (subst mult.commute) auto
	also have "\<dots> \<le> 5 * 2 ^ n"
	using assms by simp
	finally have "k div 2 ^ n \<le> 5"
	by simp
	}
	finally show ?thesis by simp
	qed

	text \<open>
	It turns out that for our use case, a single reduction is not enough to reduce
	the number in question enough (or at least I was unable to prove that it is). We
	therefore perform two reduction steps, which is enough to guarantee that our numbers
	are below $2^n + 4$ before and after every step in the Lucas--Lehmer sequence.

	Whether one or two reductions are performed is not very important anyway, since the
	dominant step is the squaring anyway.
	\<close>
	definition mersenne_mod2 :: "int \<Rightarrow> nat \<Rightarrow> int" where
	"mersenne_mod2 k n = mersenne_mod (mersenne_mod k n) n"

	lemma cong_mersenne_mod2: "[mersenne_mod2 k n = k] (mod (2 ^ n - 1))"
	unfolding mersenne_mod2_def by (rule cong_trans) (rule cong_mersenne_mod)+

	lemma mersenne_mod2_nonneg [simp]: "k \<ge> 0 \<Longrightarrow> mersenne_mod2 k n \<ge> 0"
	unfolding mersenne_mod2_def by simp

	lemma mersenne_mod2_less:
	assumes "n > 2" and "k \<le> 2 ^ (2 * n + 2)"
	shows "mersenne_mod2 k n < 2 ^ n + 5"
	proof -
	from assms have "2 ^ 3 \<le> (2 ^ n :: int)"
	by (intro power_increasing) auto
	hence "2 ^ n \<ge> (8 :: int)" by simp
	have "mersenne_mod k n < 2 ^ n + 2 ^ (2 * n + 2 - n)"
	by (rule mersenne_mod_less) (use assms in auto)
	also have "\<dots> \<le> 5 * 2 ^ n"
	by (simp add: power_add)
	finally have "mersenne_mod (mersenne_mod k n) n < 2 ^ n + 5"
	by (intro mersenne_mod_less') auto
	thus ?thesis by (simp add: mersenne_mod2_def)
	qed

	text \<open>
	Since we subtract 2 at one point, the intermediate results can become negative. This
	is not a problem since our reduction modulo $2 ^ p - 1$ happens to make them positive again
	immediately.
	\<close>
	lemma mersenne_mod_nonneg_strong:
	assumes "a > -(2 ^ p) + 1"
	shows "mersenne_mod a p \<ge> 0"
	proof (cases "a < 0")
	case True
	have "eucl_rel_int a (2 ^ p) (- 1, a + 2 ^ p)"
	using assms True by (auto simp: eucl_rel_int_iff)
	hence "a div 2 ^ p = -1" and "a mod 2 ^ p = a + 2 ^ p"
	by (simp_all add: div_int_unique mod_int_unique)
	hence "mersenne_mod a p = a + 2 ^ p - 1"
	by (simp add: mersenne_mod_def)
	also have "\<dots> > 0" using assms by simp
	finally show ?thesis by simp
	qed auto

	lemma mersenne_mod2_nonneg_strong:
	assumes "a > -(2 ^ p) + 1"
	shows "mersenne_mod2 a p \<ge> 0"
	unfolding mersenne_mod2_def
	by (rule mersenne_mod_nonneg, rule mersenne_mod_nonneg_strong) (use assms in auto)


	subsection \<open>Efficient code for the Lucas--Lehmer sequence\<close>

	primrec gen_lucas_lehmer_sequence'' :: "nat \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
	"gen_lucas_lehmer_sequence'' p a 0 = a"
	\| "gen_lucas_lehmer_sequence'' p a (Suc n) =
	gen_lucas_lehmer_sequence'' p (mersenne_mod2 (a ^ 2 - 2) p) n"

	lemma gen_lucas_lehmer_sequence''_correct:
	assumes "[a = a'] (mod (2 ^ p - 1))"
	shows "[gen_lucas_lehmer_sequence'' p a n = gen_lucas_lehmer_sequence a' n] (mod (2 ^ p - 1))"
	using assms
	proof (induction n arbitrary: a a')
	case (Suc n)
	have "[mersenne_mod2 (a ^ 2 - 2) p = a ^ 2 - 2] (mod (2 ^ p - 1))"
	by (rule cong_mersenne_mod2)
	also have "[a ^ 2 - 2 = a' ^ 2 - 2] (mod (2 ^ p - 1))"
	by (intro cong_pow cong_diff Suc.prems cong_refl)
	finally have "[gen_lucas_lehmer_sequence'' p (mersenne_mod2 (a\<^sup>2 - 2) p) n =
	gen_lucas_lehmer_sequence (a'\<^sup>2 - 2) n] (mod 2 ^ p - 1)"
	by (rule Suc.IH)
	thus ?case
	by (auto simp del: gen_lucas_lehmer_sequence.simps simp: gen_lucas_lehmer_sequence_Suc')
	qed auto

	lemma gen_lucas_lehmer_sequence''_bounds:
	assumes "a \<ge> 0" "a < 2 ^ p + 5" "p > 2"
	shows "gen_lucas_lehmer_sequence'' p a n \<in> {0..<2 ^ p + 5}"
	using assms
	proof (induction n arbitrary: a)
	case (Suc n)
	from Suc.prems have "a ^ 2 < (2 ^ p + 5) ^ 2"
	by (intro power_strict_mono Suc.prems) auto
	also have "\<dots> \<le> (2 ^ (p + 1)) ^ 2"
	using power_increasing[of 3 p "2 :: int"] \<open>p > 2\<close> by (intro power_mono) auto
	finally have "a ^ 2 - 2 < 2 ^ (2 * p + 2)"
	by (simp flip: power_mult mult_ac)
	moreover {
	from \<open>p > 2\<close> have "(2 ^ p) \<ge> (2 ^ 3 :: int)"
	by (intro power_increasing) auto
	hence "-(2 ^ p) + 1 < (-2 :: int)"
	by simp
	also have "-2 \<le> a ^ 2 - 2"
	by simp
	finally have "mersenne_mod2 (a ^ 2 - 2) p \<ge> 0"
	by (rule mersenne_mod2_nonneg_strong)
	}
	ultimately have "gen_lucas_lehmer_sequence'' p (mersenne_mod2 (a\<^sup>2 - 2) p) n \<in> {0..<2 ^ p + 5}"
	using \<open>p > 2\<close> by (intro Suc.IH mersenne_mod2_less) auto
	thus ?case by simp
	qed auto


	subsection \<open>Code for the Lucas--Lehmer test\<close>

	lemmas [code del] = lucas_lehmer_test_code_arithmetic

	lemma lucas_lehmer_test_code [code]:
	"lucas_lehmer_test p =
	(2 < p \<and> (let x = gen_lucas_lehmer_sequence'' p 4 (p - 2) in x = 0 \<or> x = (push_bit p 1) - 1))"
	unfolding lucas_lehmer_test_def
	proof (rule conj_cong)
	assume "p > 2"
	define x where "x = gen_lucas_lehmer_sequence'' p 4 (p - 2)"
	from \<open>p > 2\<close> have "2 ^ 3 \<le> (2 ^ p :: int)" by (intro power_increasing) auto
	hence "2 ^ p \<ge> (8 :: int)" by simp
	hence bounds: "x \<in> {0..<2 ^ p + 5}"
	unfolding x_def using \<open>p > 2\<close> by (intro gen_lucas_lehmer_sequence''_bounds) auto
	have "2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2) \<longleftrightarrow> 2 ^ p - 1 dvd x"
	unfolding x_def by (intro cong_dvd_iff cong_sym[OF gen_lucas_lehmer_sequence''_correct]) auto
	also have "\<dots> \<longleftrightarrow> x \<in> {0, 2 ^ p - 1}"
	proof
	assume "2 ^ p - 1 dvd x"
	then obtain k where k: "x = (2 ^ p - 1) * k" by auto
	have "k \<ge> 0" using bounds \<open>2 ^ p \<ge> 8\<close>
	by (auto simp: k zero_le_mult_iff)
	moreover {
	have "x < 2 ^ p + 5" using bounds by simp
	also have "\<dots> \<le> (2 ^ p - 1) * 2"
	using \<open>2 ^ p \<ge> 8\<close> by simp
	finally have "(2 ^ p - 1) * k < (2 ^ p - 1) * 2"
	unfolding k .
	hence "k < 2"
	by (subst (asm) mult_less_cancel_left) auto
	}
	ultimately have "k = 0 \<or> k = 1" by auto
	thus "x \<in> {0, 2 ^ p - 1}"
	using k by auto
	qed auto
	finally show "(2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2)) =
	((let x = x in x = 0 \<or> x = (push_bit p 1) - 1))"
	by (simp add: Let_def push_bit_eq_mult)
	qed auto


	subsection \<open>Examples\<close>

	text \<open>
	Note that for some reason, the clever bit-arithmetic version of the Lucas--Lehmer test is
	actually much slower than the one using integer arithmetic when using PolyML, and even more so
	when using the built-in evaluator in Isabelle (which also uses PolyML with a slightly different
	setup).

	I do not quite know why this is the case, but it is likely because of inefficient implementations
	of bit arithmetic operations in PolyML and/or the code generator setup for it.

	When running with GHC, the bit-arithmetic version is \<^emph>\<open>much\<close> faster.
	\<close>

	value "filter mersenne_prime [0..<100]"

	lemma "prime (2 ^ 521 - 1 :: nat)"
	by (subst lucas_lehmer_correct') eval

	lemma "prime (2 ^ 4253 - 1 :: nat)"
	by (subst lucas_lehmer_correct') eval

	end
	\ No newline at end of file
	diff --git a/thys/Monad_Memo_DP/Index.thy b/thys/Monad_Memo_DP/Indexing.thy
	rename from thys/Monad_Memo_DP/Index.thy
	rename to thys/Monad_Memo_DP/Indexing.thy
	--- a/thys/Monad_Memo_DP/Index.thy
	+++ b/thys/Monad_Memo_DP/Indexing.thy
	@@ -1,330 +1,330 @@
	-subsection \<open>Index\<close>
	+subsection \<open>Indexing\<close>

	-theory Index
	+theory Indexing
	imports Main
	begin

	definition injective :: "nat \<Rightarrow> ('k \<Rightarrow> nat) \<Rightarrow> bool" where
	"injective size to_index \<equiv> \<forall> a b.
	to_index a = to_index b
	\<and> to_index a < size
	\<and> to_index b < size
	\<longrightarrow> a = b"
	for size to_index

	lemma index_mono:
	fixes a b a0 b0 :: nat
	assumes a: "a < a0" and b: "b < b0"
	shows "a * b0 + b < a0 * b0"
	proof -
	have "a * b0 + b < (Suc a) * b0"
	using b by auto
	also have "\<dots> \<le> a0 * b0"
	using a[THEN Suc_leI, THEN mult_le_mono1] .
	finally show ?thesis .
	qed

	lemma index_eq_iff:
	fixes a b c d b0 :: nat
	assumes "b < b0" "d < b0" "a * b0 + b = c * b0 + d"
	shows "a = c \<and> b = d"
	proof (rule conjI)
	{ fix a b c d :: nat
	assume ac: "a < c" and b: "b < b0"
	have "a * b0 + b < (Suc a) * b0"
	using b by auto
	also have "\<dots> \<le> c * b0"
	using ac[THEN Suc_leI, THEN mult_le_mono1] .
	also have "\<dots> \<le> c * b0 + d"
	by auto
	finally have "a * b0 + b \<noteq> c * b0 + d"
	by auto
	} note ac = this

	{ assume "a \<noteq> c"
	then consider (le) "a < c" \| (ge) "a > c"
	by fastforce
	hence False proof cases
	case le show ?thesis using ac[OF le assms(1)] assms(3) ..
	next
	case ge show ?thesis using ac[OF ge assms(2)] assms(3)[symmetric] ..
	qed
	}
	-
	+
	then show "a = c"
	by auto

	with assms(3) show "b = d"
	by auto
	qed


	locale prod_order_def =
	order0: ord less_eq0 less0 +
	order1: ord less_eq1 less1
	for less_eq0 less0 less_eq1 less1
	begin

	fun less :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
	"less (a,b) (c,d) \<longleftrightarrow> less0 a c \<and> less1 b d"

	fun less_eq :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
	"less_eq ab cd \<longleftrightarrow> less ab cd \<or> ab = cd"

	end

	locale prod_order =
	prod_order_def less_eq0 less0 less_eq1 less1 +
	order0: order less_eq0 less0 +
	order1: order less_eq1 less1
	for less_eq0 less0 less_eq1 less1
	begin

	sublocale order less_eq less
	proof qed fastforce+

	end

	locale option_order =
	order0: order less_eq0 less0
	for less_eq0 less0
	begin

	fun less_eq_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
	"less_eq_option None _ \<longleftrightarrow> True"
	\| "less_eq_option (Some _) None \<longleftrightarrow> False"
	\| "less_eq_option (Some a) (Some b) \<longleftrightarrow> less_eq0 a b"

	fun less_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
	"less_option ao bo \<longleftrightarrow> less_eq_option ao bo \<and> ao \<noteq> bo"

	sublocale order less_eq_option less_option
	apply standard
	subgoal for x y by (cases x; cases y) auto
	subgoal for x by (cases x) auto
	subgoal for x y z by (cases x; cases y; cases z) auto
	subgoal for x y by (cases x; cases y) auto
	done

	end

	datatype 'a bound = Bound (lower: 'a) (upper:'a)

	definition in_bound :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a bound \<Rightarrow> 'a \<Rightarrow> bool" where
	"in_bound less_eq less bound x \<equiv> case bound of Bound l r \<Rightarrow> less_eq l x \<and> less x r" for less_eq less

	locale index_locale_def = ord less_eq less for less_eq less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" +
	fixes idx :: "'a bound \<Rightarrow> 'a \<Rightarrow> nat"
	and size :: "'a bound \<Rightarrow> nat"

	locale index_locale = index_locale_def + idx_ord: order +
	assumes idx_valid: "in_bound less_eq less bound x \<Longrightarrow> idx bound x < size bound"
	and idx_inj : "\<lbrakk>in_bound less_eq less bound x; in_bound less_eq less bound y; idx bound x = idx bound y\<rbrakk> \<Longrightarrow> x = y"

	locale prod_index_def =
	index0: index_locale_def less_eq0 less0 idx0 size0 +
	index1: index_locale_def less_eq1 less1 idx1 size1
	for less_eq0 less0 idx0 size0 less_eq1 less1 idx1 size1
	begin

	fun idx :: "('a \<times> 'b) bound \<Rightarrow> 'a \<times> 'b \<Rightarrow> nat" where
	"idx (Bound (l0, r0) (l1, r1)) (a, b) = (idx0 (Bound l0 l1) a) * (size1 (Bound r0 r1)) + idx1 (Bound r0 r1) b"

	fun size :: "('a \<times> 'b) bound \<Rightarrow> nat" where
	"size (Bound (l0, r0) (l1, r1)) = size0 (Bound l0 l1) * size1 (Bound r0 r1)"

	end

	locale prod_index = prod_index_def less_eq0 less0 idx0 size0 less_eq1 less1 idx1 size1 +
	index0: index_locale less_eq0 less0 idx0 size0 +
	index1: index_locale less_eq1 less1 idx1 size1
	for less_eq0 less0 idx0 size0 less_eq1 less1 idx1 size1
	begin

	sublocale prod_order less_eq0 less0 less_eq1 less1 ..

	sublocale index_locale less_eq less idx size proof
	{ fix ab :: "'a \<times> 'b" and bound :: "('a \<times> 'b) bound"
	assume bound: "in_bound less_eq less bound ab"

	obtain a b l0 r0 l1 r1 where defs:"ab = (a, b)" "bound = Bound (l0, r0) (l1, r1)"
	by (cases ab; cases bound) auto

	with bound have a: "in_bound less_eq0 less0 (Bound l0 l1) a" and b: "in_bound less_eq1 less1 (Bound r0 r1) b"
	unfolding in_bound_def by auto

	have "idx (Bound (l0, r0) (l1, r1)) (a, b) < size (Bound (l0, r0) (l1, r1))"
	using index_mono[OF index0.idx_valid[OF a] index1.idx_valid[OF b]] by auto

	thus "idx bound ab < size bound"
	unfolding defs .
	}

	{ fix ab cd :: "'a \<times> 'b" and bound :: "('a \<times> 'b) bound"
	assume bound: "in_bound less_eq less bound ab" "in_bound less_eq less bound cd"
	and idx_eq: "idx bound ab = idx bound cd"

	obtain a b c d l0 r0 l1 r1 where
	defs: "ab = (a, b)" "cd = (c, d)" "bound = Bound (l0, l1) (r0, r1)"
	by (cases ab; cases cd; cases bound) auto

	from defs bound have
	a: "in_bound less_eq0 less0 (Bound l0 r0) a"
	and b: "in_bound less_eq1 less1 (Bound l1 r1) b"
	and c: "in_bound less_eq0 less0 (Bound l0 r0) c"
	and d: "in_bound less_eq1 less1 (Bound l1 r1) d"
	unfolding in_bound_def by auto

	from index_eq_iff[OF index1.idx_valid[OF b] index1.idx_valid[OF d] idx_eq[unfolded defs, simplified]]
	have ac: "idx0 (Bound l0 r0) a = idx0 (Bound l0 r0) c" and bd: "idx1 (Bound l1 r1) b = idx1 (Bound l1 r1) d" by auto
	show "ab = cd"
	unfolding defs using index0.idx_inj[OF a c ac] index1.idx_inj[OF b d bd] by auto
	}
	qed
	end

	locale option_index =
	index0: index_locale less_eq0 less0 idx0 size0
	for less_eq0 less0 idx0 size0
	begin

	fun idx :: "'a option bound \<Rightarrow> 'a option \<Rightarrow> nat" where
	"idx (Bound (Some l) (Some r)) (Some a) = idx0 (Bound l r) a"
	\| "idx _ _ = undefined"
	(* option is NOT an index *)

	end

	locale nat_index_def = ord "(\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool" "(<)"
	begin

	fun idx :: "nat bound \<Rightarrow> nat \<Rightarrow> nat" where
	"idx (Bound l _) i = i - l"

	fun size :: "nat bound \<Rightarrow> nat" where
	"size (Bound l r) = r - l"

	sublocale index_locale "(\<le>)" "(<)" idx size
	-proof qed (auto simp: in_bound_def split: bound.splits)
	+proof qed (auto simp: in_bound_def split: bound.splits)

	end

	locale nat_index = nat_index_def + order "(\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool" "(<)"

	locale int_index_def = ord "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool" "(<)"
	begin

	fun idx :: "int bound \<Rightarrow> int \<Rightarrow> nat" where
	"idx (Bound l _) i = nat (i - l)"

	fun size :: "int bound \<Rightarrow> nat" where
	"size (Bound l r) = nat (r - l)"

	sublocale index_locale "(\<le>)" "(<)" idx size
	-proof qed (auto simp: in_bound_def split: bound.splits)
	+proof qed (auto simp: in_bound_def split: bound.splits)

	end

	locale int_index = int_index_def + order "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool" "(<)"

	class index =
	fixes less_eq less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
	and idx :: "'a bound \<Rightarrow> 'a \<Rightarrow> nat"
	and size :: "'a bound \<Rightarrow> nat"
	assumes is_locale: "index_locale less_eq less idx size"

	locale bounded_index =
	fixes bound :: "'k :: index bound"
	begin

	interpretation index_locale less_eq less idx size
	using is_locale .

	definition "size \<equiv> index_class.size bound" for size

	definition "checked_idx x \<equiv> if in_bound less_eq less bound x then idx bound x else size"

	lemma checked_idx_injective:
	"injective size checked_idx"
	unfolding injective_def
	unfolding checked_idx_def
	using idx_inj by (fastforce split: if_splits)
	end

	instantiation nat :: index
	begin

	interpretation nat_index ..
	thm index_locale_axioms

	definition [simp]: "less_eq_nat \<equiv> (\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool"
	definition [simp]: "less_nat \<equiv> (<) :: nat \<Rightarrow> nat \<Rightarrow> bool"
	definition [simp]: "idx_nat \<equiv> idx"
	definition size_nat where [simp]: "size_nat \<equiv> size"

	instance by (standard, simp, fact index_locale_axioms)

	end

	instantiation int :: index
	begin

	interpretation int_index ..
	thm index_locale_axioms

	definition [simp]: "less_eq_int \<equiv> (\<le>) :: int \<Rightarrow> int \<Rightarrow> bool"
	definition [simp]: "less_int \<equiv> (<) :: int \<Rightarrow> int \<Rightarrow> bool"
	definition [simp]: "idx_int \<equiv> idx"
	definition [simp]: "size_int \<equiv> size"

	lemmas size_int = size.simps

	instance by (standard, simp, fact index_locale_axioms)
	end

	instantiation prod :: (index, index) index
	begin

	interpretation prod_index
	"less_eq::'a \<Rightarrow> 'a \<Rightarrow> bool" less idx size
	"less_eq::'b \<Rightarrow> 'b \<Rightarrow> bool" less idx size
	by (rule prod_index.intro; fact is_locale)
	thm index_locale_axioms

	definition [simp]: "less_eq_prod \<equiv> less_eq"
	definition [simp]: "less_prod \<equiv> less"
	definition [simp]: "idx_prod \<equiv> idx"
	definition [simp]: "size_prod \<equiv> size" for size_prod

	lemmas size_prod = size.simps

	instance by (standard, simp, fact index_locale_axioms)

	end

	lemma bound_int_simp[code]:
	"bounded_index.size (Bound (l1, l2) (u1, u2)) = nat (u1 - l1) * nat (u2 - l2)"
	by (simp add: bounded_index.size_def,unfold size_int_def[symmetric] size_prod,simp add: size_int)

	lemmas [code] = bounded_index.size_def bounded_index.checked_idx_def

	lemmas [code] =
	nat_index_def.size.simps
	nat_index_def.idx.simps

	lemmas [code] =
	int_index_def.size.simps
	int_index_def.idx.simps

	lemmas [code] =
	prod_index_def.size.simps
	prod_index_def.idx.simps

	lemmas [code] =
	prod_order_def.less_eq.simps
	prod_order_def.less.simps

	lemmas index_size_defs =
	prod_index_def.size.simps int_index_def.size.simps nat_index_def.size.simps bounded_index.size_def

	end
	diff --git a/thys/Monad_Memo_DP/heap_monad/Heap_Default.thy b/thys/Monad_Memo_DP/heap_monad/Heap_Default.thy
	--- a/thys/Monad_Memo_DP/heap_monad/Heap_Default.thy
	+++ b/thys/Monad_Memo_DP/heap_monad/Heap_Default.thy
	@@ -1,66 +1,66 @@
	theory Heap_Default
	imports
	Heap_Main
	- "../Index"
	+ "../Indexing"
	begin

	locale dp_consistency_heap_default =
	fixes bound :: "'k :: {index, heap} bound"
	and mem :: "'v::heap option array"
	and dp :: "'k \<Rightarrow> 'v"
	begin

	interpretation idx: bounded_index bound .

	sublocale dp_consistency_heap
	where P="\<lambda>heap. Array.length heap mem = idx.size"
	and lookup="mem_lookup idx.size idx.checked_idx mem"
	and update="mem_update idx.size idx.checked_idx mem"
	apply (rule dp_consistency_heap.intro)
	apply (rule mem_heap_correct)
	apply (rule idx.checked_idx_injective)
	done

	context
	fixes empty
	assumes empty: "map_of_heap empty \<subseteq>\<^sub>m Map.empty"
	and len: "Array.length empty mem = idx.size"
	begin

	interpretation consistent: dp_consistency_heap_empty
	where P="\<lambda>heap. Array.length heap mem = idx.size"
	and lookup="mem_lookup idx.size idx.checked_idx mem"
	and update="mem_update idx.size idx.checked_idx mem"
	by (standard; rule len empty)

	lemmas memoizedI = consistent.memoized
	lemmas successI = consistent.memoized_success

	end

	lemma mem_empty_empty:
	"map_of_heap (heap_of (mem_empty idx.size :: 'v option array Heap) Heap.empty) \<subseteq>\<^sub>m Map.empty"
	if "mem = result_of (mem_empty idx.size) Heap.empty"
	by (auto intro!: map_emptyI simp:
	that length_mem_empty Let_def nth_mem_empty mem_lookup_def heap_mem_defs.map_of_heap_def
	)

	lemma memoized_empty:
	"dp x = result_of ((mem_empty idx.size :: 'v option array Heap) \<bind> (\<lambda>mem. dp\<^sub>T mem x)) Heap.empty"
	if "consistentDP (dp\<^sub>T mem)" "mem = result_of (mem_empty idx.size) Heap.empty"
	apply (subst execute_bind_success)
	defer
	apply (subst memoizedI[OF _ _ that(1)])
	using mem_empty_empty[OF that(2)] by (auto simp: that(2) length_mem_empty)

	lemma init_success:
	"success ((mem_empty idx.size :: 'v option array Heap) \<bind> (\<lambda>mem. dp\<^sub>T mem x)) Heap.empty"
	if "consistentDP (dp\<^sub>T mem)" "mem = result_of (mem_empty idx.size) Heap.empty"
	apply (rule success_bind_I[OF success_empty])
	apply (frule execute_result_ofD)
	apply (drule execute_heap_ofD)
	using mem_empty_empty that by (auto simp: length_mem_empty intro: successI)

	end

	end
	diff --git a/thys/Monad_Memo_DP/heap_monad/Memory_Heap.thy b/thys/Monad_Memo_DP/heap_monad/Memory_Heap.thy
	--- a/thys/Monad_Memo_DP/heap_monad/Memory_Heap.thy
	+++ b/thys/Monad_Memo_DP/heap_monad/Memory_Heap.thy
	@@ -1,924 +1,924 @@
	subsection \<open>Heap Memory Implementations\<close>

	theory Memory_Heap
	- imports State_Heap DP_CRelVH Pair_Memory "HOL-Eisbach.Eisbach" "../Index"
	+ imports State_Heap DP_CRelVH Pair_Memory "HOL-Eisbach.Eisbach" "../Indexing"
	begin

	text \<open>Move\<close>
	abbreviation "result_of c h \<equiv> fst (the (execute c h))"
	abbreviation "heap_of c h \<equiv> snd (the (execute c h))"

	lemma map_emptyI:
	"m \<subseteq>\<^sub>m Map.empty" if "\<And> x. m x = None"
	using that unfolding map_le_def by auto

	lemma result_of_return[simp]:
	"result_of (Heap_Monad.return x) h = x"
	by (simp add: execute_simps)

	lemma get_result_of_lookup:
	"result_of (!r) heap = x" if "Ref.get heap r = x"
	using that by (auto simp: execute_simps)

	context
	fixes size :: nat
	and to_index :: "('k2 :: heap) \<Rightarrow> nat"
	begin

	definition
	"mem_empty = (Array.new size (None :: ('v :: heap) option))"

	lemma success_empty[intro]:
	"success mem_empty heap"
	unfolding mem_empty_def by (auto intro: success_intros)

	lemma length_mem_empty:
	"Array.length
	(heap_of (mem_empty:: (('b :: heap) option array) Heap) h)
	(result_of (mem_empty :: ('b option array) Heap) h) = size"
	unfolding mem_empty_def by (auto simp: execute_simps Array.length_alloc)

	lemma nth_mem_empty:
	"result_of
	(Array.nth (result_of (mem_empty :: ('b option array) Heap) h) i)
	(heap_of (mem_empty :: (('b :: heap) option array) Heap) h) = None" if "i < size"
	apply (subst execute_nth(1))
	apply (simp add: length_mem_empty that)
	apply (simp add: execute_simps mem_empty_def Array.get_alloc that)
	done

	context
	fixes mem :: "('v :: heap) option array"
	begin

	definition
	"mem_lookup k = (let i = to_index k in
	if i < size then Array.nth mem i else return None
	)"

	definition
	"mem_update k v = (let i = to_index k in
	if i < size then (Array.upd i (Some v) mem \<bind> (\<lambda> _. return ()))
	else return ()
	)
	"

	context assumes injective: "injective size to_index"
	begin

	interpretation heap_correct "\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup
	apply standard
	subgoal lookup_inv
	unfolding State_Heap.lift_p_def mem_lookup_def by (simp add: Let_def execute_simps)
	subgoal update_inv
	unfolding State_Heap.lift_p_def mem_update_def by (simp add: Let_def execute_simps)
	subgoal for k heap
	unfolding heap_mem_defs.map_of_heap_def map_le_def mem_lookup_def
	by (auto simp: execute_simps Let_def split: if_split_asm)
	subgoal for heap k
	unfolding heap_mem_defs.map_of_heap_def map_le_def mem_lookup_def mem_update_def
	apply (auto simp: execute_simps Let_def length_def split: if_split_asm)
	apply (subst (asm) nth_list_update_neq)
	using injective[unfolded injective_def] apply auto
	done
	done

	lemmas mem_heap_correct = heap_correct_axioms

	context
	assumes [simp]: "mem = result_of mem_empty Heap.empty"
	begin

	interpretation heap_correct_empty
	"\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup
	"heap_of (mem_empty :: 'v option array Heap) Heap.empty"
	apply standard
	subgoal
	apply (rule map_emptyI)
	unfolding map_of_heap_def mem_lookup_def by (auto simp: Let_def nth_mem_empty)
	subgoal
	by (simp add: length_mem_empty)
	done

	lemmas array_heap_emptyI = heap_correct_empty_axioms

	context
	fixes dp :: "'k2 \<Rightarrow> 'v"
	begin

	interpretation dp_consistency_heap_empty
	"\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup dp
	"heap_of (mem_empty :: 'v option array Heap) Heap.empty"
	by standard

	lemmas array_consistentI = dp_consistency_heap_empty_axioms

	end

	end (* Empty Memory *)

	end (* Injectivity *)

	end (* Fixed array *)

	lemma execute_bind_success':
	assumes "success f h" "execute (f \<bind> g) h = Some (y, h'')"
	obtains x h' where "execute f h = Some (x, h')" "execute (g x) h' = Some (y, h'')"
	using assms by (auto simp: execute_simps elim: successE)

	lemma success_bind_I:
	assumes "success f h"
	and "\<And> x h'. execute f h = Some (x, h') \<Longrightarrow> success (g x) h'"
	shows "success (f \<bind> g) h"
	by (rule successE[OF assms(1)]) (auto elim: assms(2) intro: success_bind_executeI)

	definition
	"alloc_pair a b \<equiv> do {
	r1 \<leftarrow> ref a;
	r2 \<leftarrow> ref b;
	return (r1, r2)
	}"

	lemma alloc_pair_alloc:
	"Ref.get heap' r1 = a" "Ref.get heap' r2 = b"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
	using that unfolding alloc_pair_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
	(metis Ref.get_alloc fst_conv get_alloc_neq next_present present_alloc_neq snd_conv)+

	lemma alloc_pairD1:
	"r =!= r1 \<and> r =!= r2 \<and> Ref.present heap' r"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Ref.present heap r"
	using that unfolding alloc_pair_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
	(metis next_fresh noteq_I Ref.present_alloc snd_conv)+

	lemma alloc_pairD2:
	"r1 =!= r2 \<and> Ref.present heap' r2 \<and> Ref.present heap' r1"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
	using that unfolding alloc_pair_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
	(metis next_fresh next_present noteq_I Ref.present_alloc snd_conv)+

	lemma alloc_pairD3:
	"Array.present heap' r"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Array.present heap r"
	using that unfolding alloc_pair_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
	(metis array_present_alloc snd_conv)

	lemma alloc_pairD4:
	"Ref.get heap' r = x"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
	"Ref.get heap r = x" "Ref.present heap r"
	using that unfolding alloc_pair_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
	(metis Ref.not_present_alloc Ref.present_alloc get_alloc_neq noteq_I snd_conv)

	lemma alloc_pair_array_get:
	"Array.get heap' r = x"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Array.get heap r = x"
	using that unfolding alloc_pair_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
	(metis array_get_alloc snd_conv)

	lemma alloc_pair_array_length:
	"Array.length heap' r = Array.length heap r"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
	using that unfolding alloc_pair_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
	(metis Ref.length_alloc snd_conv)

	lemma alloc_pair_nth:
	"result_of (Array.nth r i) heap' = result_of (Array.nth r i) heap"
	if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
	using alloc_pair_array_get[OF that(1) HOL.refl, of r] alloc_pair_array_length[OF that(1), of r]
	by (cases "(\<lambda>h. i < Array.length h r) heap"; simp add: execute_simps Array.nth_def)

	lemma succes_alloc_pair[intro]:
	"success (alloc_pair a b) heap"
	unfolding alloc_pair_def by (auto intro: success_intros success_bind_I)

	definition
	"init_state_inner k1 k2 m1 m2 \<equiv> do {
	(k_ref1, k_ref2) \<leftarrow> alloc_pair k1 k2;
	(m_ref1, m_ref2) \<leftarrow> alloc_pair m1 m2;
	return (k_ref1, k_ref2, m_ref1, m_ref2)
	}
	"

	lemma init_state_inner_alloc:
	assumes
	"execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"Ref.get heap' k_ref1 = k1" "Ref.get heap' k_ref2 = k2"
	"Ref.get heap' m_ref1 = m1" "Ref.get heap' m_ref2 = m2"
	using assms unfolding init_state_inner_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
	(auto intro: alloc_pair_alloc dest: alloc_pairD2 elim: alloc_pairD4)

	lemma init_state_inner_distinct:
	assumes
	"execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"m_ref1 =!= m_ref2 \<and> m_ref1 =!= k_ref1 \<and> m_ref1 =!= k_ref2 \<and> m_ref2 =!= k_ref1
	\<and> m_ref2 =!= k_ref2 \<and> k_ref1 =!= k_ref2"
	using assms unfolding init_state_inner_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
	(blast dest: alloc_pairD1 alloc_pairD2 intro: noteq_sym)+

	lemma init_state_inner_present:
	assumes
	"execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"Ref.present heap' k_ref1" "Ref.present heap' k_ref2"
	"Ref.present heap' m_ref1" "Ref.present heap' m_ref2"
	using assms unfolding init_state_inner_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
	(blast dest: alloc_pairD1 alloc_pairD2)+

	lemma inite_state_inner_present':
	assumes
	"execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	"Array.present heap a"
	shows
	"Array.present heap' a"
	using assms unfolding init_state_inner_def
	by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair] alloc_pairD3)

	lemma succes_init_state_inner[intro]:
	"success (init_state_inner k1 k2 m1 m2) heap"
	unfolding init_state_inner_def by (auto 4 3 intro: success_intros success_bind_I)

	lemma init_state_inner_nth:
	"result_of (Array.nth r i) heap' = result_of (Array.nth r i) heap"
	if "execute (init_state_inner k1 k2 m1 m2) heap = Some ((r1, r2), heap')"
	using that unfolding init_state_inner_def
	by (auto simp: execute_simps alloc_pair_nth elim!: execute_bind_success'[OF succes_alloc_pair])

	definition
	"init_state k1 k2 \<equiv> do {
	m1 \<leftarrow> mem_empty;
	m2 \<leftarrow> mem_empty;
	init_state_inner k1 k2 m1 m2
	}"

	lemma succes_init_state[intro]:
	"success (init_state k1 k2) heap"
	unfolding init_state_def by (auto intro: success_intros success_bind_I)

	definition
	"inv_distinct k_ref1 k_ref2 m_ref1 m_ref2 \<equiv>
	m_ref1 =!= m_ref2 \<and> m_ref1 =!= k_ref1 \<and> m_ref1 =!= k_ref2 \<and> m_ref2 =!= k_ref1
	\<and> m_ref2 =!= k_ref2 \<and> k_ref1 =!= k_ref2
	"

	lemma init_state_distinct:
	assumes
	"execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"
	using assms unfolding init_state_def inv_distinct_def
	by (elim execute_bind_success'[OF success_empty] init_state_inner_distinct)

	lemma init_state_present:
	assumes
	"execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"Ref.present heap' k_ref1" "Ref.present heap' k_ref2"
	"Ref.present heap' m_ref1" "Ref.present heap' m_ref2"
	using assms unfolding init_state_def
	by (auto
	simp: execute_simps elim!: execute_bind_success'[OF success_empty]
	dest: init_state_inner_present
	)

	lemma empty_present:
	"Array.present h' x" if "execute mem_empty heap = Some (x, h')"
	using that unfolding mem_empty_def
	by (auto simp: execute_simps) (metis Array.present_alloc fst_conv snd_conv)

	lemma empty_present':
	"Array.present h' a" if "execute mem_empty heap = Some (x, h')" "Array.present heap a"
	using that unfolding mem_empty_def
	by (auto simp: execute_simps Array.present_def Array.alloc_def Array.set_def Let_def)

	lemma init_state_present2:
	assumes
	"execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"Array.present heap' (Ref.get heap' m_ref1)" "Array.present heap' (Ref.get heap' m_ref2)"
	using assms unfolding init_state_def
	by (auto 4 3
	simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
	dest: inite_state_inner_present' empty_present empty_present'
	)

	lemma init_state_neq:
	assumes
	"execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"Ref.get heap' m_ref1 =!!= Ref.get heap' m_ref2"
	using assms unfolding init_state_def
	by (auto 4 3
	simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
	dest: inite_state_inner_present' empty_present empty_present'
	)
	(metis empty_present execute_new fst_conv mem_empty_def option.inject present_alloc_noteq)

	lemma present_alloc_get:
	"Array.get heap' a = Array.get heap a"
	if "Array.alloc xs heap = (a', heap')" "Array.present heap a"
	using that by (auto simp: Array.alloc_def Array.present_def Array.get_def Let_def Array.set_def)

	lemma init_state_length:
	assumes
	"execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows
	"Array.length heap' (Ref.get heap' m_ref1) = size"
	"Array.length heap' (Ref.get heap' m_ref2) = size"
	using assms unfolding init_state_def
	apply (auto
	simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
	dest: inite_state_inner_present' empty_present empty_present'
	)
	apply (auto
	simp: execute_simps init_state_inner_def alloc_pair_def mem_empty_def Array.length_def
	elim!: execute_bind_success'[OF success_refI]
	)
	apply (metis
	Array.alloc_def Array.get_set_eq Array.present_alloc array_get_alloc fst_conv length_replicate
	present_alloc_get snd_conv
	)+
	done

	context
	fixes key1 :: "'k \<Rightarrow> ('k1 :: heap)" and key2 :: "'k \<Rightarrow> 'k2"
	and m_ref1 m_ref2 :: "('v :: heap) option array ref"
	and k_ref1 k_ref2 :: "('k1 :: heap) ref"
	begin

	text \<open>We assume that look-ups happen on the older row, so this is biased towards the second entry.\<close>
	definition
	"lookup_pair k = do {
	let k' = key1 k;
	k2 \<leftarrow> !k_ref2;
	if k' = k2 then
	do {
	m2 \<leftarrow> !m_ref2;
	mem_lookup m2 (key2 k)
	}
	else
	do {
	k1 \<leftarrow> !k_ref1;
	if k' = k1 then
	do {
	m1 \<leftarrow> !m_ref1;
	mem_lookup m1 (key2 k)
	}
	else
	return None
	}
	}
	"

	text \<open>We assume that updates happen on the newer row, so this is biased towards the first entry.\<close>
	definition
	"update_pair k v = do {
	let k' = key1 k;
	k1 \<leftarrow> !k_ref1;
	if k' = k1 then do {
	m \<leftarrow> !m_ref1;
	mem_update m (key2 k) v
	}
	else do {
	k2 \<leftarrow> !k_ref2;
	if k' = k2 then do {
	m \<leftarrow> !m_ref2;
	mem_update m (key2 k) v
	}
	else do {
	do {
	k1 \<leftarrow> !k_ref1;
	m \<leftarrow> mem_empty;
	m1 \<leftarrow> !m_ref1;
	k_ref2 := k1;
	k_ref1 := k';
	m_ref2 := m1;
	m_ref1 := m
	}
	;
	m \<leftarrow> !m_ref1;
	mem_update m (key2 k) v
	}
	}
	}
	"

	definition
	"inv_pair_weak heap = (
	let
	m1 = Ref.get heap m_ref1;
	m2 = Ref.get heap m_ref2
	in Array.length heap m1 = size \<and> Array.length heap m2 = size
	\<and> Ref.present heap k_ref1 \<and> Ref.present heap k_ref2
	\<and> Ref.present heap m_ref1 \<and> Ref.present heap m_ref2
	\<and> Array.present heap m1 \<and> Array.present heap m2
	\<and> m1 =!!= m2
	)"

	(* TODO: Remove? *)
	definition
	"inv_pair heap \<equiv> inv_pair_weak heap \<and> inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"

	lemma init_state_inv:
	assumes
	"execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	shows "inv_pair_weak heap'"
	using assms unfolding inv_pair_weak_def Let_def
	by (auto intro:
	init_state_present init_state_present2 init_state_neq init_state_length
	init_state_distinct
	)

	lemma inv_pair_lengthD1:
	"Array.length heap (Ref.get heap m_ref1) = size" if "inv_pair_weak heap"
	using that unfolding inv_pair_weak_def by (auto simp: Let_def)

	lemma inv_pair_lengthD2:
	"Array.length heap (Ref.get heap m_ref2) = size" if "inv_pair_weak heap"
	using that unfolding inv_pair_weak_def by (auto simp: Let_def)

	lemma inv_pair_presentD:
	"Array.present heap (Ref.get heap m_ref1)" "Array.present heap (Ref.get heap m_ref2)"
	if "inv_pair_weak heap"
	using that unfolding inv_pair_weak_def by (auto simp: Let_def)

	lemma inv_pair_presentD2:
	"Ref.present heap m_ref1" "Ref.present heap m_ref2"
	"Ref.present heap k_ref1" "Ref.present heap k_ref2"
	if "inv_pair_weak heap"
	using that unfolding inv_pair_weak_def by (auto simp: Let_def)

	lemma inv_pair_not_eqD:
	"Ref.get heap m_ref1 =!!= Ref.get heap m_ref2" if "inv_pair_weak heap"
	using that unfolding inv_pair_weak_def by (auto simp: Let_def)

	definition "lookup1 k \<equiv> state_of (do {m \<leftarrow> !m_ref1; mem_lookup m k})"

	definition "lookup2 k \<equiv> state_of (do {m \<leftarrow> !m_ref2; mem_lookup m k})"

	definition "update1 k v \<equiv> state_of (do {m \<leftarrow> !m_ref1; mem_update m k v})"

	definition "update2 k v \<equiv> state_of (do {m \<leftarrow> !m_ref2; mem_update m k v})"

	definition "move12 k \<equiv> state_of (do {
	k1 \<leftarrow> !k_ref1;
	m \<leftarrow> mem_empty;
	m1 \<leftarrow> !m_ref1;
	k_ref2 := k1;
	k_ref1 := k;
	m_ref2 := m1;
	m_ref1 := m
	})
	"

	definition "get_k1 \<equiv> state_of (!k_ref1)"

	definition "get_k2 \<equiv> state_of (!k_ref2)"

	lemma run_state_state_of[simp]:
	"State_Monad.run_state (state_of p) m = the (execute p m)"
	unfolding state_of_def by simp

	context assumes injective: "injective size to_index"
	begin

	context
	assumes inv_distinct: "inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"
	begin

	lemma disjoint[simp]:
	"m_ref1 =!= m_ref2" "m_ref1 =!= k_ref1" "m_ref1 =!= k_ref2"
	"m_ref2 =!= k_ref1" "m_ref2 =!= k_ref2"
	"k_ref1 =!= k_ref2"
	using inv_distinct unfolding inv_distinct_def by auto

	lemmas [simp] = disjoint[THEN noteq_sym]

	lemma [simp]:
	"Array.get (snd (Array.alloc xs heap)) a = Array.get heap a" if "Array.present heap a"
	using that unfolding Array.alloc_def Array.present_def
	apply (simp add: Let_def)
	apply (subst Array.get_set_neq)
	subgoal
	by (simp add: Array.noteq_def)
	subgoal
	unfolding Array.get_def by simp
	done

	lemma [simp]:
	"Ref.get (snd (Array.alloc xs heap)) r = Ref.get heap r" if "Ref.present heap r"
	using that unfolding Array.alloc_def Ref.present_def
	by (simp add: Let_def Ref.get_def Array.set_def)

	lemma alloc_present:
	"Array.present (snd (Array.alloc xs heap)) a" if "Array.present heap a"
	using that unfolding Array.present_def Array.alloc_def by (simp add: Let_def Array.set_def)

	lemma alloc_present':
	"Ref.present (snd (Array.alloc xs heap)) r" if "Ref.present heap r"
	using that unfolding Ref.present_def Array.alloc_def by (simp add: Let_def Array.set_def)

	lemma length_get_upd[simp]:
	"length (Array.get (Array.update a i x heap) r) = length (Array.get heap r)"
	unfolding Array.get_def Array.update_def Array.set_def by simp

	method solve1 =
	(frule inv_pair_lengthD1, frule inv_pair_lengthD2, frule inv_pair_not_eqD)?,
	auto split: if_split_asm dest: Array.noteq_sym

	interpretation pair: pair_mem lookup1 lookup2 update1 update2 move12 get_k1 get_k2 inv_pair_weak
	supply [simp] =
	mem_empty_def state_mem_defs.map_of_def map_le_def
	move12_def update1_def update2_def lookup1_def lookup2_def get_k1_def get_k2_def
	mem_update_def mem_lookup_def
	execute_bind_success[OF success_newI] execute_simps Let_def Array.get_alloc length_def
	inv_pair_presentD inv_pair_presentD2
	Memory_Heap.lookup1_def Memory_Heap.lookup2_def Memory_Heap.mem_lookup_def
	apply standard
	apply (solve1; fail)+
	subgoal
	apply (rule lift_pI)
	unfolding inv_pair_weak_def
	apply (auto simp:
	intro: alloc_present alloc_present'
	elim: present_alloc_noteq[THEN Array.noteq_sym]
	)
	done
	apply (rule lift_pI, unfold inv_pair_weak_def, auto split: if_split_asm; fail)+
	apply (solve1; fail)+
	subgoal
	using injective[unfolded injective_def] by - (solve1, subst (asm) nth_list_update_neq, auto)
	subgoal
	using injective[unfolded injective_def] by - (solve1, subst (asm) nth_list_update_neq, auto)
	apply (solve1; fail)+
	done

	lemmas mem_correct_pair = pair.mem_correct_pair

	definition
	"mem_lookup1 k = do {m \<leftarrow> !m_ref1; mem_lookup m k}"

	definition
	"mem_lookup2 k = do {m \<leftarrow> !m_ref2; mem_lookup m k}"

	definition "get_k1' \<equiv> !k_ref1"

	definition "get_k2' \<equiv> !k_ref2"

	definition "update1' k v \<equiv> do {m \<leftarrow> !m_ref1; mem_update m k v}"

	definition "update2' k v \<equiv> do {m \<leftarrow> !m_ref2; mem_update m k v}"

	definition "move12' k \<equiv> do {
	k1 \<leftarrow> !k_ref1;
	m \<leftarrow> mem_empty;
	m1 \<leftarrow> !m_ref1;
	k_ref2 := k1;
	k_ref1 := k;
	m_ref2 := m1;
	m_ref1 := m
	}"

	interpretation heap_mem_defs inv_pair_weak lookup_pair update_pair .

	lemma rel_state_ofI:
	"rel_state (=) (state_of m) m" if
	"\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
	"lift_p inv_pair_weak m"
	using that unfolding rel_state_def
	by (auto split: option.split intro: lift_p_P'' simp: success_def)

	lemma inv_pair_iff:
	"inv_pair_weak = inv_pair"
	unfolding inv_pair_def using inv_distinct by simp

	lemma lift_p_inv_pairI:
	"State_Heap.lift_p inv_pair m" if "State_Heap.lift_p inv_pair_weak m"
	using that unfolding inv_pair_iff by simp

	lemma lift_p_success:
	"State_Heap.lift_p inv_pair_weak m"
	if "DP_CRelVS.lift_p inv_pair_weak (state_of m)" "\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
	using that
	unfolding lift_p_def DP_CRelVS.lift_p_def
	by (auto simp: success_def split: option.split)

	lemma rel_state_ofI2:
	"rel_state (=) (state_of m) m" if
	"\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
	"DP_CRelVS.lift_p inv_pair_weak (state_of m)"
	using that by (blast intro: rel_state_ofI lift_p_success)

	context
	includes lifting_syntax
	begin

	lemma [transfer_rule]:
	"((=) ===> rel_state (=)) move12 move12'"
	unfolding move12_def move12'_def
	apply (intro rel_funI)
	apply simp
	apply (rule rel_state_ofI2)
	subgoal
	by (auto
	simp: mem_empty_def inv_pair_lengthD1 execute_simps Let_def
	intro: success_intros intro!: success_bind_I
	)
	subgoal
	using pair.move12_inv unfolding move12_def .
	done

	lemma [transfer_rule]:
	"((=) ===> rel_state (rel_option (=))) lookup1 mem_lookup1"
	unfolding lookup1_def mem_lookup1_def
	apply (intro rel_funI)
	apply (simp add: option.rel_eq)
	apply (rule rel_state_ofI2)
	subgoal
	by (auto 4 4
	simp: mem_lookup_def inv_pair_lengthD1 execute_simps Let_def
	intro: success_bind_executeI success_returnI Array.success_nthI
	)
	subgoal
	using pair.lookup_inv(1) unfolding lookup1_def .
	done

	lemma [transfer_rule]:
	"((=) ===> rel_state (rel_option (=))) lookup2 mem_lookup2"
	unfolding lookup2_def mem_lookup2_def
	apply (intro rel_funI)
	apply (simp add: option.rel_eq)
	apply (rule rel_state_ofI2)
	subgoal
	by (auto 4 3
	simp: mem_lookup_def inv_pair_lengthD2 execute_simps Let_def
	intro: success_intros intro!: success_bind_I
	)
	subgoal
	using pair.lookup_inv(2) unfolding lookup2_def .
	done

	lemma [transfer_rule]:
	"rel_state (=) get_k1 get_k1'"
	unfolding get_k1_def get_k1'_def
	apply (rule rel_state_ofI2)
	subgoal
	by (auto intro: success_lookupI)
	subgoal
	unfolding get_k1_def[symmetric] by (auto dest: pair.get_state(1) intro: lift_pI)
	done

	lemma [transfer_rule]:
	"rel_state (=) get_k2 get_k2'"
	unfolding get_k2_def get_k2'_def
	apply (rule rel_state_ofI2)
	subgoal
	by (auto intro: success_lookupI)
	subgoal
	unfolding get_k2_def[symmetric] by (auto dest: pair.get_state(2) intro: lift_pI)
	done

	lemma [transfer_rule]:
	"((=) ===> (=) ===> rel_state (=)) update1 update1'"
	unfolding update1_def update1'_def
	apply (intro rel_funI)
	apply simp
	apply (rule rel_state_ofI2)
	subgoal
	by (auto 4 3
	simp: mem_update_def inv_pair_lengthD1 execute_simps Let_def
	intro: success_intros intro!: success_bind_I
	)
	subgoal
	using pair.update_inv(1) unfolding update1_def .
	done

	lemma [transfer_rule]:
	"((=) ===> (=) ===> rel_state (=)) update2 update2'"
	unfolding update2_def update2'_def
	apply (intro rel_funI)
	apply simp
	apply (rule rel_state_ofI2)
	subgoal
	by (auto 4 3
	simp: mem_update_def inv_pair_lengthD2 execute_simps Let_def
	intro: success_intros intro!: success_bind_I
	)
	subgoal
	using pair.update_inv(2) unfolding update2_def .
	done

	lemma [transfer_rule]:
	"((=) ===> rel_state (rel_option (=))) lookup1 mem_lookup1"
	unfolding lookup1_def mem_lookup1_def
	apply (intro rel_funI)
	apply (simp add: option.rel_eq)
	apply (rule rel_state_ofI2)
	subgoal
	by (auto 4 3
	simp: mem_lookup_def inv_pair_lengthD1 execute_simps Let_def
	intro: success_intros intro!: success_bind_I
	)
	subgoal
	using pair.lookup_inv(1) unfolding lookup1_def .
	done

	lemma rel_state_lookup:
	"((=) ===> rel_state (=)) pair.lookup_pair lookup_pair"
	unfolding pair.lookup_pair_def lookup_pair_def
	unfolding
	mem_lookup1_def[symmetric] mem_lookup2_def[symmetric]
	get_k2_def[symmetric] get_k2'_def[symmetric]
	get_k1_def[symmetric] get_k1'_def[symmetric]
	by transfer_prover

	lemma rel_state_update:
	"((=) ===> (=) ===> rel_state (=)) pair.update_pair update_pair"
	unfolding pair.update_pair_def update_pair_def
	unfolding move12'_def[symmetric]
	unfolding
	update1'_def[symmetric] update2'_def[symmetric]
	get_k2_def[symmetric] get_k2'_def[symmetric]
	get_k1_def[symmetric] get_k1'_def[symmetric]
	by transfer_prover

	interpretation mem: heap_mem_defs pair.inv_pair lookup_pair update_pair .

	lemma inv_pairD:
	"inv_pair_weak heap" if "pair.inv_pair heap"
	using that unfolding pair.inv_pair_def by (auto simp: Let_def)

	lemma mem_rel_state_ofI:
	"mem.rel_state (=) m' m" if
	"rel_state (=) m' m"
	"\<And> heap. pair.inv_pair heap \<Longrightarrow>
	(case State_Monad.run_state m' heap of (_, heap) \<Rightarrow> inv_pair_weak heap \<longrightarrow> pair.inv_pair heap)"
	proof -
	show ?thesis
	apply (rule mem.rel_state_intro)
	subgoal for heap v heap'
	by (auto elim: rel_state_elim[OF that(1)] dest!: inv_pairD)
	subgoal premises prems for heap v heap'
	proof -
	from prems that(1) have "inv_pair_weak heap'"
	by (fastforce elim: rel_state_elim dest: inv_pairD)
	with prems show ?thesis
	by (auto dest: that(2))
	qed
	done
	qed

	lemma mem_rel_state_ofI':
	"mem.rel_state (=) m' m" if
	"rel_state (=) m' m"
	"DP_CRelVS.lift_p pair.inv_pair m'"
	using that by (auto elim: DP_CRelVS.lift_p_P intro: mem_rel_state_ofI)

	context
	assumes keys: "\<forall>k k'. key1 k = key1 k' \<and> key2 k = key2 k' \<longrightarrow> k = k'"
	begin

	interpretation mem_correct pair.lookup_pair pair.update_pair pair.inv_pair
	by (rule mem_correct_pair[OF keys])

	lemma rel_state_lookup':
	"((=) ===> mem.rel_state (=)) pair.lookup_pair lookup_pair"
	apply (intro rel_funI)
	apply simp
	apply (rule mem_rel_state_ofI')
	using rel_state_lookup apply (rule rel_funD) apply (rule refl)
	apply (rule lookup_inv)
	done

	lemma rel_state_update':
	"((=) ===> (=) ===> mem.rel_state (=)) pair.update_pair update_pair"
	apply (intro rel_funI)
	apply simp
	apply (rule mem_rel_state_ofI')
	subgoal for x y a b
	using rel_state_update by (blast dest: rel_funD)
	by (rule update_inv)

	interpretation heap_correct pair.inv_pair update_pair lookup_pair
	by (rule mem.mem_correct_heap_correct[OF _ rel_state_lookup' rel_state_update']) standard

	-lemmas heap_correct_pairI = heap_correct_axioms
	+lemmas heap_correct_pairI = heap_correct_axioms

	(* TODO: Generalize *)
	lemma mem_rel_state_resultD:
	"result_of m heap = fst (run_state m' heap)" if "mem.rel_state (=) m' m" "pair.inv_pair heap"
	by (metis (mono_tags, lifting) mem.rel_state_elim option.sel that)

	lemma map_of_heap_eq:
	"mem.map_of_heap heap = pair.pair.map_of heap" if "pair.inv_pair heap"
	unfolding mem.map_of_heap_def pair.pair.map_of_def
	using that by (simp add: mem_rel_state_resultD[OF rel_state_lookup'[THEN rel_funD]])

	context
	fixes k1 k2 heap heap'
	assumes init: "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
	begin

	lemma init_state_empty1:
	"pair.mem1.map_of heap' k = None"
	using init
	unfolding pair.mem1.map_of_def lookup1_def mem_lookup_def init_state_def
	by (auto
	simp: init_state_inner_nth init_state_inner_alloc(3) execute_simps Let_def
	elim!: execute_bind_success'[OF success_empty])
	(metis
	Array.present_alloc Memory_Heap.length_mem_empty execute_new execute_nth(1) fst_conv
	length_def mem_empty_def nth_mem_empty option.sel present_alloc_get snd_conv
	)

	lemma init_state_empty2:
	"pair.mem2.map_of heap' k = None"
	using init
	unfolding pair.mem2.map_of_def lookup2_def mem_lookup_def init_state_def
	by (auto
	simp: execute_simps init_state_inner_nth init_state_inner_alloc(4) Let_def
	elim!: execute_bind_success'[OF success_empty]
	)
	(metis fst_conv nth_mem_empty option.sel snd_conv)

	lemma
	shows init_state_k1: "result_of (!k_ref1) heap' = k1"
	and init_state_k2: "result_of (!k_ref2) heap' = k2"
	using init init_state_inner_alloc
	by (auto simp: execute_simps init_state_def elim!: execute_bind_success'[OF success_empty])

	context
	assumes neq: "k1 \<noteq> k2"
	begin

	lemma init_state_inv':
	"pair.inv_pair heap'"
	unfolding pair.inv_pair_def
	apply (auto simp: Let_def)
	subgoal
	using init_state_empty1 by simp
	subgoal
	using init_state_empty2 by simp
	subgoal
	using neq init by (simp add: get_k1_def get_k2_def init_state_k1 init_state_k2)
	subgoal
	by (rule init_state_inv[OF init])
	done

	lemma init_state_empty:
	"pair.pair.map_of heap' \<subseteq>\<^sub>m Map.empty"
	using neq by (intro pair.emptyI init_state_inv' map_emptyI init_state_empty1 init_state_empty2)

	interpretation heap_correct_empty pair.inv_pair update_pair lookup_pair heap'
	apply (rule heap_correct_empty.intro)
	apply (rule heap_correct_pairI)
	apply standard
	subgoal
	by (subst map_of_heap_eq; intro init_state_inv' init_state_empty)
	subgoal
	by (rule init_state_inv')
	done

	lemmas heap_correct_empty_pairI = heap_correct_empty_axioms

	context
	fixes dp :: "'k \<Rightarrow> 'v"
	begin

	interpretation dp_consistency_heap_empty
	pair.inv_pair update_pair lookup_pair dp heap'
	by standard

	lemmas consistent_empty_pairI = dp_consistency_heap_empty_axioms

	end (* DP *)

	end (* Unequal Keys *)

	end (* Init State *)

	end (* Keys injective *)

	end (* Lifting Syntax *)

	end (* Disjoint *)

	end (* Injectivity *)

	end (* Refs *)

	end (* Key functions & Size *)

	end (* Theory *)
	diff --git a/thys/Native_Word/Code_Int_Integer_Conversion.thy b/thys/Native_Word/Code_Int_Integer_Conversion.thy
	--- a/thys/Native_Word/Code_Int_Integer_Conversion.thy
	+++ b/thys/Native_Word/Code_Int_Integer_Conversion.thy
	@@ -1,29 +1,29 @@
	(* Title: Code_Int_Integer_Conversion.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>A special case of a conversion.\<close>

	theory Code_Int_Integer_Conversion
	imports
	Main
	begin

	text \<open>
	Use this function to convert numeral @{typ integer}s quickly into @{typ int}s.
	By default, it works only for symbolic evaluation; normally generated code raises
	- an exception at run-time. If theory \<open>Code_Target_Bits_Int\<close> is imported,
	+ an exception at run-time. If theory \<^text>\<open>Code_Target_Int_Bit\<close> is imported,
	it works again, because then @{typ int} is implemented in terms of @{typ integer}
	even for symbolic evaluation.
	\<close>

	definition int_of_integer_symbolic :: "integer \<Rightarrow> int"
	where "int_of_integer_symbolic = int_of_integer"

	lemma int_of_integer_symbolic_aux_code [code nbe]:
	"int_of_integer_symbolic 0 = 0"
	"int_of_integer_symbolic (Code_Numeral.Pos n) = Int.Pos n"
	"int_of_integer_symbolic (Code_Numeral.Neg n) = Int.Neg n"
	by (simp_all add: int_of_integer_symbolic_def)

	end
	diff --git a/thys/Native_Word/Code_Symbolic_Bits_Int.thy b/thys/Native_Word/Code_Symbolic_Int_Bit.thy
	rename from thys/Native_Word/Code_Symbolic_Bits_Int.thy
	rename to thys/Native_Word/Code_Symbolic_Int_Bit.thy
	--- a/thys/Native_Word/Code_Symbolic_Bits_Int.thy
	+++ b/thys/Native_Word/Code_Symbolic_Int_Bit.thy
	@@ -1,130 +1,130 @@
	-(* Title: Code_Symbolic_Bits_Int.thy
	+(* Title: Code_Symbolic_Int_Bit.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Symbolic implementation of bit operations on int\<close>

	-theory Code_Symbolic_Bits_Int
	+theory Code_Symbolic_Int_Bit
	imports
	"Word_Lib.Least_significant_bit"
	"Word_Lib.Generic_set_bit"
	"Word_Lib.Bit_Comprehension"
	begin

	section \<open>Implementations of bit operations on \<^typ>\<open>int\<close> operating on symbolic representation\<close>

	context
	includes bit_operations_syntax
	begin

	lemma test_bit_int_code [code]:
	"bit (0::int) n = False"
	"bit (Int.Neg num.One) n = True"
	"bit (Int.Pos num.One) 0 = True"
	"bit (Int.Pos (num.Bit0 m)) 0 = False"
	"bit (Int.Pos (num.Bit1 m)) 0 = True"
	"bit (Int.Neg (num.Bit0 m)) 0 = False"
	"bit (Int.Neg (num.Bit1 m)) 0 = True"
	"bit (Int.Pos num.One) (Suc n) = False"
	"bit (Int.Pos (num.Bit0 m)) (Suc n) = bit (Int.Pos m) n"
	"bit (Int.Pos (num.Bit1 m)) (Suc n) = bit (Int.Pos m) n"
	"bit (Int.Neg (num.Bit0 m)) (Suc n) = bit (Int.Neg m) n"
	"bit (Int.Neg (num.Bit1 m)) (Suc n) = bit (Int.Neg (Num.inc m)) n"
	- by (simp_all add: Num.add_One bit_Suc)
	+ by (simp_all add: Num.add_One bit_0 bit_Suc)

	lemma int_not_code [code]:
	"NOT (0 :: int) = -1"
	"NOT (Int.Pos n) = Int.Neg (Num.inc n)"
	"NOT (Int.Neg n) = Num.sub n num.One"
	by (simp_all add: Num.add_One not_int_def)

	lemma int_and_code [code]: fixes i j :: int shows
	"0 AND j = 0"
	"i AND 0 = 0"
	"Int.Pos n AND Int.Pos m = (case and_num n m of None \<Rightarrow> 0 \| Some n' \<Rightarrow> Int.Pos n')"
	"Int.Neg n AND Int.Neg m = NOT (Num.sub n num.One OR Num.sub m num.One)"
	"Int.Pos n AND Int.Neg num.One = Int.Pos n"
	"Int.Pos n AND Int.Neg (num.Bit0 m) = Num.sub (or_not_num_neg (Num.BitM m) n) num.One"
	"Int.Pos n AND Int.Neg (num.Bit1 m) = Num.sub (or_not_num_neg (num.Bit0 m) n) num.One"
	"Int.Neg num.One AND Int.Pos m = Int.Pos m"
	"Int.Neg (num.Bit0 n) AND Int.Pos m = Num.sub (or_not_num_neg (Num.BitM n) m) num.One"
	"Int.Neg (num.Bit1 n) AND Int.Pos m = Num.sub (or_not_num_neg (num.Bit0 n) m) num.One"
	apply (simp_all add: and_num_eq_None_iff [where ?'a = int] and_num_eq_Some_iff [where ?'a = int]
	split: option.split)
	apply (simp_all only: sub_one_eq_not_neg numeral_or_not_num_eq minus_minus and_not_numerals
	bit.de_Morgan_disj bit.double_compl and_not_num_eq_None_iff and_not_num_eq_Some_iff ac_simps)
	apply auto
	done

	lemma int_or_code [code]: fixes i j :: int shows
	"0 OR j = j"
	"i OR 0 = i"
	"Int.Pos n OR Int.Pos m = Int.Pos (or_num n m)"
	"Int.Neg n OR Int.Neg m = NOT (Num.sub n num.One AND Num.sub m num.One)"
	"Int.Pos n OR Int.Neg num.One = Int.Neg num.One"
	"Int.Pos n OR Int.Neg (num.Bit0 m) = (case and_not_num (Num.BitM m) n of None \<Rightarrow> -1 \| Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
	"Int.Pos n OR Int.Neg (num.Bit1 m) = (case and_not_num (num.Bit0 m) n of None \<Rightarrow> -1 \| Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
	"Int.Neg num.One OR Int.Pos m = Int.Neg num.One"
	"Int.Neg (num.Bit0 n) OR Int.Pos m = (case and_not_num (Num.BitM n) m of None \<Rightarrow> -1 \| Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
	"Int.Neg (num.Bit1 n) OR Int.Pos m = (case and_not_num (num.Bit0 n) m of None \<Rightarrow> -1 \| Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
	apply (auto simp add: numeral_or_num_eq split: option.splits)
	apply (simp_all only: and_not_num_eq_None_iff and_not_num_eq_Some_iff and_not_numerals
	numeral_or_not_num_eq or_int_def bit.double_compl ac_simps flip: numeral_eq_iff [where ?'a = int])
	apply simp_all
	done

	lemma int_xor_code [code]: fixes i j :: int shows
	"0 XOR j = j"
	"i XOR 0 = i"
	"Int.Pos n XOR Int.Pos m = (case xor_num n m of None \<Rightarrow> 0 \| Some n' \<Rightarrow> Int.Pos n')"
	"Int.Neg n XOR Int.Neg m = Num.sub n num.One XOR Num.sub m num.One"
	"Int.Neg n XOR Int.Pos m = NOT (Num.sub n num.One XOR Int.Pos m)"
	"Int.Pos n XOR Int.Neg m = NOT (Int.Pos n XOR Num.sub m num.One)"
	by (simp_all add: xor_num_eq_None_iff [where ?'a = int] xor_num_eq_Some_iff [where ?'a = int] split: option.split)

	lemma bin_rest_code: "i div 2 = drop_bit 1 i" for i :: int
	by (simp add: drop_bit_eq_div)

	lemma set_bits_code [code]:
	"set_bits = Code.abort (STR ''set_bits is unsupported on type int'') (\<lambda>_. set_bits :: _ \<Rightarrow> int)"
	by simp

	lemma fixes i :: int
	shows int_set_bit_True_conv_OR [code]: "Generic_set_bit.set_bit i n True = i OR push_bit n 1"
	and int_set_bit_False_conv_NAND [code]: "Generic_set_bit.set_bit i n False = i AND NOT (push_bit n 1)"
	and int_set_bit_conv_ops: "Generic_set_bit.set_bit i n b = (if b then i OR (push_bit n 1) else i AND NOT (push_bit n 1))"
	by (simp_all add: bit_eq_iff) (auto simp add: bit_simps)

	declare [[code drop: \<open>drop_bit :: nat \<Rightarrow> int \<Rightarrow> int\<close>]]

	lemma drop_bit_int_code [code]: fixes i :: int shows
	"drop_bit 0 i = i"
	"drop_bit (Suc n) 0 = (0 :: int)"
	"drop_bit (Suc n) (Int.Pos num.One) = 0"
	"drop_bit (Suc n) (Int.Pos (num.Bit0 m)) = drop_bit n (Int.Pos m)"
	"drop_bit (Suc n) (Int.Pos (num.Bit1 m)) = drop_bit n (Int.Pos m)"
	"drop_bit (Suc n) (Int.Neg num.One) = - 1"
	"drop_bit (Suc n) (Int.Neg (num.Bit0 m)) = drop_bit n (Int.Neg m)"
	"drop_bit (Suc n) (Int.Neg (num.Bit1 m)) = drop_bit n (Int.Neg (Num.inc m))"
	by (simp_all add: drop_bit_Suc add_One)

	declare [[code drop: \<open>push_bit :: nat \<Rightarrow> int \<Rightarrow> int\<close>]]

	lemma push_bit_int_code [code]:
	"push_bit 0 i = i"
	"push_bit (Suc n) i = push_bit n (Int.dup i)"
	by (simp_all add: ac_simps)

	lemma int_lsb_code [code]:
	"lsb (0 :: int) = False"
	"lsb (Int.Pos num.One) = True"
	"lsb (Int.Pos (num.Bit0 w)) = False"
	"lsb (Int.Pos (num.Bit1 w)) = True"
	"lsb (Int.Neg num.One) = True"
	"lsb (Int.Neg (num.Bit0 w)) = False"
	"lsb (Int.Neg (num.Bit1 w)) = True"
	by simp_all

	end

	end
	diff --git a/thys/Native_Word/Code_Target_Bits_Int.thy b/thys/Native_Word/Code_Target_Int_Bit.thy
	rename from thys/Native_Word/Code_Target_Bits_Int.thy
	rename to thys/Native_Word/Code_Target_Int_Bit.thy
	--- a/thys/Native_Word/Code_Target_Bits_Int.thy
	+++ b/thys/Native_Word/Code_Target_Int_Bit.thy
	@@ -1,100 +1,100 @@
	-(* Title: Code_Target_Bits_Int.thy
	+(* Title: Code_Target_Int_Bit.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Implementation of bit operations on int by target language operations\<close>

	-theory Code_Target_Bits_Int
	+theory Code_Target_Int_Bit
	imports
	- Bits_Integer
	+ Code_Target_Integer_Bit
	"HOL-Library.Code_Target_Int"
	begin

	context
	includes bit_operations_syntax
	begin

	declare [[code drop:
	"(AND) :: int \<Rightarrow> _" "(OR) :: int \<Rightarrow> _" "(XOR) :: int \<Rightarrow> _" "NOT :: int \<Rightarrow> _"
	"lsb :: int \<Rightarrow> _" "set_bit :: int \<Rightarrow> _" "bit :: int \<Rightarrow> _"
	"push_bit :: _ \<Rightarrow> int \<Rightarrow> _" "drop_bit :: _ \<Rightarrow> int \<Rightarrow> _"
	int_of_integer_symbolic
	]]

	lemma [code_unfold]:
	\<open>of_bool (odd i) = i AND 1\<close> for i :: int
	by (simp add: and_one_eq mod2_eq_if)

	lemma [code_unfold]:
	\<open>bit x n \<longleftrightarrow> x AND (push_bit n 1) \<noteq> 0\<close> for x :: int
	by (fact bit_iff_and_push_bit_not_eq_0)

	context
	includes integer.lifting
	begin

	lemma bit_int_code [code]:
	"bit (int_of_integer x) n = bit x n"
	by transfer simp

	lemma and_int_code [code]:
	"int_of_integer i AND int_of_integer j = int_of_integer (i AND j)"
	by transfer simp

	lemma or_int_code [code]:
	"int_of_integer i OR int_of_integer j = int_of_integer (i OR j)"
	by transfer simp

	lemma xor_int_code [code]:
	"int_of_integer i XOR int_of_integer j = int_of_integer (i XOR j)"
	by transfer simp

	lemma not_int_code [code]:
	"NOT (int_of_integer i) = int_of_integer (NOT i)"
	by transfer simp

	lemma push_bit_int_code [code]:
	\<open>push_bit n (int_of_integer x) = int_of_integer (push_bit n x)\<close>
	by transfer simp

	lemma drop_bit_int_code [code]:
	\<open>drop_bit n (int_of_integer x) = int_of_integer (drop_bit n x)\<close>
	by transfer simp

	lemma take_bit_int_code [code]:
	\<open>take_bit n (int_of_integer x) = int_of_integer (take_bit n x)\<close>
	by transfer simp

	lemma lsb_int_code [code]:
	"lsb (int_of_integer x) = lsb x"
	by transfer simp

	lemma set_bit_int_code [code]:
	"set_bit (int_of_integer x) n b = int_of_integer (set_bit x n b)"
	by transfer simp

	lemma int_of_integer_symbolic_code [code]:
	"int_of_integer_symbolic = int_of_integer"
	by (simp add: int_of_integer_symbolic_def)

	context
	begin

	qualified definition even :: \<open>int \<Rightarrow> bool\<close>
	where [code_abbrev]: \<open>even = Parity.even\<close>

	end

	lemma [code]:
	- \<open>Code_Target_Bits_Int.even i \<longleftrightarrow> i AND 1 = 0\<close>
	- by (simp add: Code_Target_Bits_Int.even_def even_iff_mod_2_eq_zero and_one_eq)
	+ \<open>Code_Target_Int_Bit.even i \<longleftrightarrow> i AND 1 = 0\<close>
	+ by (simp add: Code_Target_Int_Bit.even_def even_iff_mod_2_eq_zero and_one_eq)

	lemma bin_rest_code:
	"int_of_integer i div 2 = int_of_integer (bin_rest_integer i)"
	by transfer simp

	end

	end

	end
	diff --git a/thys/Native_Word/Bits_Integer.thy b/thys/Native_Word/Code_Target_Integer_Bit.thy
	rename from thys/Native_Word/Bits_Integer.thy
	rename to thys/Native_Word/Code_Target_Integer_Bit.thy
	--- a/thys/Native_Word/Bits_Integer.thy
	+++ b/thys/Native_Word/Code_Target_Integer_Bit.thy
	@@ -1,680 +1,679 @@
	-(* Title: Bits_Integer.thy
	+(* Title: Code_Target_Integer_Bit.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Bit operations for target language integers\<close>

	-theory Bits_Integer imports
	+theory Code_Target_Integer_Bit imports
	"Word_Lib.Bit_Comprehension"
	Code_Int_Integer_Conversion
	- Code_Symbolic_Bits_Int
	+ Code_Symbolic_Int_Bit
	begin

	+text \<open>TODO: separate\<close>
	+
	lemmas [transfer_rule] =
	identity_quotient
	fun_quotient
	Quotient_integer[folded integer.pcr_cr_eq]

	lemma undefined_transfer:
	assumes "Quotient R Abs Rep T"
	shows "T (Rep undefined) undefined"
	using assms unfolding Quotient_alt_def by blast

	bundle undefined_transfer = undefined_transfer[transfer_rule]

	section \<open>More lemmas about @{typ integer}s\<close>

	context
	includes integer.lifting
	begin

	lemma bitval_integer_transfer [transfer_rule]:
	"(rel_fun (=) pcr_integer) of_bool of_bool"
	by(auto simp add: of_bool_def integer.pcr_cr_eq cr_integer_def)

	lemma integer_of_nat_less_0_conv [simp]: "\<not> integer_of_nat n < 0"
	by(transfer) simp

	lemma int_of_integer_pow: "int_of_integer (x ^ n) = int_of_integer x ^ n"
	by(induct n) simp_all

	lemma pow_integer_transfer [transfer_rule]:
	"(rel_fun pcr_integer (rel_fun (=) pcr_integer)) (^) (^)"
	by(auto 4 3 simp add: integer.pcr_cr_eq cr_integer_def int_of_integer_pow)

	lemma sub1_lt_0_iff [simp]: "Code_Numeral.sub n num.One < 0 \<longleftrightarrow> False"
	by(cases n)(simp_all add: Code_Numeral.sub_code)

	lemma nat_of_integer_numeral [simp]: "nat_of_integer (numeral n) = numeral n"
	by transfer simp

	lemma nat_of_integer_sub1_conv_pred_numeral [simp]:
	"nat_of_integer (Code_Numeral.sub n num.One) = pred_numeral n"
	by(cases n)(simp_all add: Code_Numeral.sub_code)

	lemma nat_of_integer_1 [simp]: "nat_of_integer 1 = 1"
	by transfer simp

	lemma dup_1 [simp]: "Code_Numeral.dup 1 = 2"
	by transfer simp


	section \<open>Bit operations on @{typ integer}\<close>

	text \<open>Bit operations on @{typ integer} are the same as on @{typ int}\<close>

	lift_definition bin_rest_integer :: "integer \<Rightarrow> integer" is \<open>\<lambda>k . k div 2\<close> .
	lift_definition bin_last_integer :: "integer \<Rightarrow> bool" is odd .
	lift_definition Bit_integer :: "integer \<Rightarrow> bool \<Rightarrow> integer" is \<open>\<lambda>k b. of_bool b + 2 * k\<close> .

	end

	instantiation integer :: lsb begin
	context includes integer.lifting begin

	lift_definition lsb_integer :: "integer \<Rightarrow> bool" is lsb .

	instance
	by (standard; transfer) (fact lsb_odd)

	end
	end

	instantiation integer :: msb begin
	context includes integer.lifting begin

	lift_definition msb_integer :: "integer \<Rightarrow> bool" is msb .

	instance ..

	end
	end

	instantiation integer :: set_bit begin
	context includes integer.lifting begin

	lift_definition set_bit_integer :: "integer \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> integer" is set_bit .

	instance
	apply standard
	apply transfer
	apply (simp add: bit_simps)
	done

	end
	end

	abbreviation (input) wf_set_bits_integer
	where "wf_set_bits_integer \<equiv> wf_set_bits_int"


	section \<open>Target language implementations\<close>

	text \<open>
	Unfortunately, this is not straightforward,
	because these API functions have different signatures and preconditions on the parameters:

	\begin{description}
	\item[Standard ML] Shifts in IntInf are given as word, but not IntInf.
	\item[Haskell] In the Data.Bits.Bits type class, shifts and bit indices are given as Int rather than Integer.
	\end{description}

	Additional constants take only parameters of type @{typ integer} rather than @{typ nat}
	and check the preconditions as far as possible (e.g., being non-negative) in a portable way.
	Manual implementations inside code\_printing perform the remaining range checks and convert
	these @{typ integer}s into the right type.

	For normalisation by evaluation, we derive custom code equations, because NBE
	does not know these code\_printing serialisations and would otherwise loop.
	\<close>

	-code_identifier code_module Bits_Integer \<rightharpoonup>
	- (SML) Bits_Int and (OCaml) Bits_Int and (Haskell) Bits_Int and (Scala) Bits_Int
	-
	-code_printing code_module Bits_Integer \<rightharpoonup> (SML)
	-\<open>structure Bits_Integer : sig
	+code_printing code_module Integer_Bit \<rightharpoonup> (SML)
	+\<open>structure Integer_Bit : sig
	+ val test_bit : IntInf.int -> IntInf.int -> bool
	val set_bit : IntInf.int -> IntInf.int -> bool -> IntInf.int
	val shiftl : IntInf.int -> IntInf.int -> IntInf.int
	val shiftr : IntInf.int -> IntInf.int -> IntInf.int
	- val test_bit : IntInf.int -> IntInf.int -> bool
	end = struct

	val maxWord = IntInf.pow (2, Word.wordSize);

	+fun test_bit x n =
	+ if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
	+ else raise (Fail ("Bit index too large: " ^ IntInf.toString n));
	+
	fun set_bit x n b =
	if n < maxWord then
	if b then IntInf.orb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n)))
	else IntInf.andb (x, IntInf.notb (IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))))
	else raise (Fail ("Bit index too large: " ^ IntInf.toString n));

	fun shiftl x n =
	if n < maxWord then IntInf.<< (x, Word.fromLargeInt (IntInf.toLarge n))
	else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

	fun shiftr x n =
	if n < maxWord then IntInf.~>> (x, Word.fromLargeInt (IntInf.toLarge n))
	else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

	-fun test_bit x n =
	- if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
	- else raise (Fail ("Bit index too large: " ^ IntInf.toString n));
	+end; (struct Integer_Bit)\<close>
	+code_reserved SML Integer_Bit

	-end; (struct Bits_Integer)\<close>
	-code_reserved SML Bits_Integer
	-
	-code_printing code_module Bits_Integer \<rightharpoonup> (OCaml)
	-\<open>module Bits_Integer : sig
	+code_printing code_module Integer_Bit \<rightharpoonup> (OCaml)
	+\<open>module Integer_Bit : sig
	+ val test_bit : Z.t -> Z.t -> bool
	val shiftl : Z.t -> Z.t -> Z.t
	val shiftr : Z.t -> Z.t -> Z.t
	- val test_bit : Z.t -> Z.t -> bool
	end = struct

	(* We do not need an explicit range checks here,
	because Big_int.int_of_big_int raises Failure
	if the argument does not fit into an int. *)
	+let test_bit x n = Z.testbit x (Z.to_int n);;
	+
	let shiftl x n = Z.shift_left x (Z.to_int n);;

	let shiftr x n = Z.shift_right x (Z.to_int n);;

	-let test_bit x n = Z.testbit x (Z.to_int n);;
	-
	-end;; (struct Bits_Integer)\<close>
	-code_reserved OCaml Bits_Integer
	+end;; (struct Integer_Bit)\<close>
	+code_reserved OCaml Integer_Bit

	code_printing code_module Data_Bits \<rightharpoonup> (Haskell)
	\<open>
	module Data_Bits where {

	import qualified Data.Bits;

	{-
	The ...Bounded functions assume that the Integer argument for the shift
	or bit index fits into an Int, is non-negative and (for types of fixed bit width)
	less than bitSize
	-}

	infixl 7 .&.;
	infixl 6 `xor`;
	infixl 5 .\|.;

	(.&.) :: Data.Bits.Bits a => a -> a -> a;
	(.&.) = (Data.Bits..&.);

	xor :: Data.Bits.Bits a => a -> a -> a;
	xor = Data.Bits.xor;

	(.\|.) :: Data.Bits.Bits a => a -> a -> a;
	(.\|.) = (Data.Bits..\|.);

	complement :: Data.Bits.Bits a => a -> a;
	complement = Data.Bits.complement;

	testBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool;
	testBitUnbounded x b
	\| b <= toInteger (Prelude.maxBound :: Int) = Data.Bits.testBit x (fromInteger b)
	\| otherwise = error ("Bit index too large: " ++ show b)
	;

	testBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool;
	testBitBounded x b = Data.Bits.testBit x (fromInteger b);

	setBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
	setBitUnbounded x n b
	\| n <= toInteger (Prelude.maxBound :: Int) =
	if b then Data.Bits.setBit x (fromInteger n) else Data.Bits.clearBit x (fromInteger n)
	\| otherwise = error ("Bit index too large: " ++ show n)
	;

	setBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
	setBitBounded x n True = Data.Bits.setBit x (fromInteger n);
	setBitBounded x n False = Data.Bits.clearBit x (fromInteger n);

	shiftlUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
	shiftlUnbounded x n
	\| n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftL x (fromInteger n)
	\| otherwise = error ("Shift operand too large: " ++ show n)
	;

	shiftlBounded :: Data.Bits.Bits a => a -> Integer -> a;
	shiftlBounded x n = Data.Bits.shiftL x (fromInteger n);

	shiftrUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
	shiftrUnbounded x n
	\| n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftR x (fromInteger n)
	\| otherwise = error ("Shift operand too large: " ++ show n)
	;

	shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Integer -> a;
	shiftrBounded x n = Data.Bits.shiftR x (fromInteger n);

	}\<close>

	and \<comment> \<open>@{theory HOL.Quickcheck_Narrowing} maps @{typ integer} to
	Haskell's Prelude.Int type instead of Integer. For compatibility
	with the Haskell target, we nevertheless provide bounded and
	unbounded functions.\<close>
	(Haskell_Quickcheck)
	\<open>
	module Data_Bits where {

	import qualified Data.Bits;

	{-
	The functions assume that the Int argument for the shift or bit index is
	non-negative and (for types of fixed bit width) less than bitSize
	-}

	infixl 7 .&.;
	infixl 6 `xor`;
	infixl 5 .\|.;

	(.&.) :: Data.Bits.Bits a => a -> a -> a;
	(.&.) = (Data.Bits..&.);

	xor :: Data.Bits.Bits a => a -> a -> a;
	xor = Data.Bits.xor;

	(.\|.) :: Data.Bits.Bits a => a -> a -> a;
	(.\|.) = (Data.Bits..\|.);

	complement :: Data.Bits.Bits a => a -> a;
	complement = Data.Bits.complement;

	testBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
	testBitUnbounded = Data.Bits.testBit;

	testBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
	testBitBounded = Data.Bits.testBit;

	setBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
	setBitUnbounded x n True = Data.Bits.setBit x n;
	setBitUnbounded x n False = Data.Bits.clearBit x n;

	setBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
	setBitBounded x n True = Data.Bits.setBit x n;
	setBitBounded x n False = Data.Bits.clearBit x n;

	shiftlUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
	shiftlUnbounded = Data.Bits.shiftL;

	shiftlBounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
	shiftlBounded = Data.Bits.shiftL;

	shiftrUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
	shiftrUnbounded = Data.Bits.shiftR;

	shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Prelude.Int -> a;
	shiftrBounded = Data.Bits.shiftR;

	}\<close>
	code_reserved Haskell Data_Bits

	-code_printing code_module Bits_Integer \<rightharpoonup> (Scala)
	-\<open>object Bits_Integer {
	+code_printing code_module Integer_Bit \<rightharpoonup> (Scala)
	+\<open>object Integer_Bit {
	+
	+def testBit(x: BigInt, n: BigInt) : Boolean =
	+ if (n.isValidInt)
	+ x.testBit(n.toInt)
	+ else
	+ sys.error("Bit index too large: " + n.toString)

	def setBit(x: BigInt, n: BigInt, b: Boolean) : BigInt =
	if (n.isValidInt)
	if (b)
	x.setBit(n.toInt)
	else
	x.clearBit(n.toInt)
	else
	sys.error("Bit index too large: " + n.toString)

	def shiftl(x: BigInt, n: BigInt) : BigInt =
	if (n.isValidInt)
	x << n.toInt
	else
	sys.error("Shift index too large: " + n.toString)

	def shiftr(x: BigInt, n: BigInt) : BigInt =
	if (n.isValidInt)
	x << n.toInt
	else
	sys.error("Shift index too large: " + n.toString)

	-def testBit(x: BigInt, n: BigInt) : Boolean =
	- if (n.isValidInt)
	- x.testBit(n.toInt)
	- else
	- sys.error("Bit index too large: " + n.toString)
	-
	-} /* object Bits_Integer */\<close>
	+} /* object Integer_Bit */\<close>

	code_printing
	constant "Bit_Operations.and :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
	(SML) "IntInf.andb ((_),/ (_))" and
	(OCaml) "Z.logand" and
	(Haskell) "((Data'_Bits..&.) :: Integer -> Integer -> Integer)" and
	(Haskell_Quickcheck) "((Data'_Bits..&.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
	(Scala) infixl 3 "&"
	\| constant "Bit_Operations.or :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
	(SML) "IntInf.orb ((_),/ (_))" and
	(OCaml) "Z.logor" and
	(Haskell) "((Data'_Bits..\|.) :: Integer -> Integer -> Integer)" and
	(Haskell_Quickcheck) "((Data'_Bits..\|.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
	(Scala) infixl 1 "\|"
	\| constant "Bit_Operations.xor :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
	(SML) "IntInf.xorb ((_),/ (_))" and
	(OCaml) "Z.logxor" and
	(Haskell) "(Data'_Bits.xor :: Integer -> Integer -> Integer)" and
	(Haskell_Quickcheck) "(Data'_Bits.xor :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
	(Scala) infixl 2 "^"
	\| constant "Bit_Operations.not :: integer \<Rightarrow> integer" \<rightharpoonup>
	(SML) "IntInf.notb" and
	(OCaml) "Z.lognot" and
	(Haskell) "(Data'_Bits.complement :: Integer -> Integer)" and
	(Haskell_Quickcheck) "(Data'_Bits.complement :: Prelude.Int -> Prelude.Int)" and
	(Scala) "_.unary'_~"

	code_printing constant bin_rest_integer \<rightharpoonup>
	(SML) "IntInf.div ((_), 2)" and
	(OCaml) "Z.shift'_right/ _/ 1" and
	(Haskell) "(Data'_Bits.shiftrUnbounded _ 1 :: Integer)" and
	(Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded _ 1 :: Prelude.Int)" and
	(Scala) "_ >> 1"

	context
	includes integer.lifting bit_operations_syntax
	begin

	lemma bitNOT_integer_code [code]:
	fixes i :: integer shows
	"NOT i = - i - 1"
	by transfer (simp add: not_int_def)

	lemma bin_rest_integer_code [code nbe]:
	"bin_rest_integer i = i div 2"
	by transfer rule

	lemma bin_last_integer_code [code]:
	"bin_last_integer i \<longleftrightarrow> i AND 1 \<noteq> 0"
	by transfer (simp add: and_one_eq odd_iff_mod_2_eq_one)

	lemma bin_last_integer_nbe [code nbe]:
	"bin_last_integer i \<longleftrightarrow> i mod 2 \<noteq> 0"
	by transfer (simp add: odd_iff_mod_2_eq_one)

	lemma bitval_bin_last_integer [code_unfold]:
	"of_bool (bin_last_integer i) = i AND 1"
	by transfer (simp add: and_one_eq mod_2_eq_odd)

	end

	definition integer_test_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool"
	where "integer_test_bit x n = (if n < 0 then undefined x n else bit x (nat_of_integer n))"

	declare [[code drop: \<open>bit :: integer \<Rightarrow> nat \<Rightarrow> bool\<close>]]

	lemma bit_integer_code [code]:
	"bit x n \<longleftrightarrow> integer_test_bit x (integer_of_nat n)"
	by (simp add: integer_test_bit_def)

	lemma integer_test_bit_code [code]:
	"integer_test_bit x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
	"integer_test_bit 0 0 = False"
	"integer_test_bit 0 (Code_Numeral.Pos n) = False"
	"integer_test_bit (Code_Numeral.Pos num.One) 0 = True"
	"integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) 0 = False"
	"integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) 0 = True"
	"integer_test_bit (Code_Numeral.Pos num.One) (Code_Numeral.Pos n') = False"
	"integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) (Code_Numeral.Pos n') =
	integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
	"integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) (Code_Numeral.Pos n') =
	integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
	"integer_test_bit (Code_Numeral.Neg num.One) 0 = True"
	"integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) 0 = False"
	"integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) 0 = True"
	"integer_test_bit (Code_Numeral.Neg num.One) (Code_Numeral.Pos n') = True"
	"integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) (Code_Numeral.Pos n') =
	integer_test_bit (Code_Numeral.Neg n) (Code_Numeral.sub n' num.One)"
	"integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) (Code_Numeral.Pos n') =
	integer_test_bit (Code_Numeral.Neg (n + num.One)) (Code_Numeral.sub n' num.One)"
	- by (simp_all add: integer_test_bit_def bit_integer_def flip: bit_not_int_iff')
	+ by (simp_all add: integer_test_bit_def bit_integer_def bit_0 flip: bit_not_int_iff')

	code_printing constant integer_test_bit \<rightharpoonup>
	- (SML) "Bits'_Integer.test'_bit" and
	- (OCaml) "Bits'_Integer.test'_bit" and
	+ (SML) "Integer'_Bit.test'_bit" and
	+ (OCaml) "Integer'_Bit.test'_bit" and
	(Haskell) "(Data'_Bits.testBitUnbounded :: Integer -> Integer -> Bool)" and
	(Haskell_Quickcheck) "(Data'_Bits.testBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool)" and
	- (Scala) "Bits'_Integer.testBit"
	+ (Scala) "Integer'_Bit.testBit"

	context
	includes integer.lifting bit_operations_syntax
	begin

	lemma lsb_integer_code [code]:
	fixes x :: integer shows
	"lsb x = bit x 0"
	by transfer(simp add: lsb_int_def)

	definition integer_set_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> integer"
	where [code del]: "integer_set_bit x n b = (if n < 0 then undefined x n b else set_bit x (nat_of_integer n) b)"

	lemma set_bit_integer_code [code]:
	"set_bit x i b = integer_set_bit x (integer_of_nat i) b"
	by(simp add: integer_set_bit_def)

	lemma set_bit_integer_conv_masks:
	fixes x :: integer shows
	"set_bit x i b = (if b then x OR (push_bit i 1) else x AND NOT (push_bit i 1))"
	by transfer (simp add: int_set_bit_False_conv_NAND int_set_bit_True_conv_OR)

	end

	code_printing constant integer_set_bit \<rightharpoonup>
	- (SML) "Bits'_Integer.set'_bit" and
	+ (SML) "Integer'_Bit.set'_bit" and
	(Haskell) "(Data'_Bits.setBitUnbounded :: Integer -> Integer -> Bool -> Integer)" and
	(Haskell_Quickcheck) "(Data'_Bits.setBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool -> Prelude.Int)" and
	- (Scala) "Bits'_Integer.setBit"
	+ (Scala) "Integer'_Bit.setBit"

	text \<open>
	OCaml.Big\_int does not have a method for changing an individual bit, so we emulate that with masks.
	We prefer an Isabelle implementation, because this then takes care of the signs for AND and OR.
	\<close>

	context
	includes bit_operations_syntax
	begin

	lemma integer_set_bit_code [code]:
	"integer_set_bit x n b =
	(if n < 0 then undefined x n b else
	if b then x OR (push_bit (nat_of_integer n) 1)
	else x AND NOT (push_bit (nat_of_integer n) 1))"
	by (auto simp add: integer_set_bit_def not_less set_bit_eq set_bit_def unset_bit_def)

	end

	definition integer_shiftl :: "integer \<Rightarrow> integer \<Rightarrow> integer"
	where [code del]: "integer_shiftl x n = (if n < 0 then undefined x n else push_bit (nat_of_integer n) x)"

	declare [[code drop: \<open>push_bit :: nat \<Rightarrow> integer \<Rightarrow> integer\<close>]]

	lemma shiftl_integer_code [code]:
	fixes x :: integer shows
	"push_bit n x = integer_shiftl x (integer_of_nat n)"
	by(auto simp add: integer_shiftl_def)

	context
	includes integer.lifting
	begin

	lemma shiftl_integer_conv_mult_pow2:
	fixes x :: integer shows
	"push_bit n x = x * 2 ^ n"
	by (fact push_bit_eq_mult)

	lemma integer_shiftl_code [code]:
	"integer_shiftl x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
	"integer_shiftl x 0 = x"
	"integer_shiftl x (Code_Numeral.Pos n) = integer_shiftl (Code_Numeral.dup x) (Code_Numeral.sub n num.One)"
	"integer_shiftl 0 (Code_Numeral.Pos n) = 0"
	apply (simp_all add: integer_shiftl_def numeral_eq_Suc)
	apply transfer
	apply (simp add: ac_simps)
	done

	end

	code_printing constant integer_shiftl \<rightharpoonup>
	- (SML) "Bits'_Integer.shiftl" and
	- (OCaml) "Bits'_Integer.shiftl" and
	+ (SML) "Integer'_Bit.shiftl" and
	+ (OCaml) "Integer'_Bit.shiftl" and
	(Haskell) "(Data'_Bits.shiftlUnbounded :: Integer -> Integer -> Integer)" and
	(Haskell_Quickcheck) "(Data'_Bits.shiftlUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
	- (Scala) "Bits'_Integer.shiftl"
	+ (Scala) "Integer'_Bit.shiftl"

	definition integer_shiftr :: "integer \<Rightarrow> integer \<Rightarrow> integer"
	where [code del]: "integer_shiftr x n = (if n < 0 then undefined x n else drop_bit (nat_of_integer n) x)"

	declare [[code drop: \<open>drop_bit :: nat \<Rightarrow> integer \<Rightarrow> integer\<close>]]

	lemma shiftr_integer_conv_div_pow2:
	includes integer.lifting fixes x :: integer shows
	"drop_bit n x = x div 2 ^ n"
	by (fact drop_bit_eq_div)

	lemma shiftr_integer_code [code]:
	fixes x :: integer shows
	"drop_bit n x = integer_shiftr x (integer_of_nat n)"
	by(auto simp add: integer_shiftr_def)

	code_printing constant integer_shiftr \<rightharpoonup>
	- (SML) "Bits'_Integer.shiftr" and
	- (OCaml) "Bits'_Integer.shiftr" and
	+ (SML) "Integer'_Bit.shiftr" and
	+ (OCaml) "Integer'_Bit.shiftr" and
	(Haskell) "(Data'_Bits.shiftrUnbounded :: Integer -> Integer -> Integer)" and
	(Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
	- (Scala) "Bits'_Integer.shiftr"
	+ (Scala) "Integer'_Bit.shiftr"

	lemma integer_shiftr_code [code]:
	includes integer.lifting
	shows
	"integer_shiftr x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
	"integer_shiftr x 0 = x"
	"integer_shiftr 0 (Code_Numeral.Pos n) = 0"
	"integer_shiftr (Code_Numeral.Pos num.One) (Code_Numeral.Pos n) = 0"
	"integer_shiftr (Code_Numeral.Pos (num.Bit0 n')) (Code_Numeral.Pos n) =
	integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
	"integer_shiftr (Code_Numeral.Pos (num.Bit1 n')) (Code_Numeral.Pos n) =
	integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
	"integer_shiftr (Code_Numeral.Neg num.One) (Code_Numeral.Pos n) = -1"
	"integer_shiftr (Code_Numeral.Neg (num.Bit0 n')) (Code_Numeral.Pos n) =
	integer_shiftr (Code_Numeral.Neg n') (Code_Numeral.sub n num.One)"
	"integer_shiftr (Code_Numeral.Neg (num.Bit1 n')) (Code_Numeral.Pos n) =
	integer_shiftr (Code_Numeral.Neg (Num.inc n')) (Code_Numeral.sub n num.One)"
	apply (simp_all add: integer_shiftr_def numeral_eq_Suc drop_bit_Suc)
	apply transfer apply simp
	apply transfer apply simp
	apply transfer apply (simp add: add_One)
	done

	context
	includes integer.lifting
	begin

	lemma Bit_integer_code [code]:
	"Bit_integer i False = push_bit 1 i"
	"Bit_integer i True = push_bit 1 i + 1"
	by (transfer; simp)+

	lemma msb_integer_code [code]:
	"msb (x :: integer) \<longleftrightarrow> x < 0"
	by transfer (simp add: msb_int_def)

	end

	context
	includes integer.lifting natural.lifting bit_operations_syntax
	begin

	lemma bitAND_integer_unfold [code]:
	"x AND y =
	(if x = 0 then 0
	else if x = - 1 then y
	else Bit_integer (bin_rest_integer x AND bin_rest_integer y) (bin_last_integer x \<and> bin_last_integer y))"
	by transfer
	(auto simp add: algebra_simps
	and_int_rec [of _ \<open>_ * 2\<close>] and_int_rec [of \<open>_ * 2\<close>] and_int_rec [of \<open>1 + _ * 2\<close>]
	elim!: evenE oddE)

	lemma bitOR_integer_unfold [code]:
	"x OR y =
	(if x = 0 then y
	else if x = - 1 then - 1
	else Bit_integer (bin_rest_integer x OR bin_rest_integer y) (bin_last_integer x \<or> bin_last_integer y))"
	by transfer
	(auto simp add: algebra_simps
	or_int_rec [of _ \<open>_ * 2\<close>] or_int_rec [of _ \<open>1 + _ * 2\<close>] or_int_rec [of \<open>1 + _ * 2\<close>]
	elim!: evenE oddE)

	lemma bitXOR_integer_unfold [code]:
	"x XOR y =
	(if x = 0 then y
	else if x = - 1 then NOT y
	else Bit_integer (bin_rest_integer x XOR bin_rest_integer y)
	(\<not> bin_last_integer x \<longleftrightarrow> bin_last_integer y))"
	by transfer
	(auto simp add: algebra_simps
	xor_int_rec [of _ \<open>_ * 2\<close>] xor_int_rec [of \<open>_ * 2\<close>] xor_int_rec [of \<open>1 + _ * 2\<close>]
	elim!: evenE oddE)

	end


	section \<open>Test code generator setup\<close>

	context
	includes bit_operations_syntax
	begin

	definition bit_integer_test :: "bool" where
	"bit_integer_test =
	(([ -1 AND 3, 1 AND -3, 3 AND 5, -3 AND (- 5)
	, -3 OR 1, 1 OR -3, 3 OR 5, -3 OR (- 5)
	, NOT 1, NOT (- 3)
	, -1 XOR 3, 1 XOR (- 3), 3 XOR 5, -5 XOR (- 3)
	, set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
	, push_bit 2 1, push_bit 3 (- 1)
	, drop_bit 3 100, drop_bit 3 (- 100)] :: integer list)
	= [ 3, 1, 1, -7
	, -3, -3, 7, -1
	, -2, 2
	, -4, -4, 6, 6
	, 21, -1, 4, -7
	, 4, -8
	, 12, -13] \<and>
	[ bit (5 :: integer) 4, bit (5 :: integer) 2, bit (-5 :: integer) 4, bit (-5 :: integer) 2
	, lsb (5 :: integer), lsb (4 :: integer), lsb (-1 :: integer), lsb (-2 :: integer),
	msb (5 :: integer), msb (0 :: integer), msb (-1 :: integer), msb (-2 :: integer)]
	= [ False, True, True, False,
	True, False, True, False,
	False, False, True, True])"

	export_code bit_integer_test checking SML Haskell? Haskell_Quickcheck? OCaml? Scala

	notepad begin
	have bit_integer_test by eval
	have bit_integer_test by normalization
	have bit_integer_test by code_simp
	end
	ML_val \<open>val true = @{code bit_integer_test}\<close>

	lemma "x AND y = x OR (y :: integer)"
	quickcheck[random, expect=counterexample]
	quickcheck[exhaustive, expect=counterexample]
	oops

	lemma "(x :: integer) AND x = x OR x"
	quickcheck[narrowing, expect=no_counterexample]
	oops

	lemma "(f :: integer \<Rightarrow> unit) = g"
	quickcheck[narrowing, size=3, expect=no_counterexample]
	by(simp add: fun_eq_iff)

	end

	hide_const bit_integer_test
	hide_fact bit_integer_test_def

	end
	diff --git a/thys/Native_Word/Code_Target_Word_Base.thy b/thys/Native_Word/Code_Target_Word_Base.thy
	--- a/thys/Native_Word/Code_Target_Word_Base.thy
	+++ b/thys/Native_Word/Code_Target_Word_Base.thy
	@@ -1,425 +1,428 @@
	(* Title: Code_Target_Word_Base.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Common base for target language implementations of word types\<close>

	theory Code_Target_Word_Base imports
	"HOL-Library.Word"
	"Word_Lib.Signed_Division_Word"
	- Bits_Integer
	+ "Word_Lib.More_Word"
	+ "Word_Lib.Bit_Comprehension"
	begin

	text \<open>More lemmas\<close>

	lemma div_half_nat:
	fixes x y :: nat
	assumes "y \<noteq> 0"
	shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
	proof -
	let ?q = "2 * (x div 2 div y)"
	have q: "?q = x div y - x div y mod 2"
	by(metis div_mult2_eq mult.commute minus_mod_eq_mult_div [symmetric])
	let ?r = "x - ?q * y"
	have r: "?r = x mod y + x div y mod 2 * y"
	by(simp add: q diff_mult_distrib minus_mod_eq_div_mult [symmetric])(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)

	show ?thesis
	proof(cases "y \<le> x - ?q * y")
	case True
	with assms q have "x div y mod 2 \<noteq> 0" unfolding r
	by (metis Nat.add_0_right diff_0_eq_0 diff_Suc_1 le_div_geq mod2_gr_0 mod_div_trivial mult_0 neq0_conv numeral_1_eq_Suc_0 numerals(1))
	hence "x div y = ?q + 1" unfolding q
	by simp
	moreover hence "x mod y = ?r - y"
	by simp(metis minus_div_mult_eq_mod [symmetric] diff_commute diff_diff_left mult_Suc)
	ultimately show ?thesis using True by(simp add: Let_def)
	next
	case False
	hence "x div y mod 2 = 0" unfolding r
	by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
	hence "x div y = ?q" unfolding q by simp
	moreover hence "x mod y = ?r" by (metis minus_div_mult_eq_mod [symmetric])
	ultimately show ?thesis using False by(simp add: Let_def)
	qed
	qed

	lemma div_half_word:
	fixes x y :: "'a :: len word"
	assumes "y \<noteq> 0"
	shows "(x div y, x mod y) = (let q = push_bit 1 (drop_bit 1 x div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
	proof -
	obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
	by (rule that [of \<open>unat x\<close>]) simp_all
	moreover obtain m where m: "y = of_nat m" "m < 2 ^ LENGTH('a)"
	by (rule that [of \<open>unat y\<close>]) simp_all
	ultimately have [simp]: \<open>unat (of_nat n :: 'a word) = n\<close> \<open>unat (of_nat m :: 'a word) = m\<close>
	by (transfer, simp add: take_bit_of_nat take_bit_nat_eq_self_iff)+
	let ?q = "push_bit 1 (drop_bit 1 x div y)"
	let ?q' = "2 * (n div 2 div m)"
	have "n div 2 div m < 2 ^ LENGTH('a)"
	- using n by (metis of_nat_inverse unat_lt2p uno_simps(2))
	+ using n by (metis of_nat_inverse uno_simps(2) unsigned_less)
	hence q: "?q = of_nat ?q'" using n m
	by (auto simp add: drop_bit_eq_div word_arith_nat_div uno_simps take_bit_nat_eq_self unsigned_of_nat)
	from assms have "m \<noteq> 0" using m by -(rule notI, simp)

	from n have "2 * (n div 2 div m) < 2 ^ LENGTH('a)"
	- by(metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unat_lt2p uno_simps(2))
	+ by (metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unsigned_less uno_simps(2))
	moreover
	have "2 * (n div 2 div m) * m < 2 ^ LENGTH('a)" using n unfolding div_mult2_eq[symmetric]
	by(subst (2) mult.commute)(simp add: minus_mod_eq_div_mult [symmetric] diff_mult_distrib minus_mod_eq_mult_div [symmetric] div_mult2_eq)
	moreover have "2 * (n div 2 div m) * m \<le> n"
	by (simp flip: div_mult2_eq ac_simps)
	ultimately
	have r: "x - ?q * y = of_nat (n - ?q' * m)"
	and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
	using n m unfolding q
	apply (simp_all add: of_nat_diff)
	apply (subst of_nat_diff)
	- apply (simp_all add: word_le_nat_alt take_bit_nat_eq_self unat_sub_if' unat_word_ariths unsigned_of_nat)
	+ apply (cases \<open>LENGTH('a) \<ge> 2\<close>)
	+ apply (simp_all add: word_le_nat_alt take_bit_nat_eq_self unat_sub_if' unat_word_ariths unsigned_of_nat)
	done
	then show ?thesis using n m div_half_nat [OF \<open>m \<noteq> 0\<close>, of n] unfolding q
	by (simp add: word_le_nat_alt word_div_def word_mod_def Let_def take_bit_nat_eq_self unsigned_of_nat
	flip: zdiv_int zmod_int
	split del: if_split split: if_split_asm)
	qed

	lemma word_test_bit_set_bits: "bit (BITS n. f n :: 'a :: len word) n \<longleftrightarrow> n < LENGTH('a) \<and> f n"
	by (fact bit_set_bits_word_iff)

	lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. bit i n)"
	- by (rule word_eqI) (auto simp add: word_test_bit_set_bits bit_simps)
	+ by (rule bit_eqI) (auto simp add: bit_simps)

	context
	includes bit_operations_syntax
	begin

	lemma word_and_mask_or_conv_and_mask:
	"bit n index \<Longrightarrow> (n AND mask index) OR (push_bit index 1) = n AND mask (index + 1)"
	for n :: \<open>'a::len word\<close>
	-by(rule word_eqI)(auto simp add: bit_simps)
	+ by (rule bit_eqI) (auto simp add: bit_simps)

	lemma uint_and_mask_or_full:
	fixes n :: "'a :: len word"
	assumes "bit n (LENGTH('a) - 1)"
	and "mask1 = mask (LENGTH('a) - 1)"
	and "mask2 = push_bit (LENGTH('a) - 1) 1"
	shows "uint (n AND mask1) OR mask2 = uint n"
	proof -
	have "mask2 = uint (push_bit (LENGTH('a) - 1) 1 :: 'a word)" using assms
	by transfer (simp add: take_bit_push_bit)
	hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (push_bit (LENGTH('a) - 1) 1 :: 'a word))"
	by(simp add: uint_or)
	also have "\<dots> = uint (n AND mask (LENGTH('a) - 1 + 1))"
	using assms by(simp only: word_and_mask_or_conv_and_mask)
	also have "\<dots> = uint n" by simp
	finally show ?thesis .
	qed

	end


	text \<open>Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.\<close>

	lemmas word_sdiv_def = sdiv_word_def
	lemmas word_smod_def = smod_word_def

	lemma [code]:
	"x sdiv y =
	(let x' = sint x; y' = sint y;
	negative = (x' < 0) \<noteq> (y' < 0);
	result = abs x' div abs y'
	in word_of_int (if negative then -result else result))"
	for x y :: \<open>'a::len word\<close>
	by (simp add: sdiv_word_def signed_divide_int_def sgn_if Let_def not_less not_le)

	lemma [code]:
	"x smod y =
	(let x' = sint x; y' = sint y;
	negative = (x' < 0);
	result = abs x' mod abs y'
	in word_of_int (if negative then -result else result))"
	for x y :: \<open>'a::len word\<close>
	proof -
	have : \<open>k mod l = k - k div l l\<close> for k l :: int
	by (simp add: minus_div_mult_eq_mod)
	show ?thesis
	by (simp add: smod_word_def signed_modulo_int_def signed_divide_int_def * sgn_if Let_def)
	qed

	text \<open>
	This algorithm implements unsigned division in terms of signed division.
	Taken from Hacker's Delight.
	\<close>

	lemma divmod_via_sdivmod:
	fixes x y :: "'a :: len word"
	assumes "y \<noteq> 0"
	shows
	"(x div y, x mod y) =
	(if push_bit (LENGTH('a) - 1) 1 \<le> y then if x < y then (0, x) else (1, x - y)
	else let q = (push_bit 1 (drop_bit 1 x sdiv y));
	r = x - q * y
	in if r \<ge> y then (q + 1, r - y) else (q, r))"
	proof(cases "push_bit (LENGTH('a) - 1) 1 \<le> y")
	case True
	note y = this
	show ?thesis
	proof(cases "x < y")
	case True
	then have "x mod y = x"
	by transfer simp
	- thus ?thesis using True y by(simp add: word_div_lt_eq_0)
	+ then show ?thesis using True y
	+ using bits_mod_div_trivial [of x y] by simp
	next
	case False
	obtain n where n: "y = of_nat n" "n < 2 ^ LENGTH('a)"
	by (rule that [of \<open>unat y\<close>]) simp_all
	- have "unat x < 2 ^ LENGTH('a)" by(rule unat_lt2p)
	+ have "unat x < 2 ^ LENGTH('a)" by (rule unsigned_less)
	also have "\<dots> = 2 * 2 ^ (LENGTH('a) - 1)"
	by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
	also have "\<dots> \<le> 2 * n" using y n
	by transfer (simp add: push_bit_of_1 take_bit_eq_mod)
	finally have div: "x div of_nat n = 1" using False n
	- by (simp add: word_div_eq_1_iff take_bit_nat_eq_self unsigned_of_nat)
	+ by (simp add: take_bit_nat_eq_self unsigned_of_nat word_div_eq_1_iff)
	moreover have "x mod y = x - x div y * y"
	by (simp add: minus_div_mult_eq_mod)
	with div n have "x mod y = x - y" by simp
	ultimately show ?thesis using False y n by simp
	qed
	next
	case False
	note y = this
	obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
	by (rule that [of \<open>unat x\<close>]) simp_all
	hence "int n div 2 + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
	by (cases \<open>LENGTH('a)\<close>)
	(auto dest: less_imp_of_nat_less [where ?'a = int])
	with y n have "sint (drop_bit 1 x) = uint (drop_bit 1 x)"
	by (cases \<open>LENGTH('a)\<close>)
	(auto simp add: sint_uint drop_bit_eq_div take_bit_nat_eq_self uint_div_distrib
	signed_take_bit_int_eq_self_iff unsigned_of_nat)
	moreover have "uint y + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
	using y by (cases \<open>LENGTH('a)\<close>)
	(simp_all add: not_le push_bit_of_1 word_less_alt uint_power_lower)
	then have "sint y = uint y"
	apply (cases \<open>LENGTH('a)\<close>)
	apply (auto simp add: sint_uint signed_take_bit_int_eq_self_iff)
	using uint_ge_0 [of y]
	by linarith
	ultimately show ?thesis using y
	apply (subst div_half_word [OF assms])
	apply (simp add: sdiv_word_def signed_divide_int_def flip: uint_div)
	done
	qed


	text \<open>More implementations tailored towards target-language implementations\<close>

	context
	includes integer.lifting
	begin

	lift_definition word_of_integer :: "integer \<Rightarrow> 'a :: len word" is word_of_int .

	lemma word_of_integer_code [code]: "word_of_integer n = word_of_int (int_of_integer n)"
	by(simp add: word_of_integer.rep_eq)

	end

	context
	includes bit_operations_syntax
	begin

	lemma word_of_int_code:
	"uint (word_of_int x :: 'a word) = x AND mask (LENGTH('a :: len))"
	by (simp add: unsigned_of_int take_bit_eq_mask)

	context
	fixes f :: "nat \<Rightarrow> bool"
	begin

	definition set_bits_aux :: \<open>nat \<Rightarrow> 'a word \<Rightarrow> 'a::len word\<close>
	where \<open>set_bits_aux n w = push_bit n w OR take_bit n (set_bits f)\<close>

	lemma bit_set_bit_aux [bit_simps]:
	\<open>bit (set_bits_aux n w) m \<longleftrightarrow> m < LENGTH('a) \<and>
	(if m < n then f m else bit w (m - n))\<close> for w :: \<open>'a::len word\<close>
	by (auto simp add: bit_simps set_bits_aux_def)

	corollary set_bits_conv_set_bits_aux:
	\<open>set_bits f = (set_bits_aux LENGTH('a) 0 :: 'a :: len word)\<close>
	by (rule bit_word_eqI) (simp add: bit_simps)

	lemma set_bits_aux_0 [simp]:
	\<open>set_bits_aux 0 w = w\<close>
	by (simp add: set_bits_aux_def)

	lemma set_bits_aux_Suc [simp]:
	\<open>set_bits_aux (Suc n) w = set_bits_aux n (push_bit 1 w OR (if f n then 1 else 0))\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps le_less_Suc_eq mult.commute [of _ 2])

	lemma set_bits_aux_simps [code]:
	\<open>set_bits_aux 0 w = w\<close>
	\<open>set_bits_aux (Suc n) w = set_bits_aux n (push_bit 1 w OR (if f n then 1 else 0))\<close>
	by simp_all

	lemma set_bits_aux_rec:
	\<open>set_bits_aux n w =
	(if n = 0 then w
	else let n' = n - 1 in set_bits_aux n' (push_bit 1 w OR (if f n' then 1 else 0)))\<close>
	by (cases n) simp_all

	end

	lemma word_of_int_via_signed:
	fixes mask
	assumes mask_def: "mask = Bit_Operations.mask (LENGTH('a))"
	and shift_def: "shift = push_bit LENGTH('a) 1"
	and index_def: "index = LENGTH('a) - 1"
	and overflow_def:"overflow = push_bit (LENGTH('a) - 1) 1"
	and least_def: "least = - overflow"
	shows
	"(word_of_int i :: 'a :: len word) =
	(let i' = i AND mask
	in if bit i' index then
	if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
	else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
	proof -
	define i' where "i' = i AND mask"
	have "shift = mask + 1" unfolding assms
	by (simp add: mask_eq_exp_minus_1 push_bit_of_1)
	hence "i' < shift"
	by (simp add: mask_def i'_def)
	show ?thesis
	proof(cases "bit i' index")
	case True
	then have unf: "i' = overflow OR i'"
	apply (simp add: assms i'_def push_bit_of_1 flip: take_bit_eq_mask)
	apply (rule bit_eqI)
	apply (auto simp add: bit_take_bit_iff bit_or_iff bit_exp_iff)
	done
	have \<open>overflow \<le> overflow OR i'\<close>
	by (simp add: i'_def mask_def or_greater_eq)
	then have "overflow \<le> i'"
	by (subst unf)
	hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
	by(cases "LENGTH('a)")(simp_all add: not_less push_bit_of_1)
	moreover
	have "overflow \<le> i' - shift \<longleftrightarrow> False" using \<open>i' < shift\<close> unfolding assms
	by(cases "LENGTH('a)")(auto simp add: not_le push_bit_of_1 elim: less_le_trans)
	moreover
	have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using \<open>i' < shift\<close>
	by (simp add: i'_def shift_def mask_def push_bit_of_1 word_of_int_eq_iff flip: take_bit_eq_mask)
	ultimately show ?thesis using True by(simp add: Let_def i'_def)
	next
	case False
	have "i' = i AND Bit_Operations.mask (LENGTH('a) - 1)"
	apply (rule bit_eqI)
	apply (use False in \<open>auto simp add: bit_simps assms i'_def\<close>)
	apply (auto simp add: less_le)
	done
	also have "\<dots> \<le> Bit_Operations.mask (LENGTH('a) - 1)"
	using AND_upper2 mask_nonnegative_int by blast
	also have "\<dots> < overflow"
	by (simp add: mask_int_def push_bit_of_1 overflow_def)
	also
	have "least \<le> 0" unfolding least_def overflow_def by simp
	have "0 \<le> i'" by (simp add: i'_def mask_def)
	hence "least \<le> i'" using \<open>least \<le> 0\<close> by simp
	moreover
	have "word_of_int i' = (word_of_int i :: 'a word)"
	by (simp add: i'_def mask_def of_int_and_eq of_int_mask_eq)
	ultimately show ?thesis using False by(simp add: Let_def i'_def)
	qed
	qed

	end


	text \<open>Quickcheck conversion functions\<close>

	context
	includes state_combinator_syntax
	begin

	definition qc_random_cnv ::
	"(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
	\<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
	where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
	let n = a_of_natural k
	in (n, \<lambda>_. Code_Evaluation.term_of n)))"

	end

	definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
	\<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
	where
	"qc_exhaustive_cnv a_of_natural f d =
	Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"

	definition qc_full_exhaustive_cnv ::
	"(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
	\<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
	where
	"qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
	(%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"

	declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]

	definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
	where
	"qc_narrowing_drawn_from xs =
	foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"

	locale quickcheck_narrowing_samples =
	fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
	and zero :: "'a"
	and tr :: "typerep"
	begin

	function narrowing_samples :: "integer \<Rightarrow> 'a list"
	where
	"narrowing_samples i =
	(if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
	by pat_completeness auto
	termination including integer.lifting
	proof(relation "measure nat_of_integer")
	fix i :: integer
	assume "0 < i"
	thus "(i - 1, i) \<in> measure nat_of_integer"
	by simp(transfer, simp)
	qed simp

	definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
	where
	"partial_term_of_sample i =
	(if i < 0 then undefined
	else if i = 0 then zero
	else if i mod 2 = 0 then snd (a_of_integer (i div 2))
	else fst (a_of_integer (i div 2 + 1)))"

	lemma partial_term_of_code:
	"partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
	Code_Evaluation.Free (STR ''_'') tr"
	"partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
	Code_Evaluation.term_of (partial_term_of_sample i)"
	by (rule partial_term_of_anything)+

	end

	lemmas [code] =
	quickcheck_narrowing_samples.narrowing_samples.simps
	quickcheck_narrowing_samples.partial_term_of_sample_def


	text \<open>
	The separate code target \<open>SML_word\<close> collects setups for the
	code generator that PolyML does not provide.
	\<close>

	setup \<open>Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)])\<close>

	code_identifier code_module Code_Target_Word_Base \<rightharpoonup>
	(SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word

	end
	diff --git a/thys/Native_Word/Native_Word_Test_Emu.thy b/thys/Native_Word/Native_Word_Test_Emu.thy
	--- a/thys/Native_Word/Native_Word_Test_Emu.thy
	+++ b/thys/Native_Word/Native_Word_Test_Emu.thy
	@@ -1,55 +1,55 @@
	(* Title: Native_Word_Test_Emu.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	theory Native_Word_Test_Emu imports
	Native_Word_Test
	- Code_Target_Bits_Int
	+ Code_Target_Int_Bit
	begin

	section \<open>Test cases for emulation of native words\<close>

	subsection \<open>Tests for @{typ uint16}\<close>

	text \<open>
	Test that @{typ uint16} is emulated for PolyML and OCaml via @{typ "16 word"}
	- if @{theory Native_Word.Code_Target_Bits_Int} is imported.
	+ if @{theory Native_Word.Code_Target_Int_Bit} is imported.
	\<close>

	definition test_uint16_emulation :: bool where
	"test_uint16_emulation \<longleftrightarrow> (0xFFFFF - 0x1000 = (0xEFFF :: uint16))"

	export_code test_uint16_emulation checking SML OCaml?
	\<comment> \<open>test the other target languages as well\<close> Haskell? Scala

	notepad begin
	have test_uint16 by eval
	have test_uint16_emulation by eval
	have test_uint16_emulation by normalization
	have test_uint16_emulation by code_simp
	end

	ML_val \<open>
	val true = @{code test_uint16};
	val true = @{code test_uint16_emulation};
	\<close>

	lemma "x AND y = x OR (y :: uint16)"
	quickcheck[random, expect=counterexample]
	quickcheck[exhaustive, expect=counterexample]
	oops

	subsection \<open>Tests for @{typ uint8}\<close>

	text \<open>
	Test that @{typ uint8} is emulated for OCaml via @{typ "8 word"}
	- if @{theory Native_Word.Code_Target_Bits_Int} is imported.
	+ if @{theory Native_Word.Code_Target_Int_Bit} is imported.
	\<close>

	definition test_uint8_emulation :: bool where
	"test_uint8_emulation \<longleftrightarrow> (0xFFF - 0x10 = (0xEF :: uint8))"

	export_code test_uint8_emulation checking OCaml?
	\<comment> \<open>test the other target languages as well\<close> SML Haskell? Scala

	end
	diff --git a/thys/Native_Word/Uint.thy b/thys/Native_Word/Uint.thy
	--- a/thys/Native_Word/Uint.thy
	+++ b/thys/Native_Word/Uint.thy
	@@ -1,824 +1,825 @@
	(* Title: Uint.thy
	Author: Peter Lammich, TU Munich
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Unsigned words of default size\<close>

	theory Uint imports
	- Code_Target_Word_Base Word_Type_Copies
	+ Word_Type_Copies
	+ Code_Target_Integer_Bit
	begin

	text \<open>
	This theory provides access to words in the target languages of the code generator
	whose bit width is the default of the target language. To that end, the type \<open>uint\<close>
	models words of width \<open>dflt_size\<close>, but \<open>dflt_size\<close> is known only to be positive.

	Usage restrictions:
	Default-size words (type \<open>uint\<close>) cannot be used for evaluation, because
	the results depend on the particular choice of word size in the target language
	and implementation. Symbolic evaluation has not yet been set up for \<open>uint\<close>.
	\<close>

	text \<open>The default size type\<close>
	typedecl dflt_size

	instantiation dflt_size :: typerep begin
	definition "typerep_class.typerep \<equiv> \<lambda>_ :: dflt_size itself. Typerep.Typerep (STR ''Uint.dflt_size'') []"
	instance ..
	end

	consts dflt_size_aux :: "nat"
	specification (dflt_size_aux) dflt_size_aux_g0: "dflt_size_aux > 0"
	by auto
	hide_fact dflt_size_aux_def

	instantiation dflt_size :: len begin
	definition "len_of_dflt_size (_ :: dflt_size itself) \<equiv> dflt_size_aux"
	instance by(intro_classes)(simp add: len_of_dflt_size_def dflt_size_aux_g0)
	end

	abbreviation "dflt_size \<equiv> len_of (TYPE (dflt_size))"

	context includes integer.lifting begin
	lift_definition dflt_size_integer :: integer is "int dflt_size" .
	declare dflt_size_integer_def[code del]
	\<comment> \<open>The code generator will substitute a machine-dependent value for this constant\<close>

	lemma dflt_size_by_int[code]: "dflt_size = nat_of_integer dflt_size_integer"
	by transfer simp

	lemma dflt_size[simp]:
	"dflt_size > 0"
	"dflt_size \<ge> Suc 0"
	"\<not> dflt_size < Suc 0"
	using len_gt_0[where 'a=dflt_size]
	by (simp_all del: len_gt_0)
	end

	section \<open>Type definition and primitive operations\<close>

	typedef uint = \<open>UNIV :: dflt_size word set\<close> ..

	global_interpretation uint: word_type_copy Abs_uint Rep_uint
	using type_definition_uint by (rule word_type_copy.intro)

	setup_lifting type_definition_uint

	declare uint.of_word_of [code abstype]

	declare Quotient_uint [transfer_rule]

	instantiation uint :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
	begin

	lift_definition zero_uint :: uint is 0 .
	lift_definition one_uint :: uint is 1 .
	lift_definition plus_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(+)\<close> .
	lift_definition uminus_uint :: \<open>uint \<Rightarrow> uint\<close> is uminus .
	lift_definition minus_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(-)\<close> .
	lift_definition times_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(*)\<close> .
	lift_definition divide_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(div)\<close> .
	lift_definition modulo_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(mod)\<close> .
	lift_definition equal_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
	lift_definition less_eq_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
	lift_definition less_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> bool\<close> is \<open>(<)\<close> .

	global_interpretation uint: word_type_copy_ring Abs_uint Rep_uint
	by standard (fact zero_uint.rep_eq one_uint.rep_eq
	plus_uint.rep_eq uminus_uint.rep_eq minus_uint.rep_eq
	times_uint.rep_eq divide_uint.rep_eq modulo_uint.rep_eq
	equal_uint.rep_eq less_eq_uint.rep_eq less_uint.rep_eq)+

	instance proof -
	show \<open>OFCLASS(uint, comm_ring_1_class)\<close>
	by (rule uint.of_class_comm_ring_1)
	show \<open>OFCLASS(uint, semiring_modulo_class)\<close>
	by (fact uint.of_class_semiring_modulo)
	show \<open>OFCLASS(uint, equal_class)\<close>
	by (fact uint.of_class_equal)
	show \<open>OFCLASS(uint, linorder_class)\<close>
	by (fact uint.of_class_linorder)
	qed

	end

	instantiation uint :: ring_bit_operations
	begin

	lift_definition bit_uint :: \<open>uint \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
	lift_definition not_uint :: \<open>uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.not\<close> .
	lift_definition and_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.and\<close> .
	lift_definition or_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.or\<close> .
	lift_definition xor_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.xor\<close> .
	lift_definition mask_uint :: \<open>nat \<Rightarrow> uint\<close> is mask .
	lift_definition push_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is push_bit .
	lift_definition drop_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is drop_bit .
	lift_definition signed_drop_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is signed_drop_bit .
	lift_definition take_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is take_bit .
	lift_definition set_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is Bit_Operations.set_bit .
	lift_definition unset_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is unset_bit .
	lift_definition flip_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is flip_bit .

	global_interpretation uint: word_type_copy_bits Abs_uint Rep_uint signed_drop_bit_uint
	by standard (fact bit_uint.rep_eq not_uint.rep_eq and_uint.rep_eq or_uint.rep_eq xor_uint.rep_eq
	mask_uint.rep_eq push_bit_uint.rep_eq drop_bit_uint.rep_eq signed_drop_bit_uint.rep_eq take_bit_uint.rep_eq
	set_bit_uint.rep_eq unset_bit_uint.rep_eq flip_bit_uint.rep_eq)+

	instance
	by (fact uint.of_class_ring_bit_operations)

	end

	lift_definition uint_of_nat :: \<open>nat \<Rightarrow> uint\<close>
	is word_of_nat .

	lift_definition nat_of_uint :: \<open>uint \<Rightarrow> nat\<close>
	is unat .

	lift_definition uint_of_int :: \<open>int \<Rightarrow> uint\<close>
	is word_of_int .

	lift_definition int_of_uint :: \<open>uint \<Rightarrow> int\<close>
	is uint .

	context
	includes integer.lifting
	begin

	lift_definition Uint :: \<open>integer \<Rightarrow> uint\<close>
	is word_of_int .

	lift_definition integer_of_uint :: \<open>uint \<Rightarrow> integer\<close>
	is uint .

	end

	global_interpretation uint: word_type_copy_more Abs_uint Rep_uint signed_drop_bit_uint
	uint_of_nat nat_of_uint uint_of_int int_of_uint Uint integer_of_uint
	apply standard
	apply (simp_all add: uint_of_nat.rep_eq nat_of_uint.rep_eq
	uint_of_int.rep_eq int_of_uint.rep_eq
	Uint.rep_eq integer_of_uint.rep_eq integer_eq_iff)
	done

	instantiation uint :: "{size, msb, lsb, set_bit, bit_comprehension}"
	begin

	lift_definition size_uint :: \<open>uint \<Rightarrow> nat\<close> is size .

	lift_definition msb_uint :: \<open>uint \<Rightarrow> bool\<close> is msb .
	lift_definition lsb_uint :: \<open>uint \<Rightarrow> bool\<close> is lsb .

	text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

	definition set_bit_uint :: \<open>uint \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint\<close>
	where set_bit_uint_eq: \<open>set_bit_uint a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

	context
	includes lifting_syntax
	begin

	lemma set_bit_uint_transfer [transfer_rule]:
	\<open>(cr_uint ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
	by (simp only: set_bit_eq [abs_def] set_bit_uint_eq [abs_def]) transfer_prover

	end

	lift_definition set_bits_uint :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint\<close> is set_bits .
	lift_definition set_bits_aux_uint :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint \<Rightarrow> uint\<close> is set_bits_aux .

	global_interpretation uint: word_type_copy_misc Abs_uint Rep_uint signed_drop_bit_uint
	uint_of_nat nat_of_uint uint_of_int int_of_uint Uint integer_of_uint dflt_size set_bits_aux_uint
	by (standard; transfer) simp_all

	instance using uint.of_class_bit_comprehension
	uint.of_class_set_bit uint.of_class_lsb
	by simp_all standard

	end

	section \<open>Code setup\<close>

	code_printing code_module Uint \<rightharpoonup> (SML)
	\<open>
	structure Uint : sig
	val set_bit : Word.word -> IntInf.int -> bool -> Word.word
	val shiftl : Word.word -> IntInf.int -> Word.word
	val shiftr : Word.word -> IntInf.int -> Word.word
	val shiftr_signed : Word.word -> IntInf.int -> Word.word
	val test_bit : Word.word -> IntInf.int -> bool
	end = struct

	fun set_bit x n b =
	let val mask = Word.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
	in if b then Word.orb (x, mask)
	else Word.andb (x, Word.notb mask)
	end

	fun shiftl x n =
	Word.<< (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr x n =
	Word.>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr_signed x n =
	Word.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun test_bit x n =
	Word.andb (x, Word.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word.fromInt 0

	end; (* struct Uint *)\<close>
	code_reserved SML Uint

	code_printing code_module Uint \<rightharpoonup> (Haskell)
	\<open>module Uint(Int, Word, dflt_size) where

	import qualified Prelude
	import Data.Int(Int)
	import Data.Word(Word)
	import qualified Data.Bits

	dflt_size :: Prelude.Integer
	dflt_size = Prelude.toInteger (bitSize_aux (0::Word)) where
	bitSize_aux :: (Data.Bits.Bits a, Prelude.Bounded a) => a -> Int
	bitSize_aux = Data.Bits.bitSize\<close>
	and (Haskell_Quickcheck)
	\<open>module Uint(Int, Word, dflt_size) where

	import qualified Prelude
	import Data.Int(Int)
	import Data.Word(Word)
	import qualified Data.Bits

	dflt_size :: Prelude.Int
	dflt_size = bitSize_aux (0::Word) where
	bitSize_aux :: (Data.Bits.Bits a, Prelude.Bounded a) => a -> Int
	bitSize_aux = Data.Bits.bitSize
	\<close>
	code_reserved Haskell Uint dflt_size

	text \<open>
	OCaml and Scala provide only signed bit numbers, so we use these and
	implement sign-sensitive operations like comparisons manually.
	\<close>

	code_printing code_module "Uint" \<rightharpoonup> (OCaml)
	\<open>module Uint : sig
	type t = int
	val dflt_size : Z.t
	val less : t -> t -> bool
	val less_eq : t -> t -> bool
	val set_bit : t -> Z.t -> bool -> t
	val shiftl : t -> Z.t -> t
	val shiftr : t -> Z.t -> t
	val shiftr_signed : t -> Z.t -> t
	val test_bit : t -> Z.t -> bool
	val int_mask : int
	val int32_mask : int32
	val int64_mask : int64
	end = struct

	type t = int

	let dflt_size = Z.of_int Sys.int_size;;

	(* negative numbers have their highest bit set,
	so they are greater than positive ones *)
	let less x y =
	if x<0 then
	y<0 && x<y
	else y < 0 \|\| x < y;;

	let less_eq x y =
	if x < 0 then
	y < 0 && x <= y
	else y < 0 \|\| x <= y;;

	let set_bit x n b =
	let mask = 1 lsl (Z.to_int n)
	in if b then x lor mask
	else x land (lnot mask);;

	let shiftl x n = x lsl (Z.to_int n);;

	let shiftr x n = x lsr (Z.to_int n);;

	let shiftr_signed x n = x asr (Z.to_int n);;

	let test_bit x n = x land (1 lsl (Z.to_int n)) <> 0;;

	let int_mask =
	if Sys.int_size < 32 then lnot 0 else 0xFFFFFFFF;;

	let int32_mask =
	if Sys.int_size < 32 then Int32.pred (Int32.shift_left Int32.one Sys.int_size)
	else Int32.of_string "0xFFFFFFFF";;

	let int64_mask =
	if Sys.int_size < 64 then Int64.pred (Int64.shift_left Int64.one Sys.int_size)
	else Int64.of_string "0xFFFFFFFFFFFFFFFF";;

	end;; (struct Uint)\<close>
	code_reserved OCaml Uint

	code_printing code_module Uint \<rightharpoonup> (Scala)
	\<open>object Uint {
	def dflt_size : BigInt = BigInt(32)

	def less(x: Int, y: Int) : Boolean =
	if (x < 0) y < 0 && x < y
	else y < 0 \|\| x < y

	def less_eq(x: Int, y: Int) : Boolean =
	if (x < 0) y < 0 && x <= y
	else y < 0 \|\| x <= y

	def set_bit(x: Int, n: BigInt, b: Boolean) : Int =
	if (b)
	x \| (1 << n.intValue)
	else
	x & (1 << n.intValue).unary_~

	def shiftl(x: Int, n: BigInt) : Int = x << n.intValue

	def shiftr(x: Int, n: BigInt) : Int = x >>> n.intValue

	def shiftr_signed(x: Int, n: BigInt) : Int = x >> n.intValue

	def test_bit(x: Int, n: BigInt) : Boolean =
	(x & (1 << n.intValue)) != 0

	} /* object Uint */\<close>
	code_reserved Scala Uint


	text \<open>
	OCaml's conversion from Big\_int to int demands that the value fits into a signed integer.
	The following justifies the implementation.
	\<close>

	context
	includes integer.lifting bit_operations_syntax
	begin

	definition wivs_mask :: int where "wivs_mask = 2^ dflt_size - 1"
	lift_definition wivs_mask_integer :: integer is wivs_mask .
	lemma [code]: "wivs_mask_integer = 2 ^ dflt_size - 1"
	by transfer (simp add: wivs_mask_def)

	definition wivs_shift :: int where "wivs_shift = 2 ^ dflt_size"
	lift_definition wivs_shift_integer :: integer is wivs_shift .
	lemma [code]: "wivs_shift_integer = 2 ^ dflt_size"
	by transfer (simp add: wivs_shift_def)

	definition wivs_index :: nat where "wivs_index == dflt_size - 1"
	lift_definition wivs_index_integer :: integer is "int wivs_index".
	lemma wivs_index_integer_code[code]: "wivs_index_integer = dflt_size_integer - 1"
	by transfer (simp add: wivs_index_def of_nat_diff)

	definition wivs_overflow :: int where "wivs_overflow == 2^ (dflt_size - 1)"
	lift_definition wivs_overflow_integer :: integer is wivs_overflow .
	lemma [code]: "wivs_overflow_integer = 2 ^ (dflt_size - 1)"
	by transfer (simp add: wivs_overflow_def)

	definition wivs_least :: int where "wivs_least == - wivs_overflow"
	lift_definition wivs_least_integer :: integer is wivs_least .
	lemma [code]: "wivs_least_integer = - (2 ^ (dflt_size - 1))"
	by transfer (simp add: wivs_overflow_def wivs_least_def)

	definition Uint_signed :: "integer \<Rightarrow> uint" where
	"Uint_signed i = (if i < wivs_least_integer \<or> wivs_overflow_integer \<le> i then undefined Uint i else Uint i)"

	lemma Uint_code [code]:
	"Uint i =
	(let i' = i AND wivs_mask_integer in
	if bit i' wivs_index then Uint_signed (i' - wivs_shift_integer) else Uint_signed i')"
	including undefined_transfer
	unfolding Uint_signed_def
	apply transfer
	apply (subst word_of_int_via_signed)
	apply (auto simp add: push_bit_of_1 mask_eq_exp_minus_1 word_of_int_via_signed
	wivs_mask_def wivs_index_def wivs_overflow_def wivs_least_def wivs_shift_def)
	done

	lemma Uint_signed_code [code]:
	"Rep_uint (Uint_signed i) =
	(if i < wivs_least_integer \<or> i \<ge> wivs_overflow_integer then Rep_uint (undefined Uint i) else word_of_int (int_of_integer_symbolic i))"
	unfolding Uint_signed_def Uint_def int_of_integer_symbolic_def word_of_integer_def
	by(simp add: Abs_uint_inverse)
	end

	text \<open>
	Avoid @{term Abs_uint} in generated code, use @{term Rep_uint'} instead.
	The symbolic implementations for code\_simp use @{term Rep_uint}.

	The new destructor @{term Rep_uint'} is executable.
	As the simplifier is given the [code abstract] equations literally,
	we cannot implement @{term Rep_uint} directly, because that makes code\_simp loop.

	If code generation raises Match, some equation probably contains @{term Rep_uint}
	([code abstract] equations for @{typ uint} may use @{term Rep_uint} because
	these instances will be folded away.)
	\<close>

	definition Rep_uint' where [simp]: "Rep_uint' = Rep_uint"

	lemma Rep_uint'_code [code]: "Rep_uint' x = (BITS n. bit x n)"
	unfolding Rep_uint'_def by transfer (simp add: set_bits_bit_eq)

	lift_definition Abs_uint' :: "dflt_size word \<Rightarrow> uint" is "\<lambda>x :: dflt_size word. x" .

	lemma Abs_uint'_code [code]:
	"Abs_uint' x = Uint (integer_of_int (uint x))"
	including integer.lifting by transfer simp

	declare [[code drop: "term_of_class.term_of :: uint \<Rightarrow> _"]]

	lemma term_of_uint_code [code]:
	defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''"
	shows
	"term_of_class.term_of x =
	Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint.uint.Abs_uint'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR (STR ''Uint.dflt_size'') []], TR (STR ''Uint.uint'') []]))
	(term_of_class.term_of (Rep_uint' x))"
	by(simp add: term_of_anything)

	text \<open>Important:
	We must prevent the reflection oracle (eval-tac) to
	use our machine-dependent type.
	\<close>

	code_printing
	type_constructor uint \<rightharpoonup>
	(SML) "Word.word" and
	(Haskell) "Uint.Word" and
	(OCaml) "Uint.t" and
	(Scala) "Int" and
	(Eval) "* \"Error: Machine dependent type\" *" and
	(Quickcheck) "Word.word"
	\| constant dflt_size_integer \<rightharpoonup>
	(SML) "(IntInf.fromLarge (Int.toLarge Word.wordSize))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.wordSize" and
	(Haskell) "Uint.dflt'_size" and
	(OCaml) "Uint.dflt'_size" and
	(Scala) "Uint.dflt'_size"
	\| constant Uint \<rightharpoonup>
	(SML) "Word.fromLargeInt (IntInf.toLarge _)" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.fromInt" and
	(Haskell) "(Prelude.fromInteger _ :: Uint.Word)" and
	(Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint.Word)" and
	(Scala) "_.intValue"
	\| constant Uint_signed \<rightharpoonup>
	(OCaml) "Z.to'_int"
	\| constant "0 :: uint" \<rightharpoonup>
	(SML) "(Word.fromInt 0)" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "(Word.fromInt 0)" and
	(Haskell) "(0 :: Uint.Word)" and
	(OCaml) "0" and
	(Scala) "0"
	\| constant "1 :: uint" \<rightharpoonup>
	(SML) "(Word.fromInt 1)" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "(Word.fromInt 1)" and
	(Haskell) "(1 :: Uint.Word)" and
	(OCaml) "1" and
	(Scala) "1"
	\| constant "plus :: uint \<Rightarrow> _ " \<rightharpoonup>
	(SML) "Word.+ ((_), (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.+ ((_), (_))" and
	(Haskell) infixl 6 "+" and
	(OCaml) "Pervasives.(+)" and
	(Scala) infixl 7 "+"
	\| constant "uminus :: uint \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word.~" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.~" and
	(Haskell) "negate" and
	(OCaml) "Pervasives.(~-)" and
	(Scala) "!(- _)"
	\| constant "minus :: uint \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word.- ((_), (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.- ((_), (_))" and
	(Haskell) infixl 6 "-" and
	(OCaml) "Pervasives.(-)" and
	(Scala) infixl 7 "-"
	\| constant "times :: uint \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word.* ((_), (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.* ((_), (_))" and
	(Haskell) infixl 7 "*" and
	(OCaml) "Pervasives.( * )" and
	(Scala) infixl 8 "*"
	\| constant "HOL.equal :: uint \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "!((_ : Word.word) = _)" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "!((_ : Word.word) = _)" and
	(Haskell) infix 4 "==" and
	(OCaml) "(Pervasives.(=):Uint.t -> Uint.t -> bool)" and
	(Scala) infixl 5 "=="
	\| class_instance uint :: equal \<rightharpoonup>
	(Haskell) -
	\| constant "less_eq :: uint \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Word.<= ((_), (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.<= ((_), (_))" and
	(Haskell) infix 4 "<=" and
	(OCaml) "Uint.less'_eq" and
	(Scala) "Uint.less'_eq"
	\| constant "less :: uint \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Word.< ((_), (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.< ((_), (_))" and
	(Haskell) infix 4 "<" and
	(OCaml) "Uint.less" and
	(Scala) "Uint.less"
	\| constant "Bit_Operations.not :: uint \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word.notb" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.notb" and
	(Haskell) "Data'_Bits.complement" and
	(OCaml) "Pervasives.lnot" and
	(Scala) "_.unary'_~"
	\| constant "Bit_Operations.and :: uint \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word.andb ((_),/ (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.andb ((_),/ (_))" and
	(Haskell) infixl 7 "Data_Bits..&." and
	(OCaml) "Pervasives.(land)" and
	(Scala) infixl 3 "&"
	\| constant "Bit_Operations.or :: uint \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word.orb ((_),/ (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.orb ((_),/ (_))" and
	(Haskell) infixl 5 "Data_Bits..\|." and
	(OCaml) "Pervasives.(lor)" and
	(Scala) infixl 1 "\|"
	\| constant "Bit_Operations.xor :: uint \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word.xorb ((_),/ (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.xorb ((_),/ (_))" and
	(Haskell) "Data'_Bits.xor" and
	(OCaml) "Pervasives.(lxor)" and
	(Scala) infixl 2 "^"

	definition uint_divmod :: "uint \<Rightarrow> uint \<Rightarrow> uint \<times> uint" where
	"uint_divmod x y =
	(if y = 0 then (undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint), undefined ((mod) :: uint \<Rightarrow> _) x (0 :: uint))
	else (x div y, x mod y))"

	definition uint_div :: "uint \<Rightarrow> uint \<Rightarrow> uint"
	where "uint_div x y = fst (uint_divmod x y)"

	definition uint_mod :: "uint \<Rightarrow> uint \<Rightarrow> uint"
	where "uint_mod x y = snd (uint_divmod x y)"

	lemma div_uint_code [code]: "x div y = (if y = 0 then 0 else uint_div x y)"
	including undefined_transfer unfolding uint_divmod_def uint_div_def
	by transfer(simp add: word_div_def)

	lemma mod_uint_code [code]: "x mod y = (if y = 0 then x else uint_mod x y)"
	including undefined_transfer unfolding uint_mod_def uint_divmod_def
	by transfer(simp add: word_mod_def)

	definition uint_sdiv :: "uint \<Rightarrow> uint \<Rightarrow> uint"
	where [code del]:
	"uint_sdiv x y =
	(if y = 0 then undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint)
	else Abs_uint (Rep_uint x sdiv Rep_uint y))"

	definition div0_uint :: "uint \<Rightarrow> uint"
	where [code del]: "div0_uint x = undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint)"
	declare [[code abort: div0_uint]]

	definition mod0_uint :: "uint \<Rightarrow> uint"
	where [code del]: "mod0_uint x = undefined ((mod) :: uint \<Rightarrow> _) x (0 :: uint)"
	declare [[code abort: mod0_uint]]

	definition wivs_overflow_uint :: uint
	where "wivs_overflow_uint \<equiv> push_bit (dflt_size - 1) 1"

	lemma Rep_uint_wivs_overflow_uint_eq:
	\<open>Rep_uint wivs_overflow_uint = 2 ^ (dflt_size - Suc 0)\<close>
	by (simp add: wivs_overflow_uint_def one_uint.rep_eq push_bit_uint.rep_eq uint.word_of_power push_bit_eq_mult)

	lemma wivs_overflow_uint_greater_eq_0:
	\<open>wivs_overflow_uint > 0\<close>
	apply (simp add: less_uint.rep_eq zero_uint.rep_eq Rep_uint_wivs_overflow_uint_eq)
	apply transfer
	apply (simp add: take_bit_push_bit push_bit_eq_mult)
	done

	lemma uint_divmod_code [code]:
	"uint_divmod x y =
	(if wivs_overflow_uint \<le> y then if x < y then (0, x) else (1, x - y)
	else if y = 0 then (div0_uint x, mod0_uint x)
	else let q = push_bit 1 (uint_sdiv (drop_bit 1 x) y);
	r = x - q * y
	in if r \<ge> y then (q + 1, r - y) else (q, r))"
	proof (cases \<open>y = 0\<close>)
	case True
	moreover have \<open>x \<ge> 0\<close>
	by transfer simp
	moreover note wivs_overflow_uint_greater_eq_0
	ultimately show ?thesis
	by (auto simp add: uint_divmod_def div0_uint_def mod0_uint_def not_less)
	next
	case False
	then show ?thesis
	including undefined_transfer
	unfolding uint_divmod_def uint_sdiv_def div0_uint_def mod0_uint_def
	wivs_overflow_uint_def
	apply transfer
	apply (simp add: divmod_via_sdivmod push_bit_of_1)
	done
	qed

	lemma uint_sdiv_code [code]:
	"Rep_uint (uint_sdiv x y) =
	(if y = 0 then Rep_uint (undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint))
	else Rep_uint x sdiv Rep_uint y)"
	unfolding uint_sdiv_def by(simp add: Abs_uint_inverse)

	text \<open>
	Note that we only need a translation for signed division, but not for the remainder
	because @{thm uint_divmod_code} computes both with division only.
	\<close>

	code_printing
	constant uint_div \<rightharpoonup>
	(SML) "Word.div ((_), (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.div ((_), (_))" and
	(Haskell) "Prelude.div"
	\| constant uint_mod \<rightharpoonup>
	(SML) "Word.mod ((_), (_))" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Word.mod ((_), (_))" and
	(Haskell) "Prelude.mod"
	\| constant uint_divmod \<rightharpoonup>
	(Haskell) "divmod"
	\| constant uint_sdiv \<rightharpoonup>
	(OCaml) "Pervasives.('/)" and
	(Scala) "_ '/ _"

	definition uint_test_bit :: "uint \<Rightarrow> integer \<Rightarrow> bool"
	where [code del]:
	"uint_test_bit x n =
	(if n < 0 \<or> dflt_size_integer \<le> n then undefined (bit :: uint \<Rightarrow> _) x n
	else bit x (nat_of_integer n))"

	lemma test_bit_uint_code [code]:
	"bit x n \<longleftrightarrow> n < dflt_size \<and> uint_test_bit x (integer_of_nat n)"
	including undefined_transfer integer.lifting unfolding uint_test_bit_def
	by (transfer, simp, transfer, simp)

	lemma uint_test_bit_code [code]:
	"uint_test_bit w n =
	(if n < 0 \<or> dflt_size_integer \<le> n then undefined (bit :: uint \<Rightarrow> _) w n else bit (Rep_uint w) (nat_of_integer n))"
	unfolding uint_test_bit_def by(simp add: bit_uint.rep_eq)

	code_printing constant uint_test_bit \<rightharpoonup>
	(SML) "Uint.test'_bit" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Uint.test'_bit" and
	(Haskell) "Data'_Bits.testBitBounded" and
	(OCaml) "Uint.test'_bit" and
	(Scala) "Uint.test'_bit"

	definition uint_set_bit :: "uint \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint"
	where [code del]:
	"uint_set_bit x n b =
	(if n < 0 \<or> dflt_size_integer \<le> n then undefined (set_bit :: uint \<Rightarrow> _) x n b
	else set_bit x (nat_of_integer n) b)"

	lemma set_bit_uint_code [code]:
	"set_bit x n b = (if n < dflt_size then uint_set_bit x (integer_of_nat n) b else x)"
	including undefined_transfer integer.lifting unfolding uint_set_bit_def
	by (transfer) (auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

	lemma uint_set_bit_code [code]:
	"Rep_uint (uint_set_bit w n b) =
	(if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (set_bit :: uint \<Rightarrow> _) w n b)
	else set_bit (Rep_uint w) (nat_of_integer n) b)"
	including undefined_transfer integer.lifting unfolding uint_set_bit_def by transfer simp

	code_printing constant uint_set_bit \<rightharpoonup>
	(SML) "Uint.set'_bit" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Uint.set'_bit" and
	(Haskell) "Data'_Bits.setBitBounded" and
	(OCaml) "Uint.set'_bit" and
	(Scala) "Uint.set'_bit"

	definition uint_shiftl :: "uint \<Rightarrow> integer \<Rightarrow> uint"
	where [code del]:
	"uint_shiftl x n = (if n < 0 \<or> dflt_size_integer \<le> n then undefined (push_bit :: nat \<Rightarrow> uint \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

	lemma shiftl_uint_code [code]: "push_bit n x = (if n < dflt_size then uint_shiftl x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint_shiftl_def
	by (transfer fixing: n) simp

	lemma uint_shiftl_code [code]:
	"Rep_uint (uint_shiftl w n) =
	(if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (push_bit :: nat \<Rightarrow> uint \<Rightarrow> _) w n) else push_bit (nat_of_integer n) (Rep_uint w))"
	including undefined_transfer integer.lifting unfolding uint_shiftl_def by transfer simp

	code_printing constant uint_shiftl \<rightharpoonup>
	(SML) "Uint.shiftl" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Uint.shiftl" and
	(Haskell) "Data'_Bits.shiftlBounded" and
	(OCaml) "Uint.shiftl" and
	(Scala) "Uint.shiftl"

	definition uint_shiftr :: "uint \<Rightarrow> integer \<Rightarrow> uint"
	where [code del]:
	"uint_shiftr x n = (if n < 0 \<or> dflt_size_integer \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

	lemma shiftr_uint_code [code]: "drop_bit n x = (if n < dflt_size then uint_shiftr x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint_shiftr_def
	by (transfer fixing: n) simp

	lemma uint_shiftr_code [code]:
	"Rep_uint (uint_shiftr w n) =
	(if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (drop_bit :: nat \<Rightarrow> uint \<Rightarrow> _) w n) else drop_bit (nat_of_integer n) (Rep_uint w))"
	including undefined_transfer integer.lifting unfolding uint_shiftr_def by transfer simp

	code_printing constant uint_shiftr \<rightharpoonup>
	(SML) "Uint.shiftr" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Uint.shiftr" and
	(Haskell) "Data'_Bits.shiftrBounded" and
	(OCaml) "Uint.shiftr" and
	(Scala) "Uint.shiftr"

	definition uint_sshiftr :: "uint \<Rightarrow> integer \<Rightarrow> uint"
	where [code del]:
	"uint_sshiftr x n =
	(if n < 0 \<or> dflt_size_integer \<le> n then undefined signed_drop_bit_uint n x else signed_drop_bit_uint (nat_of_integer n) x)"

	lemma sshiftr_uint_code [code]:
	"signed_drop_bit_uint n x =
	(if n < dflt_size then uint_sshiftr x (integer_of_nat n) else
	if bit x wivs_index then -1 else 0)"
	including undefined_transfer integer.lifting unfolding uint_sshiftr_def
	by transfer(simp add: not_less signed_drop_bit_beyond word_size wivs_index_def)

	lemma uint_sshiftr_code [code]:
	"Rep_uint (uint_sshiftr w n) =
	(if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined signed_drop_bit_uint n w) else signed_drop_bit (nat_of_integer n) (Rep_uint w))"
	including undefined_transfer integer.lifting unfolding uint_sshiftr_def by transfer simp

	code_printing constant uint_sshiftr \<rightharpoonup>
	(SML) "Uint.shiftr'_signed" and
	(Eval) "(raise (Fail \"Machine dependent code\"))" and
	(Quickcheck) "Uint.shiftr'_signed" and
	(Haskell)
	"(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint.Int) _)) :: Uint.Word)" and
	(OCaml) "Uint.shiftr'_signed" and
	(Scala) "Uint.shiftr'_signed"

	lemma uint_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint) wivs_index"
	by transfer (simp add: msb_word_iff_bit wivs_index_def)

	lemma msb_uint_code [code]: "msb x \<longleftrightarrow> uint_test_bit x wivs_index_integer"
	apply(simp add: uint_test_bit_def uint_msb_test_bit
	wivs_index_integer_code dflt_size_integer_def wivs_index_def)
	by (metis (full_types) One_nat_def dflt_size(2) less_iff_diff_less_0
	nat_of_integer_of_nat of_nat_1 of_nat_diff of_nat_less_0_iff wivs_index_def)

	lemma uint_of_int_code [code]: "uint_of_int i = (BITS n. bit i n)"
	by transfer (simp add: word_of_int_conv_set_bits)


	section \<open>Quickcheck setup\<close>

	definition uint_of_natural :: "natural \<Rightarrow> uint"
	where "uint_of_natural x \<equiv> Uint (integer_of_natural x)"

	instantiation uint :: "{random, exhaustive, full_exhaustive}" begin
	definition "random_uint \<equiv> qc_random_cnv uint_of_natural"
	definition "exhaustive_uint \<equiv> qc_exhaustive_cnv uint_of_natural"
	definition "full_exhaustive_uint \<equiv> qc_full_exhaustive_cnv uint_of_natural"
	instance ..
	end

	instantiation uint :: narrowing begin

	interpretation quickcheck_narrowing_samples
	"\<lambda>i. (Uint i, Uint (- i))" "0"
	"Typerep.Typerep (STR ''Uint.uint'') []" .

	definition "narrowing_uint d = qc_narrowing_drawn_from (narrowing_samples d) d"
	declare [[code drop: "partial_term_of :: uint itself \<Rightarrow> _"]]
	lemmas partial_term_of_uint [code] = partial_term_of_code

	instance ..
	end

	end
	diff --git a/thys/Native_Word/Uint16.thy b/thys/Native_Word/Uint16.thy
	--- a/thys/Native_Word/Uint16.thy
	+++ b/thys/Native_Word/Uint16.thy
	@@ -1,536 +1,537 @@
	(* Title: Uint16.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Unsigned words of 16 bits\<close>

	theory Uint16 imports
	- Code_Target_Word_Base Word_Type_Copies
	+ Word_Type_Copies
	+ Code_Target_Integer_Bit
	begin

	text \<open>
	Restriction for ML code generation:
	This theory assumes that the ML system provides a Word16
	implementation (mlton does, but PolyML 5.5 does not).
	Therefore, the code setup lives in the target \<open>SML_word\<close>
	rather than \<open>SML\<close>. This ensures that code generation still
	works as long as \<open>uint16\<close> is not involved.
	For the target \<open>SML\<close> itself, no special code generation
	for this type is set up. Nevertheless, it should work by emulation via \<^typ>\<open>16 word\<close>
	- if the theory \<open>Code_Target_Bits_Int\<close> is imported.
	+ if the theory \<^text>\<open>Code_Target_Int_Bit\<close> is imported.

	Restriction for OCaml code generation:
	OCaml does not provide an int16 type, so no special code generation
	for this type is set up.
	\<close>

	section \<open>Type definition and primitive operations\<close>

	typedef uint16 = \<open>UNIV :: 16 word set\<close> ..

	global_interpretation uint16: word_type_copy Abs_uint16 Rep_uint16
	using type_definition_uint16 by (rule word_type_copy.intro)

	setup_lifting type_definition_uint16

	declare uint16.of_word_of [code abstype]

	declare Quotient_uint16 [transfer_rule]

	instantiation uint16 :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
	begin

	lift_definition zero_uint16 :: uint16 is 0 .
	lift_definition one_uint16 :: uint16 is 1 .
	lift_definition plus_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(+)\<close> .
	lift_definition uminus_uint16 :: \<open>uint16 \<Rightarrow> uint16\<close> is uminus .
	lift_definition minus_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(-)\<close> .
	lift_definition times_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(*)\<close> .
	lift_definition divide_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(div)\<close> .
	lift_definition modulo_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(mod)\<close> .
	lift_definition equal_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
	lift_definition less_eq_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
	lift_definition less_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> bool\<close> is \<open>(<)\<close> .

	global_interpretation uint16: word_type_copy_ring Abs_uint16 Rep_uint16
	by standard (fact zero_uint16.rep_eq one_uint16.rep_eq
	plus_uint16.rep_eq uminus_uint16.rep_eq minus_uint16.rep_eq
	times_uint16.rep_eq divide_uint16.rep_eq modulo_uint16.rep_eq
	equal_uint16.rep_eq less_eq_uint16.rep_eq less_uint16.rep_eq)+

	instance proof -
	show \<open>OFCLASS(uint16, comm_ring_1_class)\<close>
	by (rule uint16.of_class_comm_ring_1)
	show \<open>OFCLASS(uint16, semiring_modulo_class)\<close>
	by (fact uint16.of_class_semiring_modulo)
	show \<open>OFCLASS(uint16, equal_class)\<close>
	by (fact uint16.of_class_equal)
	show \<open>OFCLASS(uint16, linorder_class)\<close>
	by (fact uint16.of_class_linorder)
	qed

	end

	instantiation uint16 :: ring_bit_operations
	begin

	lift_definition bit_uint16 :: \<open>uint16 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
	lift_definition not_uint16 :: \<open>uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.not\<close> .
	lift_definition and_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.and\<close> .
	lift_definition or_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.or\<close> .
	lift_definition xor_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.xor\<close> .
	lift_definition mask_uint16 :: \<open>nat \<Rightarrow> uint16\<close> is mask .
	lift_definition push_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is push_bit .
	lift_definition drop_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is drop_bit .
	lift_definition signed_drop_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is signed_drop_bit .
	lift_definition take_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is take_bit .
	lift_definition set_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is Bit_Operations.set_bit .
	lift_definition unset_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is unset_bit .
	lift_definition flip_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is flip_bit .

	global_interpretation uint16: word_type_copy_bits Abs_uint16 Rep_uint16 signed_drop_bit_uint16
	by standard (fact bit_uint16.rep_eq not_uint16.rep_eq and_uint16.rep_eq or_uint16.rep_eq xor_uint16.rep_eq
	mask_uint16.rep_eq push_bit_uint16.rep_eq drop_bit_uint16.rep_eq signed_drop_bit_uint16.rep_eq take_bit_uint16.rep_eq
	set_bit_uint16.rep_eq unset_bit_uint16.rep_eq flip_bit_uint16.rep_eq)+

	instance
	by (fact uint16.of_class_ring_bit_operations)

	end

	lift_definition uint16_of_nat :: \<open>nat \<Rightarrow> uint16\<close>
	is word_of_nat .

	lift_definition nat_of_uint16 :: \<open>uint16 \<Rightarrow> nat\<close>
	is unat .

	lift_definition uint16_of_int :: \<open>int \<Rightarrow> uint16\<close>
	is word_of_int .

	lift_definition int_of_uint16 :: \<open>uint16 \<Rightarrow> int\<close>
	is uint .

	context
	includes integer.lifting
	begin

	lift_definition Uint16 :: \<open>integer \<Rightarrow> uint16\<close>
	is word_of_int .

	lift_definition integer_of_uint16 :: \<open>uint16 \<Rightarrow> integer\<close>
	is uint .

	end

	global_interpretation uint16: word_type_copy_more Abs_uint16 Rep_uint16 signed_drop_bit_uint16
	uint16_of_nat nat_of_uint16 uint16_of_int int_of_uint16 Uint16 integer_of_uint16
	apply standard
	apply (simp_all add: uint16_of_nat.rep_eq nat_of_uint16.rep_eq
	uint16_of_int.rep_eq int_of_uint16.rep_eq
	Uint16.rep_eq integer_of_uint16.rep_eq integer_eq_iff)
	done

	instantiation uint16 :: "{size, msb, lsb, set_bit, bit_comprehension}"
	begin

	lift_definition size_uint16 :: \<open>uint16 \<Rightarrow> nat\<close> is size .

	lift_definition msb_uint16 :: \<open>uint16 \<Rightarrow> bool\<close> is msb .
	lift_definition lsb_uint16 :: \<open>uint16 \<Rightarrow> bool\<close> is lsb .

	text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

	definition set_bit_uint16 :: \<open>uint16 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint16\<close>
	where set_bit_uint16_eq: \<open>set_bit_uint16 a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

	context
	includes lifting_syntax
	begin

	lemma set_bit_uint16_transfer [transfer_rule]:
	\<open>(cr_uint16 ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint16) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
	by (simp only: set_bit_eq [abs_def] set_bit_uint16_eq [abs_def]) transfer_prover

	end

	lift_definition set_bits_uint16 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint16\<close> is set_bits .
	lift_definition set_bits_aux_uint16 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is set_bits_aux .

	global_interpretation uint16: word_type_copy_misc Abs_uint16 Rep_uint16 signed_drop_bit_uint16
	uint16_of_nat nat_of_uint16 uint16_of_int int_of_uint16 Uint16 integer_of_uint16 16 set_bits_aux_uint16
	by (standard; transfer) simp_all

	instance using uint16.of_class_bit_comprehension
	uint16.of_class_set_bit uint16.of_class_lsb
	by simp_all standard

	end

	section \<open>Code setup\<close>

	code_printing code_module Uint16 \<rightharpoonup> (SML_word)
	\<open>(* Test that words can handle numbers between 0 and 15 *)
	val _ = if 4 <= Word.wordSize then () else raise (Fail ("wordSize less than 4"));

	structure Uint16 : sig
	val set_bit : Word16.word -> IntInf.int -> bool -> Word16.word
	val shiftl : Word16.word -> IntInf.int -> Word16.word
	val shiftr : Word16.word -> IntInf.int -> Word16.word
	val shiftr_signed : Word16.word -> IntInf.int -> Word16.word
	val test_bit : Word16.word -> IntInf.int -> bool
	end = struct

	fun set_bit x n b =
	let val mask = Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
	in if b then Word16.orb (x, mask)
	else Word16.andb (x, Word16.notb mask)
	end

	fun shiftl x n =
	Word16.<< (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr x n =
	Word16.>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr_signed x n =
	Word16.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun test_bit x n =
	Word16.andb (x, Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word16.fromInt 0

	end; (* struct Uint16 *)\<close>
	code_reserved SML_word Uint16

	code_printing code_module Uint16 \<rightharpoonup> (Haskell)
	\<open>module Uint16(Int16, Word16) where

	import Data.Int(Int16)
	import Data.Word(Word16)\<close>
	code_reserved Haskell Uint16

	text \<open>Scala provides unsigned 16-bit numbers as Char.\<close>

	code_printing code_module Uint16 \<rightharpoonup> (Scala)
	\<open>object Uint16 {

	def set_bit(x: scala.Char, n: BigInt, b: Boolean) : scala.Char =
	if (b)
	(x \| (1.toChar << n.intValue)).toChar
	else
	(x & (1.toChar << n.intValue).unary_~).toChar

	def shiftl(x: scala.Char, n: BigInt) : scala.Char = (x << n.intValue).toChar

	def shiftr(x: scala.Char, n: BigInt) : scala.Char = (x >>> n.intValue).toChar

	def shiftr_signed(x: scala.Char, n: BigInt) : scala.Char = (x.toShort >> n.intValue).toChar

	def test_bit(x: scala.Char, n: BigInt) : Boolean = (x & (1.toChar << n.intValue)) != 0

	} /* object Uint16 */\<close>
	code_reserved Scala Uint16

	text \<open>
	Avoid @{term Abs_uint16} in generated code, use @{term Rep_uint16'} instead.
	The symbolic implementations for code\_simp use @{term Rep_uint16}.

	The new destructor @{term Rep_uint16'} is executable.
	As the simplifier is given the [code abstract] equations literally,
	we cannot implement @{term Rep_uint16} directly, because that makes code\_simp loop.

	If code generation raises Match, some equation probably contains @{term Rep_uint16}
	([code abstract] equations for @{typ uint16} may use @{term Rep_uint16} because
	these instances will be folded away.)

	To convert @{typ "16 word"} values into @{typ uint16}, use @{term "Abs_uint16'"}.
	\<close>

	definition Rep_uint16' where [simp]: "Rep_uint16' = Rep_uint16"

	lemma Rep_uint16'_transfer [transfer_rule]:
	"rel_fun cr_uint16 (=) (\<lambda>x. x) Rep_uint16'"
	unfolding Rep_uint16'_def by(rule uint16.rep_transfer)

	lemma Rep_uint16'_code [code]: "Rep_uint16' x = (BITS n. bit x n)"
	by transfer (simp add: set_bits_bit_eq)

	lift_definition Abs_uint16' :: "16 word \<Rightarrow> uint16" is "\<lambda>x :: 16 word. x" .

	lemma Abs_uint16'_code [code]:
	"Abs_uint16' x = Uint16 (integer_of_int (uint x))"
	including integer.lifting by transfer simp

	declare [[code drop: "term_of_class.term_of :: uint16 \<Rightarrow> _"]]

	lemma term_of_uint16_code [code]:
	defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
	"term_of_class.term_of x =
	Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint16.uint16.Abs_uint16'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]], TR (STR ''Uint16.uint16'') []]))
	(term_of_class.term_of (Rep_uint16' x))"
	by(simp add: term_of_anything)

	lemma Uint16_code [code]: "Rep_uint16 (Uint16 i) = word_of_int (int_of_integer_symbolic i)"
	unfolding Uint16_def int_of_integer_symbolic_def by(simp add: Abs_uint16_inverse)

	code_printing
	type_constructor uint16 \<rightharpoonup>
	(SML_word) "Word16.word" and
	(Haskell) "Uint16.Word16" and
	(Scala) "scala.Char"
	\| constant Uint16 \<rightharpoonup>
	(SML_word) "Word16.fromLargeInt (IntInf.toLarge _)" and
	(Haskell) "(Prelude.fromInteger _ :: Uint16.Word16)" and
	(Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Word16)" and
	(Scala) "_.charValue"
	\| constant "0 :: uint16" \<rightharpoonup>
	(SML_word) "(Word16.fromInt 0)" and
	(Haskell) "(0 :: Uint16.Word16)" and
	(Scala) "0"
	\| constant "1 :: uint16" \<rightharpoonup>
	(SML_word) "(Word16.fromInt 1)" and
	(Haskell) "(1 :: Uint16.Word16)" and
	(Scala) "1"
	\| constant "plus :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.+ ((_), (_))" and
	(Haskell) infixl 6 "+" and
	(Scala) "(_ +/ _).toChar"
	\| constant "uminus :: uint16 \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.~" and
	(Haskell) "negate" and
	(Scala) "(- _).toChar"
	\| constant "minus :: uint16 \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.- ((_), (_))" and
	(Haskell) infixl 6 "-" and
	(Scala) "(_ -/ _).toChar"
	\| constant "times :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.* ((_), (_))" and
	(Haskell) infixl 7 "*" and
	(Scala) "(_ */ _).toChar"
	\| constant "HOL.equal :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML_word) "!((_ : Word16.word) = _)" and
	(Haskell) infix 4 "==" and
	(Scala) infixl 5 "=="
	\| class_instance uint16 :: equal \<rightharpoonup> (Haskell) -
	\| constant "less_eq :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML_word) "Word16.<= ((_), (_))" and
	(Haskell) infix 4 "<=" and
	(Scala) infixl 4 "<="
	\| constant "less :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML_word) "Word16.< ((_), (_))" and
	(Haskell) infix 4 "<" and
	(Scala) infixl 4 "<"
	\| constant "Bit_Operations.not :: uint16 \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.notb" and
	(Haskell) "Data'_Bits.complement" and
	(Scala) "_.unary'_~.toChar"
	\| constant "Bit_Operations.and :: uint16 \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.andb ((_),/ (_))" and
	(Haskell) infixl 7 "Data_Bits..&." and
	(Scala) "(_ & _).toChar"
	\| constant "Bit_Operations.or :: uint16 \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.orb ((_),/ (_))" and
	(Haskell) infixl 5 "Data_Bits..\|." and
	(Scala) "(_ \| _).toChar"
	\| constant "Bit_Operations.xor :: uint16 \<Rightarrow> _" \<rightharpoonup>
	(SML_word) "Word16.xorb ((_),/ (_))" and
	(Haskell) "Data'_Bits.xor" and
	(Scala) "(_ ^ _).toChar"

	definition uint16_div :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
	where "uint16_div x y = (if y = 0 then undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x div y)"

	definition uint16_mod :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
	where "uint16_mod x y = (if y = 0 then undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x mod y)"

	context includes undefined_transfer begin

	lemma div_uint16_code [code]: "x div y = (if y = 0 then 0 else uint16_div x y)"
	unfolding uint16_div_def by transfer (simp add: word_div_def)

	lemma mod_uint16_code [code]: "x mod y = (if y = 0 then x else uint16_mod x y)"
	unfolding uint16_mod_def by transfer (simp add: word_mod_def)

	lemma uint16_div_code [code]:
	"Rep_uint16 (uint16_div x y) =
	(if y = 0 then Rep_uint16 (undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x div Rep_uint16 y)"
	unfolding uint16_div_def by transfer simp

	lemma uint16_mod_code [code]:
	"Rep_uint16 (uint16_mod x y) =
	(if y = 0 then Rep_uint16 (undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x mod Rep_uint16 y)"
	unfolding uint16_mod_def by transfer simp

	end

	code_printing constant uint16_div \<rightharpoonup>
	(SML_word) "Word16.div ((_), (_))" and
	(Haskell) "Prelude.div" and
	(Scala) "(_ '/ _).toChar"
	\| constant uint16_mod \<rightharpoonup>
	(SML_word) "Word16.mod ((_), (_))" and
	(Haskell) "Prelude.mod" and
	(Scala) "(_ % _).toChar"

	definition uint16_test_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool"
	where [code del]:
	"uint16_test_bit x n =
	(if n < 0 \<or> 15 < n then undefined (bit :: uint16 \<Rightarrow> _) x n
	else bit x (nat_of_integer n))"

	lemma test_bit_uint16_code [code]:
	"bit x n \<longleftrightarrow> n < 16 \<and> uint16_test_bit x (integer_of_nat n)"
	including undefined_transfer integer.lifting unfolding uint16_test_bit_def
	by (transfer, simp, transfer, simp)

	lemma uint16_test_bit_code [code]:
	"uint16_test_bit w n =
	(if n < 0 \<or> 15 < n then undefined (bit :: uint16 \<Rightarrow> _) w n else bit (Rep_uint16 w) (nat_of_integer n))"
	unfolding uint16_test_bit_def by (simp add: bit_uint16.rep_eq)

	code_printing constant uint16_test_bit \<rightharpoonup>
	(SML_word) "Uint16.test'_bit" and
	(Haskell) "Data'_Bits.testBitBounded" and
	(Scala) "Uint16.test'_bit"

	definition uint16_set_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint16"
	where [code del]:
	"uint16_set_bit x n b =
	(if n < 0 \<or> 15 < n then undefined (set_bit :: uint16 \<Rightarrow> _) x n b
	else set_bit x (nat_of_integer n) b)"

	lemma set_bit_uint16_code [code]:
	"set_bit x n b = (if n < 16 then uint16_set_bit x (integer_of_nat n) b else x)"
	including undefined_transfer integer.lifting unfolding uint16_set_bit_def
	by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

	lemma uint16_set_bit_code [code]:
	"Rep_uint16 (uint16_set_bit w n b) =
	(if n < 0 \<or> 15 < n then Rep_uint16 (undefined (set_bit :: uint16 \<Rightarrow> _) w n b)
	else set_bit (Rep_uint16 w) (nat_of_integer n) b)"
	including undefined_transfer unfolding uint16_set_bit_def by transfer simp

	code_printing constant uint16_set_bit \<rightharpoonup>
	(SML_word) "Uint16.set'_bit" and
	(Haskell) "Data'_Bits.setBitBounded" and
	(Scala) "Uint16.set'_bit"

	definition uint16_shiftl :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
	where [code del]:
	"uint16_shiftl x n = (if n < 0 \<or> 16 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

	lemma shiftl_uint16_code [code]: "push_bit n x = (if n < 16 then uint16_shiftl x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint16_shiftl_def
	by transfer simp

	lemma uint16_shiftl_code [code]:
	"Rep_uint16 (uint16_shiftl w n) =
	(if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (push_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) w n)
	else push_bit (nat_of_integer n) (Rep_uint16 w))"
	including undefined_transfer unfolding uint16_shiftl_def
	by transfer simp

	code_printing constant uint16_shiftl \<rightharpoonup>
	(SML_word) "Uint16.shiftl" and
	(Haskell) "Data'_Bits.shiftlBounded" and
	(Scala) "Uint16.shiftl"

	definition uint16_shiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
	where [code del]:
	"uint16_shiftr x n = (if n < 0 \<or> 16 \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

	lemma shiftr_uint16_code [code]: "drop_bit n x = (if n < 16 then uint16_shiftr x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint16_shiftr_def
	by transfer simp

	lemma uint16_shiftr_code [code]:
	"Rep_uint16 (uint16_shiftr w n) =
	(if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (drop_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) w n)
	else drop_bit (nat_of_integer n) (Rep_uint16 w))"
	including undefined_transfer unfolding uint16_shiftr_def by transfer simp

	code_printing constant uint16_shiftr \<rightharpoonup>
	(SML_word) "Uint16.shiftr" and
	(Haskell) "Data'_Bits.shiftrBounded" and
	(Scala) "Uint16.shiftr"

	definition uint16_sshiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
	where [code del]:
	"uint16_sshiftr x n =
	(if n < 0 \<or> 16 \<le> n then undefined signed_drop_bit_uint16 n x else signed_drop_bit_uint16 (nat_of_integer n) x)"

	lemma sshiftr_uint16_code [code]:
	"signed_drop_bit_uint16 n x =
	(if n < 16 then uint16_sshiftr x (integer_of_nat n) else if bit x 15 then -1 else 0)"
	including undefined_transfer integer.lifting unfolding uint16_sshiftr_def
	by transfer (simp add: not_less signed_drop_bit_beyond word_size)

	lemma uint16_sshiftr_code [code]:
	"Rep_uint16 (uint16_sshiftr w n) =
	(if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined signed_drop_bit_uint16 n w)
	else signed_drop_bit (nat_of_integer n) (Rep_uint16 w))"
	including undefined_transfer unfolding uint16_sshiftr_def
	by transfer simp

	code_printing constant uint16_sshiftr \<rightharpoonup>
	(SML_word) "Uint16.shiftr'_signed" and
	(Haskell)
	"(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Int16) _)) :: Uint16.Word16)" and
	(Scala) "Uint16.shiftr'_signed"

	lemma uint16_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint16) 15"
	by transfer (simp add: msb_word_iff_bit)

	lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint16_test_bit x 15"
	by (simp add: uint16_test_bit_def uint16_msb_test_bit)

	lemma uint16_of_int_code [code]: "uint16_of_int i = Uint16 (integer_of_int i)"
	including integer.lifting by transfer simp

	lemma int_of_uint16_code [code]:
	"int_of_uint16 x = int_of_integer (integer_of_uint16 x)"
	by (simp add: int_of_uint16.rep_eq integer_of_uint16_def)

	lemma uint16_of_nat_code [code]:
	"uint16_of_nat = uint16_of_int \<circ> int"
	by transfer (simp add: fun_eq_iff)

	lemma nat_of_uint16_code [code]:
	"nat_of_uint16 x = nat_of_integer (integer_of_uint16 x)"
	unfolding integer_of_uint16_def including integer.lifting by transfer simp

	lemma integer_of_uint16_code [code]:
	"integer_of_uint16 n = integer_of_int (uint (Rep_uint16' n))"
	unfolding integer_of_uint16_def by transfer auto

	code_printing
	constant "integer_of_uint16" \<rightharpoonup>
	(SML_word) "Word16.toInt _ : IntInf.int" and
	(Haskell) "Prelude.toInteger" and
	(Scala) "BigInt"

	section \<open>Quickcheck setup\<close>

	definition uint16_of_natural :: "natural \<Rightarrow> uint16"
	where "uint16_of_natural x \<equiv> Uint16 (integer_of_natural x)"

	instantiation uint16 :: "{random, exhaustive, full_exhaustive}" begin
	definition "random_uint16 \<equiv> qc_random_cnv uint16_of_natural"
	definition "exhaustive_uint16 \<equiv> qc_exhaustive_cnv uint16_of_natural"
	definition "full_exhaustive_uint16 \<equiv> qc_full_exhaustive_cnv uint16_of_natural"
	instance ..
	end

	instantiation uint16 :: narrowing begin

	interpretation quickcheck_narrowing_samples
	"\<lambda>i. let x = Uint16 i in (x, 0xFFFF - x)" "0"
	"Typerep.Typerep (STR ''Uint16.uint16'') []" .

	definition "narrowing_uint16 d = qc_narrowing_drawn_from (narrowing_samples d) d"
	declare [[code drop: "partial_term_of :: uint16 itself \<Rightarrow> _"]]
	lemmas partial_term_of_uint16 [code] = partial_term_of_code

	instance ..
	end

	end
	diff --git a/thys/Native_Word/Uint32.thy b/thys/Native_Word/Uint32.thy
	--- a/thys/Native_Word/Uint32.thy
	+++ b/thys/Native_Word/Uint32.thy
	@@ -1,691 +1,692 @@
	(* Title: Uint32.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Unsigned words of 32 bits\<close>

	theory Uint32 imports
	- Code_Target_Word_Base Word_Type_Copies
	+ Word_Type_Copies
	+ Code_Target_Integer_Bit
	begin

	section \<open>Type definition and primitive operations\<close>

	typedef uint32 = \<open>UNIV :: 32 word set\<close> ..

	global_interpretation uint32: word_type_copy Abs_uint32 Rep_uint32
	using type_definition_uint32 by (rule word_type_copy.intro)

	setup_lifting type_definition_uint32

	declare uint32.of_word_of [code abstype]

	declare Quotient_uint32 [transfer_rule]

	instantiation uint32 :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
	begin

	lift_definition zero_uint32 :: uint32 is 0 .
	lift_definition one_uint32 :: uint32 is 1 .
	lift_definition plus_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(+)\<close> .
	lift_definition uminus_uint32 :: \<open>uint32 \<Rightarrow> uint32\<close> is uminus .
	lift_definition minus_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(-)\<close> .
	lift_definition times_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(*)\<close> .
	lift_definition divide_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(div)\<close> .
	lift_definition modulo_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(mod)\<close> .
	lift_definition equal_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
	lift_definition less_eq_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
	lift_definition less_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> bool\<close> is \<open>(<)\<close> .

	global_interpretation uint32: word_type_copy_ring Abs_uint32 Rep_uint32
	by standard (fact zero_uint32.rep_eq one_uint32.rep_eq
	plus_uint32.rep_eq uminus_uint32.rep_eq minus_uint32.rep_eq
	times_uint32.rep_eq divide_uint32.rep_eq modulo_uint32.rep_eq
	equal_uint32.rep_eq less_eq_uint32.rep_eq less_uint32.rep_eq)+

	instance proof -
	show \<open>OFCLASS(uint32, comm_ring_1_class)\<close>
	by (rule uint32.of_class_comm_ring_1)
	show \<open>OFCLASS(uint32, semiring_modulo_class)\<close>
	by (fact uint32.of_class_semiring_modulo)
	show \<open>OFCLASS(uint32, equal_class)\<close>
	by (fact uint32.of_class_equal)
	show \<open>OFCLASS(uint32, linorder_class)\<close>
	by (fact uint32.of_class_linorder)
	qed

	end

	instantiation uint32 :: ring_bit_operations
	begin

	lift_definition bit_uint32 :: \<open>uint32 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
	lift_definition not_uint32 :: \<open>uint32 \<Rightarrow> uint32\<close> is \<open>Bit_Operations.not\<close> .
	lift_definition and_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>Bit_Operations.and\<close> .
	lift_definition or_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>Bit_Operations.or\<close> .
	lift_definition xor_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>Bit_Operations.xor\<close> .
	lift_definition mask_uint32 :: \<open>nat \<Rightarrow> uint32\<close> is mask .
	lift_definition push_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is push_bit .
	lift_definition drop_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is drop_bit .
	lift_definition signed_drop_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is signed_drop_bit .
	lift_definition take_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is take_bit .
	lift_definition set_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is Bit_Operations.set_bit .
	lift_definition unset_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is unset_bit .
	lift_definition flip_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is flip_bit .

	global_interpretation uint32: word_type_copy_bits Abs_uint32 Rep_uint32 signed_drop_bit_uint32
	by standard (fact bit_uint32.rep_eq not_uint32.rep_eq and_uint32.rep_eq or_uint32.rep_eq xor_uint32.rep_eq
	mask_uint32.rep_eq push_bit_uint32.rep_eq drop_bit_uint32.rep_eq signed_drop_bit_uint32.rep_eq take_bit_uint32.rep_eq
	set_bit_uint32.rep_eq unset_bit_uint32.rep_eq flip_bit_uint32.rep_eq)+

	instance
	by (fact uint32.of_class_ring_bit_operations)

	end

	lift_definition uint32_of_nat :: \<open>nat \<Rightarrow> uint32\<close>
	is word_of_nat .

	lift_definition nat_of_uint32 :: \<open>uint32 \<Rightarrow> nat\<close>
	is unat .

	lift_definition uint32_of_int :: \<open>int \<Rightarrow> uint32\<close>
	is word_of_int .

	lift_definition int_of_uint32 :: \<open>uint32 \<Rightarrow> int\<close>
	is uint .

	context
	includes integer.lifting
	begin

	lift_definition Uint32 :: \<open>integer \<Rightarrow> uint32\<close>
	is word_of_int .

	lift_definition integer_of_uint32 :: \<open>uint32 \<Rightarrow> integer\<close>
	is uint .

	end

	global_interpretation uint32: word_type_copy_more Abs_uint32 Rep_uint32 signed_drop_bit_uint32
	uint32_of_nat nat_of_uint32 uint32_of_int int_of_uint32 Uint32 integer_of_uint32
	apply standard
	apply (simp_all add: uint32_of_nat.rep_eq nat_of_uint32.rep_eq
	uint32_of_int.rep_eq int_of_uint32.rep_eq
	Uint32.rep_eq integer_of_uint32.rep_eq integer_eq_iff)
	done

	instantiation uint32 :: "{size, msb, lsb, set_bit, bit_comprehension}"
	begin

	lift_definition size_uint32 :: \<open>uint32 \<Rightarrow> nat\<close> is size .

	lift_definition msb_uint32 :: \<open>uint32 \<Rightarrow> bool\<close> is msb .
	lift_definition lsb_uint32 :: \<open>uint32 \<Rightarrow> bool\<close> is lsb .

	text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

	definition set_bit_uint32 :: \<open>uint32 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint32\<close>
	where set_bit_uint32_eq: \<open>set_bit_uint32 a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

	context
	includes lifting_syntax
	begin

	lemma set_bit_uint32_transfer [transfer_rule]:
	\<open>(cr_uint32 ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint32) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
	by (simp only: set_bit_eq [abs_def] set_bit_uint32_eq [abs_def]) transfer_prover

	end

	lift_definition set_bits_uint32 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint32\<close> is set_bits .
	lift_definition set_bits_aux_uint32 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is set_bits_aux .

	global_interpretation uint32: word_type_copy_misc Abs_uint32 Rep_uint32 signed_drop_bit_uint32
	uint32_of_nat nat_of_uint32 uint32_of_int int_of_uint32 Uint32 integer_of_uint32 32 set_bits_aux_uint32
	by (standard; transfer) simp_all

	instance using uint32.of_class_bit_comprehension
	uint32.of_class_set_bit uint32.of_class_lsb
	by simp_all standard

	end

	section \<open>Code setup\<close>

	code_printing code_module Uint32 \<rightharpoonup> (SML)
	\<open>(* Test that words can handle numbers between 0 and 31 *)
	val _ = if 5 <= Word.wordSize then () else raise (Fail ("wordSize less than 5"));

	structure Uint32 : sig
	val set_bit : Word32.word -> IntInf.int -> bool -> Word32.word
	val shiftl : Word32.word -> IntInf.int -> Word32.word
	val shiftr : Word32.word -> IntInf.int -> Word32.word
	val shiftr_signed : Word32.word -> IntInf.int -> Word32.word
	val test_bit : Word32.word -> IntInf.int -> bool
	end = struct

	fun set_bit x n b =
	let val mask = Word32.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
	in if b then Word32.orb (x, mask)
	else Word32.andb (x, Word32.notb mask)
	end

	fun shiftl x n =
	Word32.<< (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr x n =
	Word32.>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr_signed x n =
	Word32.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun test_bit x n =
	Word32.andb (x, Word32.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word32.fromInt 0

	end; (* struct Uint32 *)\<close>
	code_reserved SML Uint32

	code_printing code_module Uint32 \<rightharpoonup> (Haskell)
	\<open>module Uint32(Int32, Word32) where

	import Data.Int(Int32)
	import Data.Word(Word32)\<close>
	code_reserved Haskell Uint32

	text \<open>
	OCaml and Scala provide only signed 32bit numbers, so we use these and
	implement sign-sensitive operations like comparisons manually.
	\<close>
	code_printing code_module "Uint32" \<rightharpoonup> (OCaml)
	\<open>module Uint32 : sig
	val less : int32 -> int32 -> bool
	val less_eq : int32 -> int32 -> bool
	val set_bit : int32 -> Z.t -> bool -> int32
	val shiftl : int32 -> Z.t -> int32
	val shiftr : int32 -> Z.t -> int32
	val shiftr_signed : int32 -> Z.t -> int32
	val test_bit : int32 -> Z.t -> bool
	end = struct

	(* negative numbers have their highest bit set,
	so they are greater than positive ones *)
	let less x y =
	if Int32.compare x Int32.zero < 0 then
	Int32.compare y Int32.zero < 0 && Int32.compare x y < 0
	else Int32.compare y Int32.zero < 0 \|\| Int32.compare x y < 0;;

	let less_eq x y =
	if Int32.compare x Int32.zero < 0 then
	Int32.compare y Int32.zero < 0 && Int32.compare x y <= 0
	else Int32.compare y Int32.zero < 0 \|\| Int32.compare x y <= 0;;

	let set_bit x n b =
	let mask = Int32.shift_left Int32.one (Z.to_int n)
	in if b then Int32.logor x mask
	else Int32.logand x (Int32.lognot mask);;

	let shiftl x n = Int32.shift_left x (Z.to_int n);;

	let shiftr x n = Int32.shift_right_logical x (Z.to_int n);;

	let shiftr_signed x n = Int32.shift_right x (Z.to_int n);;

	let test_bit x n =
	Int32.compare
	(Int32.logand x (Int32.shift_left Int32.one (Z.to_int n)))
	Int32.zero
	<> 0;;

	end;; (struct Uint32)\<close>
	code_reserved OCaml Uint32

	code_printing code_module Uint32 \<rightharpoonup> (Scala)
	\<open>object Uint32 {

	def less(x: Int, y: Int) : Boolean =
	if (x < 0) y < 0 && x < y
	else y < 0 \|\| x < y

	def less_eq(x: Int, y: Int) : Boolean =
	if (x < 0) y < 0 && x <= y
	else y < 0 \|\| x <= y

	def set_bit(x: Int, n: BigInt, b: Boolean) : Int =
	if (b)
	x \| (1 << n.intValue)
	else
	x & (1 << n.intValue).unary_~

	def shiftl(x: Int, n: BigInt) : Int = x << n.intValue

	def shiftr(x: Int, n: BigInt) : Int = x >>> n.intValue

	def shiftr_signed(x: Int, n: BigInt) : Int = x >> n.intValue

	def test_bit(x: Int, n: BigInt) : Boolean =
	(x & (1 << n.intValue)) != 0

	} /* object Uint32 */\<close>
	code_reserved Scala Uint32

	text \<open>
	OCaml's conversion from Big\_int to int32 demands that the value fits int a signed 32-bit integer.
	The following justifies the implementation.
	\<close>

	context
	includes bit_operations_syntax
	begin

	definition Uint32_signed :: "integer \<Rightarrow> uint32"
	where "Uint32_signed i = (if i < -(0x80000000) \<or> i \<ge> 0x80000000 then undefined Uint32 i else Uint32 i)"

	lemma Uint32_code [code]:
	"Uint32 i =
	(let i' = i AND 0xFFFFFFFF
	in if bit i' 31 then Uint32_signed (i' - 0x100000000) else Uint32_signed i')"
	including undefined_transfer integer.lifting unfolding Uint32_signed_def
	apply transfer
	apply (subst word_of_int_via_signed)
	apply (auto simp add: push_bit_of_1 mask_eq_exp_minus_1 word_of_int_via_signed cong del: if_cong)
	done

	lemma Uint32_signed_code [code]:
	"Rep_uint32 (Uint32_signed i) =
	(if i < -(0x80000000) \<or> i \<ge> 0x80000000 then Rep_uint32 (undefined Uint32 i) else word_of_int (int_of_integer_symbolic i))"
	unfolding Uint32_signed_def Uint32_def int_of_integer_symbolic_def word_of_integer_def
	by(simp add: Abs_uint32_inverse)

	end

	text \<open>
	Avoid @{term Abs_uint32} in generated code, use @{term Rep_uint32'} instead.
	The symbolic implementations for code\_simp use @{term Rep_uint32}.

	The new destructor @{term Rep_uint32'} is executable.
	As the simplifier is given the [code abstract] equations literally,
	we cannot implement @{term Rep_uint32} directly, because that makes code\_simp loop.

	If code generation raises Match, some equation probably contains @{term Rep_uint32}
	([code abstract] equations for @{typ uint32} may use @{term Rep_uint32} because
	these instances will be folded away.)

	To convert @{typ "32 word"} values into @{typ uint32}, use @{term "Abs_uint32'"}.
	\<close>

	definition Rep_uint32' where [simp]: "Rep_uint32' = Rep_uint32"

	lemma Rep_uint32'_transfer [transfer_rule]:
	"rel_fun cr_uint32 (=) (\<lambda>x. x) Rep_uint32'"
	unfolding Rep_uint32'_def by(rule uint32.rep_transfer)

	lemma Rep_uint32'_code [code]: "Rep_uint32' x = (BITS n. bit x n)"
	by transfer (simp add: set_bits_bit_eq)

	lift_definition Abs_uint32' :: "32 word \<Rightarrow> uint32" is "\<lambda>x :: 32 word. x" .

	lemma Abs_uint32'_code [code]:
	"Abs_uint32' x = Uint32 (integer_of_int (uint x))"
	including integer.lifting by transfer simp

	declare [[code drop: "term_of_class.term_of :: uint32 \<Rightarrow> _"]]

	lemma term_of_uint32_code [code]:
	defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''"
	shows
	"term_of_class.term_of x =
	Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint32.uint32.Abs_uint32'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]]], TR (STR ''Uint32.uint32'') []]))
	(term_of_class.term_of (Rep_uint32' x))"
	by(simp add: term_of_anything)

	code_printing
	type_constructor uint32 \<rightharpoonup>
	(SML) "Word32.word" and
	(Haskell) "Uint32.Word32" and
	(OCaml) "int32" and
	(Scala) "Int" and
	(Eval) "Word32.word"
	\| constant Uint32 \<rightharpoonup>
	(SML) "Word32.fromLargeInt (IntInf.toLarge _)" and
	(Haskell) "(Prelude.fromInteger _ :: Uint32.Word32)" and
	(Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint32.Word32)" and
	(Scala) "_.intValue"
	\| constant Uint32_signed \<rightharpoonup>
	(OCaml) "Z.to'_int32"
	\| constant "0 :: uint32" \<rightharpoonup>
	(SML) "(Word32.fromInt 0)" and
	(Haskell) "(0 :: Uint32.Word32)" and
	(OCaml) "Int32.zero" and
	(Scala) "0"
	\| constant "1 :: uint32" \<rightharpoonup>
	(SML) "(Word32.fromInt 1)" and
	(Haskell) "(1 :: Uint32.Word32)" and
	(OCaml) "Int32.one" and
	(Scala) "1"
	\| constant "plus :: uint32 \<Rightarrow> _ " \<rightharpoonup>
	(SML) "Word32.+ ((_), (_))" and
	(Haskell) infixl 6 "+" and
	(OCaml) "Int32.add" and
	(Scala) infixl 7 "+"
	\| constant "uminus :: uint32 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word32.~" and
	(Haskell) "negate" and
	(OCaml) "Int32.neg" and
	(Scala) "!(- _)"
	\| constant "minus :: uint32 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word32.- ((_), (_))" and
	(Haskell) infixl 6 "-" and
	(OCaml) "Int32.sub" and
	(Scala) infixl 7 "-"
	\| constant "times :: uint32 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word32.* ((_), (_))" and
	(Haskell) infixl 7 "*" and
	(OCaml) "Int32.mul" and
	(Scala) infixl 8 "*"
	\| constant "HOL.equal :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "!((_ : Word32.word) = _)" and
	(Haskell) infix 4 "==" and
	(OCaml) "(Int32.compare _ _ = 0)" and
	(Scala) infixl 5 "=="
	\| class_instance uint32 :: equal \<rightharpoonup>
	(Haskell) -
	\| constant "less_eq :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Word32.<= ((_), (_))" and
	(Haskell) infix 4 "<=" and
	(OCaml) "Uint32.less'_eq" and
	(Scala) "Uint32.less'_eq"
	\| constant "less :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Word32.< ((_), (_))" and
	(Haskell) infix 4 "<" and
	(OCaml) "Uint32.less" and
	(Scala) "Uint32.less"
	\| constant "Bit_Operations.not :: uint32 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word32.notb" and
	(Haskell) "Data'_Bits.complement" and
	(OCaml) "Int32.lognot" and
	(Scala) "_.unary'_~"
	\| constant "Bit_Operations.and :: uint32 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word32.andb ((_),/ (_))" and
	(Haskell) infixl 7 "Data_Bits..&." and
	(OCaml) "Int32.logand" and
	(Scala) infixl 3 "&"
	\| constant "Bit_Operations.or :: uint32 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word32.orb ((_),/ (_))" and
	(Haskell) infixl 5 "Data_Bits..\|." and
	(OCaml) "Int32.logor" and
	(Scala) infixl 1 "\|"
	\| constant "Bit_Operations.xor :: uint32 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word32.xorb ((_),/ (_))" and
	(Haskell) "Data'_Bits.xor" and
	(OCaml) "Int32.logxor" and
	(Scala) infixl 2 "^"

	definition uint32_divmod :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32 \<times> uint32" where
	"uint32_divmod x y =
	(if y = 0 then (undefined ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32), undefined ((mod) :: uint32 \<Rightarrow> _) x (0 :: uint32))
	else (x div y, x mod y))"

	definition uint32_div :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
	where "uint32_div x y = fst (uint32_divmod x y)"

	definition uint32_mod :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
	where "uint32_mod x y = snd (uint32_divmod x y)"

	lemma div_uint32_code [code]: "x div y = (if y = 0 then 0 else uint32_div x y)"
	including undefined_transfer unfolding uint32_divmod_def uint32_div_def
	by transfer (simp add: word_div_def)

	lemma mod_uint32_code [code]: "x mod y = (if y = 0 then x else uint32_mod x y)"
	including undefined_transfer unfolding uint32_mod_def uint32_divmod_def
	by transfer (simp add: word_mod_def)

	definition uint32_sdiv :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
	where [code del]:
	"uint32_sdiv x y =
	(if y = 0 then undefined ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32)
	else Abs_uint32 (Rep_uint32 x sdiv Rep_uint32 y))"

	definition div0_uint32 :: "uint32 \<Rightarrow> uint32"
	where [code del]: "div0_uint32 x = undefined ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32)"
	declare [[code abort: div0_uint32]]

	definition mod0_uint32 :: "uint32 \<Rightarrow> uint32"
	where [code del]: "mod0_uint32 x = undefined ((mod) :: uint32 \<Rightarrow> _) x (0 :: uint32)"
	declare [[code abort: mod0_uint32]]

	lemma uint32_divmod_code [code]:
	"uint32_divmod x y =
	(if 0x80000000 \<le> y then if x < y then (0, x) else (1, x - y)
	else if y = 0 then (div0_uint32 x, mod0_uint32 x)
	else let q = push_bit 1 (uint32_sdiv (drop_bit 1 x) y);
	r = x - q * y
	in if r \<ge> y then (q + 1, r - y) else (q, r))"
	including undefined_transfer unfolding uint32_divmod_def uint32_sdiv_def div0_uint32_def mod0_uint32_def
	less_eq_uint32.rep_eq
	apply transfer
	apply (simp add: divmod_via_sdivmod push_bit_eq_mult)
	done

	lemma uint32_sdiv_code [code]:
	"Rep_uint32 (uint32_sdiv x y) =
	(if y = 0 then Rep_uint32 (undefined ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32))
	else Rep_uint32 x sdiv Rep_uint32 y)"
	unfolding uint32_sdiv_def by(simp add: Abs_uint32_inverse)

	text \<open>
	Note that we only need a translation for signed division, but not for the remainder
	because @{thm uint32_divmod_code} computes both with division only.
	\<close>

	code_printing
	constant uint32_div \<rightharpoonup>
	(SML) "Word32.div ((_), (_))" and
	(Haskell) "Prelude.div"
	\| constant uint32_mod \<rightharpoonup>
	(SML) "Word32.mod ((_), (_))" and
	(Haskell) "Prelude.mod"
	\| constant uint32_divmod \<rightharpoonup>
	(Haskell) "divmod"
	\| constant uint32_sdiv \<rightharpoonup>
	(OCaml) "Int32.div" and
	(Scala) "_ '/ _"

	definition uint32_test_bit :: "uint32 \<Rightarrow> integer \<Rightarrow> bool"
	where [code del]:
	"uint32_test_bit x n =
	(if n < 0 \<or> 31 < n then undefined (bit :: uint32 \<Rightarrow> _) x n
	else bit x (nat_of_integer n))"

	lemma test_bit_uint32_code [code]:
	"bit x n \<longleftrightarrow> n < 32 \<and> uint32_test_bit x (integer_of_nat n)"
	including undefined_transfer integer.lifting unfolding uint32_test_bit_def
	by (transfer, simp, transfer, simp)

	lemma uint32_test_bit_code [code]:
	"uint32_test_bit w n =
	(if n < 0 \<or> 31 < n then undefined (bit :: uint32 \<Rightarrow> _) w n else bit (Rep_uint32 w) (nat_of_integer n))"
	unfolding uint32_test_bit_def by(simp add: bit_uint32.rep_eq)

	code_printing constant uint32_test_bit \<rightharpoonup>
	(SML) "Uint32.test'_bit" and
	(Haskell) "Data'_Bits.testBitBounded" and
	(OCaml) "Uint32.test'_bit" and
	(Scala) "Uint32.test'_bit" and
	(Eval) "(fn w => fn n => if n < 0 orelse 32 <= n then raise (Fail \"argument to uint32'_test'_bit out of bounds\") else Uint32.test'_bit w n)"

	definition uint32_set_bit :: "uint32 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint32"
	where [code del]:
	"uint32_set_bit x n b =
	(if n < 0 \<or> 31 < n then undefined (set_bit :: uint32 \<Rightarrow> _) x n b
	else set_bit x (nat_of_integer n) b)"

	lemma set_bit_uint32_code [code]:
	"set_bit x n b = (if n < 32 then uint32_set_bit x (integer_of_nat n) b else x)"
	including undefined_transfer integer.lifting unfolding uint32_set_bit_def
	by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

	lemma uint32_set_bit_code [code]:
	"Rep_uint32 (uint32_set_bit w n b) =
	(if n < 0 \<or> 31 < n then Rep_uint32 (undefined (set_bit :: uint32 \<Rightarrow> _) w n b)
	else set_bit (Rep_uint32 w) (nat_of_integer n) b)"
	including undefined_transfer unfolding uint32_set_bit_def by transfer simp

	code_printing constant uint32_set_bit \<rightharpoonup>
	(SML) "Uint32.set'_bit" and
	(Haskell) "Data'_Bits.setBitBounded" and
	(OCaml) "Uint32.set'_bit" and
	(Scala) "Uint32.set'_bit" and
	(Eval) "(fn w => fn n => fn b => if n < 0 orelse 32 <= n then raise (Fail \"argument to uint32'_set'_bit out of bounds\") else Uint32.set'_bit x n b)"

	definition uint32_shiftl :: "uint32 \<Rightarrow> integer \<Rightarrow> uint32"
	where [code del]:
	"uint32_shiftl x n = (if n < 0 \<or> 32 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint32 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

	lemma shiftl_uint32_code [code]: "push_bit n x = (if n < 32 then uint32_shiftl x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint32_shiftl_def
	by transfer simp

	lemma uint32_shiftl_code [code]:
	"Rep_uint32 (uint32_shiftl w n) =
	(if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined (push_bit :: nat \<Rightarrow> uint32 \<Rightarrow> _) w n) else push_bit (nat_of_integer n) (Rep_uint32 w))"
	including undefined_transfer unfolding uint32_shiftl_def
	by transfer simp

	code_printing constant uint32_shiftl \<rightharpoonup>
	(SML) "Uint32.shiftl" and
	(Haskell) "Data'_Bits.shiftlBounded" and
	(OCaml) "Uint32.shiftl" and
	(Scala) "Uint32.shiftl" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 32 then raise Fail \"argument to uint32'_shiftl out of bounds\" else Uint32.shiftl x i)"

	definition uint32_shiftr :: "uint32 \<Rightarrow> integer \<Rightarrow> uint32"
	where [code del]:
	"uint32_shiftr x n = (if n < 0 \<or> 32 \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint32 \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

	lemma shiftr_uint32_code [code]: "drop_bit n x = (if n < 32 then uint32_shiftr x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint32_shiftr_def
	by transfer simp

	lemma uint32_shiftr_code [code]:
	"Rep_uint32 (uint32_shiftr w n) =
	(if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined (drop_bit :: nat \<Rightarrow> uint32 \<Rightarrow> _) w n) else drop_bit (nat_of_integer n) (Rep_uint32 w))"
	including undefined_transfer unfolding uint32_shiftr_def by transfer simp

	code_printing constant uint32_shiftr \<rightharpoonup>
	(SML) "Uint32.shiftr" and
	(Haskell) "Data'_Bits.shiftrBounded" and
	(OCaml) "Uint32.shiftr" and
	(Scala) "Uint32.shiftr" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 32 then raise Fail \"argument to uint32'_shiftr out of bounds\" else Uint32.shiftr x i)"

	definition uint32_sshiftr :: "uint32 \<Rightarrow> integer \<Rightarrow> uint32"
	where [code del]:
	"uint32_sshiftr x n =
	(if n < 0 \<or> 32 \<le> n then undefined signed_drop_bit_uint32 n x else signed_drop_bit_uint32 (nat_of_integer n) x)"

	lemma sshiftr_uint32_code [code]:
	"signed_drop_bit_uint32 n x =
	(if n < 32 then uint32_sshiftr x (integer_of_nat n) else if bit x 31 then - 1 else 0)"
	including undefined_transfer integer.lifting unfolding uint32_sshiftr_def
	by transfer (simp add: not_less signed_drop_bit_beyond)

	lemma uint32_sshiftr_code [code]:
	"Rep_uint32 (uint32_sshiftr w n) =
	(if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined signed_drop_bit_uint32 n w) else signed_drop_bit (nat_of_integer n) (Rep_uint32 w))"
	including undefined_transfer unfolding uint32_sshiftr_def by transfer simp

	code_printing constant uint32_sshiftr \<rightharpoonup>
	(SML) "Uint32.shiftr'_signed" and
	(Haskell)
	"(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint32.Int32) _)) :: Uint32.Word32)" and
	(OCaml) "Uint32.shiftr'_signed" and
	(Scala) "Uint32.shiftr'_signed" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 32 then raise Fail \"argument to uint32'_shiftr'_signed out of bounds\" else Uint32.shiftr'_signed x i)"

	context
	includes bit_operations_syntax
	begin

	lemma uint32_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint32) 31"
	by transfer (simp add: msb_word_iff_bit)

	lemma msb_uint32_code [code]: "msb x \<longleftrightarrow> uint32_test_bit x 31"
	by (simp add: uint32_test_bit_def uint32_msb_test_bit)

	lemma uint32_of_int_code [code]:
	"uint32_of_int i = Uint32 (integer_of_int i)"
	including integer.lifting by transfer simp

	lemma int_of_uint32_code [code]:
	"int_of_uint32 x = int_of_integer (integer_of_uint32 x)"
	including integer.lifting by transfer simp

	lemma uint32_of_nat_code [code]:
	"uint32_of_nat = uint32_of_int \<circ> int"
	by transfer (simp add: fun_eq_iff)

	lemma nat_of_uint32_code [code]:
	"nat_of_uint32 x = nat_of_integer (integer_of_uint32 x)"
	unfolding integer_of_uint32_def including integer.lifting by transfer simp

	definition integer_of_uint32_signed :: "uint32 \<Rightarrow> integer"
	where
	"integer_of_uint32_signed n = (if bit n 31 then undefined integer_of_uint32 n else integer_of_uint32 n)"

	lemma integer_of_uint32_signed_code [code]:
	"integer_of_uint32_signed n =
	(if bit n 31 then undefined integer_of_uint32 n else integer_of_int (uint (Rep_uint32' n)))"
	by (simp add: integer_of_uint32_signed_def integer_of_uint32_def)

	lemma integer_of_uint32_code [code]:
	"integer_of_uint32 n =
	(if bit n 31 then integer_of_uint32_signed (n AND 0x7FFFFFFF) OR 0x80000000 else integer_of_uint32_signed n)"
	proof -
	have \<open>integer_of_uint32_signed (n AND 0x7FFFFFFF) OR 0x80000000 = Bit_Operations.set_bit 31 (integer_of_uint32_signed (take_bit 31 n))\<close>
	by (simp add: take_bit_eq_mask set_bit_eq_or push_bit_eq_mult mask_eq_exp_minus_1)
	moreover have \<open>integer_of_uint32 n = Bit_Operations.set_bit 31 (integer_of_uint32 (take_bit 31 n))\<close> if \<open>bit n 31\<close>
	proof (rule bit_eqI)
	fix m
	from that show \<open>bit (integer_of_uint32 n) m = bit (Bit_Operations.set_bit 31 (integer_of_uint32 (take_bit 31 n))) m\<close> for m
	including integer.lifting by transfer (auto simp add: bit_simps dest: bit_imp_le_length)
	qed
	ultimately show ?thesis
	by simp (simp add: integer_of_uint32_signed_def bit_simps)
	qed

	end

	code_printing
	constant "integer_of_uint32" \<rightharpoonup>
	(SML) "IntInf.fromLarge (Word32.toLargeInt _) : IntInf.int" and
	(Haskell) "Prelude.toInteger"
	\| constant "integer_of_uint32_signed" \<rightharpoonup>
	(OCaml) "Z.of'_int32" and
	(Scala) "BigInt"

	section \<open>Quickcheck setup\<close>

	definition uint32_of_natural :: "natural \<Rightarrow> uint32"
	where "uint32_of_natural x \<equiv> Uint32 (integer_of_natural x)"

	instantiation uint32 :: "{random, exhaustive, full_exhaustive}" begin
	definition "random_uint32 \<equiv> qc_random_cnv uint32_of_natural"
	definition "exhaustive_uint32 \<equiv> qc_exhaustive_cnv uint32_of_natural"
	definition "full_exhaustive_uint32 \<equiv> qc_full_exhaustive_cnv uint32_of_natural"
	instance ..
	end

	instantiation uint32 :: narrowing begin

	interpretation quickcheck_narrowing_samples
	"\<lambda>i. let x = Uint32 i in (x, 0xFFFFFFFF - x)" "0"
	"Typerep.Typerep (STR ''Uint32.uint32'') []" .

	definition "narrowing_uint32 d = qc_narrowing_drawn_from (narrowing_samples d) d"
	declare [[code drop: "partial_term_of :: uint32 itself \<Rightarrow> _"]]
	lemmas partial_term_of_uint32 [code] = partial_term_of_code

	instance ..
	end

	end
	diff --git a/thys/Native_Word/Uint64.thy b/thys/Native_Word/Uint64.thy
	--- a/thys/Native_Word/Uint64.thy
	+++ b/thys/Native_Word/Uint64.thy
	@@ -1,888 +1,889 @@
	(* Title: Uint64.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Unsigned words of 64 bits\<close>

	theory Uint64 imports
	- Code_Target_Word_Base Word_Type_Copies
	+ Word_Type_Copies
	+ Code_Target_Integer_Bit
	begin

	text \<open>
	PolyML (in version 5.7) provides a Word64 structure only when run in 64-bit mode.
	Therefore, we by default provide an implementation of 64-bit words using \verb$IntInf.int$ and
	masking. The code target \texttt{SML\_word} replaces this implementation and maps the operations
	directly to the \verb$Word64$ structure provided by the Standard ML implementations.

	The \verb$Eval$ target used by @{command value} and @{method eval} dynamically tests at
	runtime for the version of PolyML and uses PolyML's Word64 structure if it detects a 64-bit
	version which does not suffer from a division bug found in PolyML 5.6.
	\<close>

	section \<open>Type definition and primitive operations\<close>

	typedef uint64 = \<open>UNIV :: 64 word set\<close> ..

	global_interpretation uint64: word_type_copy Abs_uint64 Rep_uint64
	using type_definition_uint64 by (rule word_type_copy.intro)

	setup_lifting type_definition_uint64

	declare uint64.of_word_of [code abstype]

	declare Quotient_uint64 [transfer_rule]

	instantiation uint64 :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
	begin

	lift_definition zero_uint64 :: uint64 is 0 .
	lift_definition one_uint64 :: uint64 is 1 .
	lift_definition plus_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(+)\<close> .
	lift_definition uminus_uint64 :: \<open>uint64 \<Rightarrow> uint64\<close> is uminus .
	lift_definition minus_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(-)\<close> .
	lift_definition times_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(*)\<close> .
	lift_definition divide_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(div)\<close> .
	lift_definition modulo_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(mod)\<close> .
	lift_definition equal_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
	lift_definition less_eq_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
	lift_definition less_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> bool\<close> is \<open>(<)\<close> .

	global_interpretation uint64: word_type_copy_ring Abs_uint64 Rep_uint64
	by standard (fact zero_uint64.rep_eq one_uint64.rep_eq
	plus_uint64.rep_eq uminus_uint64.rep_eq minus_uint64.rep_eq
	times_uint64.rep_eq divide_uint64.rep_eq modulo_uint64.rep_eq
	equal_uint64.rep_eq less_eq_uint64.rep_eq less_uint64.rep_eq)+

	instance proof -
	show \<open>OFCLASS(uint64, comm_ring_1_class)\<close>
	by (rule uint64.of_class_comm_ring_1)
	show \<open>OFCLASS(uint64, semiring_modulo_class)\<close>
	by (fact uint64.of_class_semiring_modulo)
	show \<open>OFCLASS(uint64, equal_class)\<close>
	by (fact uint64.of_class_equal)
	show \<open>OFCLASS(uint64, linorder_class)\<close>
	by (fact uint64.of_class_linorder)
	qed

	end

	instantiation uint64 :: ring_bit_operations
	begin

	lift_definition bit_uint64 :: \<open>uint64 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
	lift_definition not_uint64 :: \<open>uint64 \<Rightarrow> uint64\<close> is \<open>Bit_Operations.not\<close> .
	lift_definition and_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>Bit_Operations.and\<close> .
	lift_definition or_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>Bit_Operations.or\<close> .
	lift_definition xor_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>Bit_Operations.xor\<close> .
	lift_definition mask_uint64 :: \<open>nat \<Rightarrow> uint64\<close> is mask .
	lift_definition push_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is push_bit .
	lift_definition drop_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is drop_bit .
	lift_definition signed_drop_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is signed_drop_bit .
	lift_definition take_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is take_bit .
	lift_definition set_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is Bit_Operations.set_bit .
	lift_definition unset_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is unset_bit .
	lift_definition flip_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is flip_bit .

	global_interpretation uint64: word_type_copy_bits Abs_uint64 Rep_uint64 signed_drop_bit_uint64
	by standard (fact bit_uint64.rep_eq not_uint64.rep_eq and_uint64.rep_eq or_uint64.rep_eq xor_uint64.rep_eq
	mask_uint64.rep_eq push_bit_uint64.rep_eq drop_bit_uint64.rep_eq signed_drop_bit_uint64.rep_eq take_bit_uint64.rep_eq
	set_bit_uint64.rep_eq unset_bit_uint64.rep_eq flip_bit_uint64.rep_eq)+

	instance
	by (fact uint64.of_class_ring_bit_operations)

	end

	lift_definition uint64_of_nat :: \<open>nat \<Rightarrow> uint64\<close>
	is word_of_nat .

	lift_definition nat_of_uint64 :: \<open>uint64 \<Rightarrow> nat\<close>
	is unat .

	lift_definition uint64_of_int :: \<open>int \<Rightarrow> uint64\<close>
	is word_of_int .

	lift_definition int_of_uint64 :: \<open>uint64 \<Rightarrow> int\<close>
	is uint .

	context
	includes integer.lifting
	begin

	lift_definition Uint64 :: \<open>integer \<Rightarrow> uint64\<close>
	is word_of_int .

	lift_definition integer_of_uint64 :: \<open>uint64 \<Rightarrow> integer\<close>
	is uint .

	end

	global_interpretation uint64: word_type_copy_more Abs_uint64 Rep_uint64 signed_drop_bit_uint64
	uint64_of_nat nat_of_uint64 uint64_of_int int_of_uint64 Uint64 integer_of_uint64
	apply standard
	apply (simp_all add: uint64_of_nat.rep_eq nat_of_uint64.rep_eq
	uint64_of_int.rep_eq int_of_uint64.rep_eq
	Uint64.rep_eq integer_of_uint64.rep_eq integer_eq_iff)
	done

	instantiation uint64 :: "{size, msb, lsb, set_bit, bit_comprehension}"
	begin

	lift_definition size_uint64 :: \<open>uint64 \<Rightarrow> nat\<close> is size .

	lift_definition msb_uint64 :: \<open>uint64 \<Rightarrow> bool\<close> is msb .
	lift_definition lsb_uint64 :: \<open>uint64 \<Rightarrow> bool\<close> is lsb .

	text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

	definition set_bit_uint64 :: \<open>uint64 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint64\<close>
	where set_bit_uint64_eq: \<open>set_bit_uint64 a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

	context
	includes lifting_syntax
	begin

	lemma set_bit_uint64_transfer [transfer_rule]:
	\<open>(cr_uint64 ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint64) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
	by (simp only: set_bit_eq [abs_def] set_bit_uint64_eq [abs_def]) transfer_prover

	end

	lift_definition set_bits_uint64 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint64\<close> is set_bits .
	lift_definition set_bits_aux_uint64 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is set_bits_aux .

	global_interpretation uint64: word_type_copy_misc Abs_uint64 Rep_uint64 signed_drop_bit_uint64
	uint64_of_nat nat_of_uint64 uint64_of_int int_of_uint64 Uint64 integer_of_uint64 64 set_bits_aux_uint64
	by (standard; transfer) simp_all

	instance using uint64.of_class_bit_comprehension
	uint64.of_class_set_bit uint64.of_class_lsb
	by simp_all standard

	end

	section \<open>Code setup\<close>

	text \<open> For SML, we generate an implementation of unsigned 64-bit words using \verb$IntInf.int$.
	If @{ML "LargeWord.wordSize > 63"} of the Isabelle/ML runtime environment holds, then we assume
	that there is also a \<open>Word64\<close> structure available and accordingly replace the implementation
	for the target \verb$Eval$.
	\<close>
	code_printing code_module "Uint64" \<rightharpoonup> (SML) \<open>(* Test that words can handle numbers between 0 and 63 *)
	val _ = if 6 <= Word.wordSize then () else raise (Fail ("wordSize less than 6"));

	structure Uint64 : sig
	eqtype uint64;
	val zero : uint64;
	val one : uint64;
	val fromInt : IntInf.int -> uint64;
	val toInt : uint64 -> IntInf.int;
	val toLarge : uint64 -> LargeWord.word;
	val fromLarge : LargeWord.word -> uint64
	val plus : uint64 -> uint64 -> uint64;
	val minus : uint64 -> uint64 -> uint64;
	val times : uint64 -> uint64 -> uint64;
	val divide : uint64 -> uint64 -> uint64;
	val modulus : uint64 -> uint64 -> uint64;
	val negate : uint64 -> uint64;
	val less_eq : uint64 -> uint64 -> bool;
	val less : uint64 -> uint64 -> bool;
	val notb : uint64 -> uint64;
	val andb : uint64 -> uint64 -> uint64;
	val orb : uint64 -> uint64 -> uint64;
	val xorb : uint64 -> uint64 -> uint64;
	val shiftl : uint64 -> IntInf.int -> uint64;
	val shiftr : uint64 -> IntInf.int -> uint64;
	val shiftr_signed : uint64 -> IntInf.int -> uint64;
	val set_bit : uint64 -> IntInf.int -> bool -> uint64;
	val test_bit : uint64 -> IntInf.int -> bool;
	end = struct

	type uint64 = IntInf.int;

	val mask = 0xFFFFFFFFFFFFFFFF : IntInf.int;

	val zero = 0 : IntInf.int;

	val one = 1 : IntInf.int;

	fun fromInt x = IntInf.andb(x, mask);

	fun toInt x = x

	fun toLarge x = LargeWord.fromLargeInt (IntInf.toLarge x);

	fun fromLarge x = IntInf.fromLarge (LargeWord.toLargeInt x);

	fun plus x y = IntInf.andb(IntInf.+(x, y), mask);

	fun minus x y = IntInf.andb(IntInf.-(x, y), mask);

	fun negate x = IntInf.andb(IntInf.~(x), mask);

	fun times x y = IntInf.andb(IntInf.*(x, y), mask);

	fun divide x y = IntInf.div(x, y);

	fun modulus x y = IntInf.mod(x, y);

	fun less_eq x y = IntInf.<=(x, y);

	fun less x y = IntInf.<(x, y);

	fun notb x = IntInf.andb(IntInf.notb(x), mask);

	fun orb x y = IntInf.orb(x, y);

	fun andb x y = IntInf.andb(x, y);

	fun xorb x y = IntInf.xorb(x, y);

	val maxWord = IntInf.pow (2, Word.wordSize);

	fun shiftl x n =
	if n < maxWord then IntInf.andb(IntInf.<< (x, Word.fromLargeInt (IntInf.toLarge n)), mask)
	else 0;

	fun shiftr x n =
	if n < maxWord then IntInf.~>> (x, Word.fromLargeInt (IntInf.toLarge n))
	else 0;

	val msb_mask = 0x8000000000000000 : IntInf.int;

	fun shiftr_signed x i =
	if IntInf.andb(x, msb_mask) = 0 then shiftr x i
	else if i >= 64 then 0xFFFFFFFFFFFFFFFF
	else let
	val x' = shiftr x i
	val m' = IntInf.andb(IntInf.<<(mask, Word.max(0w64 - Word.fromLargeInt (IntInf.toLarge i), 0w0)), mask)
	in IntInf.orb(x', m') end;

	fun test_bit x n =
	if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
	else false;

	fun set_bit x n b =
	if n < 64 then
	if b then IntInf.orb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n)))
	else IntInf.andb (x, IntInf.notb (IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))))
	else x;

	end
	\<close>
	code_reserved SML Uint64

	setup \<open>
	let
	val polyml64 = LargeWord.wordSize > 63;
	(* PolyML 5.6 has bugs in its Word64 implementation. We test for one such bug and refrain
	from using Word64 in that case. Testing is done with dynamic code evaluation such that
	the compiler does not choke on the Word64 structure, which need not be present in a 32bit
	environment. *)
	val error_msg = "Buggy Word64 structure";
	val test_code =
	"val _ = if Word64.div (0w18446744073709551611 : Word64.word, 0w3) = 0w6148914691236517203 then ()\n" ^
	"else raise (Fail \"" ^ error_msg ^ "\");";
	val f = Exn.interruptible_capture (fn () => ML_Compiler.eval ML_Compiler.flags Position.none (ML_Lex.tokenize test_code))
	val use_Word64 = polyml64 andalso
	(case f () of
	Exn.Res _ => true
	\| Exn.Exn (e as ERROR m) => if String.isSuffix error_msg m then false else Exn.reraise e
	\| Exn.Exn e => Exn.reraise e)
	;

	val newline = "\n";
	val content =
	"structure Uint64 : sig" ^ newline ^
	" eqtype uint64;" ^ newline ^
	" val zero : uint64;" ^ newline ^
	" val one : uint64;" ^ newline ^
	" val fromInt : IntInf.int -> uint64;" ^ newline ^
	" val toInt : uint64 -> IntInf.int;" ^ newline ^
	" val toLarge : uint64 -> LargeWord.word;" ^ newline ^
	" val fromLarge : LargeWord.word -> uint64" ^ newline ^
	" val plus : uint64 -> uint64 -> uint64;" ^ newline ^
	" val minus : uint64 -> uint64 -> uint64;" ^ newline ^
	" val times : uint64 -> uint64 -> uint64;" ^ newline ^
	" val divide : uint64 -> uint64 -> uint64;" ^ newline ^
	" val modulus : uint64 -> uint64 -> uint64;" ^ newline ^
	" val negate : uint64 -> uint64;" ^ newline ^
	" val less_eq : uint64 -> uint64 -> bool;" ^ newline ^
	" val less : uint64 -> uint64 -> bool;" ^ newline ^
	" val notb : uint64 -> uint64;" ^ newline ^
	" val andb : uint64 -> uint64 -> uint64;" ^ newline ^
	" val orb : uint64 -> uint64 -> uint64;" ^ newline ^
	" val xorb : uint64 -> uint64 -> uint64;" ^ newline ^
	" val shiftl : uint64 -> IntInf.int -> uint64;" ^ newline ^
	" val shiftr : uint64 -> IntInf.int -> uint64;" ^ newline ^
	" val shiftr_signed : uint64 -> IntInf.int -> uint64;" ^ newline ^
	" val set_bit : uint64 -> IntInf.int -> bool -> uint64;" ^ newline ^
	" val test_bit : uint64 -> IntInf.int -> bool;" ^ newline ^
	"end = struct" ^ newline ^
	"" ^ newline ^
	"type uint64 = Word64.word;" ^ newline ^
	"" ^ newline ^
	"val zero = (0wx0 : uint64);" ^ newline ^
	"" ^ newline ^
	"val one = (0wx1 : uint64);" ^ newline ^
	"" ^ newline ^
	"fun fromInt x = Word64.fromLargeInt (IntInf.toLarge x);" ^ newline ^
	"" ^ newline ^
	"fun toInt x = IntInf.fromLarge (Word64.toLargeInt x);" ^ newline ^
	"" ^ newline ^
	"fun fromLarge x = Word64.fromLarge x;" ^ newline ^
	"" ^ newline ^
	"fun toLarge x = Word64.toLarge x;" ^ newline ^
	"" ^ newline ^
	"fun plus x y = Word64.+(x, y);" ^ newline ^
	"" ^ newline ^
	"fun minus x y = Word64.-(x, y);" ^ newline ^
	"" ^ newline ^
	"fun negate x = Word64.~(x);" ^ newline ^
	"" ^ newline ^
	"fun times x y = Word64.*(x, y);" ^ newline ^
	"" ^ newline ^
	"fun divide x y = Word64.div(x, y);" ^ newline ^
	"" ^ newline ^
	"fun modulus x y = Word64.mod(x, y);" ^ newline ^
	"" ^ newline ^
	"fun less_eq x y = Word64.<=(x, y);" ^ newline ^
	"" ^ newline ^
	"fun less x y = Word64.<(x, y);" ^ newline ^
	"" ^ newline ^
	"fun set_bit x n b =" ^ newline ^
	" let val mask = Word64.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
	" in if b then Word64.orb (x, mask)" ^ newline ^
	" else Word64.andb (x, Word64.notb mask)" ^ newline ^
	" end" ^ newline ^
	"" ^ newline ^
	"fun shiftl x n =" ^ newline ^
	" Word64.<< (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
	"" ^ newline ^
	"fun shiftr x n =" ^ newline ^
	" Word64.>> (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
	"" ^ newline ^
	"fun shiftr_signed x n =" ^ newline ^
	" Word64.~>> (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
	"" ^ newline ^
	"fun test_bit x n =" ^ newline ^
	" Word64.andb (x, Word64.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word64.fromInt 0" ^ newline ^
	"" ^ newline ^
	"val notb = Word64.notb" ^ newline ^
	"" ^ newline ^
	"fun andb x y = Word64.andb(x, y);" ^ newline ^
	"" ^ newline ^
	"fun orb x y = Word64.orb(x, y);" ^ newline ^
	"" ^ newline ^
	"fun xorb x y = Word64.xorb(x, y);" ^ newline ^
	"" ^ newline ^
	"end (struct Uint64)"
	val target_SML64 = "SML_word";
	in
	(if use_Word64 then Code_Target.set_printings (Code_Symbol.Module ("Uint64", [(Code_Runtime.target, SOME (content, []))])) else I)
	#> Code_Target.set_printings (Code_Symbol.Module ("Uint64", [(target_SML64, SOME (content, []))]))
	end
	\<close>

	code_printing code_module Uint64 \<rightharpoonup> (Haskell)
	\<open>module Uint64(Int64, Word64) where

	import Data.Int(Int64)
	import Data.Word(Word64)\<close>
	code_reserved Haskell Uint64

	text \<open>
	OCaml and Scala provide only signed 64bit numbers, so we use these and
	implement sign-sensitive operations like comparisons manually.
	\<close>
	code_printing code_module "Uint64" \<rightharpoonup> (OCaml)
	\<open>module Uint64 : sig
	val less : int64 -> int64 -> bool
	val less_eq : int64 -> int64 -> bool
	val set_bit : int64 -> Z.t -> bool -> int64
	val shiftl : int64 -> Z.t -> int64
	val shiftr : int64 -> Z.t -> int64
	val shiftr_signed : int64 -> Z.t -> int64
	val test_bit : int64 -> Z.t -> bool
	end = struct

	(* negative numbers have their highest bit set,
	so they are greater than positive ones *)
	let less x y =
	if Int64.compare x Int64.zero < 0 then
	Int64.compare y Int64.zero < 0 && Int64.compare x y < 0
	else Int64.compare y Int64.zero < 0 \|\| Int64.compare x y < 0;;

	let less_eq x y =
	if Int64.compare x Int64.zero < 0 then
	Int64.compare y Int64.zero < 0 && Int64.compare x y <= 0
	else Int64.compare y Int64.zero < 0 \|\| Int64.compare x y <= 0;;

	let set_bit x n b =
	let mask = Int64.shift_left Int64.one (Z.to_int n)
	in if b then Int64.logor x mask
	else Int64.logand x (Int64.lognot mask);;

	let shiftl x n = Int64.shift_left x (Z.to_int n);;

	let shiftr x n = Int64.shift_right_logical x (Z.to_int n);;

	let shiftr_signed x n = Int64.shift_right x (Z.to_int n);;

	let test_bit x n =
	Int64.compare
	(Int64.logand x (Int64.shift_left Int64.one (Z.to_int n)))
	Int64.zero
	<> 0;;

	end;; (struct Uint64)\<close>
	code_reserved OCaml Uint64

	code_printing code_module Uint64 \<rightharpoonup> (Scala)
	\<open>object Uint64 {

	def less(x: Long, y: Long) : Boolean =
	if (x < 0) y < 0 && x < y
	else y < 0 \|\| x < y

	def less_eq(x: Long, y: Long) : Boolean =
	if (x < 0) y < 0 && x <= y
	else y < 0 \|\| x <= y

	def set_bit(x: Long, n: BigInt, b: Boolean) : Long =
	if (b)
	x \| (1L << n.intValue)
	else
	x & (1L << n.intValue).unary_~

	def shiftl(x: Long, n: BigInt) : Long = x << n.intValue

	def shiftr(x: Long, n: BigInt) : Long = x >>> n.intValue

	def shiftr_signed(x: Long, n: BigInt) : Long = x >> n.intValue

	def test_bit(x: Long, n: BigInt) : Boolean =
	(x & (1L << n.intValue)) != 0

	} /* object Uint64 */\<close>
	code_reserved Scala Uint64

	text \<open>
	OCaml's conversion from Big\_int to int64 demands that the value fits int a signed 64-bit integer.
	The following justifies the implementation.
	\<close>

	context
	includes bit_operations_syntax
	begin

	definition Uint64_signed :: "integer \<Rightarrow> uint64"
	where "Uint64_signed i = (if i < -(0x8000000000000000) \<or> i \<ge> 0x8000000000000000 then undefined Uint64 i else Uint64 i)"

	lemma Uint64_code [code]:
	"Uint64 i =
	(let i' = i AND 0xFFFFFFFFFFFFFFFF
	in if bit i' 63 then Uint64_signed (i' - 0x10000000000000000) else Uint64_signed i')"
	including undefined_transfer integer.lifting unfolding Uint64_signed_def
	apply transfer
	apply (subst word_of_int_via_signed)
	apply (auto simp add: push_bit_of_1 mask_eq_exp_minus_1 word_of_int_via_signed cong del: if_cong)
	done

	lemma Uint64_signed_code [code]:
	"Rep_uint64 (Uint64_signed i) =
	(if i < -(0x8000000000000000) \<or> i \<ge> 0x8000000000000000 then Rep_uint64 (undefined Uint64 i) else word_of_int (int_of_integer_symbolic i))"
	unfolding Uint64_signed_def Uint64_def int_of_integer_symbolic_def word_of_integer_def
	by(simp add: Abs_uint64_inverse)

	end

	text \<open>
	Avoid @{term Abs_uint64} in generated code, use @{term Rep_uint64'} instead.
	The symbolic implementations for code\_simp use @{term Rep_uint64}.

	The new destructor @{term Rep_uint64'} is executable.
	As the simplifier is given the [code abstract] equations literally,
	we cannot implement @{term Rep_uint64} directly, because that makes code\_simp loop.

	If code generation raises Match, some equation probably contains @{term Rep_uint64}
	([code abstract] equations for @{typ uint64} may use @{term Rep_uint64} because
	these instances will be folded away.)

	To convert @{typ "64 word"} values into @{typ uint64}, use @{term "Abs_uint64'"}.
	\<close>

	definition Rep_uint64' where [simp]: "Rep_uint64' = Rep_uint64"

	lemma Rep_uint64'_transfer [transfer_rule]:
	"rel_fun cr_uint64 (=) (\<lambda>x. x) Rep_uint64'"
	unfolding Rep_uint64'_def by(rule uint64.rep_transfer)

	lemma Rep_uint64'_code [code]: "Rep_uint64' x = (BITS n. bit x n)"
	by transfer (simp add: set_bits_bit_eq)

	lift_definition Abs_uint64' :: "64 word \<Rightarrow> uint64" is "\<lambda>x :: 64 word. x" .

	lemma Abs_uint64'_code [code]:
	"Abs_uint64' x = Uint64 (integer_of_int (uint x))"
	including integer.lifting by transfer simp

	declare [[code drop: "term_of_class.term_of :: uint64 \<Rightarrow> _"]]

	lemma term_of_uint64_code [code]:
	defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''"
	shows
	"term_of_class.term_of x =
	Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint64.uint64.Abs_uint64'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]]]], TR (STR ''Uint64.uint64'') []]))
	(term_of_class.term_of (Rep_uint64' x))"
	by(simp add: term_of_anything)

	code_printing
	type_constructor uint64 \<rightharpoonup>
	(SML) "Uint64.uint64" and
	(Haskell) "Uint64.Word64" and
	(OCaml) "int64" and
	(Scala) "Long"
	\| constant Uint64 \<rightharpoonup>
	(SML) "Uint64.fromInt" and
	(Haskell) "(Prelude.fromInteger _ :: Uint64.Word64)" and
	(Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint64.Word64)" and
	(Scala) "_.longValue"
	\| constant Uint64_signed \<rightharpoonup>
	(OCaml) "Z.to'_int64"
	\| constant "0 :: uint64" \<rightharpoonup>
	(SML) "Uint64.zero" and
	(Haskell) "(0 :: Uint64.Word64)" and
	(OCaml) "Int64.zero" and
	(Scala) "0"
	\| constant "1 :: uint64" \<rightharpoonup>
	(SML) "Uint64.one" and
	(Haskell) "(1 :: Uint64.Word64)" and
	(OCaml) "Int64.one" and
	(Scala) "1"
	\| constant "plus :: uint64 \<Rightarrow> _ " \<rightharpoonup>
	(SML) "Uint64.plus" and
	(Haskell) infixl 6 "+" and
	(OCaml) "Int64.add" and
	(Scala) infixl 7 "+"
	\| constant "uminus :: uint64 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Uint64.negate" and
	(Haskell) "negate" and
	(OCaml) "Int64.neg" and
	(Scala) "!(- _)"
	\| constant "minus :: uint64 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Uint64.minus" and
	(Haskell) infixl 6 "-" and
	(OCaml) "Int64.sub" and
	(Scala) infixl 7 "-"
	\| constant "times :: uint64 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
	(SML) "Uint64.times" and
	(Haskell) infixl 7 "*" and
	(OCaml) "Int64.mul" and
	(Scala) infixl 8 "*"
	\| constant "HOL.equal :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "!((_ : Uint64.uint64) = _)" and
	(Haskell) infix 4 "==" and
	(OCaml) "(Int64.compare _ _ = 0)" and
	(Scala) infixl 5 "=="
	\| class_instance uint64 :: equal \<rightharpoonup>
	(Haskell) -
	\| constant "less_eq :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Uint64.less'_eq" and
	(Haskell) infix 4 "<=" and
	(OCaml) "Uint64.less'_eq" and
	(Scala) "Uint64.less'_eq"
	\| constant "less :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Uint64.less" and
	(Haskell) infix 4 "<" and
	(OCaml) "Uint64.less" and
	(Scala) "Uint64.less"
	\| constant "Bit_Operations.not :: uint64 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Uint64.notb" and
	(Haskell) "Data'_Bits.complement" and
	(OCaml) "Int64.lognot" and
	(Scala) "_.unary'_~"
	\| constant "Bit_Operations.and :: uint64 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Uint64.andb" and
	(Haskell) infixl 7 "Data_Bits..&." and
	(OCaml) "Int64.logand" and
	(Scala) infixl 3 "&"
	\| constant "Bit_Operations.or :: uint64 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Uint64.orb" and
	(Haskell) infixl 5 "Data_Bits..\|." and
	(OCaml) "Int64.logor" and
	(Scala) infixl 1 "\|"
	\| constant "Bit_Operations.xor :: uint64 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Uint64.xorb" and
	(Haskell) "Data'_Bits.xor" and
	(OCaml) "Int64.logxor" and
	(Scala) infixl 2 "^"

	definition uint64_divmod :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64 \<times> uint64" where
	"uint64_divmod x y =
	(if y = 0 then (undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64), undefined ((mod) :: uint64 \<Rightarrow> _) x (0 :: uint64))
	else (x div y, x mod y))"

	definition uint64_div :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
	where "uint64_div x y = fst (uint64_divmod x y)"

	definition uint64_mod :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
	where "uint64_mod x y = snd (uint64_divmod x y)"

	lemma div_uint64_code [code]: "x div y = (if y = 0 then 0 else uint64_div x y)"
	including undefined_transfer unfolding uint64_divmod_def uint64_div_def
	by transfer (simp add: word_div_def)

	lemma mod_uint64_code [code]: "x mod y = (if y = 0 then x else uint64_mod x y)"
	including undefined_transfer unfolding uint64_mod_def uint64_divmod_def
	by transfer (simp add: word_mod_def)

	definition uint64_sdiv :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
	where [code del]:
	"uint64_sdiv x y =
	(if y = 0 then undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64)
	else Abs_uint64 (Rep_uint64 x sdiv Rep_uint64 y))"

	definition div0_uint64 :: "uint64 \<Rightarrow> uint64"
	where [code del]: "div0_uint64 x = undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64)"
	declare [[code abort: div0_uint64]]

	definition mod0_uint64 :: "uint64 \<Rightarrow> uint64"
	where [code del]: "mod0_uint64 x = undefined ((mod) :: uint64 \<Rightarrow> _) x (0 :: uint64)"
	declare [[code abort: mod0_uint64]]

	lemma uint64_divmod_code [code]:
	"uint64_divmod x y =
	(if 0x8000000000000000 \<le> y then if x < y then (0, x) else (1, x - y)
	else if y = 0 then (div0_uint64 x, mod0_uint64 x)
	else let q = push_bit 1 (uint64_sdiv (drop_bit 1 x) y);
	r = x - q * y
	in if r \<ge> y then (q + 1, r - y) else (q, r))"
	including undefined_transfer unfolding uint64_divmod_def uint64_sdiv_def div0_uint64_def mod0_uint64_def
	less_eq_uint64.rep_eq
	apply transfer
	apply (simp add: divmod_via_sdivmod push_bit_eq_mult)
	done

	lemma uint64_sdiv_code [code]:
	"Rep_uint64 (uint64_sdiv x y) =
	(if y = 0 then Rep_uint64 (undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64))
	else Rep_uint64 x sdiv Rep_uint64 y)"
	unfolding uint64_sdiv_def by(simp add: Abs_uint64_inverse)

	text \<open>
	Note that we only need a translation for signed division, but not for the remainder
	because @{thm uint64_divmod_code} computes both with division only.
	\<close>

	code_printing
	constant uint64_div \<rightharpoonup>
	(SML) "Uint64.divide" and
	(Haskell) "Prelude.div"
	\| constant uint64_mod \<rightharpoonup>
	(SML) "Uint64.modulus" and
	(Haskell) "Prelude.mod"
	\| constant uint64_divmod \<rightharpoonup>
	(Haskell) "divmod"
	\| constant uint64_sdiv \<rightharpoonup>
	(OCaml) "Int64.div" and
	(Scala) "_ '/ _"

	definition uint64_test_bit :: "uint64 \<Rightarrow> integer \<Rightarrow> bool"
	where [code del]:
	"uint64_test_bit x n =
	(if n < 0 \<or> 63 < n then undefined (bit :: uint64 \<Rightarrow> _) x n
	else bit x (nat_of_integer n))"

	lemma bit_uint64_code [code]:
	"bit x n \<longleftrightarrow> n < 64 \<and> uint64_test_bit x (integer_of_nat n)"
	including undefined_transfer integer.lifting unfolding uint64_test_bit_def
	by transfer (auto dest: bit_imp_le_length)

	lemma uint64_test_bit_code [code]:
	"uint64_test_bit w n =
	(if n < 0 \<or> 63 < n then undefined (bit :: uint64 \<Rightarrow> _) w n else bit (Rep_uint64 w) (nat_of_integer n))"
	unfolding uint64_test_bit_def by(simp add: bit_uint64.rep_eq)

	code_printing constant uint64_test_bit \<rightharpoonup>
	(SML) "Uint64.test'_bit" and
	(Haskell) "Data'_Bits.testBitBounded" and
	(OCaml) "Uint64.test'_bit" and
	(Scala) "Uint64.test'_bit" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_test'_bit out of bounds\") else Uint64.test'_bit x i)"

	definition uint64_set_bit :: "uint64 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint64"
	where [code del]:
	"uint64_set_bit x n b =
	(if n < 0 \<or> 63 < n then undefined (set_bit :: uint64 \<Rightarrow> _) x n b
	else set_bit x (nat_of_integer n) b)"

	lemma set_bit_uint64_code [code]:
	"set_bit x n b = (if n < 64 then uint64_set_bit x (integer_of_nat n) b else x)"
	including undefined_transfer integer.lifting unfolding uint64_set_bit_def
	by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

	lemma uint64_set_bit_code [code]:
	"Rep_uint64 (uint64_set_bit w n b) =
	(if n < 0 \<or> 63 < n then Rep_uint64 (undefined (set_bit :: uint64 \<Rightarrow> _) w n b)
	else set_bit (Rep_uint64 w) (nat_of_integer n) b)"
	including undefined_transfer unfolding uint64_set_bit_def by transfer simp

	code_printing constant uint64_set_bit \<rightharpoonup>
	(SML) "Uint64.set'_bit" and
	(Haskell) "Data'_Bits.setBitBounded" and
	(OCaml) "Uint64.set'_bit" and
	(Scala) "Uint64.set'_bit" and
	(Eval) "(fn x => fn i => fn b => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_set'_bit out of bounds\") else Uint64.set'_bit x i b)"

	definition uint64_shiftl :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
	where [code del]:
	"uint64_shiftl x n = (if n < 0 \<or> 64 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

	lemma shiftl_uint64_code [code]: "push_bit n x = (if n < 64 then uint64_shiftl x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint64_shiftl_def
	by transfer simp

	lemma uint64_shiftl_code [code]:
	"Rep_uint64 (uint64_shiftl w n) =
	(if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined (push_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) w n) else push_bit (nat_of_integer n) (Rep_uint64 w))"
	including undefined_transfer unfolding uint64_shiftl_def by transfer simp

	code_printing constant uint64_shiftl \<rightharpoonup>
	(SML) "Uint64.shiftl" and
	(Haskell) "Data'_Bits.shiftlBounded" and
	(OCaml) "Uint64.shiftl" and
	(Scala) "Uint64.shiftl" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_shiftl out of bounds\") else Uint64.shiftl x i)"

	definition uint64_shiftr :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
	where [code del]:
	"uint64_shiftr x n = (if n < 0 \<or> 64 \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

	lemma shiftr_uint64_code [code]: "drop_bit n x = (if n < 64 then uint64_shiftr x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint64_shiftr_def
	by transfer simp

	lemma uint64_shiftr_code [code]:
	"Rep_uint64 (uint64_shiftr w n) =
	(if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined (drop_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) w n) else drop_bit (nat_of_integer n) (Rep_uint64 w))"
	including undefined_transfer unfolding uint64_shiftr_def by transfer simp

	code_printing constant uint64_shiftr \<rightharpoonup>
	(SML) "Uint64.shiftr" and
	(Haskell) "Data'_Bits.shiftrBounded" and
	(OCaml) "Uint64.shiftr" and
	(Scala) "Uint64.shiftr" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_shiftr out of bounds\") else Uint64.shiftr x i)"

	definition uint64_sshiftr :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
	where [code del]:
	"uint64_sshiftr x n =
	(if n < 0 \<or> 64 \<le> n then undefined signed_drop_bit_uint64 n x else signed_drop_bit_uint64 (nat_of_integer n) x)"

	lemma sshiftr_uint64_code [code]:
	"signed_drop_bit_uint64 n x =
	(if n < 64 then uint64_sshiftr x (integer_of_nat n) else if bit x 63 then - 1 else 0)"
	including undefined_transfer integer.lifting unfolding uint64_sshiftr_def
	by transfer (simp add: not_less signed_drop_bit_beyond)

	lemma uint64_sshiftr_code [code]:
	"Rep_uint64 (uint64_sshiftr w n) =
	(if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined signed_drop_bit_uint64 n w) else signed_drop_bit (nat_of_integer n) (Rep_uint64 w))"
	including undefined_transfer unfolding uint64_sshiftr_def by transfer simp

	code_printing constant uint64_sshiftr \<rightharpoonup>
	(SML) "Uint64.shiftr'_signed" and
	(Haskell)
	"(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint64.Int64) _)) :: Uint64.Word64)" and
	(OCaml) "Uint64.shiftr'_signed" and
	(Scala) "Uint64.shiftr'_signed" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_shiftr'_signed out of bounds\") else Uint64.shiftr'_signed x i)"

	context
	includes bit_operations_syntax
	begin

	lemma uint64_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint64) 63"
	by transfer (simp add: msb_word_iff_bit)

	lemma msb_uint64_code [code]: "msb x \<longleftrightarrow> uint64_test_bit x 63"
	by (simp add: uint64_test_bit_def uint64_msb_test_bit)

	lemma uint64_of_int_code [code]:
	"uint64_of_int i = Uint64 (integer_of_int i)"
	including integer.lifting by transfer simp

	lemma int_of_uint64_code [code]:
	"int_of_uint64 x = int_of_integer (integer_of_uint64 x)"
	including integer.lifting by transfer simp

	lemma uint64_of_nat_code [code]:
	"uint64_of_nat = uint64_of_int \<circ> int"
	by transfer (simp add: fun_eq_iff)

	lemma nat_of_uint64_code [code]:
	"nat_of_uint64 x = nat_of_integer (integer_of_uint64 x)"
	unfolding integer_of_uint64_def including integer.lifting by transfer simp

	definition integer_of_uint64_signed :: "uint64 \<Rightarrow> integer"
	where
	"integer_of_uint64_signed n = (if bit n 63 then undefined integer_of_uint64 n else integer_of_uint64 n)"

	lemma integer_of_uint64_signed_code [code]:
	"integer_of_uint64_signed n =
	(if bit n 63 then undefined integer_of_uint64 n else integer_of_int (uint (Rep_uint64' n)))"
	by (simp add: integer_of_uint64_signed_def integer_of_uint64_def)

	lemma integer_of_uint64_code [code]:
	"integer_of_uint64 n =
	(if bit n 63 then integer_of_uint64_signed (n AND 0x7FFFFFFFFFFFFFFF) OR 0x8000000000000000 else integer_of_uint64_signed n)"
	proof -
	have \<open>integer_of_uint64_signed (n AND 0x7FFFFFFFFFFFFFFF) OR 0x8000000000000000 = Bit_Operations.set_bit 63 (integer_of_uint64_signed (take_bit 63 n))\<close>
	by (simp add: take_bit_eq_mask set_bit_eq_or push_bit_eq_mult mask_eq_exp_minus_1)
	moreover have \<open>integer_of_uint64 n = Bit_Operations.set_bit 63 (integer_of_uint64 (take_bit 63 n))\<close> if \<open>bit n 63\<close>
	proof (rule bit_eqI)
	fix m
	from that show \<open>bit (integer_of_uint64 n) m = bit (Bit_Operations.set_bit 63 (integer_of_uint64 (take_bit 63 n))) m\<close> for m
	including integer.lifting by transfer (auto simp add: bit_simps dest: bit_imp_le_length)
	qed
	ultimately show ?thesis
	by simp (simp add: integer_of_uint64_signed_def bit_simps)
	qed

	end

	code_printing
	constant "integer_of_uint64" \<rightharpoonup>
	(SML) "Uint64.toInt" and
	(Haskell) "Prelude.toInteger"
	\| constant "integer_of_uint64_signed" \<rightharpoonup>
	(OCaml) "Z.of'_int64" and
	(Scala) "BigInt"

	section \<open>Quickcheck setup\<close>

	definition uint64_of_natural :: "natural \<Rightarrow> uint64"
	where "uint64_of_natural x \<equiv> Uint64 (integer_of_natural x)"

	instantiation uint64 :: "{random, exhaustive, full_exhaustive}" begin
	definition "random_uint64 \<equiv> qc_random_cnv uint64_of_natural"
	definition "exhaustive_uint64 \<equiv> qc_exhaustive_cnv uint64_of_natural"
	definition "full_exhaustive_uint64 \<equiv> qc_full_exhaustive_cnv uint64_of_natural"
	instance ..
	end

	instantiation uint64 :: narrowing begin

	interpretation quickcheck_narrowing_samples
	"\<lambda>i. let x = Uint64 i in (x, 0xFFFFFFFFFFFFFFFF - x)" "0"
	"Typerep.Typerep (STR ''Uint64.uint64'') []" .

	definition "narrowing_uint64 d = qc_narrowing_drawn_from (narrowing_samples d) d"
	declare [[code drop: "partial_term_of :: uint64 itself \<Rightarrow> _"]]
	lemmas partial_term_of_uint64 [code] = partial_term_of_code

	instance ..
	end

	end
	diff --git a/thys/Native_Word/Uint8.thy b/thys/Native_Word/Uint8.thy
	--- a/thys/Native_Word/Uint8.thy
	+++ b/thys/Native_Word/Uint8.thy
	@@ -1,610 +1,611 @@
	(* Title: Uint8.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>Unsigned words of 8 bits\<close>

	theory Uint8 imports
	- Code_Target_Word_Base Word_Type_Copies
	+ Word_Type_Copies
	+ Code_Target_Integer_Bit
	begin

	text \<open>
	Restriction for OCaml code generation:
	OCaml does not provide an int8 type, so no special code generation
	- for this type is set up. If the theory \<open>Code_Target_Bits_Int\<close>
	+ for this type is set up. If the theory \<^text>\<open>Code_Target_Int_Bit\<close>
	is imported, the type \<open>uint8\<close> is emulated via \<^typ>\<open>8 word\<close>.
	\<close>

	section \<open>Type definition and primitive operations\<close>

	typedef uint8 = \<open>UNIV :: 8 word set\<close> ..

	global_interpretation uint8: word_type_copy Abs_uint8 Rep_uint8
	using type_definition_uint8 by (rule word_type_copy.intro)

	setup_lifting type_definition_uint8

	declare uint8.of_word_of [code abstype]

	declare Quotient_uint8 [transfer_rule]

	instantiation uint8 :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
	begin

	lift_definition zero_uint8 :: uint8 is 0 .
	lift_definition one_uint8 :: uint8 is 1 .
	lift_definition plus_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(+)\<close> .
	lift_definition uminus_uint8 :: \<open>uint8 \<Rightarrow> uint8\<close> is uminus .
	lift_definition minus_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(-)\<close> .
	lift_definition times_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(*)\<close> .
	lift_definition divide_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(div)\<close> .
	lift_definition modulo_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(mod)\<close> .
	lift_definition equal_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
	lift_definition less_eq_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
	lift_definition less_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> bool\<close> is \<open>(<)\<close> .

	global_interpretation uint8: word_type_copy_ring Abs_uint8 Rep_uint8
	by standard (fact zero_uint8.rep_eq one_uint8.rep_eq
	plus_uint8.rep_eq uminus_uint8.rep_eq minus_uint8.rep_eq
	times_uint8.rep_eq divide_uint8.rep_eq modulo_uint8.rep_eq
	equal_uint8.rep_eq less_eq_uint8.rep_eq less_uint8.rep_eq)+

	instance proof -
	show \<open>OFCLASS(uint8, comm_ring_1_class)\<close>
	by (rule uint8.of_class_comm_ring_1)
	show \<open>OFCLASS(uint8, semiring_modulo_class)\<close>
	by (fact uint8.of_class_semiring_modulo)
	show \<open>OFCLASS(uint8, equal_class)\<close>
	by (fact uint8.of_class_equal)
	show \<open>OFCLASS(uint8, linorder_class)\<close>
	by (fact uint8.of_class_linorder)
	qed

	end

	instantiation uint8 :: ring_bit_operations
	begin

	lift_definition bit_uint8 :: \<open>uint8 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
	lift_definition not_uint8 :: \<open>uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.not\<close> .
	lift_definition and_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.and\<close> .
	lift_definition or_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.or\<close> .
	lift_definition xor_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.xor\<close> .
	lift_definition mask_uint8 :: \<open>nat \<Rightarrow> uint8\<close> is mask .
	lift_definition push_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is push_bit .
	lift_definition drop_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is drop_bit .
	lift_definition signed_drop_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is signed_drop_bit .
	lift_definition take_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is take_bit .
	lift_definition set_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is Bit_Operations.set_bit .
	lift_definition unset_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is unset_bit .
	lift_definition flip_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is flip_bit .

	global_interpretation uint8: word_type_copy_bits Abs_uint8 Rep_uint8 signed_drop_bit_uint8
	by standard (fact bit_uint8.rep_eq not_uint8.rep_eq and_uint8.rep_eq or_uint8.rep_eq xor_uint8.rep_eq
	mask_uint8.rep_eq push_bit_uint8.rep_eq drop_bit_uint8.rep_eq signed_drop_bit_uint8.rep_eq take_bit_uint8.rep_eq
	set_bit_uint8.rep_eq unset_bit_uint8.rep_eq flip_bit_uint8.rep_eq)+

	instance
	by (fact uint8.of_class_ring_bit_operations)

	end

	lift_definition uint8_of_nat :: \<open>nat \<Rightarrow> uint8\<close>
	is word_of_nat .

	lift_definition nat_of_uint8 :: \<open>uint8 \<Rightarrow> nat\<close>
	is unat .

	lift_definition uint8_of_int :: \<open>int \<Rightarrow> uint8\<close>
	is word_of_int .

	lift_definition int_of_uint8 :: \<open>uint8 \<Rightarrow> int\<close>
	is uint .

	context
	includes integer.lifting
	begin

	lift_definition Uint8 :: \<open>integer \<Rightarrow> uint8\<close>
	is word_of_int .

	lift_definition integer_of_uint8 :: \<open>uint8 \<Rightarrow> integer\<close>
	is uint .

	end

	global_interpretation uint8: word_type_copy_more Abs_uint8 Rep_uint8 signed_drop_bit_uint8
	uint8_of_nat nat_of_uint8 uint8_of_int int_of_uint8 Uint8 integer_of_uint8
	apply standard
	apply (simp_all add: uint8_of_nat.rep_eq nat_of_uint8.rep_eq
	uint8_of_int.rep_eq int_of_uint8.rep_eq
	Uint8.rep_eq integer_of_uint8.rep_eq integer_eq_iff)
	done

	instantiation uint8 :: "{size, msb, lsb, set_bit, bit_comprehension}"
	begin

	lift_definition size_uint8 :: \<open>uint8 \<Rightarrow> nat\<close> is size .

	lift_definition msb_uint8 :: \<open>uint8 \<Rightarrow> bool\<close> is msb .
	lift_definition lsb_uint8 :: \<open>uint8 \<Rightarrow> bool\<close> is lsb .

	text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

	definition set_bit_uint8 :: \<open>uint8 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint8\<close>
	where set_bit_uint8_eq: \<open>set_bit_uint8 a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

	context
	includes lifting_syntax
	begin

	lemma set_bit_uint8_transfer [transfer_rule]:
	\<open>(cr_uint8 ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint8) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
	by (simp only: set_bit_eq [abs_def] set_bit_uint8_eq [abs_def]) transfer_prover

	end

	lift_definition set_bits_uint8 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint8\<close> is set_bits .
	lift_definition set_bits_aux_uint8 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is set_bits_aux .

	global_interpretation uint8: word_type_copy_misc Abs_uint8 Rep_uint8 signed_drop_bit_uint8
	uint8_of_nat nat_of_uint8 uint8_of_int int_of_uint8 Uint8 integer_of_uint8 8 set_bits_aux_uint8
	by (standard; transfer) simp_all

	instance using uint8.of_class_bit_comprehension
	uint8.of_class_set_bit uint8.of_class_lsb
	by simp_all standard

	end

	section \<open>Code setup\<close>

	code_printing code_module Uint8 \<rightharpoonup> (SML)
	\<open>(* Test that words can handle numbers between 0 and 3 *)
	val _ = if 3 <= Word.wordSize then () else raise (Fail ("wordSize less than 3"));

	structure Uint8 : sig
	val set_bit : Word8.word -> IntInf.int -> bool -> Word8.word
	val shiftl : Word8.word -> IntInf.int -> Word8.word
	val shiftr : Word8.word -> IntInf.int -> Word8.word
	val shiftr_signed : Word8.word -> IntInf.int -> Word8.word
	val test_bit : Word8.word -> IntInf.int -> bool
	end = struct

	fun set_bit x n b =
	let val mask = Word8.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
	in if b then Word8.orb (x, mask)
	else Word8.andb (x, Word8.notb mask)
	end

	fun shiftl x n =
	Word8.<< (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr x n =
	Word8.>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun shiftr_signed x n =
	Word8.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

	fun test_bit x n =
	Word8.andb (x, Word8.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word8.fromInt 0

	end; (* struct Uint8 *)\<close>
	code_reserved SML Uint8

	code_printing code_module Uint8 \<rightharpoonup> (Haskell)
	\<open>module Uint8(Int8, Word8) where

	import Data.Int(Int8)
	import Data.Word(Word8)\<close>
	code_reserved Haskell Uint8

	text \<open>
	Scala provides only signed 8bit numbers, so we use these and
	implement sign-sensitive operations like comparisons manually.
	\<close>

	code_printing code_module Uint8 \<rightharpoonup> (Scala)
	\<open>object Uint8 {

	def less(x: Byte, y: Byte) : Boolean =
	if (x < 0) y < 0 && x < y
	else y < 0 \|\| x < y

	def less_eq(x: Byte, y: Byte) : Boolean =
	if (x < 0) y < 0 && x <= y
	else y < 0 \|\| x <= y

	def set_bit(x: Byte, n: BigInt, b: Boolean) : Byte =
	if (b)
	(x \| (1 << n.intValue)).toByte
	else
	(x & (1 << n.intValue).unary_~).toByte

	def shiftl(x: Byte, n: BigInt) : Byte = (x << n.intValue).toByte

	def shiftr(x: Byte, n: BigInt) : Byte = ((x & 255) >>> n.intValue).toByte

	def shiftr_signed(x: Byte, n: BigInt) : Byte = (x >> n.intValue).toByte

	def test_bit(x: Byte, n: BigInt) : Boolean =
	(x & (1 << n.intValue)) != 0

	} /* object Uint8 */\<close>
	code_reserved Scala Uint8

	text \<open>
	Avoid @{term Abs_uint8} in generated code, use @{term Rep_uint8'} instead.
	The symbolic implementations for code\_simp use @{term Rep_uint8}.

	The new destructor @{term Rep_uint8'} is executable.
	As the simplifier is given the [code abstract] equations literally,
	we cannot implement @{term Rep_uint8} directly, because that makes code\_simp loop.

	If code generation raises Match, some equation probably contains @{term Rep_uint8}
	([code abstract] equations for @{typ uint8} may use @{term Rep_uint8} because
	these instances will be folded away.)

	To convert @{typ "8 word"} values into @{typ uint8}, use @{term "Abs_uint8'"}.
	\<close>

	definition Rep_uint8' where [simp]: "Rep_uint8' = Rep_uint8"

	lemma Rep_uint8'_transfer [transfer_rule]:
	"rel_fun cr_uint8 (=) (\<lambda>x. x) Rep_uint8'"
	unfolding Rep_uint8'_def by(rule uint8.rep_transfer)

	lemma Rep_uint8'_code [code]: "Rep_uint8' x = (BITS n. bit x n)"
	by transfer (simp add: set_bits_bit_eq)

	lift_definition Abs_uint8' :: "8 word \<Rightarrow> uint8" is "\<lambda>x :: 8 word. x" .

	lemma Abs_uint8'_code [code]: "Abs_uint8' x = Uint8 (integer_of_int (uint x))"
	including integer.lifting by transfer simp

	declare [[code drop: "term_of_class.term_of :: uint8 \<Rightarrow> _"]]

	lemma term_of_uint8_code [code]:
	defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
	"term_of_class.term_of x =
	Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint8.uint8.Abs_uint8'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]], TR (STR ''Uint8.uint8'') []]))
	(term_of_class.term_of (Rep_uint8' x))"
	by(simp add: term_of_anything)

	lemma Uin8_code [code]: "Rep_uint8 (Uint8 i) = word_of_int (int_of_integer_symbolic i)"
	unfolding Uint8_def int_of_integer_symbolic_def by(simp add: Abs_uint8_inverse)

	code_printing type_constructor uint8 \<rightharpoonup>
	(SML) "Word8.word" and
	(Haskell) "Uint8.Word8" and
	(Scala) "Byte"
	\| constant Uint8 \<rightharpoonup>
	(SML) "Word8.fromLargeInt (IntInf.toLarge _)" and
	(Haskell) "(Prelude.fromInteger _ :: Uint8.Word8)" and
	(Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint8.Word8)" and
	(Scala) "_.byteValue"
	\| constant "0 :: uint8" \<rightharpoonup>
	(SML) "(Word8.fromInt 0)" and
	(Haskell) "(0 :: Uint8.Word8)" and
	(Scala) "0.toByte"
	\| constant "1 :: uint8" \<rightharpoonup>
	(SML) "(Word8.fromInt 1)" and
	(Haskell) "(1 :: Uint8.Word8)" and
	(Scala) "1.toByte"
	\| constant "plus :: uint8 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.+ ((_), (_))" and
	(Haskell) infixl 6 "+" and
	(Scala) "(_ +/ _).toByte"
	\| constant "uminus :: uint8 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.~" and
	(Haskell) "negate" and
	(Scala) "(- _).toByte"
	\| constant "minus :: uint8 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.- ((_), (_))" and
	(Haskell) infixl 6 "-" and
	(Scala) "(_ -/ _).toByte"
	\| constant "times :: uint8 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.* ((_), (_))" and
	(Haskell) infixl 7 "*" and
	(Scala) "(_ */ _).toByte"
	\| constant "HOL.equal :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "!((_ : Word8.word) = _)" and
	(Haskell) infix 4 "==" and
	(Scala) infixl 5 "=="
	\| class_instance uint8 :: equal \<rightharpoonup> (Haskell) -
	\| constant "less_eq :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Word8.<= ((_), (_))" and
	(Haskell) infix 4 "<=" and
	(Scala) "Uint8.less'_eq"
	\| constant "less :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
	(SML) "Word8.< ((_), (_))" and
	(Haskell) infix 4 "<" and
	(Scala) "Uint8.less"
	\| constant "Bit_Operations.not :: uint8 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.notb" and
	(Haskell) "Data'_Bits.complement" and
	(Scala) "_.unary'_~.toByte"
	\| constant "Bit_Operations.and :: uint8 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.andb ((_),/ (_))" and
	(Haskell) infixl 7 "Data_Bits..&." and
	(Scala) "(_ & _).toByte"
	\| constant "Bit_Operations.or :: uint8 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.orb ((_),/ (_))" and
	(Haskell) infixl 5 "Data_Bits..\|." and
	(Scala) "(_ \| _).toByte"
	\| constant "Bit_Operations.xor :: uint8 \<Rightarrow> _" \<rightharpoonup>
	(SML) "Word8.xorb ((_),/ (_))" and
	(Haskell) "Data'_Bits.xor" and
	(Scala) "(_ ^ _).toByte"

	definition uint8_divmod :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8 \<times> uint8" where
	"uint8_divmod x y =
	(if y = 0 then (undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8), undefined ((mod) :: uint8 \<Rightarrow> _) x (0 :: uint8))
	else (x div y, x mod y))"

	definition uint8_div :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
	where "uint8_div x y = fst (uint8_divmod x y)"

	definition uint8_mod :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
	where "uint8_mod x y = snd (uint8_divmod x y)"

	lemma div_uint8_code [code]: "x div y = (if y = 0 then 0 else uint8_div x y)"
	including undefined_transfer unfolding uint8_divmod_def uint8_div_def
	by transfer (simp add: word_div_def)

	lemma mod_uint8_code [code]: "x mod y = (if y = 0 then x else uint8_mod x y)"
	including undefined_transfer unfolding uint8_mod_def uint8_divmod_def
	by transfer (simp add: word_mod_def)

	definition uint8_sdiv :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
	where
	"uint8_sdiv x y =
	(if y = 0 then undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8)
	else Abs_uint8 (Rep_uint8 x sdiv Rep_uint8 y))"

	definition div0_uint8 :: "uint8 \<Rightarrow> uint8"
	where [code del]: "div0_uint8 x = undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8)"
	declare [[code abort: div0_uint8]]

	definition mod0_uint8 :: "uint8 \<Rightarrow> uint8"
	where [code del]: "mod0_uint8 x = undefined ((mod) :: uint8 \<Rightarrow> _) x (0 :: uint8)"
	declare [[code abort: mod0_uint8]]

	lemma uint8_divmod_code [code]:
	"uint8_divmod x y =
	(if 0x80 \<le> y then if x < y then (0, x) else (1, x - y)
	else if y = 0 then (div0_uint8 x, mod0_uint8 x)
	else let q = push_bit 1 (uint8_sdiv (drop_bit 1 x) y);
	r = x - q * y
	in if r \<ge> y then (q + 1, r - y) else (q, r))"
	including undefined_transfer unfolding uint8_divmod_def uint8_sdiv_def div0_uint8_def mod0_uint8_def
	less_eq_uint8.rep_eq
	apply transfer
	apply (simp add: divmod_via_sdivmod push_bit_eq_mult)
	done

	lemma uint8_sdiv_code [code]:
	"Rep_uint8 (uint8_sdiv x y) =
	(if y = 0 then Rep_uint8 (undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8))
	else Rep_uint8 x sdiv Rep_uint8 y)"
	unfolding uint8_sdiv_def by(simp add: Abs_uint8_inverse)

	text \<open>
	Note that we only need a translation for signed division, but not for the remainder
	because @{thm uint8_divmod_code} computes both with division only.
	\<close>

	code_printing
	constant uint8_div \<rightharpoonup>
	(SML) "Word8.div ((_), (_))" and
	(Haskell) "Prelude.div"
	\| constant uint8_mod \<rightharpoonup>
	(SML) "Word8.mod ((_), (_))" and
	(Haskell) "Prelude.mod"
	\| constant uint8_divmod \<rightharpoonup>
	(Haskell) "divmod"
	\| constant uint8_sdiv \<rightharpoonup>
	(Scala) "(_ '/ _).toByte"

	definition uint8_test_bit :: "uint8 \<Rightarrow> integer \<Rightarrow> bool"
	where [code del]:
	"uint8_test_bit x n =
	(if n < 0 \<or> 7 < n then undefined (bit :: uint8 \<Rightarrow> _) x n
	else bit x (nat_of_integer n))"

	lemma bit_uint8_code [code]:
	"bit x n \<longleftrightarrow> n < 8 \<and> uint8_test_bit x (integer_of_nat n)"
	including undefined_transfer integer.lifting unfolding uint8_test_bit_def
	by (transfer, simp, transfer, simp)

	lemma uint8_test_bit_code [code]:
	"uint8_test_bit w n =
	(if n < 0 \<or> 7 < n then undefined (bit :: uint8 \<Rightarrow> _) w n else bit (Rep_uint8 w) (nat_of_integer n))"
	unfolding uint8_test_bit_def
	by (simp add: bit_uint8.rep_eq)

	code_printing constant uint8_test_bit \<rightharpoonup>
	(SML) "Uint8.test'_bit" and
	(Haskell) "Data'_Bits.testBitBounded" and
	(Scala) "Uint8.test'_bit" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_test'_bit out of bounds\") else Uint8.test'_bit x i)"


	definition uint8_set_bit :: "uint8 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint8"
	where [code del]:
	"uint8_set_bit x n b =
	(if n < 0 \<or> 7 < n then undefined (set_bit :: uint8 \<Rightarrow> _) x n b
	else set_bit x (nat_of_integer n) b)"

	lemma set_bit_uint8_code [code]:
	"set_bit x n b = (if n < 8 then uint8_set_bit x (integer_of_nat n) b else x)"
	including undefined_transfer integer.lifting unfolding uint8_set_bit_def
	by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

	lemma uint8_set_bit_code [code]:
	"Rep_uint8 (uint8_set_bit w n b) =
	(if n < 0 \<or> 7 < n then Rep_uint8 (undefined (set_bit :: uint8 \<Rightarrow> _) w n b)
	else set_bit (Rep_uint8 w) (nat_of_integer n) b)"
	including undefined_transfer unfolding uint8_set_bit_def by transfer simp

	code_printing constant uint8_set_bit \<rightharpoonup>
	(SML) "Uint8.set'_bit" and
	(Haskell) "Data'_Bits.setBitBounded" and
	(Scala) "Uint8.set'_bit" and
	(Eval) "(fn x => fn i => fn b => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_set'_bit out of bounds\") else Uint8.set'_bit x i b)"


	definition uint8_shiftl :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
	where [code del]:
	"uint8_shiftl x n = (if n < 0 \<or> 8 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint8 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

	lemma shiftl_uint8_code [code]:
	"push_bit n x = (if n < 8 then uint8_shiftl x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint8_shiftl_def
	by transfer simp

	lemma uint8_shiftl_code [code]:
	"Rep_uint8 (uint8_shiftl w n) =
	(if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined (push_bit :: nat \<Rightarrow> uint8 \<Rightarrow> _) w n)
	else push_bit (nat_of_integer n) (Rep_uint8 w))"
	including undefined_transfer unfolding uint8_shiftl_def
	by transfer simp

	code_printing constant uint8_shiftl \<rightharpoonup>
	(SML) "Uint8.shiftl" and
	(Haskell) "Data'_Bits.shiftlBounded" and
	(Scala) "Uint8.shiftl" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_shiftl out of bounds\") else Uint8.shiftl x i)"

	definition uint8_shiftr :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
	where [code del]:
	"uint8_shiftr x n = (if n < 0 \<or> 8 \<le> n then undefined (drop_bit :: _ \<Rightarrow> _ \<Rightarrow> uint8) x n else drop_bit (nat_of_integer n) x)"

	lemma shiftr_uint8_code [code]:
	"drop_bit n x = (if n < 8 then uint8_shiftr x (integer_of_nat n) else 0)"
	including undefined_transfer integer.lifting unfolding uint8_shiftr_def
	by transfer simp

	lemma uint8_shiftr_code [code]:
	"Rep_uint8 (uint8_shiftr w n) =
	(if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined (drop_bit :: _ \<Rightarrow> _ \<Rightarrow> uint8) w n)
	else drop_bit (nat_of_integer n) (Rep_uint8 w))"
	including undefined_transfer unfolding uint8_shiftr_def by transfer simp

	code_printing constant uint8_shiftr \<rightharpoonup>
	(SML) "Uint8.shiftr" and
	(Haskell) "Data'_Bits.shiftrBounded" and
	(Scala) "Uint8.shiftr" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_shiftr out of bounds\") else Uint8.shiftr x i)"

	definition uint8_sshiftr :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
	where [code del]:
	"uint8_sshiftr x n =
	(if n < 0 \<or> 8 \<le> n then undefined signed_drop_bit_uint8 n x else signed_drop_bit_uint8 (nat_of_integer n) x)"

	lemma sshiftr_uint8_code [code]:
	"signed_drop_bit_uint8 n x =
	(if n < 8 then uint8_sshiftr x (integer_of_nat n) else if bit x 7 then -1 else 0)"
	including undefined_transfer integer.lifting unfolding uint8_sshiftr_def
	by transfer (simp add: not_less signed_drop_bit_beyond word_size)

	lemma uint8_sshiftr_code [code]:
	"Rep_uint8 (uint8_sshiftr w n) =
	(if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined signed_drop_bit_uint8 n w)
	else signed_drop_bit (nat_of_integer n) (Rep_uint8 w))"
	including undefined_transfer unfolding uint8_sshiftr_def
	by transfer simp

	code_printing constant uint8_sshiftr \<rightharpoonup>
	(SML) "Uint8.shiftr'_signed" and
	(Haskell)
	"(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint8.Int8) _)) :: Uint8.Word8)" and
	(Scala) "Uint8.shiftr'_signed" and
	(Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_sshiftr out of bounds\") else Uint8.shiftr'_signed x i)"

	context
	includes bit_operations_syntax
	begin

	lemma uint8_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint8) 7"
	by transfer (simp add: msb_word_iff_bit)

	lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint8_test_bit x 7"
	by (simp add: uint8_test_bit_def uint8_msb_test_bit)

	lemma uint8_of_int_code [code]:
	"uint8_of_int i = Uint8 (integer_of_int i)"
	including integer.lifting by transfer simp

	lemma int_of_uint8_code [code]:
	"int_of_uint8 x = int_of_integer (integer_of_uint8 x)"
	by (simp add: int_of_uint8.rep_eq integer_of_uint8_def)

	lemma uint8_of_nat_code [code]:
	"uint8_of_nat = uint8_of_int \<circ> int"
	by transfer (simp add: fun_eq_iff)

	lemma nat_of_uint8_code [code]:
	"nat_of_uint8 x = nat_of_integer (integer_of_uint8 x)"
	unfolding integer_of_uint8_def including integer.lifting by transfer simp

	definition integer_of_uint8_signed :: "uint8 \<Rightarrow> integer"
	where
	"integer_of_uint8_signed n = (if bit n 7 then undefined integer_of_uint8 n else integer_of_uint8 n)"

	lemma integer_of_uint8_signed_code [code]:
	"integer_of_uint8_signed n =
	(if bit n 7 then undefined integer_of_uint8 n else integer_of_int (uint (Rep_uint8' n)))"
	by (simp add: integer_of_uint8_signed_def integer_of_uint8_def)

	lemma integer_of_uint8_code [code]:
	"integer_of_uint8 n =
	(if bit n 7 then integer_of_uint8_signed (n AND 0x7F) OR 0x80 else integer_of_uint8_signed n)"
	proof -
	have \<open>integer_of_uint8_signed (n AND 0x7F) OR 0x80 = Bit_Operations.set_bit 7 (integer_of_uint8_signed (take_bit 7 n))\<close>
	by (simp add: take_bit_eq_mask set_bit_eq_or push_bit_eq_mult mask_eq_exp_minus_1)
	moreover have \<open>integer_of_uint8 n = Bit_Operations.set_bit 7 (integer_of_uint8 (take_bit 7 n))\<close> if \<open>bit n 7\<close>
	proof (rule bit_eqI)
	fix m
	from that show \<open>bit (integer_of_uint8 n) m = bit (Bit_Operations.set_bit 7 (integer_of_uint8 (take_bit 7 n))) m\<close> for m
	including integer.lifting by transfer (auto simp add: bit_simps dest: bit_imp_le_length)
	qed
	ultimately show ?thesis
	by simp (simp add: integer_of_uint8_signed_def bit_simps)
	qed

	end

	code_printing
	constant "integer_of_uint8" \<rightharpoonup>
	(SML) "IntInf.fromLarge (Word8.toLargeInt _)" and
	(Haskell) "Prelude.toInteger"
	\| constant "integer_of_uint8_signed" \<rightharpoonup>
	(Scala) "BigInt"

	section \<open>Quickcheck setup\<close>

	definition uint8_of_natural :: "natural \<Rightarrow> uint8"
	where "uint8_of_natural x \<equiv> Uint8 (integer_of_natural x)"

	instantiation uint8 :: "{random, exhaustive, full_exhaustive}" begin
	definition "random_uint8 \<equiv> qc_random_cnv uint8_of_natural"
	definition "exhaustive_uint8 \<equiv> qc_exhaustive_cnv uint8_of_natural"
	definition "full_exhaustive_uint8 \<equiv> qc_full_exhaustive_cnv uint8_of_natural"
	instance ..
	end

	instantiation uint8 :: narrowing begin

	interpretation quickcheck_narrowing_samples
	"\<lambda>i. let x = Uint8 i in (x, 0xFF - x)" "0"
	"Typerep.Typerep (STR ''Uint8.uint8'') []" .

	definition "narrowing_uint8 d = qc_narrowing_drawn_from (narrowing_samples d) d"
	declare [[code drop: "partial_term_of :: uint8 itself \<Rightarrow> _"]]
	lemmas partial_term_of_uint8 [code] = partial_term_of_code

	instance ..
	end

	end
	diff --git a/thys/Native_Word/Uint_Userguide.thy b/thys/Native_Word/Uint_Userguide.thy
	--- a/thys/Native_Word/Uint_Userguide.thy
	+++ b/thys/Native_Word/Uint_Userguide.thy
	@@ -1,343 +1,343 @@
	(* Title: Uint_Userguide.thy
	Author: Andreas Lochbihler, ETH Zurich
	*)

	chapter \<open>User guide for native words\<close>

	(<)
	theory Uint_Userguide imports
	Uint32
	Uint16
	- Code_Target_Bits_Int
	+ Code_Target_Int_Bit
	begin
	(>)

	text \<open>
	This tutorial explains how to best use the types for native
	words like @{typ "uint32"} in your formalisation.
	You can base your formalisation
	\begin{enumerate}
	\item either directly on these types,
	\item or on the generic @{typ "'a word"} and only introduce native
	words a posteriori via code generator refinement.
	\end{enumerate}

	The first option causes the least overhead if you have to prove only
	little about the words you use and start a fresh formalisation.
	Just use the native type @{typ uint32} instead of @{typ "32 word"}
	and similarly for \<open>uint64\<close>, \<open>uint16\<close>, and \<open>uint8\<close>.
	As native word types are meant only for code generation, the lemmas
	about @{typ "'a word"} have not been duplicated, but you can transfer
	theorems between native word types and @{typ "'a word"} using the
	transfer package.

	Note, however, that this option restricts your work a bit:
	your own functions cannot be ``polymorphic'' in the word length,
	but you have to define a separate function for every word length you need.

	The second option is recommended if you already have a formalisation
	based on @{typ "'a word"} or if your proofs involve words and their
	properties. It separates code generation from modelling and proving,
	i.e., you can work with words as usual. Consequently, you have to
	manually setup the code generator to use the native types wherever
	you want. The following describes how to achieve this with moderate
	effort.

	Note, however, that some target languages of the code generator
	(especially OCaml) do not support all the native word types provided.
	Therefore, you should only import those types that you need -- the
	theory file for each type mentions at the top the restrictions for
	code generation. For example, PolyML does not provide the Word16
	structure, and OCaml provides neither Word8 nor Word16.
	You can still use these theories provided that you also import
	- the theory @{theory Native_Word.Code_Target_Bits_Int} (which implements
	+ the theory @{theory Native_Word.Code_Target_Int_Bit} (which implements
	@{typ int} by target-language integers), but these words will
	be implemented via Isabelle's \<open>Word\<close> library, i.e.,
	you do not gain anything in terms of efficiency.

	\textbf{There is a separate code target \<open>SML_word\<close> for SML.}
	If you use one of the native words that PolyML does not support
	(such as \<open>uint16\<close> and \<open>uint64\<close> in 32-bit mode), but would
	like to map its operations to the Standard Basis Library functions,
	make sure to use the target \<open>SML_word\<close> instead of \<open>SML\<close>;
	if you only use native word sizes that PolyML supports, you can stick
	with \<open>SML\<close>. This ensures that code generation within Isabelle
	as used by \<open>Quickcheck\<close>, \<open>value\<close> and @\{code\} in ML blocks
	continues to work.
	\<close>

	section \<open>Lifting functions from @{typ "'a word"} to native words\<close>

	text \<open>
	This section shows how to convert functions from @{typ "'a word"} to native
	words. For example, the following function \<open>sum_squares\<close> computes
	the sum of the first @{term n} square numbers in 16 bit arithmetic using
	a tail-recursive function \<open>gen_sum_squares\<close> with accumulator;
	for convenience, \<open>sum_squares_int\<close> takes an integer instead of a word.
	\<close>

	function gen_sum_squares :: "16 word \<Rightarrow> 16 word \<Rightarrow> 16 word" where (<)[simp del]:(>)

	"gen_sum_squares accum n =
	(if n = 0 then accum else gen_sum_squares (accum + n * n) (n - 1))"
	(<)by pat_completeness simp
	termination by (relation \<open>measure (nat \<circ> uint \<circ> snd)\<close>) (simp_all add: measure_unat)(>)

	definition sum_squares :: "16 word \<Rightarrow> 16 word" where
	"sum_squares = gen_sum_squares 0"

	definition sum_squares_int :: "int \<Rightarrow> 16 word" where
	"sum_squares_int n = sum_squares (word_of_int n)"

	text \<open>
	The generated code for @{term sum_squares} and @{term sum_squares_int}
	emulates words with unbounded integers and explicit modulus as specified
	in the theory @{theory "HOL-Library.Word"}. But for efficiency, we want that the
	generated code uses machine words and machine arithmetic. Unfortunately,
	as @{typ "'a word"} is polymorphic in the word length, the code generator
	can only do this if we use another type for machine words. The theory
	@{theory Native_Word.Uint16} defines the type @{typ uint16} for machine words of
	16~bits. We just have to follow two steps to use it:

	First, we lift all our functions from @{typ "16 word"} to @{typ uint16},
	i.e., @{term sum_squares}, @{term gen_sum_squares}, and
	@{term sum_squares_int} in our case. The theory @{theory Native_Word.Uint16} sets
	up the lifting package for this and has already taken care of the
	arithmetic and bit-wise operations.
	\<close>
	lift_definition gen_sum_squares_uint :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
	is gen_sum_squares .
	lift_definition sum_squares_uint :: "uint16 \<Rightarrow> uint16" is sum_squares .
	lift_definition sum_squares_int_uint :: "int \<Rightarrow> uint16" is sum_squares_int .

	text \<open>
	Second, we also have to transfer the code equations for our functions.
	The attribute \<open>Transfer.transferred\<close> takes care of that, but it is
	better to check that the transfer succeeded: inspect the theorem to check
	that the new constants are used throughout.
	\<close>

	lemmas [Transfer.transferred, code] =
	gen_sum_squares.simps
	sum_squares_def
	sum_squares_int_def

	text \<open>
	Finally, we export the code to standard ML. We use the target
	\<open>SML_word\<close> instead of \<open>SML\<close> to have the operations
	on @{typ uint16} mapped to the Standard Basis Library. As PolyML
	does not provide a Word16 type, the mapping for @{typ uint16} is only
	active in the refined target \<open>SML_word\<close>.
	\<close>
	export_code sum_squares_int_uint in SML_word

	text \<open>
	Nevertheless, we can still evaluate terms with @{term "uint16"} within
	Isabelle, i.e., PolyML, but this will be translated to @{typ "16 word"}
	and therefore less efficient.
	\<close>

	value "sum_squares_int_uint 40"

	section \<open>Storing native words in datatypes\<close>

	text \<open>
	The above lifting is necessary for all functions whose type mentions
	the word type. Fortunately, we do not have to duplicate functions that
	merely operate on datatypes that contain words. Nevertheless, we have
	to tell the code generator that these functions should call the new ones,
	which operate on machine words. This section shows how to achieve this
	with data refinement.
	\<close>

	subsection \<open>Example: expressions and two semantics\<close>

	text \<open>
	As the running example, we consider a language of expressions (literal values, less-than comparisions and conditional) where values are either booleans or 32-bit words.
	The original specification uses the type @{typ "32 word"}.
	\<close>

	datatype val = Bool bool \| Word "32 word"
	datatype expr = Lit val \| LT expr expr \| IF expr expr expr

	abbreviation (input) word :: "32 word \<Rightarrow> expr" where "word i \<equiv> Lit (Word i)"
	abbreviation (input) bool :: "bool \<Rightarrow> expr" where "bool i \<equiv> Lit (Bool i)"

	\<comment> \<open>Denotational semantics of expressions, @{term None} denotes a type error\<close>
	fun eval :: "expr \<Rightarrow> val option" where
	"eval (Lit v) = Some v"
	\| "eval (LT e\<^sub>1 e\<^sub>2) =
	(case (eval e\<^sub>1, eval e\<^sub>2)
	of (Some (Word i\<^sub>1), Some (Word i\<^sub>2)) \<Rightarrow> Some (Bool (i\<^sub>1 < i\<^sub>2))
	\| _ \<Rightarrow> None)"
	\| "eval (IF e\<^sub>1 e\<^sub>2 e\<^sub>3) =
	(case eval e\<^sub>1 of Some (Bool b) \<Rightarrow> if b then eval e\<^sub>2 else eval e\<^sub>3
	\| _ \<Rightarrow> None)"

	\<comment> \<open>Small-step semantics of expressions, it gets stuck upon type errors.\<close>
	inductive step :: "expr \<Rightarrow> expr \<Rightarrow> bool" ("_ \<rightarrow> _" [50, 50] 60) where
	"e \<rightarrow> e' \<Longrightarrow> LT e e\<^sub>2 \<rightarrow> LT e' e\<^sub>2"
	\| "e \<rightarrow> e' \<Longrightarrow> LT (word i) e \<rightarrow> LT (word i) e'"
	\| "LT (word i\<^sub>1) (word i\<^sub>2) \<rightarrow> bool (i\<^sub>1 < i\<^sub>2)"
	\| "e \<rightarrow> e' \<Longrightarrow> IF e e\<^sub>1 e\<^sub>2 \<rightarrow> IF e' e\<^sub>1 e\<^sub>2"
	\| "IF (bool True) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>1"
	\| "IF (bool False) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>2"

	\<comment> \<open>Compile the inductive definition with the predicate compiler\<close>
	code_pred (modes: i \<Rightarrow> o \<Rightarrow> bool as reduce, i \<Rightarrow> i \<Rightarrow> bool as step') step .

	subsection \<open>Change the datatype to use machine words\<close>

	text \<open>
	Now, we want to use @{typ uint32} instead of @{typ "32 word"}.
	The goal is to make the code generator use the new type without
	duplicating any of the types (@{typ val}, @{typ expr}) or the
	functions (@{term eval}, @{term reduce}) on such types.

	The constructor @{term Word} has @{typ "32 word"} in its type, so
	we have to lift it to \<open>Word'\<close>, and the same holds for the
	case combinator @{term case_val}, which @{term case_val'} replaces.%
	\footnote{%
	Note that we should not declare a case translation for the new
	case combinator because this will break parsing case expressions
	with old case combinator.
	}
	Next, we set up the code generator accordingly:
	@{term Bool} and @{term Word'} are the new constructors for @{typ val},
	and @{term case_val'} is the new case combinator with an appropriate
	case certificate.%
	\footnote{%
	Case certificates tell the code generator to replace the HOL
	case combinator for a datatype with the case combinator of the
	target language. Without a case certificate, the code generator
	generates a function that re-implements the case combinator;
	in a strict languages like ML or Scala, this means that the code
	evaluates all possible cases before it decides which one is taken.

	Case certificates are described in Haftmann's PhD thesis
	\cite[Def.\ 27]{Haftmann2009PhD}. For a datatype \<open>dt\<close>
	with constructors \<open>C\<^sub>1\<close> to \<open>C\<^sub>n\<close>
	where each constructor \<open>C\<^sub>i\<close> takes \<open>k\<^sub>i\<close> parameters,
	the certificate for the case combinator \<open>case_dt\<close>
	looks as follows:

	{
	\isamarkuptrue\isacommand{lemma}\isamarkupfalse\isanewline%
	\ \ \isakeyword{assumes}\ {\isachardoublequoteopen}CASE\ {\isasymequiv}\ dt{\isacharunderscore}case\ c\isactrlsub {\isadigit{1}}\ c\isactrlsub {\isadigit{2}}\ \ldots\ c\isactrlsub{n}{\isachardoublequoteclose}\isanewline
	\ \ \isakeyword{shows}\ {\isachardoublequoteopen}{\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\isanewline
	\ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\isanewline
	\ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ \ldots\isanewline
	\ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}{\isachardoublequoteclose}\isanewline
	}
	}
	We delete the code equations for the old constructor @{term Word}
	and case combinator @{term case_val} such that the code generator
	reports missing adaptations.
	\<close>

	lift_definition Word' :: "uint32 \<Rightarrow> val" is Word .

	code_datatype Bool Word'

	lift_definition case_val' :: "(bool \<Rightarrow> 'a) \<Rightarrow> (uint32 \<Rightarrow> 'a) \<Rightarrow> val \<Rightarrow> 'a" is case_val .

	lemmas [code, simp] = val.case [Transfer.transferred]

	lemma case_val'_cert:
	fixes bool word' b w
	assumes "CASE \<equiv> case_val' bool word'"
	shows "(CASE (Bool b) \<equiv> bool b) &&& (CASE (Word' w) \<equiv> word' w)"
	by (simp_all add: assms)

	setup \<open>Code.declare_case_global @{thm case_val'_cert}\<close>

	declare [[code drop: case_val Word]]


	subsection \<open>Make functions use functions on machine words\<close>

	text \<open>
	Finally, we merely have to change the code equations to use the
	new functions that operate on @{typ uint32}. As before, the
	attribute \<open>Transfer.transferred\<close> does the job. In our example,
	we adapt the equality test on @{typ val} (code equations
	@{thm [source] val.eq.simps}) and the denotational and small-step
	semantics (code equations @{thm [source] eval.simps} and
	@{thm [source] step.equation}, respectively).

	We check that the adaptation has suceeded by exporting the functions.
	As we only use native word sizes that PolyML supports, we can use
	the usual target \<open>SML\<close> instead of \<open>SML_word\<close>.
	\<close>

	lemmas [code] =
	val.eq.simps[THEN meta_eq_to_obj_eq, Transfer.transferred, THEN eq_reflection]
	eval.simps[Transfer.transferred]
	step.equation[Transfer.transferred]

	export_code reduce step' eval checking SML

	section \<open>Troubleshooting\<close>

	text \<open>
	This section explains some possible problems when using native words.
	If you experience other difficulties, please contact the author.
	\<close>

	subsection \<open>\<open>export_code\<close> raises an exception \label{section:export_code:exception}\<close>

	text \<open>
	Probably, you have defined and are using a function on a native word type,
	but the code equation refers to emulated words. For example, the following
	defines a function \<open>double\<close> that doubles a word. When we try to export
	code for \<open>double\<close> without any further setup, \<open>export_code\<close> will
	raise an exception or generate code that does not compile.
	\<close>

	lift_definition double :: "uint32 \<Rightarrow> uint32" is "\<lambda>x. x + x" .

	text \<open>
	We have to prove a code equation that only uses the existing operations on
	@{typ uint32}. Then, \<open>export_code\<close> works again.
	\<close>

	lemma double_code [code]: "double n = n + n"
	by transfer simp

	subsection \<open>The generated code does not compile\<close>

	text \<open>
	Probably, you have been exporting to a target language for which there
	is no setup, or your compiler does not provide the required API. Every
	theory for native words mentions at the start the limitations on code
	generation. Check that your concrete application meets all the
	requirements.

	Alternatively, this might be an instance of the problem described
	in \S\ref{section:export_code:exception}.

	For Haskell, you have to enable the extension TypeSynonymInstances with \texttt{-XTypeSynonymInstances}
	if you are using polymorphic bit operations on the native word types.
	\<close>

	subsection \<open>The generated code is too slow\<close>

	text \<open>
	The generated code will most likely not be as fast as a direct implementation in the target language with manual tuning.
	This is because we want the configuration of the code generation to be sound (as it can be used to prove theorems in Isabelle).
	Therefore, the bit operations sometimes perform range checks before they call the target language API.
	Here are some examples:
	\begin{itemize}
	\item Shift distances and bit indices in target languages are often expected to fit into a bounded integer or word.
	However, the size of these types varies across target languages and platforms.
	Hence, no Isabelle/HOL type can model uniformly all of them.
	Instead, the bit operations use arbitrary-precision integers for such quantities and check at run-time that the values fit into a bounded integer or word, respectively -- if not, they raise an exception.

	\item Division and modulo operations explicitly test whether the divisor is $0$ and return the HOL value of division by $0$ in that case.
	This is necessary because some languages leave the behaviour of division by 0 unspecified.
	\end{itemize}

	If you have better ideas how to eliminate such checks and speed up the generated code without sacrificing soundness, please contact the author!
	\<close>

	(<)end(>)
	diff --git a/thys/Optics/Lens_Record.ML b/thys/Optics/Lens_Record.ML
	--- a/thys/Optics/Lens_Record.ML
	+++ b/thys/Optics/Lens_Record.ML
	@@ -1,343 +1,361 @@
	signature LENS_UTILS =
	sig
	val add_alphabet :
	(string * class list) list * binding ->
	string option -> (binding * typ * mixfix) list -> theory -> theory

	val add_alphabet_cmd :
	(string * string option) list * binding ->
	string option -> (binding * string * mixfix) list -> theory -> theory

	val rename_alpha_vars : tactic
	end;

	structure Lens_Utils : LENS_UTILS =
	struct

	open Syntax;
	open Lens_Lib;

	(* We set up the following syntactic entities that correspond to various parts of Isabelle syntax
	and names that we depend on. These code would need to be updated if the names of the Isabelle
	and lens theories and/or theorems change. *)

	val FLDLENS = "FLDLENS"
	val BASELENS = "BASELENS"
	val base_lensN = "base\<^sub>L"
	val child_lensN = "more\<^sub>L"
	val all_lensN = "all\<^sub>L"
	val base_moreN = "base_more"
	val bij_lens_suffix = "_bij_lens"
	val vwb_lens_suffix = "_vwb_lens"
	val sym_lens_suffix = "_sym_lens"
	val Trueprop = @{const_name Trueprop}
	val HOLeq = @{const_name HOL.eq}

	val lens_suffix = "\<^sub>v"
	val lens_defsN = "lens_defs"
	val lens_defs = (Binding.empty, [Token.make_src (lens_defsN, Position.none) []])
	val alpha_splitsN = "alpha_splits"
	val alpha_splits = [Token.make_src (alpha_splitsN, Position.none) []]
	val equivN = "equivs"
	val splits_suffix = ".splits"
	val defs_suffix = ".defs"
	val slens_view = "view"
	val slens_coview = "coview"

	(* The following code is adapted from the record package. We generate a record, but also create
	lenses for each field and prove properties about them. *)

	fun read_parent NONE ctxt = (NONE, ctxt)
	\| read_parent (SOME raw_T) ctxt =
	(case Proof_Context.read_typ_abbrev ctxt raw_T of
	Type (name, Ts) => (SOME (Ts, name), fold Variable.declare_typ Ts ctxt)
	\| T => error ("Bad parent record specification: " ^ Syntax.string_of_typ ctxt T));


	fun add_record_cmd overloaded (params, binding) raw_parent fields thy =
	let
	val ctxt = Proof_Context.init_global thy;
	val ctxt1 = fold (Variable.declare_typ o TFree) params ctxt;
	val (parent, ctxt2) = read_parent raw_parent ctxt1;
	val ctxt3 = fold Variable.declare_typ (map (fn (_, ty, _) => ty) fields) ctxt2
	val params' = (map (Proof_Context.check_tfree ctxt3) params);
	in thy \|> Record.add_record overloaded (params', binding) parent fields end;

	+(* Get all the parents of a given named record *)
	+
	+fun get_parents thy nm =
	+ case Record.get_parent thy nm of
	+ SOME (ts, nm') => (ts, nm') :: get_parents thy nm' \|
	+ NONE => [];
	+
	+
	(* Construct a theorem and proof that a given field lens is very well-behaved *)

	fun lens_proof tname x thy =
	let open Simplifier; open Global_Theory in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[mk_vwb_lens (const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x))]))
	(fn {context = context, prems = _}
	=> EVERY [ Locale.intro_locales_tac {strict = true, eager = true} context []
	, PARALLEL_ALLGOALS (asm_simp_tac
	(fold add_simp (get_thm thy (x ^ "_def") :: get_thms thy (tname ^ ".defs"))
	context))])
	end

	fun lens_sym_proof tname thy =
	let open Simplifier; open Global_Theory in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ (const sym_lensN $ const (Context.theory_name thy ^ "." ^ tname ^ "." ^ all_lensN))]))
	(fn {context = context, prems = _}
	=> EVERY [ Classical.rule_tac context [@{thm sym_lens.intro}] [] 1
	, PARALLEL_ALLGOALS (asm_simp_tac
	(fold add_simp (@{thms slens.defs} @ get_thms thy (tname ^ ".defs"))
	context))])
	end


	fun prove_lens_goal tname thy ctx =
	let open Simplifier; open Global_Theory in
	auto_tac (fold add_simp (get_thms thy lens_defsN @
	get_thms thy (tname ^ splits_suffix) @
	[@{thm prod.case_eq_if}]) ctx)
	end

	fun prove_indep tname thy =
	let open Simplifier; open Global_Theory in
	(fn {context, prems = _} =>
	EVERY [auto_tac (add_simp @{thm lens_indep_vwb_iff} context)
	,prove_lens_goal tname thy context])
	end

	fun prove_sublens tname thy =
	let open Simplifier; open Global_Theory in
	(fn {context, prems = _} =>
	EVERY [auto_tac (add_simp @{thm sublens_iff_sublens'} context)
	,prove_lens_goal tname thy context])
	end

	fun prove_quotient tname thy =
	let open Simplifier; open Global_Theory in
	(fn {context, prems = _} =>
	EVERY [prove_lens_goal tname thy context])
	end


	fun prove_equiv tname thy =
	let open Simplifier; open Global_Theory in
	(fn {context, prems = _} =>
	EVERY [auto_tac (add_simp @{thm lens_equiv_iff_lens_equiv'} context)
	,prove_lens_goal tname thy context])
	end

	(* Constrct a proof that base + more is a bijective lens *)

	fun lens_bij_proof tname thy =
	let open Simplifier; open Global_Theory in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ (const (bij_lensN) $
	(const (lens_plusN) $ const (Context.theory_name thy ^ "." ^ tname ^ "." ^ base_lensN)
	$ const (Context.theory_name thy ^ "." ^ tname ^ "." ^ child_lensN)))]))
	(fn {context = context, prems = _}
	=> EVERY [ Locale.intro_locales_tac {strict = true, eager = true} context []
	, auto_tac (fold add_simp (get_thms thy lens_defsN @ [@{thm prod.case_eq_if}])
	context)])
	end

	(* Construct a theorem and proof that two lenses, x and y, are independent. Since some lenses exist
	both with the source type as the record extension, and in the context of the extended record
	we need two versions of this function. The first shows it for the lenses on the extension, and
	thus uses an "intro_locales" as a means to discharge the individual lens laws of the vwb_lens
	locale. *)

	fun indep_proof tname thy (x, y) =
	let open Simplifier; open Global_Theory in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ mk_indep
	(const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x))
	(const (Context.theory_name thy ^ "." ^ tname ^ "." ^ y))
	]))
	(prove_indep tname thy)
	end

	fun equiv_more_proof tname pname thy fs =
	let open Simplifier; open Global_Theory; open Context; open Term in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ ( Const (lens_equivN, dummyT)
	$ Const (pname ^ "." ^ child_lensN, dummyT)
	$ foldr1 (fn (x, y) => Const (lens_plusN, dummyT) $ x $ y)
	(map (fn n => Const (theory_name thy ^ "." ^ tname ^ "." ^ n, dummyT)) (fs @ [child_lensN]))
	)]))
	(prove_equiv tname thy)
	end

	fun equiv_base_proof tname parent thy fs =
	let open Simplifier; open Global_Theory; open Context; open Term in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ ( Const (lens_equivN, dummyT)
	$ Const (theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
	$ foldr1 (fn (x, y) => Const (lens_plusN, dummyT) $ x $ y)
	((case parent of NONE => [] \| SOME (_, pname) => [Const (pname ^ "." ^ base_lensN, dummyT)]) @
	map (fn n => Const (theory_name thy ^ "." ^ tname ^ "." ^ n, dummyT)) fs)
	)]))
	(prove_equiv tname thy)
	end

	fun equiv_partition_proof tname thy =
	let open Simplifier; open Global_Theory; open Context; open Term in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ ( Const (lens_equivN, dummyT)
	$ ( Const (lens_plusN, dummyT)
	$ Const (theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
	$ Const (theory_name thy ^ "." ^ tname ^ "." ^ child_lensN, dummyT))
	$ Const (id_lensN, dummyT)
	)]))
	(prove_equiv tname thy)
	end

	(* Prove a theorem that every child lens is a sublens of the parent. *)

	fun sublens_proof tname pname thy y x =
	let open Simplifier; open Global_Theory in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ ( Const (sublensN, dummyT)
	$ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
	$ Const (pname ^ "." ^ y, dummyT)
	)]))
	(prove_sublens tname thy)
	end

	fun quotient_proof tname thy x =
	let open Simplifier; open Global_Theory in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ ( Const (HOLeq, dummyT)
	$ (Const (lens_quotientN, dummyT)
	$ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
	$ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
	)
	$ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
	)]))
	(prove_quotient tname thy)
	end

	fun composition_proof tname thy x =
	let open Simplifier; open Global_Theory in
	Goal.prove_global thy [] []
	(hd (Type_Infer_Context.infer_types
	(Proof_Context.init_global thy)
	[ Const (Trueprop, dummyT)
	$ ( Const (HOLeq, dummyT)
	$ (Const (lens_compN, dummyT)
	$ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
	$ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
	)
	$ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
	)]))
	(prove_quotient tname thy)
	end

	(* Finally we have the function that actually constructs the record, lenses for each field,
	independence proofs, and also sublens proofs. *)

	fun add_alphabet (params, binding) raw_parent ty_fields thy =
	let
	open Simplifier; open Global_Theory
	val tname = Binding.name_of binding
	val fields = map (fn (x, y, z) => (Binding.suffix_name lens_suffix x, y, z)) ty_fields
	val lnames = map (fn (x, _, _) => Binding.name_of x) ty_fields
	val (parent, _) = read_parent raw_parent (Proof_Context.init_global thy);
	fun ldef x = (x, x ^ " = " ^ FLDLENS ^ " " ^ x ^ lens_suffix)
	val pname = case parent of SOME (_,r) => r \| NONE => "";
	val plchild =
	case raw_parent of
	SOME _ => child_lensN \|
	NONE => ""
	val bldef = (base_lensN, base_lensN ^ " = " ^ BASELENS ^ " " ^ tname);
	val mldef = (child_lensN, child_lensN ^ " = " ^ FLDLENS ^ " more");
	val sldef = (all_lensN, all_lensN ^ " \<equiv> \<lparr> " ^ slens_view ^ " = " ^ base_lensN ^ ", " ^ slens_coview ^ " = " ^ child_lensN ^ " \<rparr>");
	val plnames = if (raw_parent = NONE) then [] else lnames @ [child_lensN];
	fun pindeps thy = map (fn thm => @{thm sublens_pres_indep} OF [thm]) (get_thms thy sublensesN)
	@ map (fn thm => @{thm sublens_pres_indep'} OF [thm]) (get_thms thy sublensesN)
	val attrs = map (Attrib.attribute (Named_Target.theory_init thy)) @{attributes [simp, code_unfold]}
	in thy (* Add a new record for the new alphabet lenses *)
	\|> add_record_cmd {overloaded = false} (params, binding) raw_parent fields
	(* Add the record definition theorems to lens_defs *)
	\|> Named_Target.theory_map (snd o Specification.theorems_cmd "" [((Binding.empty, []), [(Facts.named (tname ^ defs_suffix), snd lens_defs)])] [] false)
	(* Add the record splitting theorems to the alpha_splits set for proof automation *)
	\|> Named_Target.theory_map (snd o Specification.theorems_cmd "" [((Binding.empty, []), [(Facts.named (tname ^ splits_suffix), alpha_splits)])] [] false)
	+ (* Reorder parent splitting theorems, so the child ones have higher priority *)
	+ \|> (fn thy =>
	+ let
	+ (* Get the splitting theorems of all parents in reverse order *)
	+ val psplits = List.concat (map (#splits o Record.the_info thy) ((map snd (get_parents thy (Context.theory_name thy ^ "." ^ tname)))))
	+ (* Remove the splitting theorems *)
	+ val thy1 = Context.theory_map (fold (Named_Theorems.del_thm "Lens_Instances.alpha_splits") psplits) thy
	+ (* Add them again, so they have lower priority than the child splitting theorems *)
	+ val thy2 = Context.theory_map (fold (Named_Theorems.add_thm "Lens_Instances.alpha_splits") psplits) thy1
	+ in thy2 end)
	(* Add definitions for each of the lenses corresponding to each record field in-situ *)
	\|> Sign.qualified_path false binding
	\|> Named_Target.theory_map
	(fold (fn (n, d) => snd o Specification.definition_cmd (SOME (Binding.make (n, Position.none), NONE, NoSyn)) [] [] (lens_defs, d) true) (map ldef lnames @ [bldef, mldef]))
	(* Add definition of the underlying symmetric lens *)
	\|> Named_Target.theory_map
	(fold (fn (n, d) => Specification.abbreviation_cmd Syntax.mode_default (SOME (Binding.make (n, Position.none), NONE, NoSyn)) [] d true) [sldef])
	(* Add a vwb lens proof for each field lens *)
	\|> fold (fn x => fn thy => snd (add_thm ((Binding.make (x ^ vwb_lens_suffix, Position.none), lens_proof tname x thy), attrs) thy)) (lnames @ [base_lensN, child_lensN])
	(* Add a bij lens proof for the base and more lenses *)
	\|> (fn thy => snd (add_thm ((Binding.make (base_moreN ^ bij_lens_suffix, Position.none), lens_bij_proof tname thy), attrs) thy))
	(* Add sublens proofs *)
	\|> (fn thy => snd (add_thmss [((Binding.make (sublensesN, Position.none), map (sublens_proof tname pname thy plchild) plnames @ map (sublens_proof tname (Context.theory_name thy ^ "." ^ tname) thy base_lensN) lnames), attrs)] thy))
	(* Add quotient proofs *)
	\|> (fn thy => snd (add_thmss [((Binding.make (quotientsN, Position.none), map (quotient_proof tname thy) lnames), attrs)] thy))
	(* Add composition proofs *)
	\|> (fn thy => snd (add_thmss [((Binding.make (compositionsN, Position.none), map (composition_proof tname thy) lnames), attrs)] thy))
	(* Add independence proofs for each pairing of lenses *)
	\|> (fn thy => snd (add_thmss
	[((Binding.make (indepsN, Position.none), map (indep_proof tname thy) (pairings (lnames @ [child_lensN]) @ pairings [base_lensN, child_lensN]) (@ map (parent_indep_proof_1 tname pname thy plchild) plnames @ map (parent_indep_proof_2 tname pname thy plchild) plnames ) @ pindeps thy), attrs)] thy))
	(* Add equivalence properties *)
	\|> (fn thy => snd (add_thmss
	[((Binding.make (equivN, Position.none), (if (raw_parent = NONE) then [] else [equiv_more_proof tname pname thy lnames]) @ [equiv_base_proof tname parent thy lnames, equiv_partition_proof tname thy]), attrs)] thy))
	(* Add a symmetric lens proof for the base and more lenses *)
	\|> (fn thy => snd (add_thm ((Binding.make (all_lensN ^ sym_lens_suffix, Position.none), lens_sym_proof tname thy), attrs) thy))
	\|> Sign.parent_path
	end;


	fun add_alphabet_cmd (raw_params, binding) raw_parent raw_fields thy =
	let val ctx = (Proof_Context.init_global thy)
	val params = map (apsnd (Typedecl.read_constraint ctx)) raw_params;
	val ctx1 = fold (Variable.declare_typ o TFree) params ctx;
	val ty_fields = map (fn (x, y, z) => (x, Syntax.read_typ ctx1 y, z)) raw_fields
	in add_alphabet (params, binding) raw_parent ty_fields thy
	end

	fun remove_lens_suffixes i st =
	let
	val (_, _, Bi, _) = Thm.dest_state (st, i);
	val params = (map #1 (Logic.strip_params Bi))
	val params' =
	map (fn x => if (String.isSuffix lens_suffix x)
	then String.substring (x, 0, (String.size x - String.size lens_suffix))
	else x) params ;
	in if params = params' then Seq.empty else Seq.single (Thm.rename_params_rule (params', i) st)
	end;

	val rename_alpha_vars = ALLGOALS (fn i => PRIMSEQ (remove_lens_suffixes i));

	val _ =
	Outer_Syntax.command @{command_keyword alphabet} "define record with lenses"
	((Parse.type_args_constrained -- Parse.binding) --
	(@{keyword "="} \|-- Scan.option (Parse.typ --\| @{keyword "+"}) --
	Scan.repeat1 Parse.const_binding)
	>> (fn (x, (y, z)) =>
	Toplevel.theory (add_alphabet_cmd x y z)));
	end
	\ No newline at end of file
	diff --git a/thys/Ordered_Resolution_Prover/Abstract_Substitution.thy b/thys/Ordered_Resolution_Prover/Abstract_Substitution.thy
	--- a/thys/Ordered_Resolution_Prover/Abstract_Substitution.thy
	+++ b/thys/Ordered_Resolution_Prover/Abstract_Substitution.thy
	@@ -1,1271 +1,1323 @@
	(* Title: Abstract Substitutions
	Author: Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
	Author: Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
	Author: Anders Schlichtkrull <andschl at dtu.dk>, 2016, 2017
	Maintainer: Anders Schlichtkrull <andschl at dtu.dk>
	*)

	section \<open>Abstract Substitutions\<close>

	theory Abstract_Substitution
	imports Clausal_Logic Map2
	begin

	text \<open>
	Atoms and substitutions are abstracted away behind some locales, to avoid having a direct dependency
	on the IsaFoR library.

	Conventions: \<open>'s\<close> substitutions, \<open>'a\<close> atoms.
	\<close>


	subsection \<open>Library\<close>

	lemma f_Suc_decr_eventually_const:
	fixes f :: "nat \<Rightarrow> nat"
	assumes leq: "\<forall>i. f (Suc i) \<le> f i"
	shows "\<exists>l. \<forall>l' \<ge> l. f l' = f (Suc l')"
	proof (rule ccontr)
	assume a: "\<nexists>l. \<forall>l' \<ge> l. f l' = f (Suc l')"
	have "\<forall>i. \<exists>i'. i' > i \<and> f i' < f i"
	proof
	fix i
	from a have "\<exists>l' \<ge> i. f l' \<noteq> f (Suc l')"
	by auto
	then obtain l' where
	l'_p: "l' \<ge> i \<and> f l' \<noteq> f (Suc l')"
	by metis
	then have "f l' > f (Suc l')"
	using leq le_eq_less_or_eq by auto
	moreover have "f i \<ge> f l'"
	using leq l'_p by (induction l' arbitrary: i) (blast intro: lift_Suc_antimono_le)+
	ultimately show "\<exists>i' > i. f i' < f i"
	using l'_p less_le_trans by blast
	qed
	then obtain g_sm :: "nat \<Rightarrow> nat" where
	g_sm_p: "\<forall>i. g_sm i > i \<and> f (g_sm i) < f i"
	by metis

	define c :: "nat \<Rightarrow> nat" where
	"\<And>n. c n = (g_sm ^^ n) 0"

	have "f (c i) > f (c (Suc i))" for i
	by (induction i) (auto simp: c_def g_sm_p)
	then have "\<forall>i. (f \<circ> c) i > (f \<circ> c) (Suc i)"
	by auto
	then have "\<exists>fc :: nat \<Rightarrow> nat. \<forall>i. fc i > fc (Suc i)"
	by metis
	then show False
	using wf_less_than by (simp add: wf_iff_no_infinite_down_chain)
	qed


	subsection \<open>Substitution Operators\<close>

	locale substitution_ops =
	fixes
	subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
	id_subst :: 's and
	comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's"
	begin

	abbreviation subst_atm_abbrev :: "'a \<Rightarrow> 's \<Rightarrow> 'a" (infixl "\<cdot>a" 67) where
	"subst_atm_abbrev \<equiv> subst_atm"

	abbreviation comp_subst_abbrev :: "'s \<Rightarrow> 's \<Rightarrow> 's" (infixl "\<odot>" 67) where
	"comp_subst_abbrev \<equiv> comp_subst"

	definition comp_substs :: "'s list \<Rightarrow> 's list \<Rightarrow> 's list" (infixl "\<odot>s" 67) where
	"\<sigma>s \<odot>s \<tau>s = map2 comp_subst \<sigma>s \<tau>s"

	definition subst_atms :: "'a set \<Rightarrow> 's \<Rightarrow> 'a set" (infixl "\<cdot>as" 67) where
	"AA \<cdot>as \<sigma> = (\<lambda>A. A \<cdot>a \<sigma>) ` AA"

	definition subst_atmss :: "'a set set \<Rightarrow> 's \<Rightarrow> 'a set set" (infixl "\<cdot>ass" 67) where
	"AAA \<cdot>ass \<sigma> = (\<lambda>AA. AA \<cdot>as \<sigma>) ` AAA"

	definition subst_atm_list :: "'a list \<Rightarrow> 's \<Rightarrow> 'a list" (infixl "\<cdot>al" 67) where
	"As \<cdot>al \<sigma> = map (\<lambda>A. A \<cdot>a \<sigma>) As"

	definition subst_atm_mset :: "'a multiset \<Rightarrow> 's \<Rightarrow> 'a multiset" (infixl "\<cdot>am" 67) where
	"AA \<cdot>am \<sigma> = image_mset (\<lambda>A. A \<cdot>a \<sigma>) AA"

	definition
	subst_atm_mset_list :: "'a multiset list \<Rightarrow> 's \<Rightarrow> 'a multiset list" (infixl "\<cdot>aml" 67)
	where
	"AAA \<cdot>aml \<sigma> = map (\<lambda>AA. AA \<cdot>am \<sigma>) AAA"

	definition
	subst_atm_mset_lists :: "'a multiset list \<Rightarrow> 's list \<Rightarrow> 'a multiset list" (infixl "\<cdot>\<cdot>aml" 67)
	where
	"AAs \<cdot>\<cdot>aml \<sigma>s = map2 (\<cdot>am) AAs \<sigma>s"

	definition subst_lit :: "'a literal \<Rightarrow> 's \<Rightarrow> 'a literal" (infixl "\<cdot>l" 67) where
	"L \<cdot>l \<sigma> = map_literal (\<lambda>A. A \<cdot>a \<sigma>) L"

	lemma atm_of_subst_lit[simp]: "atm_of (L \<cdot>l \<sigma>) = atm_of L \<cdot>a \<sigma>"
	unfolding subst_lit_def by (cases L) simp+

	definition subst_cls :: "'a clause \<Rightarrow> 's \<Rightarrow> 'a clause" (infixl "\<cdot>" 67) where
	"AA \<cdot> \<sigma> = image_mset (\<lambda>A. A \<cdot>l \<sigma>) AA"

	definition subst_clss :: "'a clause set \<Rightarrow> 's \<Rightarrow> 'a clause set" (infixl "\<cdot>cs" 67) where
	"AA \<cdot>cs \<sigma> = (\<lambda>A. A \<cdot> \<sigma>) ` AA"

	definition subst_cls_list :: "'a clause list \<Rightarrow> 's \<Rightarrow> 'a clause list" (infixl "\<cdot>cl" 67) where
	"Cs \<cdot>cl \<sigma> = map (\<lambda>A. A \<cdot> \<sigma>) Cs"

	definition subst_cls_lists :: "'a clause list \<Rightarrow> 's list \<Rightarrow> 'a clause list" (infixl "\<cdot>\<cdot>cl" 67) where
	"Cs \<cdot>\<cdot>cl \<sigma>s = map2 (\<cdot>) Cs \<sigma>s"

	definition subst_cls_mset :: "'a clause multiset \<Rightarrow> 's \<Rightarrow> 'a clause multiset" (infixl "\<cdot>cm" 67) where
	"CC \<cdot>cm \<sigma> = image_mset (\<lambda>A. A \<cdot> \<sigma>) CC"

	lemma subst_cls_add_mset[simp]: "add_mset L C \<cdot> \<sigma> = add_mset (L \<cdot>l \<sigma>) (C \<cdot> \<sigma>)"
	unfolding subst_cls_def by simp

	lemma subst_cls_mset_add_mset[simp]: "add_mset C CC \<cdot>cm \<sigma> = add_mset (C \<cdot> \<sigma>) (CC \<cdot>cm \<sigma>)"
	unfolding subst_cls_mset_def by simp

	definition generalizes_atm :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
	"generalizes_atm A B \<longleftrightarrow> (\<exists>\<sigma>. A \<cdot>a \<sigma> = B)"

	definition strictly_generalizes_atm :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
	"strictly_generalizes_atm A B \<longleftrightarrow> generalizes_atm A B \<and> \<not> generalizes_atm B A"

	definition generalizes_lit :: "'a literal \<Rightarrow> 'a literal \<Rightarrow> bool" where
	"generalizes_lit L M \<longleftrightarrow> (\<exists>\<sigma>. L \<cdot>l \<sigma> = M)"

	definition strictly_generalizes_lit :: "'a literal \<Rightarrow> 'a literal \<Rightarrow> bool" where
	"strictly_generalizes_lit L M \<longleftrightarrow> generalizes_lit L M \<and> \<not> generalizes_lit M L"

	definition generalizes :: "'a clause \<Rightarrow> 'a clause \<Rightarrow> bool" where
	"generalizes C D \<longleftrightarrow> (\<exists>\<sigma>. C \<cdot> \<sigma> = D)"

	definition strictly_generalizes :: "'a clause \<Rightarrow> 'a clause \<Rightarrow> bool" where
	"strictly_generalizes C D \<longleftrightarrow> generalizes C D \<and> \<not> generalizes D C"

	definition subsumes :: "'a clause \<Rightarrow> 'a clause \<Rightarrow> bool" where
	"subsumes C D \<longleftrightarrow> (\<exists>\<sigma>. C \<cdot> \<sigma> \<subseteq># D)"

	definition strictly_subsumes :: "'a clause \<Rightarrow> 'a clause \<Rightarrow> bool" where
	"strictly_subsumes C D \<longleftrightarrow> subsumes C D \<and> \<not> subsumes D C"

	definition variants :: "'a clause \<Rightarrow> 'a clause \<Rightarrow> bool" where
	"variants C D \<longleftrightarrow> generalizes C D \<and> generalizes D C"

	definition is_renaming :: "'s \<Rightarrow> bool" where
	"is_renaming \<sigma> \<longleftrightarrow> (\<exists>\<tau>. \<sigma> \<odot> \<tau> = id_subst)"

	definition is_renaming_list :: "'s list \<Rightarrow> bool" where
	"is_renaming_list \<sigma>s \<longleftrightarrow> (\<forall>\<sigma> \<in> set \<sigma>s. is_renaming \<sigma>)"

	definition inv_renaming :: "'s \<Rightarrow> 's" where
	"inv_renaming \<sigma> = (SOME \<tau>. \<sigma> \<odot> \<tau> = id_subst)"

	definition is_ground_atm :: "'a \<Rightarrow> bool" where
	"is_ground_atm A \<longleftrightarrow> (\<forall>\<sigma>. A = A \<cdot>a \<sigma>)"

	definition is_ground_atms :: "'a set \<Rightarrow> bool" where
	"is_ground_atms AA = (\<forall>A \<in> AA. is_ground_atm A)"

	definition is_ground_atm_list :: "'a list \<Rightarrow> bool" where
	"is_ground_atm_list As \<longleftrightarrow> (\<forall>A \<in> set As. is_ground_atm A)"

	definition is_ground_atm_mset :: "'a multiset \<Rightarrow> bool" where
	"is_ground_atm_mset AA \<longleftrightarrow> (\<forall>A. A \<in># AA \<longrightarrow> is_ground_atm A)"

	definition is_ground_lit :: "'a literal \<Rightarrow> bool" where
	"is_ground_lit L \<longleftrightarrow> is_ground_atm (atm_of L)"

	definition is_ground_cls :: "'a clause \<Rightarrow> bool" where
	"is_ground_cls C \<longleftrightarrow> (\<forall>L. L \<in># C \<longrightarrow> is_ground_lit L)"

	definition is_ground_clss :: "'a clause set \<Rightarrow> bool" where
	"is_ground_clss CC \<longleftrightarrow> (\<forall>C \<in> CC. is_ground_cls C)"

	definition is_ground_cls_list :: "'a clause list \<Rightarrow> bool" where
	"is_ground_cls_list CC \<longleftrightarrow> (\<forall>C \<in> set CC. is_ground_cls C)"

	definition is_ground_subst :: "'s \<Rightarrow> bool" where
	"is_ground_subst \<sigma> \<longleftrightarrow> (\<forall>A. is_ground_atm (A \<cdot>a \<sigma>))"

	definition is_ground_subst_list :: "'s list \<Rightarrow> bool" where
	"is_ground_subst_list \<sigma>s \<longleftrightarrow> (\<forall>\<sigma> \<in> set \<sigma>s. is_ground_subst \<sigma>)"

	definition grounding_of_cls :: "'a clause \<Rightarrow> 'a clause set" where
	"grounding_of_cls C = {C \<cdot> \<sigma> \|\<sigma>. is_ground_subst \<sigma>}"

	definition grounding_of_clss :: "'a clause set \<Rightarrow> 'a clause set" where
	"grounding_of_clss CC = (\<Union>C \<in> CC. grounding_of_cls C)"

	definition is_unifier :: "'s \<Rightarrow> 'a set \<Rightarrow> bool" where
	"is_unifier \<sigma> AA \<longleftrightarrow> card (AA \<cdot>as \<sigma>) \<le> 1"

	definition is_unifiers :: "'s \<Rightarrow> 'a set set \<Rightarrow> bool" where
	"is_unifiers \<sigma> AAA \<longleftrightarrow> (\<forall>AA \<in> AAA. is_unifier \<sigma> AA)"

	definition is_mgu :: "'s \<Rightarrow> 'a set set \<Rightarrow> bool" where
	"is_mgu \<sigma> AAA \<longleftrightarrow> is_unifiers \<sigma> AAA \<and> (\<forall>\<tau>. is_unifiers \<tau> AAA \<longrightarrow> (\<exists>\<gamma>. \<tau> = \<sigma> \<odot> \<gamma>))"

	+definition is_imgu :: "'s \<Rightarrow> 'a set set \<Rightarrow> bool" where
	+ "is_imgu \<sigma> AAA \<longleftrightarrow> is_unifiers \<sigma> AAA \<and> (\<forall>\<tau>. is_unifiers \<tau> AAA \<longrightarrow> \<tau> = \<sigma> \<odot> \<tau>)"
	+
	definition var_disjoint :: "'a clause list \<Rightarrow> bool" where
	"var_disjoint Cs \<longleftrightarrow>
	(\<forall>\<sigma>s. length \<sigma>s = length Cs \<longrightarrow> (\<exists>\<tau>. \<forall>i < length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> S \<cdot> \<sigma>s ! i = S \<cdot> \<tau>))"

	end


	subsection \<open>Substitution Lemmas\<close>

	locale substitution = substitution_ops subst_atm id_subst comp_subst
	for
	subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
	id_subst :: 's and
	comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" +
	- fixes
	- renamings_apart :: "'a clause list \<Rightarrow> 's list" and
	- atm_of_atms :: "'a list \<Rightarrow> 'a"
	assumes
	subst_atm_id_subst[simp]: "A \<cdot>a id_subst = A" and
	subst_atm_comp_subst[simp]: "A \<cdot>a (\<sigma> \<odot> \<tau>) = (A \<cdot>a \<sigma>) \<cdot>a \<tau>" and
	subst_ext: "(\<And>A. A \<cdot>a \<sigma> = A \<cdot>a \<tau>) \<Longrightarrow> \<sigma> = \<tau>" and
	make_ground_subst: "is_ground_cls (C \<cdot> \<sigma>) \<Longrightarrow> \<exists>\<tau>. is_ground_subst \<tau> \<and>C \<cdot> \<tau> = C \<cdot> \<sigma>" and
	- wf_strictly_generalizes_atm: "wfP strictly_generalizes_atm" and
	- renamings_apart_length: "length (renamings_apart Cs) = length Cs" and
	- renamings_apart_renaming: "\<rho> \<in> set (renamings_apart Cs) \<Longrightarrow> is_renaming \<rho>" and
	- renamings_apart_var_disjoint: "var_disjoint (Cs \<cdot>\<cdot>cl (renamings_apart Cs))" and
	- atm_of_atms_subst:
	- "\<And>As Bs. atm_of_atms As \<cdot>a \<sigma> = atm_of_atms Bs \<longleftrightarrow> map (\<lambda>A. A \<cdot>a \<sigma>) As = Bs"
	+ wf_strictly_generalizes_atm: "wfP strictly_generalizes_atm"
	begin

	lemma subst_ext_iff: "\<sigma> = \<tau> \<longleftrightarrow> (\<forall>A. A \<cdot>a \<sigma> = A \<cdot>a \<tau>)"
	by (blast intro: subst_ext)


	subsubsection \<open>Identity Substitution\<close>

	lemma id_subst_comp_subst[simp]: "id_subst \<odot> \<sigma> = \<sigma>"
	by (rule subst_ext) simp

	lemma comp_subst_id_subst[simp]: "\<sigma> \<odot> id_subst = \<sigma>"
	by (rule subst_ext) simp

	lemma id_subst_comp_substs[simp]: "replicate (length \<sigma>s) id_subst \<odot>s \<sigma>s = \<sigma>s"
	using comp_substs_def by (induction \<sigma>s) auto

	lemma comp_substs_id_subst[simp]: "\<sigma>s \<odot>s replicate (length \<sigma>s) id_subst = \<sigma>s"
	using comp_substs_def by (induction \<sigma>s) auto

	lemma subst_atms_id_subst[simp]: "AA \<cdot>as id_subst = AA"
	unfolding subst_atms_def by simp

	lemma subst_atmss_id_subst[simp]: "AAA \<cdot>ass id_subst = AAA"
	unfolding subst_atmss_def by simp

	lemma subst_atm_list_id_subst[simp]: "As \<cdot>al id_subst = As"
	unfolding subst_atm_list_def by auto

	lemma subst_atm_mset_id_subst[simp]: "AA \<cdot>am id_subst = AA"
	unfolding subst_atm_mset_def by simp

	lemma subst_atm_mset_list_id_subst[simp]: "AAs \<cdot>aml id_subst = AAs"
	unfolding subst_atm_mset_list_def by simp

	lemma subst_atm_mset_lists_id_subst[simp]: "AAs \<cdot>\<cdot>aml replicate (length AAs) id_subst = AAs"
	unfolding subst_atm_mset_lists_def by (induct AAs) auto

	lemma subst_lit_id_subst[simp]: "L \<cdot>l id_subst = L"
	unfolding subst_lit_def by (simp add: literal.map_ident)

	lemma subst_cls_id_subst[simp]: "C \<cdot> id_subst = C"
	unfolding subst_cls_def by simp

	lemma subst_clss_id_subst[simp]: "CC \<cdot>cs id_subst = CC"
	unfolding subst_clss_def by simp

	lemma subst_cls_list_id_subst[simp]: "Cs \<cdot>cl id_subst = Cs"
	unfolding subst_cls_list_def by simp

	lemma subst_cls_lists_id_subst[simp]: "Cs \<cdot>\<cdot>cl replicate (length Cs) id_subst = Cs"
	unfolding subst_cls_lists_def by (induct Cs) auto

	lemma subst_cls_mset_id_subst[simp]: "CC \<cdot>cm id_subst = CC"
	unfolding subst_cls_mset_def by simp


	subsubsection \<open>Associativity of Composition\<close>

	lemma comp_subst_assoc[simp]: "\<sigma> \<odot> (\<tau> \<odot> \<gamma>) = \<sigma> \<odot> \<tau> \<odot> \<gamma>"
	by (rule subst_ext) simp


	subsubsection \<open>Compatibility of Substitution and Composition\<close>

	lemma subst_atms_comp_subst[simp]: "AA \<cdot>as (\<tau> \<odot> \<sigma>) = AA \<cdot>as \<tau> \<cdot>as \<sigma>"
	unfolding subst_atms_def by auto

	lemma subst_atmss_comp_subst[simp]: "AAA \<cdot>ass (\<tau> \<odot> \<sigma>) = AAA \<cdot>ass \<tau> \<cdot>ass \<sigma>"
	unfolding subst_atmss_def by auto

	lemma subst_atm_list_comp_subst[simp]: "As \<cdot>al (\<tau> \<odot> \<sigma>) = As \<cdot>al \<tau> \<cdot>al \<sigma>"
	unfolding subst_atm_list_def by auto

	lemma subst_atm_mset_comp_subst[simp]: "AA \<cdot>am (\<tau> \<odot> \<sigma>) = AA \<cdot>am \<tau> \<cdot>am \<sigma>"
	unfolding subst_atm_mset_def by auto

	lemma subst_atm_mset_list_comp_subst[simp]: "AAs \<cdot>aml (\<tau> \<odot> \<sigma>) = (AAs \<cdot>aml \<tau>) \<cdot>aml \<sigma>"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_atm_mset_lists_comp_substs[simp]: "AAs \<cdot>\<cdot>aml (\<tau>s \<odot>s \<sigma>s) = AAs \<cdot>\<cdot>aml \<tau>s \<cdot>\<cdot>aml \<sigma>s"
	unfolding subst_atm_mset_lists_def comp_substs_def map_zip_map map_zip_map2 map_zip_assoc
	by (simp add: split_def)

	lemma subst_lit_comp_subst[simp]: "L \<cdot>l (\<tau> \<odot> \<sigma>) = L \<cdot>l \<tau> \<cdot>l \<sigma>"
	unfolding subst_lit_def by (auto simp: literal.map_comp o_def)

	lemma subst_cls_comp_subst[simp]: "C \<cdot> (\<tau> \<odot> \<sigma>) = C \<cdot> \<tau> \<cdot> \<sigma>"
	unfolding subst_cls_def by auto

	lemma subst_clsscomp_subst[simp]: "CC \<cdot>cs (\<tau> \<odot> \<sigma>) = CC \<cdot>cs \<tau> \<cdot>cs \<sigma>"
	unfolding subst_clss_def by auto

	lemma subst_cls_list_comp_subst[simp]: "Cs \<cdot>cl (\<tau> \<odot> \<sigma>) = Cs \<cdot>cl \<tau> \<cdot>cl \<sigma>"
	unfolding subst_cls_list_def by auto

	lemma subst_cls_lists_comp_substs[simp]: "Cs \<cdot>\<cdot>cl (\<tau>s \<odot>s \<sigma>s) = Cs \<cdot>\<cdot>cl \<tau>s \<cdot>\<cdot>cl \<sigma>s"
	unfolding subst_cls_lists_def comp_substs_def map_zip_map map_zip_map2 map_zip_assoc
	by (simp add: split_def)

	lemma subst_cls_mset_comp_subst[simp]: "CC \<cdot>cm (\<tau> \<odot> \<sigma>) = CC \<cdot>cm \<tau> \<cdot>cm \<sigma>"
	unfolding subst_cls_mset_def by auto


	subsubsection \<open>``Commutativity'' of Membership and Substitution\<close>

	lemma Melem_subst_atm_mset[simp]: "A \<in># AA \<cdot>am \<sigma> \<longleftrightarrow> (\<exists>B. B \<in># AA \<and> A = B \<cdot>a \<sigma>)"
	unfolding subst_atm_mset_def by auto

	lemma Melem_subst_cls[simp]: "L \<in># C \<cdot> \<sigma> \<longleftrightarrow> (\<exists>M. M \<in># C \<and> L = M \<cdot>l \<sigma>)"
	unfolding subst_cls_def by auto

	lemma Melem_subst_cls_mset[simp]: "AA \<in># CC \<cdot>cm \<sigma> \<longleftrightarrow> (\<exists>BB. BB \<in># CC \<and> AA = BB \<cdot> \<sigma>)"
	unfolding subst_cls_mset_def by auto


	subsubsection \<open>Signs and Substitutions\<close>

	lemma subst_lit_is_neg[simp]: "is_neg (L \<cdot>l \<sigma>) = is_neg L"
	unfolding subst_lit_def by auto

	lemma subst_lit_is_pos[simp]: "is_pos (L \<cdot>l \<sigma>) = is_pos L"
	unfolding subst_lit_def by auto

	lemma subst_minus[simp]: "(- L) \<cdot>l \<mu> = - (L \<cdot>l \<mu>)"
	by (simp add: literal.map_sel subst_lit_def uminus_literal_def)


	subsubsection \<open>Substitution on Literal(s)\<close>

	lemma eql_neg_lit_eql_atm[simp]: "(Neg A' \<cdot>l \<eta>) = Neg A \<longleftrightarrow> A' \<cdot>a \<eta> = A"
	by (simp add: subst_lit_def)

	lemma eql_pos_lit_eql_atm[simp]: "(Pos A' \<cdot>l \<eta>) = Pos A \<longleftrightarrow> A' \<cdot>a \<eta> = A"
	by (simp add: subst_lit_def)

	lemma subst_cls_negs[simp]: "(negs AA) \<cdot> \<sigma> = negs (AA \<cdot>am \<sigma>)"
	unfolding subst_cls_def subst_lit_def subst_atm_mset_def by auto

	lemma subst_cls_poss[simp]: "(poss AA) \<cdot> \<sigma> = poss (AA \<cdot>am \<sigma>)"
	unfolding subst_cls_def subst_lit_def subst_atm_mset_def by auto

	lemma atms_of_subst_atms: "atms_of C \<cdot>as \<sigma> = atms_of (C \<cdot> \<sigma>)"
	proof -
	have "atms_of (C \<cdot> \<sigma>) = set_mset (image_mset atm_of (image_mset (map_literal (\<lambda>A. A \<cdot>a \<sigma>)) C))"
	unfolding subst_cls_def subst_atms_def subst_lit_def atms_of_def by auto
	also have "... = set_mset (image_mset (\<lambda>A. A \<cdot>a \<sigma>) (image_mset atm_of C))"
	by simp (meson literal.map_sel)
	finally show "atms_of C \<cdot>as \<sigma> = atms_of (C \<cdot> \<sigma>)"
	unfolding subst_atms_def atms_of_def by auto
	qed

	lemma in_image_Neg_is_neg[simp]: "L \<cdot>l \<sigma> \<in> Neg ` AA \<Longrightarrow> is_neg L"
	by (metis bex_imageD literal.disc(2) literal.map_disc_iff subst_lit_def)

	lemma subst_lit_in_negs_subst_is_neg: "L \<cdot>l \<sigma> \<in># (negs AA) \<cdot> \<tau> \<Longrightarrow> is_neg L"
	by simp

	lemma subst_lit_in_negs_is_neg: "L \<cdot>l \<sigma> \<in># negs AA \<Longrightarrow> is_neg L"
	by simp


	subsubsection \<open>Substitution on Empty\<close>

	lemma subst_atms_empty[simp]: "{} \<cdot>as \<sigma> = {}"
	unfolding subst_atms_def by auto

	lemma subst_atmss_empty[simp]: "{} \<cdot>ass \<sigma> = {}"
	unfolding subst_atmss_def by auto

	lemma comp_substs_empty_iff[simp]: "\<sigma>s \<odot>s \<eta>s = [] \<longleftrightarrow> \<sigma>s = [] \<or> \<eta>s = []"
	using comp_substs_def map2_empty_iff by auto

	lemma subst_atm_list_empty[simp]: "[] \<cdot>al \<sigma> = []"
	unfolding subst_atm_list_def by auto

	lemma subst_atm_mset_empty[simp]: "{#} \<cdot>am \<sigma> = {#}"
	unfolding subst_atm_mset_def by auto

	lemma subst_atm_mset_list_empty[simp]: "[] \<cdot>aml \<sigma> = []"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_atm_mset_lists_empty[simp]: "[] \<cdot>\<cdot>aml \<sigma>s = []"
	unfolding subst_atm_mset_lists_def by auto

	lemma subst_cls_empty[simp]: "{#} \<cdot> \<sigma> = {#}"
	unfolding subst_cls_def by auto

	lemma subst_clss_empty[simp]: "{} \<cdot>cs \<sigma> = {}"
	unfolding subst_clss_def by auto

	lemma subst_cls_list_empty[simp]: "[] \<cdot>cl \<sigma> = []"
	unfolding subst_cls_list_def by auto

	lemma subst_cls_lists_empty[simp]: "[] \<cdot>\<cdot>cl \<sigma>s = []"
	unfolding subst_cls_lists_def by auto

	lemma subst_scls_mset_empty[simp]: "{#} \<cdot>cm \<sigma> = {#}"
	unfolding subst_cls_mset_def by auto

	lemma subst_atms_empty_iff[simp]: "AA \<cdot>as \<eta> = {} \<longleftrightarrow> AA = {}"
	unfolding subst_atms_def by auto

	lemma subst_atmss_empty_iff[simp]: "AAA \<cdot>ass \<eta> = {} \<longleftrightarrow> AAA = {}"
	unfolding subst_atmss_def by auto

	lemma subst_atm_list_empty_iff[simp]: "As \<cdot>al \<eta> = [] \<longleftrightarrow> As = []"
	unfolding subst_atm_list_def by auto

	lemma subst_atm_mset_empty_iff[simp]: "AA \<cdot>am \<eta> = {#} \<longleftrightarrow> AA = {#}"
	unfolding subst_atm_mset_def by auto

	lemma subst_atm_mset_list_empty_iff[simp]: "AAs \<cdot>aml \<eta> = [] \<longleftrightarrow> AAs = []"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_atm_mset_lists_empty_iff[simp]: "AAs \<cdot>\<cdot>aml \<eta>s = [] \<longleftrightarrow> (AAs = [] \<or> \<eta>s = [])"
	using map2_empty_iff subst_atm_mset_lists_def by auto

	lemma subst_cls_empty_iff[simp]: "C \<cdot> \<eta> = {#} \<longleftrightarrow> C = {#}"
	unfolding subst_cls_def by auto

	lemma subst_clss_empty_iff[simp]: "CC \<cdot>cs \<eta> = {} \<longleftrightarrow> CC = {}"
	unfolding subst_clss_def by auto

	lemma subst_cls_list_empty_iff[simp]: "Cs \<cdot>cl \<eta> = [] \<longleftrightarrow> Cs = []"
	unfolding subst_cls_list_def by auto

	lemma subst_cls_lists_empty_iff[simp]: "Cs \<cdot>\<cdot>cl \<eta>s = [] \<longleftrightarrow> Cs = [] \<or> \<eta>s = []"
	using map2_empty_iff subst_cls_lists_def by auto

	lemma subst_cls_mset_empty_iff[simp]: "CC \<cdot>cm \<eta> = {#} \<longleftrightarrow> CC = {#}"
	unfolding subst_cls_mset_def by auto


	subsubsection \<open>Substitution on a Union\<close>

	lemma subst_atms_union[simp]: "(AA \<union> BB) \<cdot>as \<sigma> = AA \<cdot>as \<sigma> \<union> BB \<cdot>as \<sigma>"
	unfolding subst_atms_def by auto

	lemma subst_atmss_union[simp]: "(AAA \<union> BBB) \<cdot>ass \<sigma> = AAA \<cdot>ass \<sigma> \<union> BBB \<cdot>ass \<sigma>"
	unfolding subst_atmss_def by auto

	lemma subst_atm_list_append[simp]: "(As @ Bs) \<cdot>al \<sigma> = As \<cdot>al \<sigma> @ Bs \<cdot>al \<sigma>"
	unfolding subst_atm_list_def by auto

	lemma subst_atm_mset_union[simp]: "(AA + BB) \<cdot>am \<sigma> = AA \<cdot>am \<sigma> + BB \<cdot>am \<sigma>"
	unfolding subst_atm_mset_def by auto

	lemma subst_atm_mset_list_append[simp]: "(AAs @ BBs) \<cdot>aml \<sigma> = AAs \<cdot>aml \<sigma> @ BBs \<cdot>aml \<sigma>"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_cls_union[simp]: "(C + D) \<cdot> \<sigma> = C \<cdot> \<sigma> + D \<cdot> \<sigma>"
	unfolding subst_cls_def by auto

	lemma subst_clss_union[simp]: "(CC \<union> DD) \<cdot>cs \<sigma> = CC \<cdot>cs \<sigma> \<union> DD \<cdot>cs \<sigma>"
	unfolding subst_clss_def by auto

	lemma subst_cls_list_append[simp]: "(Cs @ Ds) \<cdot>cl \<sigma> = Cs \<cdot>cl \<sigma> @ Ds \<cdot>cl \<sigma>"
	unfolding subst_cls_list_def by auto

	lemma subst_cls_lists_append[simp]:
	"length Cs = length \<sigma>s \<Longrightarrow> length Cs' = length \<sigma>s' \<Longrightarrow>
	(Cs @ Cs') \<cdot>\<cdot>cl (\<sigma>s @ \<sigma>s') = Cs \<cdot>\<cdot>cl \<sigma>s @ Cs' \<cdot>\<cdot>cl \<sigma>s'"
	unfolding subst_cls_lists_def by auto

	lemma subst_cls_mset_union[simp]: "(CC + DD) \<cdot>cm \<sigma> = CC \<cdot>cm \<sigma> + DD \<cdot>cm \<sigma>"
	unfolding subst_cls_mset_def by auto


	subsubsection \<open>Substitution on a Singleton\<close>

	lemma subst_atms_single[simp]: "{A} \<cdot>as \<sigma> = {A \<cdot>a \<sigma>}"
	unfolding subst_atms_def by auto

	lemma subst_atmss_single[simp]: "{AA} \<cdot>ass \<sigma> = {AA \<cdot>as \<sigma>}"
	unfolding subst_atmss_def by auto

	lemma subst_atm_list_single[simp]: "[A] \<cdot>al \<sigma> = [A \<cdot>a \<sigma>]"
	unfolding subst_atm_list_def by auto

	lemma subst_atm_mset_single[simp]: "{#A#} \<cdot>am \<sigma> = {#A \<cdot>a \<sigma>#}"
	unfolding subst_atm_mset_def by auto

	lemma subst_atm_mset_list[simp]: "[AA] \<cdot>aml \<sigma> = [AA \<cdot>am \<sigma>]"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_cls_single[simp]: "{#L#} \<cdot> \<sigma> = {#L \<cdot>l \<sigma>#}"
	by simp

	lemma subst_clss_single[simp]: "{C} \<cdot>cs \<sigma> = {C \<cdot> \<sigma>}"
	unfolding subst_clss_def by auto

	lemma subst_cls_list_single[simp]: "[C] \<cdot>cl \<sigma> = [C \<cdot> \<sigma>]"
	unfolding subst_cls_list_def by auto

	lemma subst_cls_lists_single[simp]: "[C] \<cdot>\<cdot>cl [\<sigma>] = [C \<cdot> \<sigma>]"
	unfolding subst_cls_lists_def by auto

	lemma subst_cls_mset_single[simp]: "{#C#} \<cdot>cm \<sigma> = {#C \<cdot> \<sigma>#}"
	by simp


	subsubsection \<open>Substitution on @{term Cons}\<close>

	lemma subst_atm_list_Cons[simp]: "(A # As) \<cdot>al \<sigma> = A \<cdot>a \<sigma> # As \<cdot>al \<sigma>"
	unfolding subst_atm_list_def by auto

	lemma subst_atm_mset_list_Cons[simp]: "(A # As) \<cdot>aml \<sigma> = A \<cdot>am \<sigma> # As \<cdot>aml \<sigma>"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_atm_mset_lists_Cons[simp]: "(C # Cs) \<cdot>\<cdot>aml (\<sigma> # \<sigma>s) = C \<cdot>am \<sigma> # Cs \<cdot>\<cdot>aml \<sigma>s"
	unfolding subst_atm_mset_lists_def by auto

	lemma subst_cls_list_Cons[simp]: "(C # Cs) \<cdot>cl \<sigma> = C \<cdot> \<sigma> # Cs \<cdot>cl \<sigma>"
	unfolding subst_cls_list_def by auto

	lemma subst_cls_lists_Cons[simp]: "(C # Cs) \<cdot>\<cdot>cl (\<sigma> # \<sigma>s) = C \<cdot> \<sigma> # Cs \<cdot>\<cdot>cl \<sigma>s"
	unfolding subst_cls_lists_def by auto


	subsubsection \<open>Substitution on @{term tl}\<close>

	lemma subst_atm_list_tl[simp]: "tl (As \<cdot>al \<sigma>) = tl As \<cdot>al \<sigma>"
	by (cases As) auto

	lemma subst_atm_mset_list_tl[simp]: "tl (AAs \<cdot>aml \<sigma>) = tl AAs \<cdot>aml \<sigma>"
	by (cases AAs) auto

	lemma subst_cls_list_tl[simp]: "tl (Cs \<cdot>cl \<sigma>) = tl Cs \<cdot>cl \<sigma>"
	by (cases Cs) auto

	lemma subst_cls_lists_tl[simp]: "length Cs = length \<sigma>s \<Longrightarrow> tl (Cs \<cdot>\<cdot>cl \<sigma>s) = tl Cs \<cdot>\<cdot>cl tl \<sigma>s"
	by (cases Cs; cases \<sigma>s) auto


	subsubsection \<open>Substitution on @{term nth}\<close>

	lemma comp_substs_nth[simp]:
	"length \<tau>s = length \<sigma>s \<Longrightarrow> i < length \<tau>s \<Longrightarrow> (\<tau>s \<odot>s \<sigma>s) ! i = (\<tau>s ! i) \<odot> (\<sigma>s ! i)"
	by (simp add: comp_substs_def)

	lemma subst_atm_list_nth[simp]: "i < length As \<Longrightarrow> (As \<cdot>al \<tau>) ! i = As ! i \<cdot>a \<tau>"
	unfolding subst_atm_list_def using less_Suc_eq_0_disj nth_map by force

	lemma subst_atm_mset_list_nth[simp]: "i < length AAs \<Longrightarrow> (AAs \<cdot>aml \<eta>) ! i = (AAs ! i) \<cdot>am \<eta>"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_atm_mset_lists_nth[simp]:
	"length AAs = length \<sigma>s \<Longrightarrow> i < length AAs \<Longrightarrow> (AAs \<cdot>\<cdot>aml \<sigma>s) ! i = (AAs ! i) \<cdot>am (\<sigma>s ! i)"
	unfolding subst_atm_mset_lists_def by auto

	lemma subst_cls_list_nth[simp]: "i < length Cs \<Longrightarrow> (Cs \<cdot>cl \<tau>) ! i = (Cs ! i) \<cdot> \<tau>"
	unfolding subst_cls_list_def using less_Suc_eq_0_disj nth_map by (induction Cs) auto

	lemma subst_cls_lists_nth[simp]:
	"length Cs = length \<sigma>s \<Longrightarrow> i < length Cs \<Longrightarrow> (Cs \<cdot>\<cdot>cl \<sigma>s) ! i = (Cs ! i) \<cdot> (\<sigma>s ! i)"
	unfolding subst_cls_lists_def by auto


	subsubsection \<open>Substitution on Various Other Functions\<close>

	lemma subst_clss_image[simp]: "image f X \<cdot>cs \<sigma> = {f x \<cdot> \<sigma> \| x. x \<in> X}"
	unfolding subst_clss_def by auto

	lemma subst_cls_mset_image_mset[simp]: "image_mset f X \<cdot>cm \<sigma> = {# f x \<cdot> \<sigma>. x \<in># X #}"
	unfolding subst_cls_mset_def by auto

	lemma mset_subst_atm_list_subst_atm_mset[simp]: "mset (As \<cdot>al \<sigma>) = mset (As) \<cdot>am \<sigma>"
	unfolding subst_atm_list_def subst_atm_mset_def by auto

	lemma mset_subst_cls_list_subst_cls_mset: "mset (Cs \<cdot>cl \<sigma>) = (mset Cs) \<cdot>cm \<sigma>"
	unfolding subst_cls_mset_def subst_cls_list_def by auto

	lemma sum_list_subst_cls_list_subst_cls[simp]: "sum_list (Cs \<cdot>cl \<eta>) = sum_list Cs \<cdot> \<eta>"
	unfolding subst_cls_list_def by (induction Cs) auto

	lemma set_mset_subst_cls_mset_subst_clss: "set_mset (CC \<cdot>cm \<mu>) = (set_mset CC) \<cdot>cs \<mu>"
	by (simp add: subst_cls_mset_def subst_clss_def)

	lemma Neg_Melem_subst_atm_subst_cls[simp]: "Neg A \<in># C \<Longrightarrow> Neg (A \<cdot>a \<sigma>) \<in># C \<cdot> \<sigma> "
	by (metis Melem_subst_cls eql_neg_lit_eql_atm)

	lemma Pos_Melem_subst_atm_subst_cls[simp]: "Pos A \<in># C \<Longrightarrow> Pos (A \<cdot>a \<sigma>) \<in># C \<cdot> \<sigma> "
	by (metis Melem_subst_cls eql_pos_lit_eql_atm)

	lemma in_atms_of_subst[simp]: "B \<in> atms_of C \<Longrightarrow> B \<cdot>a \<sigma> \<in> atms_of (C \<cdot> \<sigma>)"
	by (metis atms_of_subst_atms image_iff subst_atms_def)


	subsubsection \<open>Renamings\<close>

	lemma is_renaming_id_subst[simp]: "is_renaming id_subst"
	unfolding is_renaming_def by simp

	lemma is_renamingD: "is_renaming \<sigma> \<Longrightarrow> (\<forall>A1 A2. A1 \<cdot>a \<sigma> = A2 \<cdot>a \<sigma> \<longleftrightarrow> A1 = A2)"
	by (metis is_renaming_def subst_atm_comp_subst subst_atm_id_subst)

	lemma inv_renaming_cancel_r[simp]: "is_renaming r \<Longrightarrow> r \<odot> inv_renaming r = id_subst"
	unfolding inv_renaming_def is_renaming_def by (metis (mono_tags) someI_ex)

	lemma inv_renaming_cancel_r_list[simp]:
	"is_renaming_list rs \<Longrightarrow> rs \<odot>s map inv_renaming rs = replicate (length rs) id_subst"
	unfolding is_renaming_list_def by (induction rs) (auto simp add: comp_substs_def)

	lemma Nil_comp_substs[simp]: "[] \<odot>s s = []"
	unfolding comp_substs_def by auto

	lemma comp_substs_Nil[simp]: "s \<odot>s [] = []"
	unfolding comp_substs_def by auto

	lemma is_renaming_idempotent_id_subst: "is_renaming r \<Longrightarrow> r \<odot> r = r \<Longrightarrow> r = id_subst"
	by (metis comp_subst_assoc comp_subst_id_subst inv_renaming_cancel_r)

	lemma is_renaming_left_id_subst_right_id_subst:
	"is_renaming r \<Longrightarrow> s \<odot> r = id_subst \<Longrightarrow> r \<odot> s = id_subst"
	by (metis comp_subst_assoc comp_subst_id_subst is_renaming_def)

	lemma is_renaming_closure: "is_renaming r1 \<Longrightarrow> is_renaming r2 \<Longrightarrow> is_renaming (r1 \<odot> r2)"
	unfolding is_renaming_def by (metis comp_subst_assoc comp_subst_id_subst)

	lemma is_renaming_inv_renaming_cancel_atm[simp]: "is_renaming \<rho> \<Longrightarrow> A \<cdot>a \<rho> \<cdot>a inv_renaming \<rho> = A"
	by (metis inv_renaming_cancel_r subst_atm_comp_subst subst_atm_id_subst)

	lemma is_renaming_inv_renaming_cancel_atms[simp]: "is_renaming \<rho> \<Longrightarrow> AA \<cdot>as \<rho> \<cdot>as inv_renaming \<rho> = AA"
	by (metis inv_renaming_cancel_r subst_atms_comp_subst subst_atms_id_subst)

	lemma is_renaming_inv_renaming_cancel_atmss[simp]: "is_renaming \<rho> \<Longrightarrow> AAA \<cdot>ass \<rho> \<cdot>ass inv_renaming \<rho> = AAA"
	by (metis inv_renaming_cancel_r subst_atmss_comp_subst subst_atmss_id_subst)

	lemma is_renaming_inv_renaming_cancel_atm_list[simp]: "is_renaming \<rho> \<Longrightarrow> As \<cdot>al \<rho> \<cdot>al inv_renaming \<rho> = As"
	by (metis inv_renaming_cancel_r subst_atm_list_comp_subst subst_atm_list_id_subst)

	lemma is_renaming_inv_renaming_cancel_atm_mset[simp]: "is_renaming \<rho> \<Longrightarrow> AA \<cdot>am \<rho> \<cdot>am inv_renaming \<rho> = AA"
	by (metis inv_renaming_cancel_r subst_atm_mset_comp_subst subst_atm_mset_id_subst)

	lemma is_renaming_inv_renaming_cancel_atm_mset_list[simp]: "is_renaming \<rho> \<Longrightarrow> (AAs \<cdot>aml \<rho>) \<cdot>aml inv_renaming \<rho> = AAs"
	by (metis inv_renaming_cancel_r subst_atm_mset_list_comp_subst subst_atm_mset_list_id_subst)

	lemma is_renaming_list_inv_renaming_cancel_atm_mset_lists[simp]:
	"length AAs = length \<rho>s \<Longrightarrow> is_renaming_list \<rho>s \<Longrightarrow> AAs \<cdot>\<cdot>aml \<rho>s \<cdot>\<cdot>aml map inv_renaming \<rho>s = AAs"
	by (metis inv_renaming_cancel_r_list subst_atm_mset_lists_comp_substs
	subst_atm_mset_lists_id_subst)

	lemma is_renaming_inv_renaming_cancel_lit[simp]: "is_renaming \<rho> \<Longrightarrow> (L \<cdot>l \<rho>) \<cdot>l inv_renaming \<rho> = L"
	by (metis inv_renaming_cancel_r subst_lit_comp_subst subst_lit_id_subst)

	lemma is_renaming_inv_renaming_cancel_cls[simp]: "is_renaming \<rho> \<Longrightarrow> C \<cdot> \<rho> \<cdot> inv_renaming \<rho> = C"
	by (metis inv_renaming_cancel_r subst_cls_comp_subst subst_cls_id_subst)

	lemma is_renaming_inv_renaming_cancel_clss[simp]:
	"is_renaming \<rho> \<Longrightarrow> CC \<cdot>cs \<rho> \<cdot>cs inv_renaming \<rho> = CC"
	by (metis inv_renaming_cancel_r subst_clss_id_subst subst_clsscomp_subst)

	lemma is_renaming_inv_renaming_cancel_cls_list[simp]:
	"is_renaming \<rho> \<Longrightarrow> Cs \<cdot>cl \<rho> \<cdot>cl inv_renaming \<rho> = Cs"
	by (metis inv_renaming_cancel_r subst_cls_list_comp_subst subst_cls_list_id_subst)

	lemma is_renaming_list_inv_renaming_cancel_cls_list[simp]:
	"length Cs = length \<rho>s \<Longrightarrow> is_renaming_list \<rho>s \<Longrightarrow> Cs \<cdot>\<cdot>cl \<rho>s \<cdot>\<cdot>cl map inv_renaming \<rho>s = Cs"
	by (metis inv_renaming_cancel_r_list subst_cls_lists_comp_substs subst_cls_lists_id_subst)

	lemma is_renaming_inv_renaming_cancel_cls_mset[simp]:
	"is_renaming \<rho> \<Longrightarrow> CC \<cdot>cm \<rho> \<cdot>cm inv_renaming \<rho> = CC"
	by (metis inv_renaming_cancel_r subst_cls_mset_comp_subst subst_cls_mset_id_subst)


	subsubsection \<open>Monotonicity\<close>

	lemma subst_cls_mono: "set_mset C \<subseteq> set_mset D \<Longrightarrow> set_mset (C \<cdot> \<sigma>) \<subseteq> set_mset (D \<cdot> \<sigma>)"
	by force

	lemma subst_cls_mono_mset: "C \<subseteq># D \<Longrightarrow> C \<cdot> \<sigma> \<subseteq># D \<cdot> \<sigma>"
	unfolding subst_clss_def by (metis mset_subset_eq_exists_conv subst_cls_union)

	lemma subst_subset_mono: "D \<subset># C \<Longrightarrow> D \<cdot> \<sigma> \<subset># C \<cdot> \<sigma>"
	unfolding subst_cls_def by (simp add: image_mset_subset_mono)


	subsubsection \<open>Size after Substitution\<close>

	lemma size_subst[simp]: "size (D \<cdot> \<sigma>) = size D"
	unfolding subst_cls_def by auto

	lemma subst_atm_list_length[simp]: "length (As \<cdot>al \<sigma>) = length As"
	unfolding subst_atm_list_def by auto

	lemma length_subst_atm_mset_list[simp]: "length (AAs \<cdot>aml \<eta>) = length AAs"
	unfolding subst_atm_mset_list_def by auto

	lemma subst_atm_mset_lists_length[simp]: "length (AAs \<cdot>\<cdot>aml \<sigma>s) = min (length AAs) (length \<sigma>s)"
	unfolding subst_atm_mset_lists_def by auto

	lemma subst_cls_list_length[simp]: "length (Cs \<cdot>cl \<sigma>) = length Cs"
	unfolding subst_cls_list_def by auto

	lemma comp_substs_length[simp]: "length (\<tau>s \<odot>s \<sigma>s) = min (length \<tau>s) (length \<sigma>s)"
	unfolding comp_substs_def by auto

	lemma subst_cls_lists_length[simp]: "length (Cs \<cdot>\<cdot>cl \<sigma>s) = min (length Cs) (length \<sigma>s)"
	unfolding subst_cls_lists_def by auto


	subsubsection \<open>Variable Disjointness\<close>

	lemma var_disjoint_clauses:
	assumes "var_disjoint Cs"
	shows "\<forall>\<sigma>s. length \<sigma>s = length Cs \<longrightarrow> (\<exists>\<tau>. Cs \<cdot>\<cdot>cl \<sigma>s = Cs \<cdot>cl \<tau>)"
	proof clarify
	fix \<sigma>s :: "'s list"
	assume a: "length \<sigma>s = length Cs"
	then obtain \<tau> where "\<forall>i < length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> S \<cdot> \<sigma>s ! i = S \<cdot> \<tau>"
	using assms unfolding var_disjoint_def by blast
	then have "\<forall>i < length Cs. (Cs ! i) \<cdot> \<sigma>s ! i = (Cs ! i) \<cdot> \<tau>"
	by auto
	then have "Cs \<cdot>\<cdot>cl \<sigma>s = Cs \<cdot>cl \<tau>"
	using a by (auto intro: nth_equalityI)
	then show "\<exists>\<tau>. Cs \<cdot>\<cdot>cl \<sigma>s = Cs \<cdot>cl \<tau>"
	by auto
	qed


	subsubsection \<open>Ground Expressions and Substitutions\<close>

	lemma ex_ground_subst: "\<exists>\<sigma>. is_ground_subst \<sigma>"
	using make_ground_subst[of "{#}"]
	by (simp add: is_ground_cls_def)

	lemma is_ground_cls_list_Cons[simp]:
	"is_ground_cls_list (C # Cs) = (is_ground_cls C \<and> is_ground_cls_list Cs)"
	unfolding is_ground_cls_list_def by auto


	paragraph \<open>Ground union\<close>

	lemma is_ground_atms_union[simp]: "is_ground_atms (AA \<union> BB) \<longleftrightarrow> is_ground_atms AA \<and> is_ground_atms BB"
	unfolding is_ground_atms_def by auto

	lemma is_ground_atm_mset_union[simp]:
	"is_ground_atm_mset (AA + BB) \<longleftrightarrow> is_ground_atm_mset AA \<and> is_ground_atm_mset BB"
	unfolding is_ground_atm_mset_def by auto

	lemma is_ground_cls_union[simp]: "is_ground_cls (C + D) \<longleftrightarrow> is_ground_cls C \<and> is_ground_cls D"
	unfolding is_ground_cls_def by auto

	lemma is_ground_clss_union[simp]:
	"is_ground_clss (CC \<union> DD) \<longleftrightarrow> is_ground_clss CC \<and> is_ground_clss DD"
	unfolding is_ground_clss_def by auto

	lemma is_ground_cls_list_is_ground_cls_sum_list[simp]:
	"is_ground_cls_list Cs \<Longrightarrow> is_ground_cls (sum_list Cs)"
	by (meson in_mset_sum_list2 is_ground_cls_def is_ground_cls_list_def)


	paragraph \<open>Grounding monotonicity\<close>

	lemma is_ground_cls_mono: "C \<subseteq># D \<Longrightarrow> is_ground_cls D \<Longrightarrow> is_ground_cls C"
	unfolding is_ground_cls_def by (metis set_mset_mono subsetD)

	lemma is_ground_clss_mono: "CC \<subseteq> DD \<Longrightarrow> is_ground_clss DD \<Longrightarrow> is_ground_clss CC"
	unfolding is_ground_clss_def by blast

	lemma grounding_of_clss_mono: "CC \<subseteq> DD \<Longrightarrow> grounding_of_clss CC \<subseteq> grounding_of_clss DD"
	using grounding_of_clss_def by auto

	lemma sum_list_subseteq_mset_is_ground_cls_list[simp]:
	"sum_list Cs \<subseteq># sum_list Ds \<Longrightarrow> is_ground_cls_list Ds \<Longrightarrow> is_ground_cls_list Cs"
	by (meson in_mset_sum_list is_ground_cls_def is_ground_cls_list_is_ground_cls_sum_list
	is_ground_cls_mono is_ground_cls_list_def)


	paragraph \<open>Substituting on ground expression preserves ground\<close>

	lemma is_ground_comp_subst[simp]: "is_ground_subst \<sigma> \<Longrightarrow> is_ground_subst (\<tau> \<odot> \<sigma>)"
	unfolding is_ground_subst_def is_ground_atm_def by auto

	lemma ground_subst_ground_atm[simp]: "is_ground_subst \<sigma> \<Longrightarrow> is_ground_atm (A \<cdot>a \<sigma>)"
	by (simp add: is_ground_subst_def)

	lemma ground_subst_ground_lit[simp]: "is_ground_subst \<sigma> \<Longrightarrow> is_ground_lit (L \<cdot>l \<sigma>)"
	unfolding is_ground_lit_def subst_lit_def by (cases L) auto

	lemma ground_subst_ground_cls[simp]: "is_ground_subst \<sigma> \<Longrightarrow> is_ground_cls (C \<cdot> \<sigma>)"
	unfolding is_ground_cls_def by auto

	lemma ground_subst_ground_clss[simp]: "is_ground_subst \<sigma> \<Longrightarrow> is_ground_clss (CC \<cdot>cs \<sigma>)"
	unfolding is_ground_clss_def subst_clss_def by auto

	lemma ground_subst_ground_cls_list[simp]: "is_ground_subst \<sigma> \<Longrightarrow> is_ground_cls_list (Cs \<cdot>cl \<sigma>)"
	unfolding is_ground_cls_list_def subst_cls_list_def by auto

	lemma ground_subst_ground_cls_lists[simp]:
	"\<forall>\<sigma> \<in> set \<sigma>s. is_ground_subst \<sigma> \<Longrightarrow> is_ground_cls_list (Cs \<cdot>\<cdot>cl \<sigma>s)"
	unfolding is_ground_cls_list_def subst_cls_lists_def by (auto simp: set_zip)

	lemma subst_cls_eq_grounding_of_cls_subset_eq:
	assumes "D \<cdot> \<sigma> = C"
	shows "grounding_of_cls C \<subseteq> grounding_of_cls D"
	proof
	fix C\<sigma>'
	assume "C\<sigma>' \<in> grounding_of_cls C"
	then obtain \<sigma>' where
	C\<sigma>': "C \<cdot> \<sigma>' = C\<sigma>'" "is_ground_subst \<sigma>'"
	unfolding grounding_of_cls_def by auto
	then have "C \<cdot> \<sigma>' = D \<cdot> \<sigma> \<cdot> \<sigma>' \<and> is_ground_subst (\<sigma> \<odot> \<sigma>')"
	using assms by auto
	then show "C\<sigma>' \<in> grounding_of_cls D"
	unfolding grounding_of_cls_def using C\<sigma>'(1) by force
	qed

	paragraph \<open>Substituting on ground expression has no effect\<close>

	lemma is_ground_subst_atm[simp]: "is_ground_atm A \<Longrightarrow> A \<cdot>a \<sigma> = A"
	unfolding is_ground_atm_def by simp

	lemma is_ground_subst_atms[simp]: "is_ground_atms AA \<Longrightarrow> AA \<cdot>as \<sigma> = AA"
	unfolding is_ground_atms_def subst_atms_def image_def by auto

	lemma is_ground_subst_atm_mset[simp]: "is_ground_atm_mset AA \<Longrightarrow> AA \<cdot>am \<sigma> = AA"
	unfolding is_ground_atm_mset_def subst_atm_mset_def by auto

	lemma is_ground_subst_atm_list[simp]: "is_ground_atm_list As \<Longrightarrow> As \<cdot>al \<sigma> = As"
	unfolding is_ground_atm_list_def subst_atm_list_def by (auto intro: nth_equalityI)

	lemma is_ground_subst_atm_list_member[simp]:
	"is_ground_atm_list As \<Longrightarrow> i < length As \<Longrightarrow> As ! i \<cdot>a \<sigma> = As ! i"
	unfolding is_ground_atm_list_def by auto

	lemma is_ground_subst_lit[simp]: "is_ground_lit L \<Longrightarrow> L \<cdot>l \<sigma> = L"
	unfolding is_ground_lit_def subst_lit_def by (cases L) simp_all

	lemma is_ground_subst_cls[simp]: "is_ground_cls C \<Longrightarrow> C \<cdot> \<sigma> = C"
	unfolding is_ground_cls_def subst_cls_def by simp

	lemma is_ground_subst_clss[simp]: "is_ground_clss CC \<Longrightarrow> CC \<cdot>cs \<sigma> = CC"
	unfolding is_ground_clss_def subst_clss_def image_def by auto

	lemma is_ground_subst_cls_lists[simp]:
	assumes "length P = length Cs" and "is_ground_cls_list Cs"
	shows "Cs \<cdot>\<cdot>cl P = Cs"
	using assms by (metis is_ground_cls_list_def is_ground_subst_cls min.idem nth_equalityI nth_mem
	subst_cls_lists_nth subst_cls_lists_length)

	lemma is_ground_subst_lit_iff: "is_ground_lit L \<longleftrightarrow> (\<forall>\<sigma>. L = L \<cdot>l \<sigma>)"
	using is_ground_atm_def is_ground_lit_def subst_lit_def by (cases L) auto

	lemma is_ground_subst_cls_iff: "is_ground_cls C \<longleftrightarrow> (\<forall>\<sigma>. C = C \<cdot> \<sigma>)"
	by (metis ex_ground_subst ground_subst_ground_cls is_ground_subst_cls)


	paragraph \<open>Members of ground expressions are ground\<close>

	lemma is_ground_cls_as_atms: "is_ground_cls C \<longleftrightarrow> (\<forall>A \<in> atms_of C. is_ground_atm A)"
	by (auto simp: atms_of_def is_ground_cls_def is_ground_lit_def)

	lemma is_ground_cls_imp_is_ground_lit: "L \<in># C \<Longrightarrow> is_ground_cls C \<Longrightarrow> is_ground_lit L"
	by (simp add: is_ground_cls_def)

	lemma is_ground_cls_imp_is_ground_atm: "A \<in> atms_of C \<Longrightarrow> is_ground_cls C \<Longrightarrow> is_ground_atm A"
	by (simp add: is_ground_cls_as_atms)

	lemma is_ground_cls_is_ground_atms_atms_of[simp]: "is_ground_cls C \<Longrightarrow> is_ground_atms (atms_of C)"
	by (simp add: is_ground_cls_imp_is_ground_atm is_ground_atms_def)

	lemma grounding_ground: "C \<in> grounding_of_clss M \<Longrightarrow> is_ground_cls C"
	unfolding grounding_of_clss_def grounding_of_cls_def by auto

	lemma in_subset_eq_grounding_of_clss_is_ground_cls[simp]:
	"C \<in> CC \<Longrightarrow> CC \<subseteq> grounding_of_clss DD \<Longrightarrow> is_ground_cls C"
	unfolding grounding_of_clss_def grounding_of_cls_def by auto

	lemma is_ground_cls_empty[simp]: "is_ground_cls {#}"
	unfolding is_ground_cls_def by simp

	lemma grounding_of_cls_ground: "is_ground_cls C \<Longrightarrow> grounding_of_cls C = {C}"
	unfolding grounding_of_cls_def by (simp add: ex_ground_subst)

	lemma grounding_of_cls_empty[simp]: "grounding_of_cls {#} = {{#}}"
	by (simp add: grounding_of_cls_ground)

	lemma union_grounding_of_cls_ground: "is_ground_clss (\<Union> (grounding_of_cls ` N))"
	by (simp add: grounding_ground grounding_of_clss_def is_ground_clss_def)


	paragraph \<open>Grounding idempotence\<close>

	lemma grounding_of_grounding_of_cls: "E \<in> grounding_of_cls D \<Longrightarrow> D \<in> grounding_of_cls C \<Longrightarrow> E = D"
	using grounding_of_cls_def by auto


	subsubsection \<open>Subsumption\<close>

	lemma subsumes_empty_left[simp]: "subsumes {#} C"
	unfolding subsumes_def subst_cls_def by simp

	lemma strictly_subsumes_empty_left[simp]: "strictly_subsumes {#} C \<longleftrightarrow> C \<noteq> {#}"
	unfolding strictly_subsumes_def subsumes_def subst_cls_def by simp


	subsubsection \<open>Unifiers\<close>

	lemma card_le_one_alt: "finite X \<Longrightarrow> card X \<le> 1 \<longleftrightarrow> X = {} \<or> (\<exists>x. X = {x})"
	by (induct rule: finite_induct) auto

	lemma is_unifier_subst_atm_eqI:
	assumes "finite AA"
	shows "is_unifier \<sigma> AA \<Longrightarrow> A \<in> AA \<Longrightarrow> B \<in> AA \<Longrightarrow> A \<cdot>a \<sigma> = B \<cdot>a \<sigma>"
	unfolding is_unifier_def subst_atms_def card_le_one_alt[OF finite_imageI[OF assms]]
	by (metis equals0D imageI insert_iff)

	lemma is_unifier_alt:
	assumes "finite AA"
	shows "is_unifier \<sigma> AA \<longleftrightarrow> (\<forall>A \<in> AA. \<forall>B \<in> AA. A \<cdot>a \<sigma> = B \<cdot>a \<sigma>)"
	unfolding is_unifier_def subst_atms_def card_le_one_alt[OF finite_imageI[OF assms(1)]]
	by (rule iffI, metis empty_iff insert_iff insert_image, blast)

	lemma is_unifiers_subst_atm_eqI:
	assumes "finite AA" "is_unifiers \<sigma> AAA" "AA \<in> AAA" "A \<in> AA" "B \<in> AA"
	shows "A \<cdot>a \<sigma> = B \<cdot>a \<sigma>"
	by (metis assms is_unifiers_def is_unifier_subst_atm_eqI)

	theorem is_unifiers_comp:
	"is_unifiers \<sigma> (set_mset ` set (map2 add_mset As Bs) \<cdot>ass \<eta>) \<longleftrightarrow>
	is_unifiers (\<eta> \<odot> \<sigma>) (set_mset ` set (map2 add_mset As Bs))"
	unfolding is_unifiers_def is_unifier_def subst_atmss_def by auto


	subsubsection \<open>Most General Unifier\<close>

	lemma is_mgu_is_unifiers: "is_mgu \<sigma> AAA \<Longrightarrow> is_unifiers \<sigma> AAA"
	using is_mgu_def by blast

	lemma is_mgu_is_most_general: "is_mgu \<sigma> AAA \<Longrightarrow> is_unifiers \<tau> AAA \<Longrightarrow> \<exists>\<gamma>. \<tau> = \<sigma> \<odot> \<gamma>"
	using is_mgu_def by blast

	lemma is_unifiers_is_unifier: "is_unifiers \<sigma> AAA \<Longrightarrow> AA \<in> AAA \<Longrightarrow> is_unifier \<sigma> AA"
	using is_unifiers_def by simp

	+lemma is_imgu_is_mgu[intro]: "is_imgu \<sigma> AAA \<Longrightarrow> is_mgu \<sigma> AAA"
	+ by (auto simp: is_imgu_def is_mgu_def)
	+
	+lemma is_imgu_comp_idempotent[simp]: "is_imgu \<sigma> AAA \<Longrightarrow> \<sigma> \<odot> \<sigma> = \<sigma>"
	+ by (simp add: is_imgu_def)
	+
	+lemma is_imgu_subst_atm_idempotent[simp]: "is_imgu \<sigma> AAA \<Longrightarrow> A \<cdot>a \<sigma> \<cdot>a \<sigma> = A \<cdot>a \<sigma>"
	+ using is_imgu_comp_idempotent[of \<sigma>] subst_atm_comp_subst[of A \<sigma> \<sigma>] by simp
	+
	+lemma is_imgu_subst_atms_idempotent[simp]: "is_imgu \<sigma> AAA \<Longrightarrow> AA \<cdot>as \<sigma> \<cdot>as \<sigma> = AA \<cdot>as \<sigma>"
	+ using is_imgu_comp_idempotent[of \<sigma>] subst_atms_comp_subst[of AA \<sigma> \<sigma>] by simp
	+
	+lemma is_imgu_subst_lit_idemptotent[simp]: "is_imgu \<sigma> AAA \<Longrightarrow> L \<cdot>l \<sigma> \<cdot>l \<sigma> = L \<cdot>l \<sigma>"
	+ using is_imgu_comp_idempotent[of \<sigma>] subst_lit_comp_subst[of L \<sigma> \<sigma>] by simp
	+
	+lemma is_imgu_subst_cls_idemptotent[simp]: "is_imgu \<sigma> AAA \<Longrightarrow> C \<cdot> \<sigma> \<cdot> \<sigma> = C \<cdot> \<sigma>"
	+ using is_imgu_comp_idempotent[of \<sigma>] subst_cls_comp_subst[of C \<sigma> \<sigma>] by simp
	+
	+lemma is_imgu_subst_clss_idemptotent[simp]: "is_imgu \<sigma> AAA \<Longrightarrow> CC \<cdot>cs \<sigma> \<cdot>cs \<sigma> = CC \<cdot>cs \<sigma>"
	+ using is_imgu_comp_idempotent[of \<sigma>] subst_clsscomp_subst[of CC \<sigma> \<sigma>] by simp
	+

	subsubsection \<open>Generalization and Subsumption\<close>

	lemma variants_sym: "variants D D' \<longleftrightarrow> variants D' D"
	unfolding variants_def by auto

	lemma variants_iff_subsumes: "variants C D \<longleftrightarrow> subsumes C D \<and> subsumes D C"
	proof
	assume "variants C D"
	then show "subsumes C D \<and> subsumes D C"
	unfolding variants_def generalizes_def subsumes_def
	by (metis subset_mset.refl)
	next
	assume sub: "subsumes C D \<and> subsumes D C"
	then have "size C = size D"
	unfolding subsumes_def by (metis antisym size_mset_mono size_subst)
	then show "variants C D"
	using sub unfolding subsumes_def variants_def generalizes_def
	by (metis leD mset_subset_size size_mset_mono size_subst
	subset_mset.not_eq_order_implies_strict)
	qed

	+lemma strict_subset_subst_strictly_subsumes: "C \<cdot> \<eta> \<subset># D \<Longrightarrow> strictly_subsumes C D"
	+ by (metis leD mset_subset_size size_mset_mono size_subst strictly_subsumes_def
	+ subset_mset.dual_order.strict_implies_order substitution_ops.subsumes_def)
	+
	+lemma generalizes_refl: "generalizes C C"
	+ unfolding generalizes_def by (rule exI[of _ id_subst]) auto
	+
	+lemma generalizes_trans: "generalizes C D \<Longrightarrow> generalizes D E \<Longrightarrow> generalizes C E"
	+ unfolding generalizes_def using subst_cls_comp_subst by blast
	+
	+lemma subsumes_refl: "subsumes C C"
	+ unfolding subsumes_def by (rule exI[of _ id_subst]) auto
	+
	+lemma subsumes_trans: "subsumes C D \<Longrightarrow> subsumes D E \<Longrightarrow> subsumes C E"
	+ unfolding subsumes_def
	+ by (metis (no_types) subset_mset.trans subst_cls_comp_subst subst_cls_mono_mset)
	+
	+lemma strictly_generalizes_irrefl: "\<not> strictly_generalizes C C"
	+ unfolding strictly_generalizes_def by blast
	+
	+lemma strictly_generalizes_antisym: "strictly_generalizes C D \<Longrightarrow> \<not> strictly_generalizes D C"
	+ unfolding strictly_generalizes_def by blast
	+
	+lemma strictly_generalizes_trans:
	+ "strictly_generalizes C D \<Longrightarrow> strictly_generalizes D E \<Longrightarrow> strictly_generalizes C E"
	+ unfolding strictly_generalizes_def using generalizes_trans by blast
	+
	+lemma strictly_subsumes_irrefl: "\<not> strictly_subsumes C C"
	+ unfolding strictly_subsumes_def by blast
	+
	+lemma strictly_subsumes_antisym: "strictly_subsumes C D \<Longrightarrow> \<not> strictly_subsumes D C"
	+ unfolding strictly_subsumes_def by blast
	+
	+lemma strictly_subsumes_trans:
	+ "strictly_subsumes C D \<Longrightarrow> strictly_subsumes D E \<Longrightarrow> strictly_subsumes C E"
	+ unfolding strictly_subsumes_def using subsumes_trans by blast
	+
	+lemma subset_strictly_subsumes: "C \<subset># D \<Longrightarrow> strictly_subsumes C D"
	+ using strict_subset_subst_strictly_subsumes[of C id_subst] by auto
	+
	+lemma strictly_generalizes_neq: "strictly_generalizes D' D \<Longrightarrow> D' \<noteq> D \<cdot> \<sigma>"
	+ unfolding strictly_generalizes_def generalizes_def by blast
	+
	+lemma strictly_subsumes_neq: "strictly_subsumes D' D \<Longrightarrow> D' \<noteq> D \<cdot> \<sigma>"
	+ unfolding strictly_subsumes_def subsumes_def by blast
	+
	+lemma variants_imp_exists_substitution: "variants D D' \<Longrightarrow> \<exists>\<sigma>. D \<cdot> \<sigma> = D'"
	+ unfolding variants_iff_subsumes subsumes_def
	+ by (meson strictly_subsumes_def subset_mset_def strict_subset_subst_strictly_subsumes subsumes_def)
	+
	+lemma strictly_subsumes_variants:
	+ assumes "strictly_subsumes E D" and "variants D D'"
	+ shows "strictly_subsumes E D'"
	+proof -
	+ from assms obtain \<sigma> \<sigma>' where
	+ \<sigma>_\<sigma>'_p: "D \<cdot> \<sigma> = D' \<and> D' \<cdot> \<sigma>' = D"
	+ using variants_imp_exists_substitution variants_sym by metis
	+
	+ from assms obtain \<sigma>'' where
	+ "E \<cdot> \<sigma>'' \<subseteq># D"
	+ unfolding strictly_subsumes_def subsumes_def by auto
	+ then have "E \<cdot> \<sigma>'' \<cdot> \<sigma> \<subseteq># D \<cdot> \<sigma>"
	+ using subst_cls_mono_mset by blast
	+ then have "E \<cdot> (\<sigma>'' \<odot> \<sigma>) \<subseteq># D'"
	+ using \<sigma>_\<sigma>'_p by auto
	+ moreover from assms have n: "\<nexists>\<sigma>. D \<cdot> \<sigma> \<subseteq># E"
	+ unfolding strictly_subsumes_def subsumes_def by auto
	+ have "\<nexists>\<sigma>. D' \<cdot> \<sigma> \<subseteq># E"
	+ proof
	+ assume "\<exists>\<sigma>'''. D' \<cdot> \<sigma>''' \<subseteq># E"
	+ then obtain \<sigma>''' where
	+ "D' \<cdot> \<sigma>''' \<subseteq># E"
	+ by auto
	+ then have "D \<cdot> (\<sigma> \<odot> \<sigma>''') \<subseteq># E"
	+ using \<sigma>_\<sigma>'_p by auto
	+ then show False
	+ using n by metis
	+ qed
	+ ultimately show ?thesis
	+ unfolding strictly_subsumes_def subsumes_def by metis
	+qed
	+
	+lemma neg_strictly_subsumes_variants:
	+ assumes "\<not> strictly_subsumes E D" and "variants D D'"
	+ shows "\<not> strictly_subsumes E D'"
	+ using assms strictly_subsumes_variants variants_sym by auto
	+
	+
	+end
	+
	+locale substitution_renamings = substitution subst_atm id_subst comp_subst
	+ for
	+ subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
	+ id_subst :: 's and
	+ comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" +
	+ fixes
	+ renamings_apart :: "'a clause list \<Rightarrow> 's list" and
	+ atm_of_atms :: "'a list \<Rightarrow> 'a"
	+ assumes
	+ renamings_apart_length: "length (renamings_apart Cs) = length Cs" and
	+ renamings_apart_renaming: "\<rho> \<in> set (renamings_apart Cs) \<Longrightarrow> is_renaming \<rho>" and
	+ renamings_apart_var_disjoint: "var_disjoint (Cs \<cdot>\<cdot>cl (renamings_apart Cs))" and
	+ atm_of_atms_subst:
	+ "\<And>As Bs. atm_of_atms As \<cdot>a \<sigma> = atm_of_atms Bs \<longleftrightarrow> map (\<lambda>A. A \<cdot>a \<sigma>) As = Bs"
	+begin
	+
	+
	+subsubsection \<open>Generalization and Subsumption\<close>
	+
	lemma wf_strictly_generalizes: "wfP strictly_generalizes"
	proof -
	{
	assume "\<exists>C_at. \<forall>i. strictly_generalizes (C_at (Suc i)) (C_at i)"
	then obtain C_at :: "nat \<Rightarrow> 'a clause" where
	sg_C: "\<And>i. strictly_generalizes (C_at (Suc i)) (C_at i)"
	by blast

	define n :: nat where
	"n = size (C_at 0)"

	have sz_C: "size (C_at i) = n" for i
	proof (induct i)
	case (Suc i)
	then show ?case
	using sg_C[of i] unfolding strictly_generalizes_def generalizes_def subst_cls_def
	by (metis size_image_mset)
	qed (simp add: n_def)

	obtain \<sigma>_at :: "nat \<Rightarrow> 's" where
	C_\<sigma>: "\<And>i. image_mset (\<lambda>L. L \<cdot>l \<sigma>_at i) (C_at (Suc i)) = C_at i"
	using sg_C[unfolded strictly_generalizes_def generalizes_def subst_cls_def] by metis

	define Ls_at :: "nat \<Rightarrow> 'a literal list" where
	"Ls_at = rec_nat (SOME Ls. mset Ls = C_at 0)
	(\<lambda>i Lsi. SOME Ls. mset Ls = C_at (Suc i) \<and> map (\<lambda>L. L \<cdot>l \<sigma>_at i) Ls = Lsi)"

	have
	Ls_at_0: "Ls_at 0 = (SOME Ls. mset Ls = C_at 0)" and
	Ls_at_Suc: "\<And>i. Ls_at (Suc i) =
	(SOME Ls. mset Ls = C_at (Suc i) \<and> map (\<lambda>L. L \<cdot>l \<sigma>_at i) Ls = Ls_at i)"
	unfolding Ls_at_def by simp+

	have mset_Lt_at_0: "mset (Ls_at 0) = C_at 0"
	unfolding Ls_at_0 by (rule someI_ex) (metis list_of_mset_exi)

	have "mset (Ls_at (Suc i)) = C_at (Suc i) \<and> map (\<lambda>L. L \<cdot>l \<sigma>_at i) (Ls_at (Suc i)) = Ls_at i"
	for i
	proof (induct i)
	case 0
	then show ?case
	by (simp add: Ls_at_Suc, rule someI_ex,
	metis C_\<sigma> image_mset_of_subset_list mset_Lt_at_0)
	next
	case Suc
	then show ?case
	by (subst (1 2) Ls_at_Suc) (rule someI_ex, metis C_\<sigma> image_mset_of_subset_list)
	qed
	note mset_Ls = this[THEN conjunct1] and Ls_\<sigma> = this[THEN conjunct2]

	have len_Ls: "\<And>i. length (Ls_at i) = n"
	by (metis mset_Ls mset_Lt_at_0 not0_implies_Suc size_mset sz_C)

	have is_pos_Ls: "\<And>i j. j < n \<Longrightarrow> is_pos (Ls_at (Suc i) ! j) \<longleftrightarrow> is_pos (Ls_at i ! j)"
	using Ls_\<sigma> len_Ls by (metis literal.map_disc_iff nth_map subst_lit_def)

	have Ls_\<tau>_strict_lit: "\<And>i \<tau>. map (\<lambda>L. L \<cdot>l \<tau>) (Ls_at i) \<noteq> Ls_at (Suc i)"
	by (metis C_\<sigma> mset_Ls Ls_\<sigma> mset_map sg_C generalizes_def strictly_generalizes_def
	subst_cls_def)

	have Ls_\<tau>_strict_tm:
	"map ((\<lambda>t. t \<cdot>a \<tau>) \<circ> atm_of) (Ls_at i) \<noteq> map atm_of (Ls_at (Suc i))" for i \<tau>
	proof -
	obtain j :: nat where
	j_lt: "j < n" and
	j_\<tau>: "Ls_at i ! j \<cdot>l \<tau> \<noteq> Ls_at (Suc i) ! j"
	using Ls_\<tau>_strict_lit[of \<tau> i] len_Ls
	by (metis (no_types, lifting) length_map list_eq_iff_nth_eq nth_map)

	have "atm_of (Ls_at i ! j) \<cdot>a \<tau> \<noteq> atm_of (Ls_at (Suc i) ! j)"
	using j_\<tau> is_pos_Ls[OF j_lt]
	by (metis (mono_guards) literal.expand literal.map_disc_iff literal.map_sel subst_lit_def)
	then show ?thesis
	using j_lt len_Ls by (metis nth_map o_apply)
	qed

	define tm_at :: "nat \<Rightarrow> 'a" where
	"\<And>i. tm_at i = atm_of_atms (map atm_of (Ls_at i))"

	have "\<And>i. generalizes_atm (tm_at (Suc i)) (tm_at i)"
	unfolding tm_at_def generalizes_atm_def atm_of_atms_subst
	using Ls_\<sigma>[THEN arg_cong, of "map atm_of"] by (auto simp: comp_def)
	moreover have "\<And>i. \<not> generalizes_atm (tm_at i) (tm_at (Suc i))"
	unfolding tm_at_def generalizes_atm_def atm_of_atms_subst by (simp add: Ls_\<tau>_strict_tm)
	ultimately have "\<And>i. strictly_generalizes_atm (tm_at (Suc i)) (tm_at i)"
	unfolding strictly_generalizes_atm_def by blast
	then have False
	using wf_strictly_generalizes_atm[unfolded wfP_def wf_iff_no_infinite_down_chain] by blast
	}
	then show "wfP (strictly_generalizes :: 'a clause \<Rightarrow> _ \<Rightarrow> _)"
	unfolding wfP_def by (blast intro: wf_iff_no_infinite_down_chain[THEN iffD2])
	qed

	-lemma strict_subset_subst_strictly_subsumes: "C \<cdot> \<eta> \<subset># D \<Longrightarrow> strictly_subsumes C D"
	- by (metis leD mset_subset_size size_mset_mono size_subst strictly_subsumes_def
	- subset_mset.dual_order.strict_implies_order substitution_ops.subsumes_def)
	-
	-lemma generalizes_refl: "generalizes C C"
	- unfolding generalizes_def by (rule exI[of _ id_subst]) auto
	-
	-lemma generalizes_trans: "generalizes C D \<Longrightarrow> generalizes D E \<Longrightarrow> generalizes C E"
	- unfolding generalizes_def using subst_cls_comp_subst by blast
	-
	-lemma subsumes_refl: "subsumes C C"
	- unfolding subsumes_def by (rule exI[of _ id_subst]) auto
	-
	-lemma subsumes_trans: "subsumes C D \<Longrightarrow> subsumes D E \<Longrightarrow> subsumes C E"
	- unfolding subsumes_def
	- by (metis (no_types) subset_mset.trans subst_cls_comp_subst subst_cls_mono_mset)
	-
	-lemma strictly_generalizes_irrefl: "\<not> strictly_generalizes C C"
	- unfolding strictly_generalizes_def by blast
	-
	-lemma strictly_generalizes_antisym: "strictly_generalizes C D \<Longrightarrow> \<not> strictly_generalizes D C"
	- unfolding strictly_generalizes_def by blast
	-
	-lemma strictly_generalizes_trans:
	- "strictly_generalizes C D \<Longrightarrow> strictly_generalizes D E \<Longrightarrow> strictly_generalizes C E"
	- unfolding strictly_generalizes_def using generalizes_trans by blast
	-
	-lemma strictly_subsumes_irrefl: "\<not> strictly_subsumes C C"
	- unfolding strictly_subsumes_def by blast
	-
	-lemma strictly_subsumes_antisym: "strictly_subsumes C D \<Longrightarrow> \<not> strictly_subsumes D C"
	- unfolding strictly_subsumes_def by blast
	-
	-lemma strictly_subsumes_trans:
	- "strictly_subsumes C D \<Longrightarrow> strictly_subsumes D E \<Longrightarrow> strictly_subsumes C E"
	- unfolding strictly_subsumes_def using subsumes_trans by blast
	-
	-lemma subset_strictly_subsumes: "C \<subset># D \<Longrightarrow> strictly_subsumes C D"
	- using strict_subset_subst_strictly_subsumes[of C id_subst] by auto
	-
	-lemma strictly_generalizes_neq: "strictly_generalizes D' D \<Longrightarrow> D' \<noteq> D \<cdot> \<sigma>"
	- unfolding strictly_generalizes_def generalizes_def by blast
	-
	-lemma strictly_subsumes_neq: "strictly_subsumes D' D \<Longrightarrow> D' \<noteq> D \<cdot> \<sigma>"
	- unfolding strictly_subsumes_def subsumes_def by blast
	-
	lemma strictly_subsumes_has_minimum:
	assumes "CC \<noteq> {}"
	shows "\<exists>C \<in> CC. \<forall>D \<in> CC. \<not> strictly_subsumes D C"
	proof (rule ccontr)
	assume "\<not> (\<exists>C \<in> CC. \<forall>D\<in>CC. \<not> strictly_subsumes D C)"
	then have "\<forall>C \<in> CC. \<exists>D \<in> CC. strictly_subsumes D C"
	by blast
	then obtain f where
	f_p: "\<forall>C \<in> CC. f C \<in> CC \<and> strictly_subsumes (f C) C"
	by metis
	from assms obtain C where
	C_p: "C \<in> CC"
	by auto

	define c :: "nat \<Rightarrow> 'a clause" where
	"\<And>n. c n = (f ^^ n) C"

	have incc: "c i \<in> CC" for i
	by (induction i) (auto simp: c_def f_p C_p)
	have ps: "\<forall>i. strictly_subsumes (c (Suc i)) (c i)"
	using incc f_p unfolding c_def by auto
	have "\<forall>i. size (c i) \<ge> size (c (Suc i))"
	using ps unfolding strictly_subsumes_def subsumes_def by (metis size_mset_mono size_subst)
	then have lte: "\<forall>i. (size \<circ> c) i \<ge> (size \<circ> c) (Suc i)"
	unfolding comp_def .
	then have "\<exists>l. \<forall>l' \<ge> l. size (c l') = size (c (Suc l'))"
	using f_Suc_decr_eventually_const comp_def by auto
	then obtain l where
	l_p: "\<forall>l' \<ge> l. size (c l') = size (c (Suc l'))"
	by metis
	then have "\<forall>l' \<ge> l. strictly_generalizes (c (Suc l')) (c l')"
	using ps unfolding strictly_generalizes_def generalizes_def
	by (metis size_subst less_irrefl strictly_subsumes_def mset_subset_size subset_mset_def
	subsumes_def strictly_subsumes_neq)
	then have "\<forall>i. strictly_generalizes (c (Suc i + l)) (c (i + l))"
	unfolding strictly_generalizes_def generalizes_def by auto
	then have "\<exists>f. \<forall>i. strictly_generalizes (f (Suc i)) (f i)"
	by (rule exI[of _ "\<lambda>x. c (x + l)"])
	then show False
	using wf_strictly_generalizes
	wf_iff_no_infinite_down_chain[of "{(x, y). strictly_generalizes x y}"]
	unfolding wfP_def by auto
	qed

	lemma wf_strictly_subsumes: "wfP strictly_subsumes"
	using strictly_subsumes_has_minimum by (metis equals0D wfP_eq_minimal)

	-lemma variants_imp_exists_substitution: "variants D D' \<Longrightarrow> \<exists>\<sigma>. D \<cdot> \<sigma> = D'"
	- unfolding variants_iff_subsumes subsumes_def
	- by (meson strictly_subsumes_def subset_mset_def strict_subset_subst_strictly_subsumes subsumes_def)
	-
	-lemma strictly_subsumes_variants:
	- assumes "strictly_subsumes E D" and "variants D D'"
	- shows "strictly_subsumes E D'"
	-proof -
	- from assms obtain \<sigma> \<sigma>' where
	- \<sigma>_\<sigma>'_p: "D \<cdot> \<sigma> = D' \<and> D' \<cdot> \<sigma>' = D"
	- using variants_imp_exists_substitution variants_sym by metis
	-
	- from assms obtain \<sigma>'' where
	- "E \<cdot> \<sigma>'' \<subseteq># D"
	- unfolding strictly_subsumes_def subsumes_def by auto
	- then have "E \<cdot> \<sigma>'' \<cdot> \<sigma> \<subseteq># D \<cdot> \<sigma>"
	- using subst_cls_mono_mset by blast
	- then have "E \<cdot> (\<sigma>'' \<odot> \<sigma>) \<subseteq># D'"
	- using \<sigma>_\<sigma>'_p by auto
	- moreover from assms have n: "\<nexists>\<sigma>. D \<cdot> \<sigma> \<subseteq># E"
	- unfolding strictly_subsumes_def subsumes_def by auto
	- have "\<nexists>\<sigma>. D' \<cdot> \<sigma> \<subseteq># E"
	- proof
	- assume "\<exists>\<sigma>'''. D' \<cdot> \<sigma>''' \<subseteq># E"
	- then obtain \<sigma>''' where
	- "D' \<cdot> \<sigma>''' \<subseteq># E"
	- by auto
	- then have "D \<cdot> (\<sigma> \<odot> \<sigma>''') \<subseteq># E"
	- using \<sigma>_\<sigma>'_p by auto
	- then show False
	- using n by metis
	- qed
	- ultimately show ?thesis
	- unfolding strictly_subsumes_def subsumes_def by metis
	-qed
	-
	-lemma neg_strictly_subsumes_variants:
	- assumes "\<not> strictly_subsumes E D" and "variants D D'"
	- shows "\<not> strictly_subsumes E D'"
	- using assms strictly_subsumes_variants variants_sym by auto
	-
	end


	subsection \<open>Most General Unifiers\<close>

	-locale mgu = substitution subst_atm id_subst comp_subst renamings_apart atm_of_atms
	+locale mgu = substitution_renamings subst_atm id_subst comp_subst renamings_apart atm_of_atms
	for
	subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
	id_subst :: 's and
	comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" and
	- atm_of_atms :: "'a list \<Rightarrow> 'a" and
	- renamings_apart :: "'a literal multiset list \<Rightarrow> 's list" +
	+ renamings_apart :: "'a literal multiset list \<Rightarrow> 's list" and
	+ atm_of_atms :: "'a list \<Rightarrow> 'a"+
	fixes
	mgu :: "'a set set \<Rightarrow> 's option"
	assumes
	mgu_sound: "finite AAA \<Longrightarrow> (\<forall>AA \<in> AAA. finite AA) \<Longrightarrow> mgu AAA = Some \<sigma> \<Longrightarrow> is_mgu \<sigma> AAA" and
	mgu_complete:
	"finite AAA \<Longrightarrow> (\<forall>AA \<in> AAA. finite AA) \<Longrightarrow> is_unifiers \<sigma> AAA \<Longrightarrow> \<exists>\<tau>. mgu AAA = Some \<tau>"
	begin

	lemmas is_unifiers_mgu = mgu_sound[unfolded is_mgu_def, THEN conjunct1]
	lemmas is_mgu_most_general = mgu_sound[unfolded is_mgu_def, THEN conjunct2]

	lemma mgu_unifier:
	assumes
	aslen: "length As = n" and
	aaslen: "length AAs = n" and
	mgu: "Some \<sigma> = mgu (set_mset ` set (map2 add_mset As AAs))" and
	i_lt: "i < n" and
	a_in: "A \<in># AAs ! i"
	shows "A \<cdot>a \<sigma> = As ! i \<cdot>a \<sigma>"
	proof -
	from mgu have "is_mgu \<sigma> (set_mset ` set (map2 add_mset As AAs))"
	using mgu_sound by auto
	then have "is_unifiers \<sigma> (set_mset ` set (map2 add_mset As AAs))"
	using is_mgu_is_unifiers by auto
	then have "is_unifier \<sigma> (set_mset (add_mset (As ! i) (AAs ! i)))"
	using i_lt aslen aaslen unfolding is_unifiers_def is_unifier_def
	by simp (metis length_zip min.idem nth_mem nth_zip prod.case set_mset_add_mset_insert)
	then show ?thesis
	using aslen aaslen a_in is_unifier_subst_atm_eqI
	by (metis finite_set_mset insertCI set_mset_add_mset_insert)
	qed

	end

	+
	+subsection \<open>Idempotent Most General Unifiers\<close>
	+
	+locale imgu = mgu subst_atm id_subst comp_subst renamings_apart atm_of_atms mgu
	+ for
	+ subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
	+ id_subst :: 's and
	+ comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" and
	+ renamings_apart :: "'a literal multiset list \<Rightarrow> 's list" and
	+ atm_of_atms :: "'a list \<Rightarrow> 'a" and
	+ mgu :: "'a set set \<Rightarrow> 's option" +
	+ assumes
	+ mgu_is_imgu: "finite AAA \<Longrightarrow> (\<forall>AA \<in> AAA. finite AA) \<Longrightarrow> mgu AAA = Some \<sigma> \<Longrightarrow> is_imgu \<sigma> AAA"
	+
	end
	diff --git a/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution.thy b/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution.thy
	--- a/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution.thy
	+++ b/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution.thy
	@@ -1,1412 +1,1411 @@
	(* Title: First-Order Ordered Resolution Calculus with Selection
	Author: Anders Schlichtkrull <andschl at dtu.dk>, 2016, 2017
	Author: Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
	Author: Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
	Author: Sophie Tourret <stourret at mpi-inf.mpg.de>, 2020
	Maintainer: Anders Schlichtkrull <andschl at dtu.dk>
	*)

	section \<open>First-Order Ordered Resolution Calculus with Selection\<close>

	theory FO_Ordered_Resolution
	imports Abstract_Substitution Ordered_Ground_Resolution Standard_Redundancy
	begin

	text \<open>
	This material is based on Section 4.3 (``A Simple Resolution Prover for First-Order Clauses'') of
	Bachmair and Ganzinger's chapter. Specifically, it formalizes the ordered resolution calculus for
	first-order standard clauses presented in Figure 4 and its related lemmas and theorems, including
	soundness and Lemma 4.12 (the lifting lemma).

	The following corresponds to pages 41--42 of Section 4.3, until Figure 5 and its explanation.
	\<close>

	-locale FO_resolution = mgu subst_atm id_subst comp_subst atm_of_atms renamings_apart mgu
	+locale FO_resolution = mgu subst_atm id_subst comp_subst renamings_apart atm_of_atms mgu
	for
	subst_atm :: "'a :: wellorder \<Rightarrow> 's \<Rightarrow> 'a" and
	id_subst :: "'s" and
	comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" and
	renamings_apart :: "'a literal multiset list \<Rightarrow> 's list" and
	atm_of_atms :: "'a list \<Rightarrow> 'a" and
	mgu :: "'a set set \<Rightarrow> 's option" +
	fixes
	less_atm :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
	assumes
	less_atm_stable: "less_atm A B \<Longrightarrow> less_atm (A \<cdot>a \<sigma>) (B \<cdot>a \<sigma>)" and
	less_atm_ground: "is_ground_atm A \<Longrightarrow> is_ground_atm B \<Longrightarrow> less_atm A B \<Longrightarrow> A < B"
	begin


	subsection \<open>Library\<close>

	lemma Bex_cartesian_product: "(\<exists>xy \<in> A \<times> B. P xy) \<equiv> (\<exists>x \<in> A. \<exists>y \<in> B. P (x, y))"
	by simp

	lemma eql_map_neg_lit_eql_atm:
	assumes "map (\<lambda>L. L \<cdot>l \<eta>) (map Neg As') = map Neg As"
	shows "As' \<cdot>al \<eta> = As"
	using assms by (induction As' arbitrary: As) auto

	lemma instance_list:
	assumes "negs (mset As) = SDA' \<cdot> \<eta>"
	shows "\<exists>As'. negs (mset As') = SDA' \<and> As' \<cdot>al \<eta> = As"
	proof -
	from assms have negL: "\<forall>L \<in># SDA'. is_neg L"
	using Melem_subst_cls subst_lit_in_negs_is_neg by metis

	from assms have "{#L \<cdot>l \<eta>. L \<in># SDA'#} = mset (map Neg As)"
	using subst_cls_def by auto
	then have "\<exists>NAs'. map (\<lambda>L. L \<cdot>l \<eta>) NAs' = map Neg As \<and> mset NAs' = SDA'"
	using image_mset_of_subset_list[of "\<lambda>L. L \<cdot>l \<eta>" SDA' "map Neg As"] by auto
	then obtain As' where As'_p:
	"map (\<lambda>L. L \<cdot>l \<eta>) (map Neg As') = map Neg As \<and> mset (map Neg As') = SDA'"
	by (metis (no_types, lifting) Neg_atm_of_iff negL ex_map_conv set_mset_mset)

	have "negs (mset As') = SDA'"
	using As'_p by auto
	moreover have "map (\<lambda>L. L \<cdot>l \<eta>) (map Neg As') = map Neg As"
	using As'_p by auto
	then have "As' \<cdot>al \<eta> = As"
	using eql_map_neg_lit_eql_atm by auto
	ultimately show ?thesis
	by blast
	qed

	lemma map2_add_mset_map:
	assumes "length AAs' = n" and "length As' = n"
	shows "map2 add_mset (As' \<cdot>al \<eta>) (AAs' \<cdot>aml \<eta>) = map2 add_mset As' AAs' \<cdot>aml \<eta>"
	using assms
	proof (induction n arbitrary: AAs' As')
	case (Suc n)
	then have "map2 add_mset (tl (As' \<cdot>al \<eta>)) (tl (AAs' \<cdot>aml \<eta>)) = map2 add_mset (tl As') (tl AAs') \<cdot>aml \<eta>"
	by simp
	moreover have Succ: "length (As' \<cdot>al \<eta>) = Suc n" "length (AAs' \<cdot>aml \<eta>) = Suc n"
	using Suc(3) Suc(2) by auto
	then have "length (tl (As' \<cdot>al \<eta>)) = n" "length (tl (AAs' \<cdot>aml \<eta>)) = n"
	by auto
	then have "length (map2 add_mset (tl (As' \<cdot>al \<eta>)) (tl (AAs' \<cdot>aml \<eta>))) = n"
	"length (map2 add_mset (tl As') (tl AAs') \<cdot>aml \<eta>) = n"
	using Suc(2,3) by auto
	ultimately have "\<forall>i < n. tl (map2 add_mset ( (As' \<cdot>al \<eta>)) ((AAs' \<cdot>aml \<eta>))) ! i =
	tl (map2 add_mset (As') (AAs') \<cdot>aml \<eta>) ! i"
	using Suc(2,3) Succ by (simp add: map2_tl map_tl subst_atm_mset_list_def del: subst_atm_list_tl)
	moreover have nn: "length (map2 add_mset ((As' \<cdot>al \<eta>)) ((AAs' \<cdot>aml \<eta>))) = Suc n"
	"length (map2 add_mset (As') (AAs') \<cdot>aml \<eta>) = Suc n"
	using Succ Suc by auto
	ultimately have "\<forall>i. i < Suc n \<longrightarrow> i > 0 \<longrightarrow>
	map2 add_mset (As' \<cdot>al \<eta>) (AAs' \<cdot>aml \<eta>) ! i = (map2 add_mset As' AAs' \<cdot>aml \<eta>) ! i"
	by (auto simp: subst_atm_mset_list_def gr0_conv_Suc subst_atm_mset_def)
	moreover have "add_mset (hd As' \<cdot>a \<eta>) (hd AAs' \<cdot>am \<eta>) = add_mset (hd As') (hd AAs') \<cdot>am \<eta>"
	unfolding subst_atm_mset_def by auto
	then have "(map2 add_mset (As' \<cdot>al \<eta>) (AAs' \<cdot>aml \<eta>)) ! 0 = (map2 add_mset (As') (AAs') \<cdot>aml \<eta>) ! 0"
	using Suc by (simp add: Succ(2) subst_atm_mset_def)
	ultimately have "\<forall>i < Suc n. (map2 add_mset (As' \<cdot>al \<eta>) (AAs' \<cdot>aml \<eta>)) ! i =
	(map2 add_mset (As') (AAs') \<cdot>aml \<eta>) ! i"
	using Suc by auto
	then show ?case
	using nn list_eq_iff_nth_eq by metis
	qed auto

	context
	fixes S :: "'a clause \<Rightarrow> 'a clause"
	begin


	subsection \<open>Calculus\<close>

	text \<open>
	The following corresponds to Figure 4.
	\<close>

	definition maximal_wrt :: "'a \<Rightarrow> 'a literal multiset \<Rightarrow> bool" where
	"maximal_wrt A C \<longleftrightarrow> (\<forall>B \<in> atms_of C. \<not> less_atm A B)"

	definition strictly_maximal_wrt :: "'a \<Rightarrow> 'a literal multiset \<Rightarrow> bool" where
	"strictly_maximal_wrt A C \<equiv> \<forall>B \<in> atms_of C. A \<noteq> B \<and> \<not> less_atm A B"

	lemma strictly_maximal_wrt_maximal_wrt: "strictly_maximal_wrt A C \<Longrightarrow> maximal_wrt A C"
	unfolding maximal_wrt_def strictly_maximal_wrt_def by auto

	lemma maximal_wrt_subst: "maximal_wrt (A \<cdot>a \<sigma>) (C \<cdot> \<sigma>) \<Longrightarrow> maximal_wrt A C"
	unfolding maximal_wrt_def using in_atms_of_subst less_atm_stable by blast

	lemma strictly_maximal_wrt_subst:
	"strictly_maximal_wrt (A \<cdot>a \<sigma>) (C \<cdot> \<sigma>) \<Longrightarrow> strictly_maximal_wrt A C"
	unfolding strictly_maximal_wrt_def using in_atms_of_subst less_atm_stable by blast

	inductive eligible :: "'s \<Rightarrow> 'a list \<Rightarrow> 'a clause \<Rightarrow> bool" where
	eligible:
	"S DA = negs (mset As) \<or> S DA = {#} \<and> length As = 1 \<and> maximal_wrt (As ! 0 \<cdot>a \<sigma>) (DA \<cdot> \<sigma>) \<Longrightarrow>
	eligible \<sigma> As DA"

	inductive
	ord_resolve
	:: "'a clause list \<Rightarrow> 'a clause \<Rightarrow> 'a multiset list \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 'a clause \<Rightarrow> bool"
	where
	ord_resolve:
	"length CAs = n \<Longrightarrow>
	length Cs = n \<Longrightarrow>
	length AAs = n \<Longrightarrow>
	length As = n \<Longrightarrow>
	n \<noteq> 0 \<Longrightarrow>
	(\<forall>i < n. CAs ! i = Cs ! i + poss (AAs ! i)) \<Longrightarrow>
	(\<forall>i < n. AAs ! i \<noteq> {#}) \<Longrightarrow>
	Some \<sigma> = mgu (set_mset ` set (map2 add_mset As AAs)) \<Longrightarrow>
	eligible \<sigma> As (D + negs (mset As)) \<Longrightarrow>
	(\<forall>i < n. strictly_maximal_wrt (As ! i \<cdot>a \<sigma>) (Cs ! i \<cdot> \<sigma>)) \<Longrightarrow>
	(\<forall>i < n. S (CAs ! i) = {#}) \<Longrightarrow>
	ord_resolve CAs (D + negs (mset As)) AAs As \<sigma> ((\<Sum>\<^sub># (mset Cs) + D) \<cdot> \<sigma>)"

	inductive
	ord_resolve_rename
	:: "'a clause list \<Rightarrow> 'a clause \<Rightarrow> 'a multiset list \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 'a clause \<Rightarrow> bool"
	where
	ord_resolve_rename:
	"length CAs = n \<Longrightarrow>
	length AAs = n \<Longrightarrow>
	length As = n \<Longrightarrow>
	(\<forall>i < n. poss (AAs ! i) \<subseteq># CAs ! i) \<Longrightarrow>
	negs (mset As) \<subseteq># DA \<Longrightarrow>
	\<rho> = hd (renamings_apart (DA # CAs)) \<Longrightarrow>
	\<rho>s = tl (renamings_apart (DA # CAs)) \<Longrightarrow>
	ord_resolve (CAs \<cdot>\<cdot>cl \<rho>s) (DA \<cdot> \<rho>) (AAs \<cdot>\<cdot>aml \<rho>s) (As \<cdot>al \<rho>) \<sigma> E \<Longrightarrow>
	ord_resolve_rename CAs DA AAs As \<sigma> E"

	lemma ord_resolve_empty_main_prem: "\<not> ord_resolve Cs {#} AAs As \<sigma> E"
	by (simp add: ord_resolve.simps)

	lemma ord_resolve_rename_empty_main_prem: "\<not> ord_resolve_rename Cs {#} AAs As \<sigma> E"
	by (simp add: ord_resolve_empty_main_prem ord_resolve_rename.simps)


	subsection \<open>Soundness\<close>

	text \<open>
	Soundness is not discussed in the chapter, but it is an important property.
	\<close>

	lemma ord_resolve_ground_inst_sound:
	assumes
	res_e: "ord_resolve CAs DA AAs As \<sigma> E" and
	cc_inst_true: "I \<Turnstile>m mset CAs \<cdot>cm \<sigma> \<cdot>cm \<eta>" and
	d_inst_true: "I \<Turnstile> DA \<cdot> \<sigma> \<cdot> \<eta>" and
	ground_subst_\<eta>: "is_ground_subst \<eta>"
	shows "I \<Turnstile> E \<cdot> \<eta>"
	using res_e
	proof (cases rule: ord_resolve.cases)
	case (ord_resolve n Cs D)
	note da = this(1) and e = this(2) and cas_len = this(3) and cs_len = this(4) and
	aas_len = this(5) and as_len = this(6) and cas = this(8) and mgu = this(10) and
	len = this(1)

	have len: "length CAs = length As"
	using as_len cas_len by auto
	have "is_ground_subst (\<sigma> \<odot> \<eta>)"
	using ground_subst_\<eta> by (rule is_ground_comp_subst)
	then have cc_true: "I \<Turnstile>m mset CAs \<cdot>cm \<sigma> \<cdot>cm \<eta>" and d_true: "I \<Turnstile> DA \<cdot> \<sigma> \<cdot> \<eta>"
	using cc_inst_true d_inst_true by auto

	from mgu have unif: "\<forall>i < n. \<forall>A\<in>#AAs ! i. A \<cdot>a \<sigma> = As ! i \<cdot>a \<sigma>"
	using mgu_unifier as_len aas_len by blast

	show "I \<Turnstile> E \<cdot> \<eta>"
	proof (cases "\<forall>A \<in> set As. A \<cdot>a \<sigma> \<cdot>a \<eta> \<in> I")
	case True
	then have "\<not> I \<Turnstile> negs (mset As) \<cdot> \<sigma> \<cdot> \<eta>"
	unfolding true_cls_def[of I] by auto
	then have "I \<Turnstile> D \<cdot> \<sigma> \<cdot> \<eta>"
	using d_true da by auto
	then show ?thesis
	unfolding e by auto
	next
	case False
	then obtain i where a_in_aa: "i < length CAs" and a_false: "(As ! i) \<cdot>a \<sigma> \<cdot>a \<eta> \<notin> I"
	using da len by (metis in_set_conv_nth)
	define C where "C \<equiv> Cs ! i"
	define BB where "BB \<equiv> AAs ! i"
	have c_cf': "C \<subseteq># \<Sum>\<^sub># (mset CAs)"
	unfolding C_def using a_in_aa cas cas_len
	by (metis less_subset_eq_Union_mset mset_subset_eq_add_left subset_mset.trans)
	have c_in_cc: "C + poss BB \<in># mset CAs"
	using C_def BB_def a_in_aa cas_len in_set_conv_nth cas by fastforce
	{
	fix B
	assume "B \<in># BB"
	then have "B \<cdot>a \<sigma> = (As ! i) \<cdot>a \<sigma>"
	using unif a_in_aa cas_len unfolding BB_def by auto
	}
	then have "\<not> I \<Turnstile> poss BB \<cdot> \<sigma> \<cdot> \<eta>"
	using a_false by (auto simp: true_cls_def)
	moreover have "I \<Turnstile> (C + poss BB) \<cdot> \<sigma> \<cdot> \<eta>"
	using c_in_cc cc_true true_cls_mset_true_cls[of I "mset CAs \<cdot>cm \<sigma> \<cdot>cm \<eta>"] by force
	ultimately have "I \<Turnstile> C \<cdot> \<sigma> \<cdot> \<eta>"
	by simp
	then show ?thesis
	unfolding e subst_cls_union using c_cf' C_def a_in_aa cas_len cs_len
	by (metis (no_types, lifting) mset_subset_eq_add_left nth_mem_mset set_mset_mono sum_mset.remove true_cls_mono subst_cls_mono)
	qed
	qed

	text \<open>
	The previous lemma is not only used to prove soundness, but also the following lemma which is
	used to prove Lemma 4.10.
	\<close>

	lemma ord_resolve_rename_ground_inst_sound:
	assumes
	"ord_resolve_rename CAs DA AAs As \<sigma> E" and
	"\<rho>s = tl (renamings_apart (DA # CAs))" and
	"\<rho> = hd (renamings_apart (DA # CAs))" and
	"I \<Turnstile>m (mset (CAs \<cdot>\<cdot>cl \<rho>s)) \<cdot>cm \<sigma> \<cdot>cm \<eta>" and
	"I \<Turnstile> DA \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<eta>" and
	"is_ground_subst \<eta>"
	shows "I \<Turnstile> E \<cdot> \<eta>"
	using assms by (cases rule: ord_resolve_rename.cases) (fast intro: ord_resolve_ground_inst_sound)

	text \<open>
	Here follows the soundness theorem for the resolution rule.
	\<close>

	theorem ord_resolve_sound:
	assumes
	res_e: "ord_resolve CAs DA AAs As \<sigma> E" and
	cc_d_true: "\<And>\<sigma>. is_ground_subst \<sigma> \<Longrightarrow> I \<Turnstile>m (mset CAs + {#DA#}) \<cdot>cm \<sigma>" and
	ground_subst_\<eta>: "is_ground_subst \<eta>"
	shows "I \<Turnstile> E \<cdot> \<eta>"
	proof (use res_e in \<open>cases rule: ord_resolve.cases\<close>)
	case (ord_resolve n Cs D)
	note da = this(1) and e = this(2) and cas_len = this(3) and cs_len = this(4)
	and aas_len = this(5) and as_len = this(6) and cas = this(8) and mgu = this(10)
	have ground_subst_\<sigma>_\<eta>: "is_ground_subst (\<sigma> \<odot> \<eta>)"
	using ground_subst_\<eta> by (rule is_ground_comp_subst)
	have cas_true: "I \<Turnstile>m mset CAs \<cdot>cm \<sigma> \<cdot>cm \<eta>"
	using cc_d_true ground_subst_\<sigma>_\<eta> by fastforce
	have da_true: "I \<Turnstile> DA \<cdot> \<sigma> \<cdot> \<eta>"
	using cc_d_true ground_subst_\<sigma>_\<eta> by fastforce
	show "I \<Turnstile> E \<cdot> \<eta>"
	using ord_resolve_ground_inst_sound[OF res_e cas_true da_true] ground_subst_\<eta> by auto
	qed

	lemma subst_sound:
	assumes
	"\<And>\<sigma>. is_ground_subst \<sigma> \<Longrightarrow> I \<Turnstile> C \<cdot> \<sigma>" and
	"is_ground_subst \<eta>"
	shows "I \<Turnstile> C \<cdot> \<rho> \<cdot> \<eta>"
	using assms is_ground_comp_subst subst_cls_comp_subst by metis

	lemma subst_sound_scl:
	assumes
	len: "length P = length CAs" and
	true_cas: "\<And>\<sigma>. is_ground_subst \<sigma> \<Longrightarrow> I \<Turnstile>m mset CAs \<cdot>cm \<sigma>" and
	ground_subst_\<eta>: "is_ground_subst \<eta>"
	shows "I \<Turnstile>m mset (CAs \<cdot>\<cdot>cl P) \<cdot>cm \<eta>"
	proof -
	from true_cas have "\<And>CA. CA\<in># mset CAs \<Longrightarrow> (\<And>\<sigma>. is_ground_subst \<sigma> \<Longrightarrow> I \<Turnstile> CA \<cdot> \<sigma>)"
	unfolding true_cls_mset_def by force
	then have "\<forall>i < length CAs. \<forall>\<sigma>. is_ground_subst \<sigma> \<longrightarrow> (I \<Turnstile> CAs ! i \<cdot> \<sigma>)"
	using in_set_conv_nth by auto
	then have true_cp: "\<forall>i < length CAs. \<forall>\<sigma>. is_ground_subst \<sigma> \<longrightarrow> I \<Turnstile> CAs ! i \<cdot> P ! i \<cdot> \<sigma>"
	using subst_sound len by auto

	{
	fix CA
	assume "CA \<in># mset (CAs \<cdot>\<cdot>cl P)"
	then obtain i where
	i_x: "i < length (CAs \<cdot>\<cdot>cl P)" "CA = (CAs \<cdot>\<cdot>cl P) ! i"
	by (metis in_mset_conv_nth)
	then have "\<forall>\<sigma>. is_ground_subst \<sigma> \<longrightarrow> I \<Turnstile> CA \<cdot> \<sigma>"
	using true_cp unfolding subst_cls_lists_def by (simp add: len)
	}
	then show ?thesis
	using assms unfolding true_cls_mset_def by auto
	qed

	text \<open>
	Here follows the soundness theorem for the resolution rule with renaming.
	\<close>

	lemma ord_resolve_rename_sound:
	assumes
	res_e: "ord_resolve_rename CAs DA AAs As \<sigma> E" and
	cc_d_true: "\<And>\<sigma>. is_ground_subst \<sigma> \<Longrightarrow> I \<Turnstile>m ((mset CAs) + {#DA#}) \<cdot>cm \<sigma>" and
	ground_subst_\<eta>: "is_ground_subst \<eta>"
	shows "I \<Turnstile> E \<cdot> \<eta>"
	using res_e
	proof (cases rule: ord_resolve_rename.cases)
	case (ord_resolve_rename n \<rho> \<rho>s)
	note \<rho>s = this(7) and res = this(8)
	have len: "length \<rho>s = length CAs"
	using \<rho>s renamings_apart_length by auto
	have "\<And>\<sigma>. is_ground_subst \<sigma> \<Longrightarrow> I \<Turnstile>m (mset (CAs \<cdot>\<cdot>cl \<rho>s) + {#DA \<cdot> \<rho>#}) \<cdot>cm \<sigma>"
	using subst_sound_scl[OF len, of I] subst_sound cc_d_true by auto
	then show "I \<Turnstile> E \<cdot> \<eta>"
	using ground_subst_\<eta> ord_resolve_sound[OF res] by simp
	qed


	subsection \<open>Other Basic Properties\<close>

	lemma ord_resolve_unique:
	assumes
	"ord_resolve CAs DA AAs As \<sigma> E" and
	"ord_resolve CAs DA AAs As \<sigma>' E'"
	shows "\<sigma> = \<sigma>' \<and> E = E'"
	using assms
	proof (cases rule: ord_resolve.cases[case_product ord_resolve.cases], intro conjI)
	case (ord_resolve_ord_resolve CAs n Cs AAs As \<sigma>'' DA CAs' n' Cs' AAs' As' \<sigma>''' DA')
	note res = this(1-17) and res' = this(18-34)

	show \<sigma>: "\<sigma> = \<sigma>'"
	using res(3-5,14) res'(3-5,14) by (metis option.inject)

	have "Cs = Cs'"
	using res(1,3,7,8,12) res'(1,3,7,8,12) by (metis add_right_imp_eq nth_equalityI)
	moreover have "DA = DA'"
	using res(2,4) res'(2,4) by fastforce
	ultimately show "E = E'"
	using res(5,6) res'(5,6) \<sigma> by blast
	qed

	lemma ord_resolve_rename_unique:
	assumes
	"ord_resolve_rename CAs DA AAs As \<sigma> E" and
	"ord_resolve_rename CAs DA AAs As \<sigma>' E'"
	shows "\<sigma> = \<sigma>' \<and> E = E'"
	using assms unfolding ord_resolve_rename.simps using ord_resolve_unique by meson

	lemma ord_resolve_max_side_prems: "ord_resolve CAs DA AAs As \<sigma> E \<Longrightarrow> length CAs \<le> size DA"
	by (auto elim!: ord_resolve.cases)

	lemma ord_resolve_rename_max_side_prems:
	"ord_resolve_rename CAs DA AAs As \<sigma> E \<Longrightarrow> length CAs \<le> size DA"
	by (elim ord_resolve_rename.cases, drule ord_resolve_max_side_prems, simp add: renamings_apart_length)


	subsection \<open>Inference System\<close>

	definition ord_FO_\<Gamma> :: "'a inference set" where
	"ord_FO_\<Gamma> = {Infer (mset CAs) DA E \| CAs DA AAs As \<sigma> E. ord_resolve_rename CAs DA AAs As \<sigma> E}"

	interpretation ord_FO_resolution: inference_system ord_FO_\<Gamma> .

	lemma finite_ord_FO_resolution_inferences_between:
	assumes fin_cc: "finite CC"
	shows "finite (ord_FO_resolution.inferences_between CC C)"
	proof -
	let ?CCC = "CC \<union> {C}"

	define all_AA where "all_AA = (\<Union>D \<in> ?CCC. atms_of D)"
	define max_ary where "max_ary = Max (size ` ?CCC)"
	define CAS where "CAS = {CAs. CAs \<in> lists ?CCC \<and> length CAs \<le> max_ary}"
	define AS where "AS = {As. As \<in> lists all_AA \<and> length As \<le> max_ary}"
	define AAS where "AAS = {AAs. AAs \<in> lists (mset ` AS) \<and> length AAs \<le> max_ary}"

	note defs = all_AA_def max_ary_def CAS_def AS_def AAS_def

	let ?infer_of =
	"\<lambda>CAs DA AAs As. Infer (mset CAs) DA (THE E. \<exists>\<sigma>. ord_resolve_rename CAs DA AAs As \<sigma> E)"

	let ?Z = "{\<gamma> \| CAs DA AAs As \<sigma> E \<gamma>. \<gamma> = Infer (mset CAs) DA E
	\<and> ord_resolve_rename CAs DA AAs As \<sigma> E \<and> infer_from ?CCC \<gamma> \<and> C \<in># prems_of \<gamma>}"
	let ?Y = "{Infer (mset CAs) DA E \| CAs DA AAs As \<sigma> E.
	ord_resolve_rename CAs DA AAs As \<sigma> E \<and> set CAs \<union> {DA} \<subseteq> ?CCC}"
	let ?X = "{?infer_of CAs DA AAs As \| CAs DA AAs As. CAs \<in> CAS \<and> DA \<in> ?CCC \<and> AAs \<in> AAS \<and> As \<in> AS}"
	let ?W = "CAS \<times> ?CCC \<times> AAS \<times> AS"

	have fin_w: "finite ?W"
	unfolding defs using fin_cc by (simp add: finite_lists_length_le lists_eq_set)

	have "?Z \<subseteq> ?Y"
	by (force simp: infer_from_def)
	also have "\<dots> \<subseteq> ?X"
	proof -
	{
	fix CAs DA AAs As \<sigma> E
	assume
	res_e: "ord_resolve_rename CAs DA AAs As \<sigma> E" and
	da_in: "DA \<in> ?CCC" and
	cas_sub: "set CAs \<subseteq> ?CCC"

	have "E = (THE E. \<exists>\<sigma>. ord_resolve_rename CAs DA AAs As \<sigma> E)
	\<and> CAs \<in> CAS \<and> AAs \<in> AAS \<and> As \<in> AS" (is "?e \<and> ?cas \<and> ?aas \<and> ?as")
	proof (intro conjI)
	show ?e
	using res_e ord_resolve_rename_unique by (blast intro: the_equality[symmetric])
	next
	show ?cas
	unfolding CAS_def max_ary_def using cas_sub
	ord_resolve_rename_max_side_prems[OF res_e] da_in fin_cc
	by (auto simp add: Max_ge_iff)
	next
	show ?aas
	using res_e
	proof (cases rule: ord_resolve_rename.cases)
	case (ord_resolve_rename n \<rho> \<rho>s)
	note len_cas = this(1) and len_aas = this(2) and len_as = this(3) and
	aas_sub = this(4) and as_sub = this(5) and res_e' = this(8)

	show ?thesis
	unfolding AAS_def
	proof (clarify, intro conjI)
	show "AAs \<in> lists (mset ` AS)"
	unfolding AS_def image_def
	proof clarsimp
	fix AA
	assume "AA \<in> set AAs"
	then obtain i where
	i_lt: "i < n" and
	aa: "AA = AAs ! i"
	by (metis in_set_conv_nth len_aas)

	have casi_in: "CAs ! i \<in> ?CCC"
	using i_lt len_cas cas_sub nth_mem by blast

	have pos_aa_sub: "poss AA \<subseteq># CAs ! i"
	using aa aas_sub i_lt by blast
	then have "set_mset AA \<subseteq> atms_of (CAs ! i)"
	by (metis atms_of_poss lits_subseteq_imp_atms_subseteq set_mset_mono)
	also have aa_sub: "\<dots> \<subseteq> all_AA"
	unfolding all_AA_def using casi_in by force
	finally have aa_sub: "set_mset AA \<subseteq> all_AA"
	.

	have "size AA = size (poss AA)"
	by simp
	also have "\<dots> \<le> size (CAs ! i)"
	by (rule size_mset_mono[OF pos_aa_sub])
	also have "\<dots> \<le> max_ary"
	unfolding max_ary_def using fin_cc casi_in by auto
	finally have sz_aa: "size AA \<le> max_ary"
	.

	let ?As' = "sorted_list_of_multiset AA"

	have "?As' \<in> lists all_AA"
	using aa_sub by auto
	moreover have "length ?As' \<le> max_ary"
	using sz_aa by simp
	moreover have "AA = mset ?As'"
	by simp
	ultimately show "\<exists>xa. xa \<in> lists all_AA \<and> length xa \<le> max_ary \<and> AA = mset xa"
	by blast
	qed
	next
	have "length AAs = length As"
	unfolding len_aas len_as ..
	also have "\<dots> \<le> size DA"
	using as_sub size_mset_mono by fastforce
	also have "\<dots> \<le> max_ary"
	unfolding max_ary_def using fin_cc da_in by auto
	finally show "length AAs \<le> max_ary"
	.
	qed
	qed
	next
	show ?as
	unfolding AS_def
	proof (clarify, intro conjI)
	have "set As \<subseteq> atms_of DA"
	using res_e[simplified ord_resolve_rename.simps]
	by (metis atms_of_negs lits_subseteq_imp_atms_subseteq set_mset_mono set_mset_mset)
	also have "\<dots> \<subseteq> all_AA"
	unfolding all_AA_def using da_in by blast
	finally show "As \<in> lists all_AA"
	unfolding lists_eq_set by simp
	next
	have "length As \<le> size DA"
	using res_e[simplified ord_resolve_rename.simps]
	ord_resolve_rename_max_side_prems[OF res_e] by auto
	also have "size DA \<le> max_ary"
	unfolding max_ary_def using fin_cc da_in by auto
	finally show "length As \<le> max_ary"
	.
	qed
	qed
	}
	then show ?thesis
	by simp fast
	qed
	also have "\<dots> \<subseteq> (\<lambda>(CAs, DA, AAs, As). ?infer_of CAs DA AAs As) ` ?W"
	unfolding image_def Bex_cartesian_product by fast
	finally show ?thesis
	unfolding inference_system.inferences_between_def ord_FO_\<Gamma>_def mem_Collect_eq
	by (fast intro: rev_finite_subset[OF finite_imageI[OF fin_w]])
	qed

	lemma ord_FO_resolution_inferences_between_empty_empty:
	"ord_FO_resolution.inferences_between {} {#} = {}"
	unfolding ord_FO_resolution.inferences_between_def inference_system.inferences_between_def
	infer_from_def ord_FO_\<Gamma>_def
	using ord_resolve_rename_empty_main_prem by auto


	subsection \<open>Lifting\<close>

	text \<open>
	The following corresponds to the passage between Lemmas 4.11 and 4.12.
	\<close>

	context
	fixes M :: "'a clause set"
	assumes select: "selection S"
	begin

	interpretation selection
	by (rule select)

	definition S_M :: "'a literal multiset \<Rightarrow> 'a literal multiset" where
	"S_M C =
	(if C \<in> grounding_of_clss M then
	(SOME C'. \<exists>D \<sigma>. D \<in> M \<and> C = D \<cdot> \<sigma> \<and> C' = S D \<cdot> \<sigma> \<and> is_ground_subst \<sigma>)
	else
	S C)"

	lemma S_M_grounding_of_clss:
	assumes "C \<in> grounding_of_clss M"
	obtains D \<sigma> where
	"D \<in> M \<and> C = D \<cdot> \<sigma> \<and> S_M C = S D \<cdot> \<sigma> \<and> is_ground_subst \<sigma>"
	proof (atomize_elim, unfold S_M_def eqTrueI[OF assms] if_True, rule someI_ex)
	from assms show "\<exists>C' D \<sigma>. D \<in> M \<and> C = D \<cdot> \<sigma> \<and> C' = S D \<cdot> \<sigma> \<and> is_ground_subst \<sigma>"
	by (auto simp: grounding_of_clss_def grounding_of_cls_def)
	qed

	lemma S_M_not_grounding_of_clss: "C \<notin> grounding_of_clss M \<Longrightarrow> S_M C = S C"
	unfolding S_M_def by simp

	lemma S_M_selects_subseteq: "S_M C \<subseteq># C"
	by (metis S_M_grounding_of_clss S_M_not_grounding_of_clss S_selects_subseteq subst_cls_mono_mset)

	lemma S_M_selects_neg_lits: "L \<in># S_M C \<Longrightarrow> is_neg L"
	by (metis Melem_subst_cls S_M_grounding_of_clss S_M_not_grounding_of_clss S_selects_neg_lits
	subst_lit_is_neg)

	end

	end

	text \<open>
	The following corresponds to Lemma 4.12:
	\<close>

	lemma ground_resolvent_subset:
	assumes
	gr_cas: "is_ground_cls_list CAs" and
	gr_da: "is_ground_cls DA" and
	res_e: "ord_resolve S CAs DA AAs As \<sigma> E"
	shows "E \<subseteq># \<Sum>\<^sub># (mset CAs) + DA"
	using res_e
	proof (cases rule: ord_resolve.cases)
	case (ord_resolve n Cs D)
	note da = this(1) and e = this(2) and cas_len = this(3) and cs_len = this(4)
	and aas_len = this(5) and as_len = this(6) and cas = this(8) and mgu = this(10)
	then have cs_sub_cas: "\<Sum>\<^sub># (mset Cs) \<subseteq># \<Sum>\<^sub># (mset CAs)"
	using subseteq_list_Union_mset cas_len cs_len by force
	then have cs_sub_cas: "\<Sum>\<^sub># (mset Cs) \<subseteq># \<Sum>\<^sub># (mset CAs)"
	using subseteq_list_Union_mset cas_len cs_len by force
	then have gr_cs: "is_ground_cls_list Cs"
	using gr_cas by simp
	have d_sub_da: "D \<subseteq># DA"
	by (simp add: da)
	then have gr_d: "is_ground_cls D"
	using gr_da is_ground_cls_mono by auto

	have "is_ground_cls (\<Sum>\<^sub># (mset Cs) + D)"
	using gr_cs gr_d by auto
	with e have "E = \<Sum>\<^sub># (mset Cs) + D"
	by auto
	then show ?thesis
	using cs_sub_cas d_sub_da by (auto simp: subset_mset.add_mono)
	qed

	lemma ord_resolve_obtain_clauses:
	assumes
	res_e: "ord_resolve (S_M S M) CAs DA AAs As \<sigma> E" and
	select: "selection S" and
	grounding: "{DA} \<union> set CAs \<subseteq> grounding_of_clss M" and
	n: "length CAs = n" and
	d: "DA = D + negs (mset As)" and
	c: "(\<forall>i < n. CAs ! i = Cs ! i + poss (AAs ! i))" "length Cs = n" "length AAs = n"
	obtains DA0 \<eta>0 CAs0 \<eta>s0 As0 AAs0 D0 Cs0 where
	"length CAs0 = n"
	"length \<eta>s0 = n"
	"DA0 \<in> M"
	"DA0 \<cdot> \<eta>0 = DA"
	"S DA0 \<cdot> \<eta>0 = S_M S M DA"
	"\<forall>CA0 \<in> set CAs0. CA0 \<in> M"
	"CAs0 \<cdot>\<cdot>cl \<eta>s0 = CAs"
	"map S CAs0 \<cdot>\<cdot>cl \<eta>s0 = map (S_M S M) CAs"
	"is_ground_subst \<eta>0"
	"is_ground_subst_list \<eta>s0"
	"As0 \<cdot>al \<eta>0 = As"
	"AAs0 \<cdot>\<cdot>aml \<eta>s0 = AAs"
	"length As0 = n"
	"D0 \<cdot> \<eta>0 = D"
	"DA0 = D0 + (negs (mset As0))"
	"S_M S M (D + negs (mset As)) \<noteq> {#} \<Longrightarrow> negs (mset As0) = S DA0"
	"length Cs0 = n"
	"Cs0 \<cdot>\<cdot>cl \<eta>s0 = Cs"
	"\<forall>i < n. CAs0 ! i = Cs0 ! i + poss (AAs0 ! i)"
	"length AAs0 = n"
	using res_e
	proof (cases rule: ord_resolve.cases)
	case (ord_resolve n_twin Cs_twins D_twin)
	note da = this(1) and e = this(2) and cas = this(8) and mgu = this(10) and eligible = this(11)
	from ord_resolve have "n_twin = n" "D_twin = D"
	using n d by auto
	moreover have "Cs_twins = Cs"
	using c cas n calculation(1) \<open>length Cs_twins = n_twin\<close> by (auto simp add: nth_equalityI)
	ultimately
	have nz: "n \<noteq> 0" and cs_len: "length Cs = n" and aas_len: "length AAs = n" and as_len: "length As = n"
	and da: "DA = D + negs (mset As)" and eligible: "eligible (S_M S M) \<sigma> As (D + negs (mset As))"
	and cas: "\<forall>i<n. CAs ! i = Cs ! i + poss (AAs ! i)"
	using ord_resolve by force+

	note n = \<open>n \<noteq> 0\<close> \<open>length CAs = n\<close> \<open>length Cs = n\<close> \<open>length AAs = n\<close> \<open>length As = n\<close>

	interpret S: selection S by (rule select)

	\<comment> \<open>Obtain FO side premises\<close>
	have "\<forall>CA \<in> set CAs. \<exists>CA0 \<eta>c0. CA0 \<in> M \<and> CA0 \<cdot> \<eta>c0 = CA \<and> S CA0 \<cdot> \<eta>c0 = S_M S M CA \<and> is_ground_subst \<eta>c0"
	using grounding S_M_grounding_of_clss select by (metis (no_types) le_supE subset_iff)
	then have "\<forall>i < n. \<exists>CA0 \<eta>c0. CA0 \<in> M \<and> CA0 \<cdot> \<eta>c0 = (CAs ! i) \<and> S CA0 \<cdot> \<eta>c0 = S_M S M (CAs ! i) \<and> is_ground_subst \<eta>c0"
	using n by force
	then obtain \<eta>s0f CAs0f where f_p:
	"\<forall>i < n. CAs0f i \<in> M"
	"\<forall>i < n. (CAs0f i) \<cdot> (\<eta>s0f i) = (CAs ! i)"
	"\<forall>i < n. S (CAs0f i) \<cdot> (\<eta>s0f i) = S_M S M (CAs ! i)"
	"\<forall>i < n. is_ground_subst (\<eta>s0f i)"
	using n by (metis (no_types))

	define \<eta>s0 where
	"\<eta>s0 = map \<eta>s0f [0 ..<n]"
	define CAs0 where
	"CAs0 = map CAs0f [0 ..<n]"

	have "length \<eta>s0 = n" "length CAs0 = n"
	unfolding \<eta>s0_def CAs0_def by auto
	note n = \<open>length \<eta>s0 = n\<close> \<open>length CAs0 = n\<close> n

	\<comment> \<open>The properties we need of the FO side premises\<close>
	have CAs0_in_M: "\<forall>CA0 \<in> set CAs0. CA0 \<in> M"
	unfolding CAs0_def using f_p(1) by auto
	have CAs0_to_CAs: "CAs0 \<cdot>\<cdot>cl \<eta>s0 = CAs"
	unfolding CAs0_def \<eta>s0_def using f_p(2) by (auto simp: n intro: nth_equalityI)
	have SCAs0_to_SMCAs: "(map S CAs0) \<cdot>\<cdot>cl \<eta>s0 = map (S_M S M) CAs"
	unfolding CAs0_def \<eta>s0_def using f_p(3) n by (force intro: nth_equalityI)
	have sub_ground: "\<forall>\<eta>c0 \<in> set \<eta>s0. is_ground_subst \<eta>c0"
	unfolding \<eta>s0_def using f_p n by force
	then have "is_ground_subst_list \<eta>s0"
	using n unfolding is_ground_subst_list_def by auto

	\<comment> \<open>Split side premises CAs0 into Cs0 and AAs0\<close>
	obtain AAs0 Cs0 where AAs0_Cs0_p:
	"AAs0 \<cdot>\<cdot>aml \<eta>s0 = AAs" "length Cs0 = n" "Cs0 \<cdot>\<cdot>cl \<eta>s0 = Cs"
	"\<forall>i < n. CAs0 ! i = Cs0 ! i + poss (AAs0 ! i)" "length AAs0 = n"
	proof -
	have "\<forall>i < n. \<exists>AA0. AA0 \<cdot>am \<eta>s0 ! i = AAs ! i \<and> poss AA0 \<subseteq># CAs0 ! i"
	proof (rule, rule)
	fix i
	assume "i < n"
	have "CAs0 ! i \<cdot> \<eta>s0 ! i = CAs ! i"
	using \<open>i < n\<close> \<open>CAs0 \<cdot>\<cdot>cl \<eta>s0 = CAs\<close> n by force
	moreover have "poss (AAs ! i) \<subseteq># CAs !i"
	using \<open>i < n\<close> cas by auto
	ultimately obtain poss_AA0 where
	nn: "poss_AA0 \<cdot> \<eta>s0 ! i = poss (AAs ! i) \<and> poss_AA0 \<subseteq># CAs0 ! i"
	using cas image_mset_of_subset unfolding subst_cls_def by metis
	then have l: "\<forall>L \<in># poss_AA0. is_pos L"
	unfolding subst_cls_def by (metis Melem_subst_cls imageE literal.disc(1)
	literal.map_disc_iff set_image_mset subst_cls_def subst_lit_def)

	define AA0 where
	"AA0 = image_mset atm_of poss_AA0"

	have na: "poss AA0 = poss_AA0"
	using l unfolding AA0_def by auto
	then have "AA0 \<cdot>am \<eta>s0 ! i = AAs ! i"
	using nn by (metis (mono_tags) literal.inject(1) multiset.inj_map_strong subst_cls_poss)
	moreover have "poss AA0 \<subseteq># CAs0 ! i"
	using na nn by auto
	ultimately show "\<exists>AA0. AA0 \<cdot>am \<eta>s0 ! i = AAs ! i \<and> poss AA0 \<subseteq># CAs0 ! i"
	by blast
	qed
	then obtain AAs0f where
	AAs0f_p: "\<forall>i < n. AAs0f i \<cdot>am \<eta>s0 ! i = AAs ! i \<and> (poss (AAs0f i)) \<subseteq># CAs0 ! i"
	by metis

	define AAs0 where "AAs0 = map AAs0f [0 ..<n]"

	then have "length AAs0 = n"
	by auto
	note n = n \<open>length AAs0 = n\<close>

	from AAs0_def have "\<forall>i < n. AAs0 ! i \<cdot>am \<eta>s0 ! i = AAs ! i"
	using AAs0f_p by auto
	then have AAs0_AAs: "AAs0 \<cdot>\<cdot>aml \<eta>s0 = AAs"
	using n by (auto intro: nth_equalityI)

	from AAs0_def have AAs0_in_CAs0: "\<forall>i < n. poss (AAs0 ! i) \<subseteq># CAs0 ! i"
	using AAs0f_p by auto

	define Cs0 where
	"Cs0 = map2 (-) CAs0 (map poss AAs0)"

	have "length Cs0 = n"
	using Cs0_def n by auto
	note n = n \<open>length Cs0 = n\<close>

	have "\<forall>i < n. CAs0 ! i = Cs0 ! i + poss (AAs0 ! i)"
	using AAs0_in_CAs0 Cs0_def n by auto
	then have "Cs0 \<cdot>\<cdot>cl \<eta>s0 = Cs"
	using \<open>CAs0 \<cdot>\<cdot>cl \<eta>s0 = CAs\<close> AAs0_AAs cas n by (auto intro: nth_equalityI)

	show ?thesis
	using that
	\<open>AAs0 \<cdot>\<cdot>aml \<eta>s0 = AAs\<close> \<open>Cs0 \<cdot>\<cdot>cl \<eta>s0 = Cs\<close> \<open>\<forall>i < n. CAs0 ! i = Cs0 ! i + poss (AAs0 ! i)\<close>
	\<open>length AAs0 = n\<close> \<open>length Cs0 = n\<close>
	by blast
	qed

	\<comment> \<open>Obtain FO main premise\<close>
	have "\<exists>DA0 \<eta>0. DA0 \<in> M \<and> DA = DA0 \<cdot> \<eta>0 \<and> S DA0 \<cdot> \<eta>0 = S_M S M DA \<and> is_ground_subst \<eta>0"
	using grounding S_M_grounding_of_clss select by (metis le_supE singletonI subsetCE)
	then obtain DA0 \<eta>0 where
	DA0_\<eta>0_p: "DA0 \<in> M \<and> DA = DA0 \<cdot> \<eta>0 \<and> S DA0 \<cdot> \<eta>0 = S_M S M DA \<and> is_ground_subst \<eta>0"
	by auto
	\<comment> \<open>The properties we need of the FO main premise\<close>
	have DA0_in_M: "DA0 \<in> M"
	using DA0_\<eta>0_p by auto
	have DA0_to_DA: "DA0 \<cdot> \<eta>0 = DA"
	using DA0_\<eta>0_p by auto
	have SDA0_to_SMDA: "S DA0 \<cdot> \<eta>0 = S_M S M DA"
	using DA0_\<eta>0_p by auto
	have "is_ground_subst \<eta>0"
	using DA0_\<eta>0_p by auto

	\<comment> \<open>Split main premise DA0 into D0 and As0\<close>
	obtain D0 As0 where D0As0_p:
	"As0 \<cdot>al \<eta>0 = As" "length As0 = n" "D0 \<cdot> \<eta>0 = D" "DA0 = D0 + (negs (mset As0))"
	"S_M S M (D + negs (mset As)) \<noteq> {#} \<Longrightarrow> negs (mset As0) = S DA0"
	proof -
	{
	assume a: "S_M S M (D + negs (mset As)) = {#} \<and> length As = (Suc 0)
	\<and> maximal_wrt (As ! 0 \<cdot>a \<sigma>) ((D + negs (mset As)) \<cdot> \<sigma>)"
	then have as: "mset As = {#As ! 0#}"
	by (auto intro: nth_equalityI)
	then have "negs (mset As) = {#Neg (As ! 0)#}"
	by (simp add: \<open>mset As = {#As ! 0#}\<close>)
	then have "DA = D + {#Neg (As ! 0)#}"
	using da by auto
	then obtain L where "L \<in># DA0 \<and> L \<cdot>l \<eta>0 = Neg (As ! 0)"
	using DA0_to_DA by (metis Melem_subst_cls mset_subset_eq_add_right single_subset_iff)
	then have "Neg (atm_of L) \<in># DA0 \<and> Neg (atm_of L) \<cdot>l \<eta>0 = Neg (As ! 0)"
	by (metis Neg_atm_of_iff literal.sel(2) subst_lit_is_pos)
	then have "[atm_of L] \<cdot>al \<eta>0 = As \<and> negs (mset [atm_of L]) \<subseteq># DA0"
	using as subst_lit_def by auto
	then have "\<exists>As0. As0 \<cdot>al \<eta>0 = As \<and> negs (mset As0) \<subseteq># DA0
	\<and> (S_M S M (D + negs (mset As)) \<noteq> {#} \<longrightarrow> negs (mset As0) = S DA0)"
	using a by blast
	}
	moreover
	{
	assume "S_M S M (D + negs (mset As)) = negs (mset As)"
	then have "negs (mset As) = S DA0 \<cdot> \<eta>0"
	using da \<open>S DA0 \<cdot> \<eta>0 = S_M S M DA\<close> by auto
	then have "\<exists>As0. negs (mset As0) = S DA0 \<and> As0 \<cdot>al \<eta>0 = As"
	using instance_list[of As "S DA0" \<eta>0] S.S_selects_neg_lits by auto
	then have "\<exists>As0. As0 \<cdot>al \<eta>0 = As \<and> negs (mset As0) \<subseteq># DA0
	\<and> (S_M S M (D + negs (mset As)) \<noteq> {#} \<longrightarrow> negs (mset As0) = S DA0)"
	using S.S_selects_subseteq by auto
	}
	ultimately have "\<exists>As0. As0 \<cdot>al \<eta>0 = As \<and> (negs (mset As0)) \<subseteq># DA0
	\<and> (S_M S M (D + negs (mset As)) \<noteq> {#} \<longrightarrow> negs (mset As0) = S DA0)"
	using eligible unfolding eligible.simps by auto
	then obtain As0 where
	As0_p: "As0 \<cdot>al \<eta>0 = As \<and> negs (mset As0) \<subseteq># DA0
	\<and> (S_M S M (D + negs (mset As)) \<noteq> {#} \<longrightarrow> negs (mset As0) = S DA0)"
	by blast
	then have "length As0 = n"
	using as_len by auto
	note n = n this

	have "As0 \<cdot>al \<eta>0 = As"
	using As0_p by auto

	define D0 where
	"D0 = DA0 - negs (mset As0)"
	then have "DA0 = D0 + negs (mset As0)"
	using As0_p by auto
	then have "D0 \<cdot> \<eta>0 = D"
	using DA0_to_DA da As0_p by auto

	have "S_M S M (D + negs (mset As)) \<noteq> {#} \<Longrightarrow> negs (mset As0) = S DA0"
	using As0_p by blast
	then show ?thesis
	using that \<open>As0 \<cdot>al \<eta>0 = As\<close> \<open>D0 \<cdot> \<eta>0= D\<close> \<open>DA0 = D0 + (negs (mset As0))\<close> \<open>length As0 = n\<close>
	by metis
	qed

	show ?thesis
	using that[OF n(2,1) DA0_in_M DA0_to_DA SDA0_to_SMDA CAs0_in_M CAs0_to_CAs SCAs0_to_SMCAs
	\<open>is_ground_subst \<eta>0\<close> \<open>is_ground_subst_list \<eta>s0\<close> \<open>As0 \<cdot>al \<eta>0 = As\<close>
	\<open>AAs0 \<cdot>\<cdot>aml \<eta>s0 = AAs\<close>
	\<open>length As0 = n\<close>
	\<open>D0 \<cdot> \<eta>0 = D\<close>
	\<open>DA0 = D0 + (negs (mset As0))\<close>
	\<open>S_M S M (D + negs (mset As)) \<noteq> {#} \<Longrightarrow> negs (mset As0) = S DA0\<close>
	\<open>length Cs0 = n\<close>
	\<open>Cs0 \<cdot>\<cdot>cl \<eta>s0 = Cs\<close>
	\<open>\<forall>i < n. CAs0 ! i = Cs0 ! i + poss (AAs0 ! i)\<close>
	\<open>length AAs0 = n\<close>]
	by auto
	qed

	lemma ord_resolve_rename_lifting:
	assumes
	sel_stable: "\<And>\<rho> C. is_renaming \<rho> \<Longrightarrow> S (C \<cdot> \<rho>) = S C \<cdot> \<rho>" and
	res_e: "ord_resolve (S_M S M) CAs DA AAs As \<sigma> E" and
	select: "selection S" and
	grounding: "{DA} \<union> set CAs \<subseteq> grounding_of_clss M"
	obtains \<eta>s \<eta> \<eta>2 CAs0 DA0 AAs0 As0 E0 \<tau> where
	"is_ground_subst \<eta>"
	"is_ground_subst_list \<eta>s"
	"is_ground_subst \<eta>2"
	"ord_resolve_rename S CAs0 DA0 AAs0 As0 \<tau> E0"
	"CAs0 \<cdot>\<cdot>cl \<eta>s = CAs" "DA0 \<cdot> \<eta> = DA" "E0 \<cdot> \<eta>2 = E"
	"{DA0} \<union> set CAs0 \<subseteq> M"
	"length CAs0 = length CAs"
	"length \<eta>s = length CAs"
	using res_e
	proof (cases rule: ord_resolve.cases)
	case (ord_resolve n Cs D)
	note da = this(1) and e = this(2) and cas_len = this(3) and cs_len = this(4) and
	aas_len = this(5) and as_len = this(6) and nz = this(7) and cas = this(8) and
	aas_not_empt = this(9) and mgu = this(10) and eligible = this(11) and str_max = this(12) and
	sel_empt = this(13)

	have sel_ren_list_inv:
	"\<And>\<rho>s Cs. length \<rho>s = length Cs \<Longrightarrow> is_renaming_list \<rho>s \<Longrightarrow> map S (Cs \<cdot>\<cdot>cl \<rho>s) = map S Cs \<cdot>\<cdot>cl \<rho>s"
	using sel_stable unfolding is_renaming_list_def by (auto intro: nth_equalityI)

	note n = \<open>n \<noteq> 0\<close> \<open>length CAs = n\<close> \<open>length Cs = n\<close> \<open>length AAs = n\<close> \<open>length As = n\<close>

	interpret S: selection S by (rule select)

	obtain DA0 \<eta>0 CAs0 \<eta>s0 As0 AAs0 D0 Cs0 where as0:
	"length CAs0 = n"
	"length \<eta>s0 = n"
	"DA0 \<in> M"
	"DA0 \<cdot> \<eta>0 = DA"
	"S DA0 \<cdot> \<eta>0 = S_M S M DA"
	"\<forall>CA0 \<in> set CAs0. CA0 \<in> M"
	"CAs0 \<cdot>\<cdot>cl \<eta>s0 = CAs"
	"map S CAs0 \<cdot>\<cdot>cl \<eta>s0 = map (S_M S M) CAs"
	"is_ground_subst \<eta>0"
	"is_ground_subst_list \<eta>s0"
	"As0 \<cdot>al \<eta>0 = As"
	"AAs0 \<cdot>\<cdot>aml \<eta>s0 = AAs"
	"length As0 = n"
	"D0 \<cdot> \<eta>0 = D"
	"DA0 = D0 + (negs (mset As0))"
	"S_M S M (D + negs (mset As)) \<noteq> {#} \<Longrightarrow> negs (mset As0) = S DA0"
	"length Cs0 = n"
	"Cs0 \<cdot>\<cdot>cl \<eta>s0 = Cs"
	"\<forall>i < n. CAs0 ! i = Cs0 ! i + poss (AAs0 ! i)"
	"length AAs0 = n"
	using ord_resolve_obtain_clauses[of S M CAs DA, OF res_e select grounding n(2) \<open>DA = D + negs (mset As)\<close>
	\<open>\<forall>i<n. CAs ! i = Cs ! i + poss (AAs ! i)\<close> \<open>length Cs = n\<close> \<open>length AAs = n\<close>, of thesis] by blast

	note n = \<open>length CAs0 = n\<close> \<open>length \<eta>s0 = n\<close> \<open>length As0 = n\<close> \<open>length AAs0 = n\<close> \<open>length Cs0 = n\<close> n

	have "length (renamings_apart (DA0 # CAs0)) = Suc n"
	using n renamings_apart_length by auto

	note n = this n

	define \<rho> where
	"\<rho> = hd (renamings_apart (DA0 # CAs0))"
	define \<rho>s where
	"\<rho>s = tl (renamings_apart (DA0 # CAs0))"
	define DA0' where
	"DA0' = DA0 \<cdot> \<rho>"
	define D0' where
	"D0' = D0 \<cdot> \<rho>"
	define As0' where
	"As0' = As0 \<cdot>al \<rho>"
	define CAs0' where
	"CAs0' = CAs0 \<cdot>\<cdot>cl \<rho>s"
	define Cs0' where
	"Cs0' = Cs0 \<cdot>\<cdot>cl \<rho>s"
	define AAs0' where
	"AAs0' = AAs0 \<cdot>\<cdot>aml \<rho>s"
	define \<eta>0' where
	"\<eta>0' = inv_renaming \<rho> \<odot> \<eta>0"
	define \<eta>s0' where
	"\<eta>s0' = map inv_renaming \<rho>s \<odot>s \<eta>s0"

	have renames_DA0: "is_renaming \<rho>"
	using renamings_apart_length renamings_apart_renaming unfolding \<rho>_def
	by (metis length_greater_0_conv list.exhaust_sel list.set_intros(1) list.simps(3))

	have renames_CAs0: "is_renaming_list \<rho>s"
	using renamings_apart_length renamings_apart_renaming unfolding \<rho>s_def
	by (metis is_renaming_list_def length_greater_0_conv list.set_sel(2) list.simps(3))

	have "length \<rho>s = n"
	unfolding \<rho>s_def using n by auto
	note n = n \<open>length \<rho>s = n\<close>
	have "length As0' = n"
	unfolding As0'_def using n by auto
	have "length CAs0' = n"
	using as0(1) n unfolding CAs0'_def by auto
	have "length Cs0' = n"
	unfolding Cs0'_def using n by auto
	have "length AAs0' = n"
	unfolding AAs0'_def using n by auto
	have "length \<eta>s0' = n"
	using as0(2) n unfolding \<eta>s0'_def by auto
	note n = \<open>length CAs0' = n\<close> \<open>length \<eta>s0' = n\<close> \<open>length As0' = n\<close> \<open>length AAs0' = n\<close> \<open>length Cs0' = n\<close> n

	have DA0'_DA: "DA0' \<cdot> \<eta>0' = DA"
	using as0(4) unfolding \<eta>0'_def DA0'_def using renames_DA0 by simp
	have D0'_D: "D0' \<cdot> \<eta>0' = D"
	using as0(14) unfolding \<eta>0'_def D0'_def using renames_DA0 by simp
	have As0'_As: "As0' \<cdot>al \<eta>0' = As"
	using as0(11) unfolding \<eta>0'_def As0'_def using renames_DA0 by auto
	have "S DA0' \<cdot> \<eta>0' = S_M S M DA"
	using as0(5) unfolding \<eta>0'_def DA0'_def using renames_DA0 sel_stable by auto
	have CAs0'_CAs: "CAs0' \<cdot>\<cdot>cl \<eta>s0' = CAs"
	using as0(7) unfolding CAs0'_def \<eta>s0'_def using renames_CAs0 n by auto
	have Cs0'_Cs: "Cs0' \<cdot>\<cdot>cl \<eta>s0' = Cs"
	using as0(18) unfolding Cs0'_def \<eta>s0'_def using renames_CAs0 n by auto
	have AAs0'_AAs: "AAs0' \<cdot>\<cdot>aml \<eta>s0' = AAs"
	using as0(12) unfolding \<eta>s0'_def AAs0'_def using renames_CAs0 using n by auto
	have "map S CAs0' \<cdot>\<cdot>cl \<eta>s0' = map (S_M S M) CAs"
	unfolding CAs0'_def \<eta>s0'_def using as0(8) n renames_CAs0 sel_ren_list_inv by auto

	have DA0'_split: "DA0' = D0' + negs (mset As0')"
	using as0(15) DA0'_def D0'_def As0'_def by auto
	then have D0'_subset_DA0': "D0' \<subseteq># DA0'"
	by auto
	from DA0'_split have negs_As0'_subset_DA0': "negs (mset As0') \<subseteq># DA0'"
	by auto

	have CAs0'_split: "\<forall>i<n. CAs0' ! i = Cs0' ! i + poss (AAs0' ! i)"
	using as0(19) CAs0'_def Cs0'_def AAs0'_def n by auto
	then have "\<forall>i<n. Cs0' ! i \<subseteq># CAs0' ! i"
	by auto
	from CAs0'_split have poss_AAs0'_subset_CAs0': "\<forall>i<n. poss (AAs0' ! i) \<subseteq># CAs0' ! i"
	by auto
	then have AAs0'_in_atms_of_CAs0': "\<forall>i < n. \<forall>A\<in>#AAs0' ! i. A \<in> atms_of (CAs0' ! i)"
	by (auto simp add: atm_iff_pos_or_neg_lit)

	have as0':
	"S_M S M (D + negs (mset As)) \<noteq> {#} \<Longrightarrow> negs (mset As0') = S DA0'"
	proof -
	assume a: "S_M S M (D + negs (mset As)) \<noteq> {#}"
	then have "negs (mset As0) \<cdot> \<rho> = S DA0 \<cdot> \<rho>"
	using as0(16) unfolding \<rho>_def by metis
	then show "negs (mset As0') = S DA0'"
	using As0'_def DA0'_def using sel_stable[of \<rho> DA0] renames_DA0 by auto
	qed

	have vd: "var_disjoint (DA0' # CAs0')"
	unfolding DA0'_def CAs0'_def using renamings_apart_var_disjoint
	unfolding \<rho>_def \<rho>s_def
	- by (metis length_greater_0_conv list.exhaust_sel n(6) substitution.subst_cls_lists_Cons
	- substitution_axioms zero_less_Suc)
	+ by (metis length_greater_0_conv list.exhaust_sel n(6) subst_cls_lists_Cons zero_less_Suc)

	\<comment> \<open>Introduce ground substitution\<close>
	from vd DA0'_DA CAs0'_CAs have "\<exists>\<eta>. \<forall>i < Suc n. \<forall>S. S \<subseteq># (DA0' # CAs0') ! i \<longrightarrow> S \<cdot> (\<eta>0'#\<eta>s0') ! i = S \<cdot> \<eta>"
	unfolding var_disjoint_def using n by auto
	then obtain \<eta> where \<eta>_p: "\<forall>i < Suc n. \<forall>S. S \<subseteq># (DA0' # CAs0') ! i \<longrightarrow> S \<cdot> (\<eta>0'#\<eta>s0') ! i = S \<cdot> \<eta>"
	by auto
	have \<eta>_p_lit: "\<forall>i < Suc n. \<forall>L. L \<in># (DA0' # CAs0') ! i \<longrightarrow> L \<cdot>l (\<eta>0'#\<eta>s0') ! i = L \<cdot>l \<eta>"
	proof (rule, rule, rule, rule)
	fix i :: "nat" and L :: "'a literal"
	assume a:
	"i < Suc n"
	"L \<in># (DA0' # CAs0') ! i"
	then have "\<forall>S. S \<subseteq># (DA0' # CAs0') ! i \<longrightarrow> S \<cdot> (\<eta>0' # \<eta>s0') ! i = S \<cdot> \<eta>"
	using \<eta>_p by auto
	then have "{# L #} \<cdot> (\<eta>0' # \<eta>s0') ! i = {# L #} \<cdot> \<eta>"
	using a by (meson single_subset_iff)
	then show "L \<cdot>l (\<eta>0' # \<eta>s0') ! i = L \<cdot>l \<eta>" by auto
	qed
	have \<eta>_p_atm: "\<forall>i < Suc n. \<forall>A. A \<in> atms_of ((DA0' # CAs0') ! i) \<longrightarrow> A \<cdot>a (\<eta>0'#\<eta>s0') ! i = A \<cdot>a \<eta>"
	proof (rule, rule, rule, rule)
	fix i :: "nat" and A :: "'a"
	assume a:
	"i < Suc n"
	"A \<in> atms_of ((DA0' # CAs0') ! i)"
	then obtain L where L_p: "atm_of L = A \<and> L \<in># (DA0' # CAs0') ! i"
	unfolding atms_of_def by auto
	then have "L \<cdot>l (\<eta>0'#\<eta>s0') ! i = L \<cdot>l \<eta>"
	using \<eta>_p_lit a by auto
	then show "A \<cdot>a (\<eta>0' # \<eta>s0') ! i = A \<cdot>a \<eta>"
	using L_p unfolding subst_lit_def by (cases L) auto
	qed

	have DA0'_DA: "DA0' \<cdot> \<eta> = DA"
	using DA0'_DA \<eta>_p by auto
	have "D0' \<cdot> \<eta> = D" using \<eta>_p D0'_D n D0'_subset_DA0' by auto
	have "As0' \<cdot>al \<eta> = As"
	proof (rule nth_equalityI)
	show "length (As0' \<cdot>al \<eta>) = length As"
	using n by auto
	next
	fix i
	show "i<length (As0' \<cdot>al \<eta>) \<Longrightarrow> (As0' \<cdot>al \<eta>) ! i = As ! i"
	proof -
	assume a: "i < length (As0' \<cdot>al \<eta>)"
	have A_eq: "\<forall>A. A \<in> atms_of DA0' \<longrightarrow> A \<cdot>a \<eta>0' = A \<cdot>a \<eta>"
	using \<eta>_p_atm n by force
	have "As0' ! i \<in> atms_of DA0'"
	using negs_As0'_subset_DA0' unfolding atms_of_def
	using a n by force
	then have "As0' ! i \<cdot>a \<eta>0' = As0' ! i \<cdot>a \<eta>"
	using A_eq by simp
	then show "(As0' \<cdot>al \<eta>) ! i = As ! i"
	using As0'_As \<open>length As0' = n\<close> a by auto
	qed
	qed

	interpret selection
	by (rule select)

	have "S DA0' \<cdot> \<eta> = S_M S M DA"
	using \<open>S DA0' \<cdot> \<eta>0' = S_M S M DA\<close> \<eta>_p S.S_selects_subseteq by auto

	from \<eta>_p have \<eta>_p_CAs0': "\<forall>i < n. (CAs0' ! i) \<cdot> (\<eta>s0' ! i) = (CAs0'! i) \<cdot> \<eta>"
	using n by auto
	then have "CAs0' \<cdot>\<cdot>cl \<eta>s0' = CAs0' \<cdot>cl \<eta>"
	using n by (auto intro: nth_equalityI)
	then have CAs0'_\<eta>_fo_CAs: "CAs0' \<cdot>cl \<eta> = CAs"
	using CAs0'_CAs \<eta>_p n by auto

	from \<eta>_p have "\<forall>i < n. S (CAs0' ! i) \<cdot> \<eta>s0' ! i = S (CAs0' ! i) \<cdot> \<eta>"
	using S.S_selects_subseteq n by auto
	then have "map S CAs0' \<cdot>\<cdot>cl \<eta>s0' = map S CAs0' \<cdot>cl \<eta>"
	using n by (auto intro: nth_equalityI)
	then have SCAs0'_\<eta>_fo_SMCAs: "map S CAs0' \<cdot>cl \<eta> = map (S_M S M) CAs"
	using \<open>map S CAs0' \<cdot>\<cdot>cl \<eta>s0' = map (S_M S M) CAs\<close> by auto

	have "Cs0' \<cdot>cl \<eta> = Cs"
	proof (rule nth_equalityI)
	show "length (Cs0' \<cdot>cl \<eta>) = length Cs"
	using n by auto
	next
	fix i
	show "i<length (Cs0' \<cdot>cl \<eta>) \<Longrightarrow> (Cs0' \<cdot>cl \<eta>) ! i = Cs ! i"
	proof -
	assume "i < length (Cs0' \<cdot>cl \<eta>)"
	then have a: "i < n"
	using n by force
	have "(Cs0' \<cdot>\<cdot>cl \<eta>s0') ! i = Cs ! i"
	using Cs0'_Cs a n by force
	moreover
	have \<eta>_p_CAs0': "\<forall>S. S \<subseteq># CAs0' ! i \<longrightarrow> S \<cdot> \<eta>s0' ! i = S \<cdot> \<eta>"
	using \<eta>_p a by force
	have "Cs0' ! i \<cdot> \<eta>s0' ! i = (Cs0' \<cdot>cl \<eta>) ! i"
	using \<eta>_p_CAs0' \<open>\<forall>i<n. Cs0' ! i \<subseteq># CAs0' ! i\<close> a n by force
	then have "(Cs0' \<cdot>\<cdot>cl \<eta>s0') ! i = (Cs0' \<cdot>cl \<eta>) ! i "
	using a n by force
	ultimately show "(Cs0' \<cdot>cl \<eta>) ! i = Cs ! i"
	by auto
	qed
	qed

	have AAs0'_AAs: "AAs0' \<cdot>aml \<eta> = AAs"
	proof (rule nth_equalityI)
	show "length (AAs0' \<cdot>aml \<eta>) = length AAs"
	using n by auto
	next
	fix i
	show "i<length (AAs0' \<cdot>aml \<eta>) \<Longrightarrow> (AAs0' \<cdot>aml \<eta>) ! i = AAs ! i"
	proof -
	assume a: "i < length (AAs0' \<cdot>aml \<eta>)"
	then have "i < n"
	using n by force
	then have "\<forall>A. A \<in> atms_of ((DA0' # CAs0') ! Suc i) \<longrightarrow> A \<cdot>a (\<eta>0' # \<eta>s0') ! Suc i = A \<cdot>a \<eta>"
	using \<eta>_p_atm n by force
	then have A_eq: "\<forall>A. A \<in> atms_of (CAs0' ! i) \<longrightarrow> A \<cdot>a \<eta>s0' ! i = A \<cdot>a \<eta>"
	by auto
	have AAs_CAs0': "\<forall>A \<in># AAs0' ! i. A \<in> atms_of (CAs0' ! i)"
	using AAs0'_in_atms_of_CAs0' unfolding atms_of_def
	using a n by force
	then have "AAs0' ! i \<cdot>am \<eta>s0' ! i = AAs0' ! i \<cdot>am \<eta>"
	unfolding subst_atm_mset_def using A_eq unfolding subst_atm_mset_def by auto
	then show "(AAs0' \<cdot>aml \<eta>) ! i = AAs ! i"
	using AAs0'_AAs \<open>length AAs0' = n\<close> \<open>length \<eta>s0' = n\<close> a by auto
	qed
	qed

	\<comment> \<open>Obtain MGU and substitution\<close>
	obtain \<tau> \<phi> where \<tau>\<phi>:
	"Some \<tau> = mgu (set_mset ` set (map2 add_mset As0' AAs0'))"
	"\<tau> \<odot> \<phi> = \<eta> \<odot> \<sigma>"
	proof -
	have uu: "is_unifiers \<sigma> (set_mset ` set (map2 add_mset (As0' \<cdot>al \<eta>) (AAs0' \<cdot>aml \<eta>)))"
	using mgu mgu_sound is_mgu_def unfolding \<open>AAs0' \<cdot>aml \<eta> = AAs\<close> using \<open>As0' \<cdot>al \<eta> = As\<close> by auto
	have \<eta>\<sigma>uni: "is_unifiers (\<eta> \<odot> \<sigma>) (set_mset ` set (map2 add_mset As0' AAs0'))"
	proof -
	have "set_mset ` set (map2 add_mset As0' AAs0' \<cdot>aml \<eta>) =
	set_mset ` set (map2 add_mset As0' AAs0') \<cdot>ass \<eta>"
	unfolding subst_atmss_def subst_atm_mset_list_def using subst_atm_mset_def subst_atms_def
	by (simp add: image_image subst_atm_mset_def subst_atms_def)
	then have "is_unifiers \<sigma> (set_mset ` set (map2 add_mset As0' AAs0') \<cdot>ass \<eta>)"
	using uu by (auto simp: n map2_add_mset_map)
	then show ?thesis
	using is_unifiers_comp by auto
	qed
	then obtain \<tau> where
	\<tau>_p: "Some \<tau> = mgu (set_mset ` set (map2 add_mset As0' AAs0'))"
	using mgu_complete
	by (metis (mono_tags, opaque_lifting) List.finite_set finite_imageI finite_set_mset image_iff)
	moreover then obtain \<phi> where \<phi>_p: "\<tau> \<odot> \<phi> = \<eta> \<odot> \<sigma>"
	by (metis (mono_tags, opaque_lifting) finite_set \<eta>\<sigma>uni finite_imageI finite_set_mset image_iff
	mgu_sound set_mset_mset substitution_ops.is_mgu_def) (* should be simpler *)
	ultimately show thesis
	using that by auto
	qed

	\<comment> \<open>Lifting eligibility\<close>
	have eligible0': "eligible S \<tau> As0' (D0' + negs (mset As0'))"
	proof -
	have "S_M S M (D + negs (mset As)) = negs (mset As) \<or> S_M S M (D + negs (mset As)) = {#} \<and>
	length As = 1 \<and> maximal_wrt (As ! 0 \<cdot>a \<sigma>) ((D + negs (mset As)) \<cdot> \<sigma>)"
	using eligible unfolding eligible.simps by auto
	then show ?thesis
	proof
	assume "S_M S M (D + negs (mset As)) = negs (mset As)"
	then have "S_M S M (D + negs (mset As)) \<noteq> {#}"
	using n by force
	then have "S (D0' + negs (mset As0')) = negs (mset As0')"
	using as0' DA0'_split by auto
	then show ?thesis
	unfolding eligible.simps[simplified] by auto
	next
	assume asm: "S_M S M (D + negs (mset As)) = {#} \<and> length As = 1 \<and>
	maximal_wrt (As ! 0 \<cdot>a \<sigma>) ((D + negs (mset As)) \<cdot> \<sigma>)"
	then have "S (D0' + negs (mset As0')) = {#}"
	using \<open>D0' \<cdot> \<eta> = D\<close>[symmetric] \<open>As0' \<cdot>al \<eta> = As\<close>[symmetric] \<open>S (DA0') \<cdot> \<eta> = S_M S M (DA)\<close>
	da DA0'_split subst_cls_empty_iff by metis
	moreover from asm have l: "length As0' = 1"
	using \<open>As0' \<cdot>al \<eta> = As\<close> by auto
	moreover from asm have "maximal_wrt (As0' ! 0 \<cdot>a (\<tau> \<odot> \<phi>)) ((D0' + negs (mset As0')) \<cdot> (\<tau> \<odot> \<phi>))"
	using \<open>As0' \<cdot>al \<eta> = As\<close> \<open>D0' \<cdot> \<eta> = D\<close> using l \<tau>\<phi> by auto
	then have "maximal_wrt (As0' ! 0 \<cdot>a \<tau> \<cdot>a \<phi>) ((D0' + negs (mset As0')) \<cdot> \<tau> \<cdot> \<phi>)"
	by auto
	then have "maximal_wrt (As0' ! 0 \<cdot>a \<tau>) ((D0' + negs (mset As0')) \<cdot> \<tau>)"
	using maximal_wrt_subst by blast
	ultimately show ?thesis
	unfolding eligible.simps[simplified] by auto
	qed
	qed

	\<comment> \<open>Lifting maximality\<close>
	have maximality: "\<forall>i < n. strictly_maximal_wrt (As0' ! i \<cdot>a \<tau>) (Cs0' ! i \<cdot> \<tau>)"
	(* Reformulate in list notation? *)
	proof -
	from str_max have "\<forall>i < n. strictly_maximal_wrt ((As0' \<cdot>al \<eta>) ! i \<cdot>a \<sigma>) ((Cs0' \<cdot>cl \<eta>) ! i \<cdot> \<sigma>)"
	using \<open>As0' \<cdot>al \<eta> = As\<close> \<open>Cs0' \<cdot>cl \<eta> = Cs\<close> by simp
	then have "\<forall>i < n. strictly_maximal_wrt (As0' ! i \<cdot>a (\<tau> \<odot> \<phi>)) (Cs0' ! i \<cdot> (\<tau> \<odot> \<phi>))"
	using n \<tau>\<phi> by simp
	then have "\<forall>i < n. strictly_maximal_wrt (As0' ! i \<cdot>a \<tau> \<cdot>a \<phi>) (Cs0' ! i \<cdot> \<tau> \<cdot> \<phi>)"
	by auto
	then show "\<forall>i < n. strictly_maximal_wrt (As0' ! i \<cdot>a \<tau>) (Cs0' ! i \<cdot> \<tau>)"
	using strictly_maximal_wrt_subst \<tau>\<phi> by blast
	qed

	\<comment> \<open>Lifting nothing being selected\<close>
	have nothing_selected: "\<forall>i < n. S (CAs0' ! i) = {#}"
	proof -
	have "\<forall>i < n. (map S CAs0' \<cdot>cl \<eta>) ! i = map (S_M S M) CAs ! i"
	by (simp add: \<open>map S CAs0' \<cdot>cl \<eta> = map (S_M S M) CAs\<close>)
	then have "\<forall>i < n. S (CAs0' ! i) \<cdot> \<eta> = S_M S M (CAs ! i)"
	using n by auto
	then have "\<forall>i < n. S (CAs0' ! i) \<cdot> \<eta> = {#}"
	using sel_empt \<open>\<forall>i < n. S (CAs0' ! i) \<cdot> \<eta> = S_M S M (CAs ! i)\<close> by auto
	then show "\<forall>i < n. S (CAs0' ! i) = {#}"
	using subst_cls_empty_iff by blast
	qed

	\<comment> \<open>Lifting AAs0's non-emptiness\<close>
	have "\<forall>i < n. AAs0' ! i \<noteq> {#}"
	using n aas_not_empt \<open>AAs0' \<cdot>aml \<eta> = AAs\<close> by auto

	\<comment> \<open>Resolve the lifted clauses\<close>
	define E0' where
	"E0' = ((\<Sum>\<^sub># (mset Cs0')) + D0') \<cdot> \<tau>"

	have res_e0': "ord_resolve S CAs0' DA0' AAs0' As0' \<tau> E0'"
	using ord_resolve.intros[of CAs0' n Cs0' AAs0' As0' \<tau> S D0',
	OF _ _ _ _ _ _ \<open>\<forall>i < n. AAs0' ! i \<noteq> {#}\<close> \<tau>\<phi>(1) eligible0'
	\<open>\<forall>i < n. strictly_maximal_wrt (As0' ! i \<cdot>a \<tau>) (Cs0' ! i \<cdot> \<tau>)\<close> \<open>\<forall>i < n. S (CAs0' ! i) = {#}\<close>]
	unfolding E0'_def using DA0'_split n \<open>\<forall>i<n. CAs0' ! i = Cs0' ! i + poss (AAs0' ! i)\<close> by blast

	\<comment> \<open>Prove resolvent instantiates to ground resolvent\<close>
	have e0'\<phi>e: "E0' \<cdot> \<phi> = E"
	proof -
	have "E0' \<cdot> \<phi> = ((\<Sum>\<^sub># (mset Cs0')) + D0') \<cdot> (\<tau> \<odot> \<phi>)"
	unfolding E0'_def by auto
	also have "\<dots> = (\<Sum>\<^sub># (mset Cs0') + D0') \<cdot> (\<eta> \<odot> \<sigma>)"
	using \<tau>\<phi> by auto
	also have "\<dots> = (\<Sum>\<^sub># (mset Cs) + D) \<cdot> \<sigma>"
	using \<open>Cs0' \<cdot>cl \<eta> = Cs\<close> \<open>D0' \<cdot> \<eta> = D\<close> by auto
	also have "\<dots> = E"
	using e by auto
	finally show e0'\<phi>e: "E0' \<cdot> \<phi> = E"
	.
	qed

	\<comment> \<open>Replace @{term \<phi>} with a true ground substitution\<close>
	obtain \<eta>2 where
	ground_\<eta>2: "is_ground_subst \<eta>2" "E0' \<cdot> \<eta>2 = E"
	proof -
	have "is_ground_cls_list CAs" "is_ground_cls DA"
	using grounding grounding_ground unfolding is_ground_cls_list_def by auto
	then have "is_ground_cls E"
	using res_e ground_resolvent_subset by (force intro: is_ground_cls_mono)
	then show thesis
	using that e0'\<phi>e make_ground_subst by auto
	qed

	have \<open>length CAs0 = length CAs\<close>
	using n by simp

	have \<open>length \<eta>s0 = length CAs\<close>
	using n by simp

	\<comment> \<open>Wrap up the proof\<close>
	have "ord_resolve S (CAs0 \<cdot>\<cdot>cl \<rho>s) (DA0 \<cdot> \<rho>) (AAs0 \<cdot>\<cdot>aml \<rho>s) (As0 \<cdot>al \<rho>) \<tau> E0'"
	using res_e0' As0'_def \<rho>_def AAs0'_def \<rho>s_def DA0'_def \<rho>_def CAs0'_def \<rho>s_def by simp
	moreover have "\<forall>i<n. poss (AAs0 ! i) \<subseteq># CAs0 ! i"
	using as0(19) by auto
	moreover have "negs (mset As0) \<subseteq># DA0"
	using local.as0(15) by auto
	ultimately have "ord_resolve_rename S CAs0 DA0 AAs0 As0 \<tau> E0'"
	using ord_resolve_rename[of CAs0 n AAs0 As0 DA0 \<rho> \<rho>s S \<tau> E0'] \<rho>_def \<rho>s_def n by auto
	then show thesis
	using that[of \<eta>0 \<eta>s0 \<eta>2 CAs0 DA0] \<open>is_ground_subst \<eta>0\<close> \<open>is_ground_subst_list \<eta>s0\<close>
	\<open>is_ground_subst \<eta>2\<close> \<open>CAs0 \<cdot>\<cdot>cl \<eta>s0 = CAs\<close> \<open>DA0 \<cdot> \<eta>0 = DA\<close> \<open>E0' \<cdot> \<eta>2 = E\<close> \<open>DA0 \<in> M\<close>
	\<open>\<forall>CA \<in> set CAs0. CA \<in> M\<close> \<open>length CAs0 = length CAs\<close> \<open>length \<eta>s0 = length CAs\<close>
	by blast
	qed

	lemma ground_ord_resolve_ground:
	assumes
	select: "selection S" and
	CAs_p: "ground_resolution_with_selection.ord_resolve S CAs DA AAs As E" and
	ground_cas: "is_ground_cls_list CAs" and
	ground_da: "is_ground_cls DA"
	shows "is_ground_cls E"
	proof -
	have a1: "atms_of E \<subseteq> (\<Union>CA \<in> set CAs. atms_of CA) \<union> atms_of DA"
	using ground_resolution_with_selection.ord_resolve_atms_of_concl_subset[OF _ CAs_p]
	ground_resolution_with_selection.intro[OF select] by blast
	{
	fix L :: "'a literal"
	assume "L \<in># E"
	then have "atm_of L \<in> atms_of E"
	by (meson atm_of_lit_in_atms_of)
	then have "is_ground_atm (atm_of L)"
	using a1 ground_cas ground_da is_ground_cls_imp_is_ground_atm is_ground_cls_list_def
	by auto
	}
	then show ?thesis
	unfolding is_ground_cls_def is_ground_lit_def by simp
	qed

	lemma ground_ord_resolve_imp_ord_resolve:
	assumes
	ground_da: \<open>is_ground_cls DA\<close> and
	ground_cas: \<open>is_ground_cls_list CAs\<close> and
	gr: "ground_resolution_with_selection S_G" and
	gr_res: \<open>ground_resolution_with_selection.ord_resolve S_G CAs DA AAs As E\<close>
	shows \<open>\<exists>\<sigma>. ord_resolve S_G CAs DA AAs As \<sigma> E\<close>
	proof (cases rule: ground_resolution_with_selection.ord_resolve.cases[OF gr gr_res])
	case (1 CAs n Cs AAs As D)
	note cas = this(1) and da = this(2) and aas = this(3) and as = this(4) and e = this(5) and
	cas_len = this(6) and cs_len = this(7) and aas_len = this(8) and as_len = this(9) and
	nz = this(10) and casi = this(11) and aas_not_empt = this(12) and as_aas = this(13) and
	eligibility = this(14) and str_max = this(15) and sel_empt = this(16)

	have len_aas_len_as: "length AAs = length As"
	using aas_len as_len by auto

	from as_aas have "\<forall>i < n. \<forall>A \<in># add_mset (As ! i) (AAs ! i). A = As ! i"
	by simp
	then have "\<forall>i < n. card (set_mset (add_mset (As ! i) (AAs ! i))) \<le> Suc 0"
	using all_the_same by metis
	then have "\<forall>i < length AAs. card (set_mset (add_mset (As ! i) (AAs ! i))) \<le> Suc 0"
	using aas_len by auto
	then have "\<forall>AA \<in> set (map2 add_mset As AAs). card (set_mset AA) \<le> Suc 0"
	using set_map2_ex[of AAs As add_mset, OF len_aas_len_as] by auto
	then have "is_unifiers id_subst (set_mset ` set (map2 add_mset As AAs))"
	unfolding is_unifiers_def is_unifier_def by auto
	moreover have "finite (set_mset ` set (map2 add_mset As AAs))"
	by auto
	moreover have "\<forall>AA \<in> set_mset ` set (map2 add_mset As AAs). finite AA"
	by auto
	ultimately obtain \<sigma> where
	\<sigma>_p: "Some \<sigma> = mgu (set_mset ` set (map2 add_mset As AAs))"
	using mgu_complete by metis

	have ground_elig: "ground_resolution_with_selection.eligible S_G As (D + negs (mset As))"
	using eligibility by simp
	have ground_cs: "\<forall>i < n. is_ground_cls (Cs ! i)"
	using cas cas_len cs_len casi ground_cas nth_mem unfolding is_ground_cls_list_def by force
	have ground_set_as: "is_ground_atms (set As)"
	using da ground_da by (metis atms_of_negs is_ground_cls_is_ground_atms_atms_of
	is_ground_cls_union set_mset_mset)
	then have ground_mset_as: "is_ground_atm_mset (mset As)"
	unfolding is_ground_atm_mset_def is_ground_atms_def by auto
	have ground_as: "is_ground_atm_list As"
	using ground_set_as is_ground_atm_list_def is_ground_atms_def by auto
	have ground_d: "is_ground_cls D"
	using ground_da da by simp

	from as_len nz have atms:
	"atms_of D \<union> set As \<noteq> {}"
	"finite (atms_of D \<union> set As)"
	by auto
	then have "Max (atms_of D \<union> set As) \<in> atms_of D \<union> set As"
	using Max_in by metis
	then have is_ground_Max: "is_ground_atm (Max (atms_of D \<union> set As))"
	using ground_d ground_mset_as is_ground_cls_imp_is_ground_atm
	unfolding is_ground_atm_mset_def by auto

	have "maximal_wrt (Max (atms_of D \<union> set As)) (D + negs (mset As))"
	unfolding maximal_wrt_def
	by clarsimp (metis atms Max_less_iff UnCI ground_d ground_set_as infinite_growing
	is_ground_Max is_ground_atms_def is_ground_cls_imp_is_ground_atm less_atm_ground)
	moreover have
	"Max (atms_of D \<union> set As) \<cdot>a \<sigma> = Max (atms_of D \<union> set As)" and
	"D \<cdot> \<sigma> + negs (mset As \<cdot>am \<sigma>) = D + negs (mset As)"
	using ground_elig is_ground_Max ground_mset_as ground_d by auto
	ultimately have fo_elig: "eligible S_G \<sigma> As (D + negs (mset As))"
	using ground_elig unfolding ground_resolution_with_selection.eligible.simps[OF gr]
	ground_resolution_with_selection.maximal_wrt_def[OF gr] eligible.simps
	by auto

	have "\<forall>i < n. strictly_maximal_wrt (As ! i) (Cs ! i)"
	using str_max[unfolded ground_resolution_with_selection.strictly_maximal_wrt_def[OF gr]]
	ground_as[unfolded is_ground_atm_list_def] ground_cs as_len less_atm_ground
	unfolding strictly_maximal_wrt_def by clarsimp (fastforce simp: is_ground_cls_as_atms)+
	then have ll: "\<forall>i < n. strictly_maximal_wrt (As ! i \<cdot>a \<sigma>) (Cs ! i \<cdot> \<sigma>)"
	by (simp add: ground_as ground_cs as_len)

	have ground_e: "is_ground_cls E"
	using ground_d ground_cs cs_len unfolding e is_ground_cls_def
	by simp (metis in_mset_sum_list2 in_set_conv_nth)

	show ?thesis
	using cas da aas as e ground_e ord_resolve.intros[OF cas_len cs_len aas_len as_len nz casi
	aas_not_empt \<sigma>_p fo_elig ll sel_empt]
	by auto
	qed

	end

	end
	diff --git a/thys/Public_Announcement_Logic/PAL.thy b/thys/Public_Announcement_Logic/PAL.thy
	--- a/thys/Public_Announcement_Logic/PAL.thy
	+++ b/thys/Public_Announcement_Logic/PAL.thy
	@@ -1,733 +1,1002 @@
	(*
	File: PAL.thy
	Author: Asta Halkjær From

	This work is a formalization of public announcement logic with countably many agents.
	- It includes proofs of soundness and completeness for a variant of the axiom system
	+ It includes proofs of soundness and completeness for variants of the axiom system
	PA + DIST! + NEC!.
	- The completeness proof builds on the Epistemic Logic theory.
	+ The completeness proofs build on the Epistemic Logic theory.
	*)

	theory PAL imports "Epistemic_Logic.Epistemic_Logic" begin

	section \<open>Syntax\<close>

	datatype 'i pfm
	- = FF ("\<^bold>\<bottom>\<^sub>!")
	- \| Pro' id ("Pro\<^sub>!")
	- \| Dis \<open>'i pfm\<close> \<open>'i pfm\<close> (infixr "\<^bold>\<or>\<^sub>!" 30)
	- \| Con \<open>'i pfm\<close> \<open>'i pfm\<close> (infixr "\<^bold>\<and>\<^sub>!" 35)
	- \| Imp \<open>'i pfm\<close> \<open>'i pfm\<close> (infixr "\<^bold>\<longrightarrow>\<^sub>!" 25)
	+ = FF (\<open>\<^bold>\<bottom>\<^sub>!\<close>)
	+ \| Pro' id (\<open>Pro\<^sub>!\<close>)
	+ \| Dis \<open>'i pfm\<close> \<open>'i pfm\<close> (infixr \<open>\<^bold>\<or>\<^sub>!\<close> 60)
	+ \| Con \<open>'i pfm\<close> \<open>'i pfm\<close> (infixr \<open>\<^bold>\<and>\<^sub>!\<close> 65)
	+ \| Imp \<open>'i pfm\<close> \<open>'i pfm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<^sub>!\<close> 55)
	\| K' 'i \<open>'i pfm\<close> (\<open>K\<^sub>!\<close>)
	- \| Ann \<open>'i pfm\<close> \<open>'i pfm\<close> ("[_]\<^sub>! _" [50, 50] 50)
	+ \| Ann \<open>'i pfm\<close> \<open>'i pfm\<close> (\<open>[_]\<^sub>! _\<close> [80, 80] 80)

	-abbreviation PIff :: \<open>'i pfm \<Rightarrow> 'i pfm \<Rightarrow> 'i pfm\<close> (infixr "\<^bold>\<longleftrightarrow>\<^sub>!" 25) where
	+abbreviation PIff :: \<open>'i pfm \<Rightarrow> 'i pfm \<Rightarrow> 'i pfm\<close> (infixr \<open>\<^bold>\<longleftrightarrow>\<^sub>!\<close> 55) where
	\<open>p \<^bold>\<longleftrightarrow>\<^sub>! q \<equiv> (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<and>\<^sub>! (q \<^bold>\<longrightarrow>\<^sub>! p)\<close>

	-abbreviation PNeg (\<open>\<^bold>\<not>\<^sub>! _\<close> [40] 40) where
	+abbreviation PNeg (\<open>\<^bold>\<not>\<^sub>! _\<close> [70] 70) where
	\<open>\<^bold>\<not>\<^sub>! p \<equiv> p \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!\<close>

	abbreviation PL (\<open>L\<^sub>!\<close>) where
	\<open>L\<^sub>! i p \<equiv> (\<^bold>\<not>\<^sub>! (K\<^sub>! i (\<^bold>\<not>\<^sub>! p)))\<close>

	+primrec anns :: \<open>'i pfm \<Rightarrow> 'i pfm set\<close> where
	+ \<open>anns \<^bold>\<bottom>\<^sub>! = {}\<close>
	+\| \<open>anns (Pro\<^sub>! _) = {}\<close>
	+\| \<open>anns (p \<^bold>\<or>\<^sub>! q) = (anns p \<union> anns q)\<close>
	+\| \<open>anns (p \<^bold>\<and>\<^sub>! q) = (anns p \<union> anns q)\<close>
	+\| \<open>anns (p \<^bold>\<longrightarrow>\<^sub>! q) = (anns p \<union> anns q)\<close>
	+\| \<open>anns (K\<^sub>! i p) = anns p\<close>
	+\| \<open>anns ([r]\<^sub>! p) = {r} \<union> anns r \<union> anns p\<close>
	+
	section \<open>Semantics\<close>

	fun
	- psemantics :: \<open>('i, 'w) kripke \<Rightarrow> 'w \<Rightarrow> 'i pfm \<Rightarrow> bool\<close> ("_, _ \<Turnstile>\<^sub>! _" [50, 50] 50) and
	- restrict :: \<open>('i, 'w) kripke \<Rightarrow> 'i pfm \<Rightarrow> ('i, 'w) kripke\<close> where
	- \<open>(M, w \<Turnstile>\<^sub>! \<^bold>\<bottom>\<^sub>!) = False\<close>
	-\| \<open>(M, w \<Turnstile>\<^sub>! Pro\<^sub>! x) = \<pi> M w x\<close>
	-\| \<open>(M, w \<Turnstile>\<^sub>! (p \<^bold>\<or>\<^sub>! q)) = ((M, w \<Turnstile>\<^sub>! p) \<or> (M, w \<Turnstile>\<^sub>! q))\<close>
	-\| \<open>(M, w \<Turnstile>\<^sub>! (p \<^bold>\<and>\<^sub>! q)) = ((M, w \<Turnstile>\<^sub>! p) \<and> (M, w \<Turnstile>\<^sub>! q))\<close>
	-\| \<open>(M, w \<Turnstile>\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q)) = ((M, w \<Turnstile>\<^sub>! p) \<longrightarrow> (M, w \<Turnstile>\<^sub>! q))\<close>
	-\| \<open>(M, w \<Turnstile>\<^sub>! K\<^sub>! i p) = (\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile>\<^sub>! p)\<close>
	-\| \<open>(M, w \<Turnstile>\<^sub>! [r]\<^sub>! p) = ((M, w \<Turnstile>\<^sub>! r) \<longrightarrow> (restrict M r, w \<Turnstile>\<^sub>! p))\<close>
	-\| \<open>restrict M p = Kripke {w. w \<in> \<W> M \<and> M, w \<Turnstile>\<^sub>! p} (\<pi> M) (\<K> M)\<close>
	+ psemantics :: \<open>('i, 'w) kripke \<Rightarrow> 'w \<Rightarrow> 'i pfm \<Rightarrow> bool\<close> (\<open>_, _ \<Turnstile>\<^sub>! _\<close> [50, 50, 50] 50) and
	+ restrict :: \<open>('i, 'w) kripke \<Rightarrow> 'i pfm \<Rightarrow> ('i, 'w) kripke\<close> (\<open>_[_!]\<close> [50, 50] 50) where
	+ \<open>M, w \<Turnstile>\<^sub>! \<^bold>\<bottom>\<^sub>! \<longleftrightarrow> False\<close>
	+\| \<open>M, w \<Turnstile>\<^sub>! Pro\<^sub>! x \<longleftrightarrow> \<pi> M w x\<close>
	+\| \<open>M, w \<Turnstile>\<^sub>! p \<^bold>\<or>\<^sub>! q \<longleftrightarrow> M, w \<Turnstile>\<^sub>! p \<or> M, w \<Turnstile>\<^sub>! q\<close>
	+\| \<open>M, w \<Turnstile>\<^sub>! p \<^bold>\<and>\<^sub>! q \<longleftrightarrow> M, w \<Turnstile>\<^sub>! p \<and> M, w \<Turnstile>\<^sub>! q\<close>
	+\| \<open>M, w \<Turnstile>\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! q \<longleftrightarrow> M, w \<Turnstile>\<^sub>! p \<longrightarrow> M, w \<Turnstile>\<^sub>! q\<close>
	+\| \<open>M, w \<Turnstile>\<^sub>! K\<^sub>! i p \<longleftrightarrow> (\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile>\<^sub>! p)\<close>
	+\| \<open>M, w \<Turnstile>\<^sub>! [r]\<^sub>! p \<longleftrightarrow> M, w \<Turnstile>\<^sub>! r \<longrightarrow> M[r!], w \<Turnstile>\<^sub>! p\<close>
	+\| \<open>M[r!] = M \<lparr>\<W> := {w. w \<in> \<W> M \<and> M, w \<Turnstile>\<^sub>! r}\<rparr>\<close>
	+
	+abbreviation validPStar :: \<open>(('i, 'w) kripke \<Rightarrow> bool) \<Rightarrow> 'i pfm set \<Rightarrow> 'i pfm \<Rightarrow> bool\<close>
	+ (\<open>_; _ \<TTurnstile>\<^sub>!\<star> _\<close> [50, 50, 50] 50) where
	+ \<open>P; G \<TTurnstile>\<^sub>!\<star> p \<equiv> \<forall>M. P M \<longrightarrow> (\<forall>w \<in> \<W> M. (\<forall>q \<in> G. M, w \<Turnstile>\<^sub>! q) \<longrightarrow> M, w \<Turnstile>\<^sub>! p)\<close>

	primrec static :: \<open>'i pfm \<Rightarrow> bool\<close> where
	\<open>static \<^bold>\<bottom>\<^sub>! = True\<close>
	\| \<open>static (Pro\<^sub>! _) = True\<close>
	\| \<open>static (p \<^bold>\<or>\<^sub>! q) = (static p \<and> static q)\<close>
	\| \<open>static (p \<^bold>\<and>\<^sub>! q) = (static p \<and> static q)\<close>
	\| \<open>static (p \<^bold>\<longrightarrow>\<^sub>! q) = (static p \<and> static q)\<close>
	\| \<open>static (K\<^sub>! i p) = static p\<close>
	\| \<open>static ([r]\<^sub>! p) = False\<close>

	primrec lower :: \<open>'i pfm \<Rightarrow> 'i fm\<close> where
	\<open>lower \<^bold>\<bottom>\<^sub>! = \<^bold>\<bottom>\<close>
	\| \<open>lower (Pro\<^sub>! x) = Pro x\<close>
	\| \<open>lower (p \<^bold>\<or>\<^sub>! q) = (lower p \<^bold>\<or> lower q)\<close>
	\| \<open>lower (p \<^bold>\<and>\<^sub>! q) = (lower p \<^bold>\<and> lower q)\<close>
	\| \<open>lower (p \<^bold>\<longrightarrow>\<^sub>! q) = (lower p \<^bold>\<longrightarrow> lower q)\<close>
	\| \<open>lower (K\<^sub>! i p) = K i (lower p)\<close>
	\| \<open>lower ([r]\<^sub>! p) = undefined\<close>

	primrec lift :: \<open>'i fm \<Rightarrow> 'i pfm\<close> where
	\<open>lift \<^bold>\<bottom> = \<^bold>\<bottom>\<^sub>!\<close>
	\| \<open>lift (Pro x) = Pro\<^sub>! x\<close>
	\| \<open>lift (p \<^bold>\<or> q) = (lift p \<^bold>\<or>\<^sub>! lift q)\<close>
	\| \<open>lift (p \<^bold>\<and> q) = (lift p \<^bold>\<and>\<^sub>! lift q)\<close>
	\| \<open>lift (p \<^bold>\<longrightarrow> q) = (lift p \<^bold>\<longrightarrow>\<^sub>! lift q)\<close>
	\| \<open>lift (K i p) = K\<^sub>! i (lift p)\<close>

	lemma lower_semantics:
	assumes \<open>static p\<close>
	shows \<open>(M, w \<Turnstile> lower p) \<longleftrightarrow> (M, w \<Turnstile>\<^sub>! p)\<close>
	using assms by (induct p arbitrary: w) simp_all

	lemma lift_semantics: \<open>(M, w \<Turnstile> p) \<longleftrightarrow> (M, w \<Turnstile>\<^sub>! lift p)\<close>
	by (induct p arbitrary: w) simp_all

	lemma lower_lift: \<open>lower (lift p) = p\<close>
	by (induct p) simp_all

	lemma lift_lower: \<open>static p \<Longrightarrow> lift (lower p) = p\<close>
	by (induct p) simp_all

	section \<open>Soundness of Reduction\<close>

	primrec reduce' :: \<open>'i pfm \<Rightarrow> 'i pfm \<Rightarrow> 'i pfm\<close> where
	\<open>reduce' r \<^bold>\<bottom>\<^sub>! = (r \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!)\<close>
	\| \<open>reduce' r (Pro\<^sub>! x) = (r \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x)\<close>
	\| \<open>reduce' r (p \<^bold>\<or>\<^sub>! q) = (reduce' r p \<^bold>\<or>\<^sub>! reduce' r q)\<close>
	\| \<open>reduce' r (p \<^bold>\<and>\<^sub>! q) = (reduce' r p \<^bold>\<and>\<^sub>! reduce' r q)\<close>
	\| \<open>reduce' r (p \<^bold>\<longrightarrow>\<^sub>! q) = (reduce' r p \<^bold>\<longrightarrow>\<^sub>! reduce' r q)\<close>
	\| \<open>reduce' r (K\<^sub>! i p) = (r \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (reduce' r p))\<close>
	\| \<open>reduce' r ([p]\<^sub>! q) = undefined\<close>

	primrec reduce :: \<open>'i pfm \<Rightarrow> 'i pfm\<close> where
	\<open>reduce \<^bold>\<bottom>\<^sub>! = \<^bold>\<bottom>\<^sub>!\<close>
	\| \<open>reduce (Pro\<^sub>! x) = Pro\<^sub>! x\<close>
	\| \<open>reduce (p \<^bold>\<or>\<^sub>! q) = (reduce p \<^bold>\<or>\<^sub>! reduce q)\<close>
	\| \<open>reduce (p \<^bold>\<and>\<^sub>! q) = (reduce p \<^bold>\<and>\<^sub>! reduce q)\<close>
	\| \<open>reduce (p \<^bold>\<longrightarrow>\<^sub>! q) = (reduce p \<^bold>\<longrightarrow>\<^sub>! reduce q)\<close>
	\| \<open>reduce (K\<^sub>! i p) = K\<^sub>! i (reduce p)\<close>
	\| \<open>reduce ([r]\<^sub>! p) = reduce' (reduce r) (reduce p)\<close>

	lemma static_reduce': \<open>static p \<Longrightarrow> static r \<Longrightarrow> static (reduce' r p)\<close>
	by (induct p) simp_all

	lemma static_reduce: \<open>static (reduce p)\<close>
	by (induct p) (simp_all add: static_reduce')

	lemma reduce'_semantics:
	assumes \<open>static q\<close>
	- shows \<open>((M, w \<Turnstile>\<^sub>! [p]\<^sub>! (q))) = (M, w \<Turnstile>\<^sub>! reduce' p q)\<close>
	+ shows \<open>(M, w \<Turnstile>\<^sub>! [p]\<^sub>! q) = (M, w \<Turnstile>\<^sub>! reduce' p q)\<close>
	using assms by (induct q arbitrary: w) auto

	-lemma reduce_semantics: \<open>(M, w \<Turnstile>\<^sub>! p) = (M, w \<Turnstile>\<^sub>! reduce p)\<close>
	+lemma reduce_semantics: \<open>M, w \<Turnstile>\<^sub>! p \<longleftrightarrow> M, w \<Turnstile>\<^sub>! reduce p\<close>
	proof (induct p arbitrary: M w)
	case (Ann p q)
	then show ?case
	using reduce'_semantics static_reduce by fastforce
	qed simp_all

	+section \<open>Chains of Implications\<close>
	+
	+primrec implyP :: \<open>'i pfm list \<Rightarrow> 'i pfm \<Rightarrow> 'i pfm\<close> (infixr \<open>\<^bold>\<leadsto>\<^sub>!\<close> 56) where
	+ \<open>([] \<^bold>\<leadsto>\<^sub>! q) = q\<close>
	+\| \<open>(p # ps \<^bold>\<leadsto>\<^sub>! q) = (p \<^bold>\<longrightarrow>\<^sub>! ps \<^bold>\<leadsto>\<^sub>! q)\<close>
	+
	+lemma lift_implyP: \<open>lift (ps \<^bold>\<leadsto> q) = (map lift ps \<^bold>\<leadsto>\<^sub>! lift q)\<close>
	+ by (induct ps) auto
	+
	+lemma reduce_implyP: \<open>reduce (ps \<^bold>\<leadsto>\<^sub>! q) = (map reduce ps \<^bold>\<leadsto>\<^sub>! reduce q)\<close>
	+ by (induct ps) auto
	+
	section \<open>Proof System\<close>

	primrec peval :: \<open>(id \<Rightarrow> bool) \<Rightarrow> ('i pfm \<Rightarrow> bool) \<Rightarrow> 'i pfm \<Rightarrow> bool\<close> where
	\<open>peval _ _ \<^bold>\<bottom>\<^sub>! = False\<close>
	\| \<open>peval g _ (Pro\<^sub>! x) = g x\<close>
	\| \<open>peval g h (p \<^bold>\<or>\<^sub>! q) = (peval g h p \<or> peval g h q)\<close>
	\| \<open>peval g h (p \<^bold>\<and>\<^sub>! q) = (peval g h p \<and> peval g h q)\<close>
	\| \<open>peval g h (p \<^bold>\<longrightarrow>\<^sub>! q) = (peval g h p \<longrightarrow> peval g h q)\<close>
	\| \<open>peval _ h (K\<^sub>! i p) = h (K\<^sub>! i p)\<close>
	\| \<open>peval _ h ([r]\<^sub>! p) = h ([r]\<^sub>! p)\<close>

	abbreviation \<open>ptautology p \<equiv> \<forall>g h. peval g h p\<close>

	-inductive PAK :: \<open>('i pfm \<Rightarrow> bool) \<Rightarrow> 'i pfm \<Rightarrow> bool\<close> ("_ \<turnstile>\<^sub>! _" [50, 50] 50)
	- for A :: \<open>'i pfm \<Rightarrow> bool\<close> where
	- PA1: \<open>ptautology p \<Longrightarrow> A \<turnstile>\<^sub>! p\<close>
	- \| PA2: \<open>A \<turnstile>\<^sub>! (K\<^sub>! i p \<^bold>\<and>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q)\<close>
	- \| PAx: \<open>A p \<Longrightarrow> A \<turnstile>\<^sub>! p\<close>
	- \| PR1: \<open>A \<turnstile>\<^sub>! p \<Longrightarrow> A \<turnstile>\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q) \<Longrightarrow> A \<turnstile>\<^sub>! q\<close>
	- \| PR2: \<open>A \<turnstile>\<^sub>! p \<Longrightarrow> A \<turnstile>\<^sub>! K\<^sub>! i p\<close>
	- \| PFF: \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! \<^bold>\<bottom>\<^sub>! \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!))\<close>
	- \| PPro: \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! Pro\<^sub>! x \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x))\<close>
	- \| PDis: \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! (p \<^bold>\<or>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q)\<close>
	- \| PCon: \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! (p \<^bold>\<and>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q)\<close>
	- \| PImp: \<open>A \<turnstile>\<^sub>! (([r]\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q)) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q))\<close>
	- \| PK: \<open>A \<turnstile>\<^sub>! (([r]\<^sub>! K\<^sub>! i p) \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i ([r]\<^sub>! p)))\<close>
	- \| PAnn: \<open>A \<turnstile>\<^sub>! p \<Longrightarrow> A \<turnstile>\<^sub>! [r]\<^sub>! p\<close>
	+inductive PAK :: \<open>('i pfm \<Rightarrow> bool) \<Rightarrow> ('i pfm \<Rightarrow> bool) \<Rightarrow> 'i pfm \<Rightarrow> bool\<close>
	+ (\<open>_; _ \<turnstile>\<^sub>! _\<close> [50, 50, 50] 50)
	+ for A B :: \<open>'i pfm \<Rightarrow> bool\<close> where
	+ PA1: \<open>ptautology p \<Longrightarrow> A; B \<turnstile>\<^sub>! p\<close>
	+ \| PA2: \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i p \<^bold>\<and>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q\<close>
	+ \| PAx: \<open>A p \<Longrightarrow> A; B \<turnstile>\<^sub>! p\<close>
	+ \| PR1: \<open>A; B \<turnstile>\<^sub>! p \<Longrightarrow> A; B \<turnstile>\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! q \<Longrightarrow> A; B \<turnstile>\<^sub>! q\<close>
	+ \| PR2: \<open>A; B \<turnstile>\<^sub>! p \<Longrightarrow> A; B \<turnstile>\<^sub>! K\<^sub>! i p\<close>
	+ \| PAnn: \<open>A; B \<turnstile>\<^sub>! p \<Longrightarrow> B r \<Longrightarrow> A; B \<turnstile>\<^sub>! [r]\<^sub>! p\<close>
	+ \| PFF: \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! \<^bold>\<bottom>\<^sub>! \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!)\<close>
	+ \| PPro: \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! Pro\<^sub>! x \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x)\<close>
	+ \| PDis: \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! (p \<^bold>\<or>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q\<close>
	+ \| PCon: \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! (p \<^bold>\<and>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q\<close>
	+ \| PImp: \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q)\<close>
	+ \| PK: \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! K\<^sub>! i p \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i ([r]\<^sub>! p))\<close>
	+
	+abbreviation PAK_assms (\<open>_; _; _ \<turnstile>\<^sub>! _\<close> [50, 50, 50, 50] 50) where
	+ \<open>A; B; G \<turnstile>\<^sub>! p \<equiv> \<exists>qs. set qs \<subseteq> G \<and> (A; B \<turnstile>\<^sub>! qs \<^bold>\<leadsto>\<^sub>! p)\<close>

	lemma eval_peval: \<open>eval h (g o lift) p = peval h g (lift p)\<close>
	by (induct p) simp_all

	lemma tautology_ptautology: \<open>tautology p \<Longrightarrow> ptautology (lift p)\<close>
	using eval_peval by blast

	-lemma peval_eval:
	- assumes \<open>static p\<close>
	- shows \<open>eval h g (lower p) = peval h (g o lower) p\<close>
	- using assms by (induct p) simp_all
	-
	-lemma ptautology_tautology:
	- assumes \<open>static p\<close>
	- shows \<open>ptautology p \<Longrightarrow> tautology (lower p)\<close>
	- using assms peval_eval by blast
	-
	-theorem AK_PAK: \<open>A o lift \<turnstile> p \<Longrightarrow> A \<turnstile>\<^sub>! lift p\<close>
	+theorem AK_PAK: \<open>A o lift \<turnstile> p \<Longrightarrow> A; B \<turnstile>\<^sub>! lift p\<close>
	by (induct p rule: AK.induct) (auto intro: PAK.intros(1-5) simp: tautology_ptautology)

	-abbreviation
	- \<open>valid P p \<equiv> \<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M. P M \<longrightarrow> M, w \<Turnstile> p\<close>
	-
	-abbreviation
	- \<open>valid\<^sub>P P p \<equiv> \<forall>(M :: ('i :: countable, 'i fm set) kripke). \<forall>w \<in> \<W> M. P M \<longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+abbreviation validP
	+ :: \<open>(('i :: countable, 'i fm set) kripke \<Rightarrow> bool) \<Rightarrow> 'i pfm set \<Rightarrow> 'i pfm \<Rightarrow> bool\<close>
	+ (\<open>_; _ \<TTurnstile>\<^sub>! _\<close> [50, 50, 50] 50)
	+ where \<open>P; G \<TTurnstile>\<^sub>! p \<equiv> P; G \<TTurnstile>\<^sub>!\<star> p\<close>

	-theorem static_completeness:
	- assumes \<open>static p\<close> \<open>valid\<^sub>P P p\<close> \<open>valid P (lower p) \<Longrightarrow> A o lift \<turnstile> lower p\<close>
	- shows \<open>A \<turnstile>\<^sub>! p\<close>
	+lemma set_map_inv:
	+ assumes \<open>set xs \<subseteq> f ` X\<close>
	+ shows \<open>\<exists>ys. set ys \<subseteq> X \<and> map f ys = xs\<close>
	+ using assms
	+proof (induct xs)
	+ case (Cons x xs)
	+ then obtain ys where \<open>set ys \<subseteq> X\<close> \<open>map f ys = xs\<close>
	+ by auto
	+ moreover obtain y where \<open>y \<in> X\<close> \<open>f y = x\<close>
	+ using Cons.prems by auto
	+ ultimately have \<open>set (y # ys) \<subseteq> X\<close> \<open>map f (y # ys) = x # xs\<close>
	+ by simp_all
	+ then show ?case
	+ by meson
	+qed simp
	+
	+lemma strong_static_completeness':
	+ assumes \<open>static p\<close> and \<open>\<forall>q \<in> G. static q\<close> and \<open>P; G \<TTurnstile>\<^sub>! p\<close>
	+ and \<open>P; lower ` G \<TTurnstile>\<star> lower p \<Longrightarrow> A o lift; lower ` G \<turnstile> lower p\<close>
	+ shows \<open>A; B; G \<turnstile>\<^sub>! p\<close>
	proof -
	- have \<open>valid P (lower p)\<close>
	+ have \<open>P; lower ` G \<TTurnstile>\<star> lower p\<close>
	using assms by (simp add: lower_semantics)
	- then have \<open>A o lift \<turnstile> lower p\<close>
	- using assms(3) by fast
	- then have \<open>A \<turnstile>\<^sub>! lift (lower p)\<close>
	+ then have \<open>A o lift; lower ` G \<turnstile> lower p\<close>
	+ using assms(4) by blast
	+ then obtain qs where \<open>set qs \<subseteq> G\<close> and \<open>A o lift \<turnstile> map lower qs \<^bold>\<leadsto> lower p\<close>
	+ using set_map_inv by blast
	+ then have \<open>A; B \<turnstile>\<^sub>! lift (map lower qs \<^bold>\<leadsto> lower p)\<close>
	using AK_PAK by fast
	+ then have \<open>A; B \<turnstile>\<^sub>! map lift (map lower qs) \<^bold>\<leadsto>\<^sub>! lift (lower p)\<close>
	+ using lift_implyP by metis
	+ then have \<open>A; B \<turnstile>\<^sub>! map (lift o lower) qs \<^bold>\<leadsto>\<^sub>! lift (lower p)\<close>
	+ by simp
	then show ?thesis
	- using assms(1) lift_lower by metis
	+ using assms(1-2) \<open>set qs \<subseteq> G\<close> lift_lower
	+ by (metis (mono_tags, lifting) comp_apply map_idI subset_eq)
	qed

	-corollary static_completeness\<^sub>P\<^sub>K:
	- assumes \<open>static p\<close> \<open>valid\<^sub>P (\<lambda>_. True) p\<close>
	- shows \<open>A \<turnstile>\<^sub>! p\<close>
	- using assms static_completeness[where P=\<open>\<lambda>_. True\<close>] completeness by metis
	+theorem strong_static_completeness:
	+ assumes \<open>static p\<close> and \<open>\<forall>q \<in> G. static q\<close> and \<open>P; G \<TTurnstile>\<^sub>! p\<close>
	+ and \<open>\<And>G p. valid P G p \<Longrightarrow> A o lift; G \<turnstile> p\<close>
	+ shows \<open>A; B; G \<turnstile>\<^sub>! p\<close>
	+ using strong_static_completeness' assms .
	+
	+corollary static_completeness':
	+ assumes \<open>static p\<close> and \<open>P; {} \<TTurnstile>\<^sub>!\<star> p\<close>
	+ and \<open>P; {} \<TTurnstile> lower p \<Longrightarrow> A o lift \<turnstile> lower p\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p\<close>
	+ using assms strong_static_completeness'[where G=\<open>{}\<close> and p=p] by simp
	+
	+corollary static_completeness:
	+ assumes \<open>static p\<close> and \<open>P; {} \<TTurnstile>\<^sub>!\<star> p\<close> and \<open>\<And>p. P; {} \<TTurnstile> p \<Longrightarrow> A o lift \<turnstile> p\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p\<close>
	+ using static_completeness' assms .
	+
	+corollary
	+ assumes \<open>static p\<close> \<open>(\<lambda>_. True); {} \<TTurnstile>\<^sub>! p\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p\<close>
	+ using assms static_completeness[where P=\<open>\<lambda>_. True\<close> and p=p] completeness\<^sub>A by blast

	section \<open>Soundness\<close>

	-lemma peval_semantics: \<open>peval (val w) (\<lambda>q. Kripke W val r, w \<Turnstile>\<^sub>! q) p = (Kripke W val r, w \<Turnstile>\<^sub>! p)\<close>
	+lemma peval_semantics:
	+ \<open>peval (val w) (\<lambda>q. \<lparr>\<W> = W, \<K> = r, \<pi> = val\<rparr>, w \<Turnstile>\<^sub>! q) p = (\<lparr>\<W> = W, \<K> = r, \<pi> = val\<rparr>, w \<Turnstile>\<^sub>! p)\<close>
	by (induct p) simp_all

	lemma ptautology:
	assumes \<open>ptautology p\<close>
	shows \<open>M, w \<Turnstile>\<^sub>! p\<close>
	proof -
	- from assms have \<open>peval (g w) (\<lambda>q. Kripke W g r, w \<Turnstile>\<^sub>! q) p\<close> for W g r
	+ from assms have \<open>peval (g w) (\<lambda>q. \<lparr>\<W> = W, \<K> = r, \<pi> = g\<rparr>, w \<Turnstile>\<^sub>! q) p\<close> for W g r
	by simp
	- then have \<open>Kripke W g r, w \<Turnstile>\<^sub>! p\<close> for W g r
	+ then have \<open>\<lparr>\<W> = W, \<K> = r, \<pi> = g\<rparr>, w \<Turnstile>\<^sub>! p\<close> for W g r
	using peval_semantics by fast
	then show \<open>M, w \<Turnstile>\<^sub>! p\<close>
	- by (metis kripke.collapse)
	+ by (metis kripke.cases)
	qed

	-theorem soundness:
	- fixes M :: \<open>('i, 'w) kripke\<close>
	+theorem soundness\<^sub>P:
	assumes
	- \<open>\<And>(M :: ('i, 'w) kripke) p w. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- \<open>\<And>(M :: ('i, 'w) kripke) p. P M \<Longrightarrow> P (restrict M p)\<close>
	- shows \<open>A \<turnstile>\<^sub>! p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ \<open>\<And>M p w. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ \<open>\<And>M r. P M \<Longrightarrow> B r \<Longrightarrow> P (M[r!])\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	proof (induct p arbitrary: M w rule: PAK.induct)
	case (PAnn p r)
	- moreover have \<open>P (restrict M r)\<close>
	- using PAnn(3) assms(2) by simp
	- ultimately show ?case
	- by simp
	+ then show ?case
	+ using assms by simp
	qed (simp_all add: assms ptautology)

	-corollary \<open>(\<lambda>_. False) \<turnstile>\<^sub>! p \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using soundness[where P=\<open>\<lambda>_. True\<close>] by metis
	+corollary \<open>(\<lambda>_. False); B \<turnstile>\<^sub>! p \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ using soundness\<^sub>P[where P=\<open>\<lambda>_. True\<close>] by metis
	+
	+section \<open>Strong Soundness\<close>
	+
	+lemma ptautology_imply_superset:
	+ assumes \<open>set ps \<subseteq> set qs\<close>
	+ shows \<open>ptautology (ps \<^bold>\<leadsto>\<^sub>! r \<^bold>\<longrightarrow>\<^sub>! qs \<^bold>\<leadsto>\<^sub>! r)\<close>
	+proof (rule ccontr)
	+ assume \<open>\<not> ?thesis\<close>
	+ then obtain g h where \<open>\<not> peval g h (ps \<^bold>\<leadsto>\<^sub>! r \<^bold>\<longrightarrow>\<^sub>! qs \<^bold>\<leadsto>\<^sub>! r)\<close>
	+ by blast
	+ then have \<open>peval g h (ps \<^bold>\<leadsto>\<^sub>! r)\<close> \<open>\<not> peval g h (qs \<^bold>\<leadsto>\<^sub>! r)\<close>
	+ by simp_all
	+ then consider (np) \<open>\<exists>p \<in> set ps. \<not> peval g h p\<close> \| (r) \<open>\<forall>p \<in> set ps. peval g h p\<close> \<open>peval g h r\<close>
	+ by (induct ps) auto
	+ then show False
	+ proof cases
	+ case np
	+ then have \<open>\<exists>p \<in> set qs. \<not> peval g h p\<close>
	+ using \<open>set ps \<subseteq> set qs\<close> by blast
	+ then have \<open>peval g h (qs \<^bold>\<leadsto>\<^sub>! r)\<close>
	+ by (induct qs) simp_all
	+ then show ?thesis
	+ using \<open>\<not> peval g h (qs \<^bold>\<leadsto>\<^sub>! r)\<close> by blast
	+ next
	+ case r
	+ then have \<open>peval g h (qs \<^bold>\<leadsto>\<^sub>! r)\<close>
	+ by (induct qs) simp_all
	+ then show ?thesis
	+ using \<open>\<not> peval g h (qs \<^bold>\<leadsto>\<^sub>! r)\<close> by blast
	+ qed
	+qed
	+
	+lemma PK_imply_weaken:
	+ assumes \<open>A; B \<turnstile>\<^sub>! ps \<^bold>\<leadsto>\<^sub>! q\<close> \<open>set ps \<subseteq> set ps'\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! ps' \<^bold>\<leadsto>\<^sub>! q\<close>
	+proof -
	+ have \<open>ptautology (ps \<^bold>\<leadsto>\<^sub>! q \<^bold>\<longrightarrow>\<^sub>! ps' \<^bold>\<leadsto>\<^sub>! q)\<close>
	+ using \<open>set ps \<subseteq> set ps'\<close> ptautology_imply_superset by blast
	+ then have \<open>A; B \<turnstile>\<^sub>! ps \<^bold>\<leadsto>\<^sub>! q \<^bold>\<longrightarrow>\<^sub>! ps' \<^bold>\<leadsto>\<^sub>! q\<close>
	+ using PA1 by blast
	+ then show ?thesis
	+ using \<open>A; B \<turnstile>\<^sub>! ps \<^bold>\<leadsto>\<^sub>! q\<close> PR1 by blast
	+qed
	+
	+lemma implyP_append: \<open>(ps @ ps' \<^bold>\<leadsto>\<^sub>! q) = (ps \<^bold>\<leadsto>\<^sub>! ps' \<^bold>\<leadsto>\<^sub>! q)\<close>
	+ by (induct ps) simp_all
	+
	+lemma PK_ImpI:
	+ assumes \<open>A; B \<turnstile>\<^sub>! p # G \<^bold>\<leadsto>\<^sub>! q\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! G \<^bold>\<leadsto>\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q)\<close>
	+proof -
	+ have \<open>set (p # G) \<subseteq> set (G @ [p])\<close>
	+ by simp
	+ then have \<open>A; B \<turnstile>\<^sub>! G @ [p] \<^bold>\<leadsto>\<^sub>! q\<close>
	+ using assms PK_imply_weaken by blast
	+ then have \<open>A; B \<turnstile>\<^sub>! G \<^bold>\<leadsto>\<^sub>! [p] \<^bold>\<leadsto>\<^sub>! q\<close>
	+ using implyP_append by metis
	+ then show ?thesis
	+ by simp
	+qed
	+
	+corollary soundness_imply\<^sub>P:
	+ assumes
	+ \<open>\<And>M p w. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ \<open>\<And>M r. P M \<Longrightarrow> B r \<Longrightarrow> P (M[r!])\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! qs \<^bold>\<leadsto>\<^sub>! p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> \<forall>q \<in> set qs. M, w \<Turnstile>\<^sub>! q \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+proof (induct qs arbitrary: p)
	+ case Nil
	+ then show ?case
	+ using soundness\<^sub>P[of A P B p M w] assms by simp
	+next
	+ case (Cons q qs)
	+ then show ?case
	+ using PK_ImpI by fastforce
	+qed
	+
	+theorem strong_soundness\<^sub>P:
	+ assumes
	+ \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ \<open>\<And>M r. P M \<Longrightarrow> B r \<Longrightarrow> P (M[r!])\<close>
	+ shows \<open>A; B; G \<turnstile>\<^sub>! p \<Longrightarrow> P; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+proof safe
	+ fix qs w and M :: \<open>('a, 'b) kripke\<close>
	+ assume \<open>A; B \<turnstile>\<^sub>! qs \<^bold>\<leadsto>\<^sub>! p\<close>
	+ moreover assume \<open>set qs \<subseteq> G\<close> \<open>\<forall>q \<in> G. M, w \<Turnstile>\<^sub>! q\<close>
	+ then have \<open>\<forall>q \<in> set qs. M, w \<Turnstile>\<^sub>! q\<close>
	+ using \<open>set qs \<subseteq> G\<close> by blast
	+ moreover assume \<open>P M\<close> \<open>w \<in> \<W> M\<close>
	+ ultimately show \<open>M, w \<Turnstile>\<^sub>! p\<close>
	+ using soundness_imply\<^sub>P[of A P B qs p] assms by blast
	+qed

	section \<open>Completeness\<close>

	lemma ConE:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<and>\<^sub>! q)\<close>
	- shows \<open>A \<turnstile>\<^sub>! p\<close> \<open>A \<turnstile>\<^sub>! q\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<and>\<^sub>! q\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p\<close> \<open>A; B \<turnstile>\<^sub>! q\<close>
	using assms by (metis PA1 PR1 peval.simps(4-5))+

	lemma Iff_Dis:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p')\<close> \<open>A \<turnstile>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q')\<close>
	- shows \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<or>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<or>\<^sub>! q'))\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! p'\<close> \<open>A; B \<turnstile>\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! q'\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! ((p \<^bold>\<or>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<or>\<^sub>! q'))\<close>
	proof -
	- have \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q') \<^bold>\<longrightarrow>\<^sub>! ((p \<^bold>\<or>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<or>\<^sub>! q')))\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q') \<^bold>\<longrightarrow>\<^sub>! ((p \<^bold>\<or>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<or>\<^sub>! q'))\<close>
	by (simp add: PA1)
	then show ?thesis
	using assms PR1 by blast
	qed

	lemma Iff_Con:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p')\<close> \<open>A \<turnstile>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q')\<close>
	- shows \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<and>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<and>\<^sub>! q'))\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! p'\<close> \<open>A; B \<turnstile>\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! q'\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! (p \<^bold>\<and>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<and>\<^sub>! q')\<close>
	proof -
	- have \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q') \<^bold>\<longrightarrow>\<^sub>! ((p \<^bold>\<and>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<and>\<^sub>! q')))\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q') \<^bold>\<longrightarrow>\<^sub>! ((p \<^bold>\<and>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<and>\<^sub>! q'))\<close>
	by (simp add: PA1)
	then show ?thesis
	using assms PR1 by blast
	qed

	lemma Iff_Imp:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p')\<close> \<open>A \<turnstile>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q')\<close>
	- shows \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<longrightarrow>\<^sub>! q'))\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! p'\<close> \<open>A; B \<turnstile>\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! q'\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! ((p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<longrightarrow>\<^sub>! q'))\<close>
	proof -
	- have \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q') \<^bold>\<longrightarrow>\<^sub>! ((p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<longrightarrow>\<^sub>! q')))\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! q') \<^bold>\<longrightarrow>\<^sub>! ((p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (p' \<^bold>\<longrightarrow>\<^sub>! q'))\<close>
	by (simp add: PA1)
	then show ?thesis
	using assms PR1 by blast
	qed

	-lemma Iff_sym: \<open>(A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q)) = (A \<turnstile>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! p))\<close>
	+lemma Iff_sym: \<open>(A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! q) = (A; B \<turnstile>\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! p)\<close>
	proof -
	- have \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<longleftrightarrow>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! p))\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! (q \<^bold>\<longleftrightarrow>\<^sub>! p)\<close>
	by (simp add: PA1)
	then show ?thesis
	using PR1 ConE by blast
	qed

	lemma Iff_Iff:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p')\<close> \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q)\<close>
	- shows \<open>A \<turnstile>\<^sub>! (p' \<^bold>\<longleftrightarrow>\<^sub>! q)\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! p'\<close> \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! q\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p' \<^bold>\<longleftrightarrow>\<^sub>! q\<close>
	proof -
	have \<open>ptautology ((p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! (p' \<^bold>\<longleftrightarrow>\<^sub>! q))\<close>
	by (metis peval.simps(4-5))
	- with PA1 have \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! (p' \<^bold>\<longleftrightarrow>\<^sub>! q))\<close> .
	+ with PA1 have \<open>A; B \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p') \<^bold>\<longrightarrow>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! (p' \<^bold>\<longleftrightarrow>\<^sub>! q)\<close> .
	then show ?thesis
	using assms PR1 by blast
	qed

	-lemma K'_A2': \<open>A \<turnstile>\<^sub>! (K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q)\<close>
	+lemma K'_A2': \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q\<close>
	proof -
	- have \<open>A \<turnstile>\<^sub>! (K\<^sub>! i p \<^bold>\<and>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q)\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i p \<^bold>\<and>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q\<close>
	using PA2 by fast
	- moreover have \<open>A \<turnstile>\<^sub>! ((P \<^bold>\<and>\<^sub>! Q \<^bold>\<longrightarrow>\<^sub>! R) \<^bold>\<longrightarrow>\<^sub>! (Q \<^bold>\<longrightarrow>\<^sub>! P \<^bold>\<longrightarrow>\<^sub>! R))\<close> for P Q R
	+ moreover have \<open>A; B \<turnstile>\<^sub>! (P \<^bold>\<and>\<^sub>! Q \<^bold>\<longrightarrow>\<^sub>! R) \<^bold>\<longrightarrow>\<^sub>! (Q \<^bold>\<longrightarrow>\<^sub>! P \<^bold>\<longrightarrow>\<^sub>! R)\<close> for P Q R
	by (simp add: PA1)
	ultimately show ?thesis
	using PR1 by fast
	qed

	lemma K'_map:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q)\<close>
	- shows \<open>A \<turnstile>\<^sub>! (K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q)\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! q\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q\<close>
	proof -
	- note \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q)\<close>
	- then have \<open>A \<turnstile>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q)\<close>
	+ note \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! q\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q)\<close>
	using PR2 by fast
	- moreover have \<open>A \<turnstile>\<^sub>! (K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q)\<close>
	+ moreover have \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i (p \<^bold>\<longrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i q\<close>
	using K'_A2' by fast
	ultimately show ?thesis
	using PR1 by fast
	qed

	lemma ConI:
	- assumes \<open>A \<turnstile>\<^sub>! p\<close> \<open>A \<turnstile>\<^sub>! q\<close>
	- shows \<open>A \<turnstile>\<^sub>! (p \<^bold>\<and>\<^sub>! q)\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p\<close> \<open>A; B \<turnstile>\<^sub>! q\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<and>\<^sub>! q\<close>
	proof -
	- have \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q \<^bold>\<longrightarrow>\<^sub>! p \<^bold>\<and>\<^sub>! q)\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! q \<^bold>\<longrightarrow>\<^sub>! p \<^bold>\<and>\<^sub>! q\<close>
	by (simp add: PA1)
	then show ?thesis
	using assms PR1 by blast
	qed

	lemma Iff_wk:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q)\<close>
	- shows \<open>A \<turnstile>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! q))\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! q\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! q)\<close>
	proof -
	- have \<open>A \<turnstile>\<^sub>! ((p \<^bold>\<longleftrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! q)))\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! q) \<^bold>\<longrightarrow>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! q))\<close>
	by (simp add: PA1)
	then show ?thesis
	using assms PR1 by blast
	qed

	lemma Iff_reduce':
	assumes \<open>static p\<close>
	- shows \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce' r p)\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce' r p\<close>
	using assms
	proof (induct p rule: pfm.induct)
	case FF
	then show ?case
	by (simp add: PFF)
	next
	case (Pro' x)
	then show ?case
	by (simp add: PPro)
	next
	case (Dis p q)
	- then have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! reduce' r (p \<^bold>\<or>\<^sub>! q))\<close>
	- using Iff_Dis by force
	- moreover have \<open>A \<turnstile>\<^sub>! (([r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! (p \<^bold>\<or>\<^sub>! q)))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! reduce' r (p \<^bold>\<or>\<^sub>! q)\<close>
	+ using Iff_Dis by fastforce
	+ moreover have \<open>A; B \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! (p \<^bold>\<or>\<^sub>! q))\<close>
	using PDis Iff_sym by fastforce
	ultimately show ?case
	using PA1 PR1 Iff_Iff by blast
	next
	case (Con p q)
	- then have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! reduce' r (p \<^bold>\<and>\<^sub>! q))\<close>
	- using Iff_Con by force
	- moreover have \<open>A \<turnstile>\<^sub>! (([r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! (p \<^bold>\<and>\<^sub>! q)))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! reduce' r (p \<^bold>\<and>\<^sub>! q)\<close>
	+ using Iff_Con by fastforce
	+ moreover have \<open>A; B \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! (p \<^bold>\<and>\<^sub>! q))\<close>
	using PCon Iff_sym by fastforce
	ultimately show ?case
	using PA1 PR1 Iff_Iff by blast
	next
	case (Imp p q)
	- then have \<open>A \<turnstile>\<^sub>! (([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! reduce' r (p \<^bold>\<longrightarrow>\<^sub>! q))\<close>
	- using Iff_Imp by force
	- moreover have \<open>A \<turnstile>\<^sub>! (([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q)))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! reduce' r (p \<^bold>\<longrightarrow>\<^sub>! q)\<close>
	+ using Iff_Imp by fastforce
	+ moreover have \<open>A; B \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r]\<^sub>! (p \<^bold>\<longrightarrow>\<^sub>! q))\<close>
	using PImp Iff_sym by fastforce
	ultimately show ?case
	using PA1 PR1 Iff_Iff by blast
	next
	case (K' i p)
	- then have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce' r p)\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce' r p\<close>
	by simp
	- then have \<open>A \<turnstile>\<^sub>! (K\<^sub>! i ([r]\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! K\<^sub>! i (reduce' r p))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i ([r]\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! K\<^sub>! i (reduce' r p)\<close>
	using K'_map ConE ConI by metis
	- moreover have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! K\<^sub>! i p \<^bold>\<longleftrightarrow>\<^sub>! r \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i ([r]\<^sub>! p))\<close>
	+ moreover have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! K\<^sub>! i p \<^bold>\<longleftrightarrow>\<^sub>! r \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i ([r]\<^sub>! p)\<close>
	using PK .
	- ultimately have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! K\<^sub>! i p \<^bold>\<longleftrightarrow>\<^sub>! r \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (reduce' r p))\<close>
	+ ultimately have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! K\<^sub>! i p \<^bold>\<longleftrightarrow>\<^sub>! r \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (reduce' r p)\<close>
	by (meson Iff_Iff Iff_sym Iff_wk)
	then show ?case
	by simp
	next
	case (Ann r p)
	then show ?case
	by simp
	qed

	lemma Iff_Ann1:
	- assumes r: \<open>A \<turnstile>\<^sub>! (r \<^bold>\<longleftrightarrow>\<^sub>! r')\<close> and \<open>static p\<close>
	- shows \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p)\<close>
	+ assumes r: \<open>A; B \<turnstile>\<^sub>! r \<^bold>\<longleftrightarrow>\<^sub>! r'\<close> and \<open>static p\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p\<close>
	using assms(2-)
	proof (induct p)
	case FF
	- have \<open>A \<turnstile>\<^sub>! ((r \<^bold>\<longleftrightarrow>\<^sub>! r') \<^bold>\<longrightarrow>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!)))\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! (r \<^bold>\<longleftrightarrow>\<^sub>! r') \<^bold>\<longrightarrow>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!))\<close>
	by (auto intro: PA1)
	- then have \<open>A \<turnstile>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! \<^bold>\<bottom>\<^sub>!)\<close>
	using r PR1 by blast
	then show ?case
	by (meson PFF Iff_Iff Iff_sym)
	next
	case (Pro' x)
	- have \<open>A \<turnstile>\<^sub>! ((r \<^bold>\<longleftrightarrow>\<^sub>! r') \<^bold>\<longrightarrow>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x)))\<close>
	+ have \<open>A; B \<turnstile>\<^sub>! (r \<^bold>\<longleftrightarrow>\<^sub>! r') \<^bold>\<longrightarrow>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x))\<close>
	by (auto intro: PA1)
	- then have \<open>A \<turnstile>\<^sub>! ((r \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! (r \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x) \<^bold>\<longleftrightarrow>\<^sub>! (r' \<^bold>\<longrightarrow>\<^sub>! Pro\<^sub>! x)\<close>
	using r PR1 by blast
	then show ?case
	by (meson PPro Iff_Iff Iff_sym)
	next
	case (Dis p q)
	- then have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p \<^bold>\<or>\<^sub>! [r']\<^sub>! q)\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<or>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p \<^bold>\<or>\<^sub>! [r']\<^sub>! q\<close>
	by (simp add: Iff_Dis)
	then show ?case
	by (meson PDis Iff_Iff Iff_sym)
	next
	case (Con p q)
	- then have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p \<^bold>\<and>\<^sub>! [r']\<^sub>! q)\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<and>\<^sub>! [r]\<^sub>! q \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p \<^bold>\<and>\<^sub>! [r']\<^sub>! q\<close>
	by (simp add: Iff_Con)
	then show ?case
	by (meson PCon Iff_Iff Iff_sym)
	next
	case (Imp p q)
	- then have \<open>A \<turnstile>\<^sub>! (([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r']\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r']\<^sub>! q))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r]\<^sub>! q) \<^bold>\<longleftrightarrow>\<^sub>! ([r']\<^sub>! p \<^bold>\<longrightarrow>\<^sub>! [r']\<^sub>! q)\<close>
	by (simp add: Iff_Imp)
	then show ?case
	by (meson PImp Iff_Iff Iff_sym)
	next
	case (K' i p)
	- then have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p)\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! [r']\<^sub>! p\<close>
	by simp
	- then have \<open>A \<turnstile>\<^sub>! (K\<^sub>! i ([r]\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! K\<^sub>! i ([r']\<^sub>! p))\<close>
	+ then have \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i ([r]\<^sub>! p) \<^bold>\<longleftrightarrow>\<^sub>! K\<^sub>! i ([r']\<^sub>! p)\<close>
	using K'_map ConE ConI by metis
	then show ?case
	by (meson Iff_Iff Iff_Imp Iff_sym PK r)
	next
	case (Ann s p)
	then show ?case
	by simp
	qed

	lemma Iff_Ann2:
	- assumes \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! p')\<close>
	- shows \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p')\<close>
	+ assumes \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! p'\<close> and \<open>B r\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p'\<close>
	using assms PAnn ConE ConI PImp PR1 by metis

	-lemma Iff_reduce: \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! reduce p)\<close>
	+lemma Iff_reduce:
	+ assumes \<open>\<forall>r \<in> anns p. B r\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce p\<close>
	+ using assms
	proof (induct p)
	case (Dis p q)
	then show ?case
	by (simp add: Iff_Dis)
	next
	case (Con p q)
	then show ?case
	by (simp add: Iff_Con)
	next
	case (Imp p q)
	then show ?case
	by (simp add: Iff_Imp)
	next
	case (K' i p)
	- have
	- \<open>A \<turnstile>\<^sub>! (K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (reduce p))\<close>
	- \<open>A \<turnstile>\<^sub>! (K\<^sub>! i (reduce p) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i p)\<close>
	- using K' K'_map ConE by fast+
	- then have \<open>A \<turnstile>\<^sub>! (K\<^sub>! i p \<^bold>\<longleftrightarrow>\<^sub>! K\<^sub>! i (reduce p))\<close>
	+ then have
	+ \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (reduce p)\<close>
	+ \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i (reduce p) \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i p\<close>
	+ using K'_map ConE by fastforce+
	+ then have \<open>A; B \<turnstile>\<^sub>! K\<^sub>! i p \<^bold>\<longleftrightarrow>\<^sub>! K\<^sub>! i (reduce p)\<close>
	using ConI by blast
	then show ?case
	by simp
	next
	case (Ann r p)
	- have \<open>A \<turnstile>\<^sub>! ([reduce r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! reduce' (reduce r) (reduce p))\<close>
	+ then have \<open>B r\<close>
	+ by simp
	+ have \<open>A; B \<turnstile>\<^sub>! [reduce r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! reduce' (reduce r) (reduce p)\<close>
	using Iff_reduce' static_reduce by blast
	- moreover have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! [reduce r]\<^sub>! reduce p)\<close>
	- using Ann(1) Iff_Ann1 static_reduce by blast
	- ultimately have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! reduce' (reduce r) (reduce p))\<close>
	+ moreover have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! [reduce r]\<^sub>! reduce p\<close>
	+ using Ann Iff_Ann1 static_reduce by fastforce
	+ ultimately have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! reduce' (reduce r) (reduce p)\<close>
	using Iff_Iff Iff_sym by blast
	- moreover have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p)\<close>
	- by (meson Ann(2) static_reduce Iff_Ann2 Iff_sym)
	- ultimately have \<open>A \<turnstile>\<^sub>! ([r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce' (reduce r) (reduce p))\<close>
	+ moreover have \<open>\<forall>r \<in> anns p. B r\<close>
	+ using Ann.prems by simp
	+ then have \<open>A; B \<turnstile>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce p\<close>
	+ using Ann.hyps(2) by blast
	+ then have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! reduce p \<^bold>\<longleftrightarrow>\<^sub>! [r]\<^sub>! p\<close>
	+ using \<open>B r\<close> Iff_Ann2 Iff_sym by blast
	+ ultimately have \<open>A; B \<turnstile>\<^sub>! [r]\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce' (reduce r) (reduce p)\<close>
	using Iff_Iff by blast
	then show ?case
	by simp
	qed (simp_all add: PA1)

	-theorem completeness\<^sub>P:
	- assumes \<open>valid\<^sub>P P p\<close> \<open>valid P (lower (reduce p)) \<Longrightarrow> A o lift \<turnstile> lower (reduce p)\<close>
	- shows \<open>A \<turnstile>\<^sub>! p\<close>
	+lemma anns_implyP [simp]:
	+ \<open>anns (ps \<^bold>\<leadsto>\<^sub>! q) = anns q \<union> (\<Union>p \<in> set ps. anns p)\<close>
	+ by (induct ps) auto
	+
	+lemma strong_completeness\<^sub>P':
	+ assumes \<open>P; G \<TTurnstile>\<^sub>! p\<close>
	+ and \<open>\<forall>r \<in> anns p. B r\<close> \<open>\<forall>q \<in> G. \<forall>r \<in> anns q. B r\<close>
	+ and \<open>P; lower ` reduce ` G \<TTurnstile>\<star> lower (reduce p) \<Longrightarrow>
	+ A o lift; lower ` reduce ` G \<turnstile> lower (reduce p)\<close>
	+ shows \<open>A; B; G \<turnstile>\<^sub>! p\<close>
	proof -
	- have \<open>valid\<^sub>P P (reduce p)\<close>
	+ have \<open>P; reduce ` G \<TTurnstile>\<^sub>!\<star> reduce p\<close>
	using assms(1) reduce_semantics by fast
	- moreover have \<open>static (reduce p)\<close>
	- using static_reduce by fast
	- ultimately have \<open>A \<turnstile>\<^sub>! reduce p\<close>
	- using static_completeness assms(2) by blast
	- moreover have \<open>A \<turnstile>\<^sub>! (p \<^bold>\<longleftrightarrow>\<^sub>! reduce p)\<close>
	+ moreover have \<open>static (reduce p)\<close> \<open>\<forall>q \<in> reduce ` G. static q\<close>
	+ using static_reduce by fast+
	+ ultimately have \<open>A; B; reduce ` G \<turnstile>\<^sub>! reduce p\<close>
	+ using assms(4) strong_static_completeness'[where G=\<open>reduce ` G\<close> and p=\<open>reduce p\<close>]
	+ by presburger
	+ then have \<open>\<exists>qs. set qs \<subseteq> G \<and> (A; B \<turnstile>\<^sub>! map reduce qs \<^bold>\<leadsto>\<^sub>! reduce p)\<close>
	+ using set_map_inv by fast
	+ then obtain qs where qs: \<open>set qs \<subseteq> G\<close> and \<open>A; B \<turnstile>\<^sub>! map reduce qs \<^bold>\<leadsto>\<^sub>! reduce p\<close>
	+ by blast
	+ then have \<open>A; B \<turnstile>\<^sub>! reduce (qs \<^bold>\<leadsto>\<^sub>! p)\<close>
	+ using reduce_implyP by metis
	+ moreover have \<open>\<forall>r \<in> anns (qs \<^bold>\<leadsto>\<^sub>! p). B r\<close>
	+ using assms(2-3) qs by auto
	+ then have \<open>A; B \<turnstile>\<^sub>! qs \<^bold>\<leadsto>\<^sub>! p \<^bold>\<longleftrightarrow>\<^sub>! reduce (qs \<^bold>\<leadsto>\<^sub>! p)\<close>
	using Iff_reduce by blast
	- ultimately show ?thesis
	+ ultimately have \<open>A; B \<turnstile>\<^sub>! qs \<^bold>\<leadsto>\<^sub>! p\<close>
	using ConE(2) PR1 by blast
	+ then show ?thesis
	+ using qs by blast
	qed

	-corollary
	- assumes \<open>valid\<^sub>P (\<lambda>_. True) p\<close>
	- shows \<open>A \<turnstile>\<^sub>! p\<close>
	- using assms completeness\<^sub>P[where P=\<open>\<lambda>_. True\<close>] completeness by metis
	-
	-section \<open>System PK\<close>
	-
	-abbreviation SystemPK :: \<open>'i pfm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>!\<^sub>K _" [50] 50) where
	- \<open>\<turnstile>\<^sub>!\<^sub>K p \<equiv> (\<lambda>_. False) \<turnstile>\<^sub>! p\<close>
	-
	-lemma soundness\<^sub>P\<^sub>K: \<open>\<turnstile>\<^sub>!\<^sub>K p \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using soundness[where P=\<open>\<lambda>_. True\<close>] by metis
	-
	-abbreviation \<open>valid\<^sub>P\<^sub>K \<equiv> valid\<^sub>P (\<lambda>_. True)\<close>
	+theorem strong_completeness\<^sub>P:
	+ assumes \<open>P; G \<TTurnstile>\<^sub>! p\<close>
	+ and \<open>\<forall>r \<in> anns p. B r\<close> \<open>\<forall>q \<in> G. \<forall>r \<in> anns q. B r\<close>
	+ and \<open>\<And>G p. P; G \<TTurnstile>\<star> p \<Longrightarrow> A o lift; G \<turnstile> p\<close>
	+ shows \<open>A; B; G \<turnstile>\<^sub>! p\<close>
	+ using strong_completeness\<^sub>P' assms .

	-lemma completeness\<^sub>P\<^sub>K:
	- assumes \<open>valid\<^sub>P\<^sub>K p\<close>
	- shows \<open>\<turnstile>\<^sub>!\<^sub>K p\<close>
	- using assms completeness\<^sub>P[where P=\<open>\<lambda>_. True\<close>] completeness by metis
	-
	-theorem main\<^sub>P\<^sub>K: \<open>valid\<^sub>P\<^sub>K p \<longleftrightarrow> \<turnstile>\<^sub>!\<^sub>K p\<close>
	- using soundness\<^sub>P\<^sub>K completeness\<^sub>P\<^sub>K by fast
	+theorem main\<^sub>P:
	+ assumes \<open>\<And>M w p. A p \<Longrightarrow> P M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ and \<open>\<And>M r. P M \<Longrightarrow> B r \<Longrightarrow> P (M[r!])\<close>
	+ and \<open>\<forall>r \<in> anns p. B r\<close> \<open>\<forall>q \<in> G. \<forall>r \<in> anns q. B r\<close>
	+ and \<open>\<And>G p. P; G \<TTurnstile>\<star> p \<Longrightarrow> A o lift; G \<turnstile> p\<close>
	+ shows \<open>P; G \<TTurnstile>\<^sub>! p \<longleftrightarrow> A; B; G \<turnstile>\<^sub>! p\<close>
	+ using strong_soundness\<^sub>P[of A P B G p] strong_completeness\<^sub>P[of P G p B A] assms by blast

	-corollary
	- assumes \<open>valid\<^sub>P\<^sub>K p\<close> and \<open>w \<in> \<W> M\<close>
	- shows \<open>M, w \<Turnstile>\<^sub>! p\<close>
	- using assms soundness\<^sub>P\<^sub>K completeness\<^sub>P\<^sub>K by metis
	+corollary strong_completeness\<^sub>P\<^sub>B:
	+ assumes \<open>P; G \<TTurnstile>\<^sub>! p\<close>
	+ and \<open>\<And>G p. P; G \<TTurnstile>\<star> p \<Longrightarrow> A o lift; G \<turnstile> p\<close>
	+ shows \<open>A; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>
	+ using strong_completeness\<^sub>P[where B=\<open>\<lambda>_. True\<close>] assms by blast

	-section \<open>System PT\<close>
	+corollary completeness\<^sub>P':
	+ assumes \<open>P; {} \<TTurnstile>\<^sub>! p\<close>
	+ and \<open>\<forall>r \<in> anns p. B r\<close>
	+ and \<open>\<And>p. valid P {} (lower p) \<Longrightarrow> A o lift \<turnstile> lower p\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p\<close>
	+ using assms strong_completeness\<^sub>P'[where P=P and G=\<open>{}\<close>] by simp

	-text \<open>Also known as System M\<close>
	+corollary completeness\<^sub>P:
	+ assumes \<open>P; {} \<TTurnstile>\<^sub>! p\<close>
	+ and \<open>\<forall>r \<in> anns p. B r\<close>
	+ and \<open>\<And>p. valid P {} p \<Longrightarrow> A o lift \<turnstile> p\<close>
	+ shows \<open>A; B \<turnstile>\<^sub>! p\<close>
	+ using completeness\<^sub>P' assms .
	+
	+corollary completeness\<^sub>P\<^sub>A:
	+ assumes \<open>(\<lambda>_. True); {} \<TTurnstile>\<^sub>! p\<close>
	+ shows \<open>A; (\<lambda>_. True) \<turnstile>\<^sub>! p\<close>
	+ using assms completeness\<^sub>P[of \<open>\<lambda>_. True\<close> p \<open>\<lambda>_. True\<close>] completeness\<^sub>A by blast
	+
	+section \<open>System PAL + K\<close>
	+
	+abbreviation SystemPK (\<open>_ \<turnstile>\<^sub>!\<^sub>K _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>K p \<equiv> (\<lambda>_. False); (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>
	+
	+lemma strong_soundness\<^sub>P\<^sub>K: \<open>G \<turnstile>\<^sub>!\<^sub>K p \<Longrightarrow> (\<lambda>_. True); G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of \<open>\<lambda>_. False\<close> \<open>\<lambda>_. True\<close>] by fast
	+
	+abbreviation validPK (\<open>_ \<TTurnstile>\<^sub>!\<^sub>K _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>!\<^sub>K p \<equiv> (\<lambda>_. True); G \<TTurnstile>\<^sub>! p\<close>
	+
	+lemma strong_completeness\<^sub>P\<^sub>K:
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>K p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>K p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>K unfolding comp_apply .
	+
	+theorem main\<^sub>P\<^sub>K: \<open>G \<TTurnstile>\<^sub>!\<^sub>K p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>K p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K[of G p] strong_completeness\<^sub>P\<^sub>K[of G p] by fast
	+
	+corollary \<open>G \<TTurnstile>\<^sub>!\<^sub>K p \<Longrightarrow> (\<lambda>_. True); G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K[of G p] strong_completeness\<^sub>P\<^sub>K[of G p] by fast
	+
	+section \<open>System PAL + T\<close>
	+
	+text \<open>Also known as System PAL + M\<close>

	inductive AxPT :: \<open>'i pfm \<Rightarrow> bool\<close> where
	\<open>AxPT (K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! p)\<close>

	-abbreviation SystemPT :: \<open>'i pfm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>!\<^sub>T _" [50] 50) where
	- \<open>\<turnstile>\<^sub>!\<^sub>T p \<equiv> AxPT \<turnstile>\<^sub>! p\<close>
	+abbreviation SystemPT (\<open>_ \<turnstile>\<^sub>!\<^sub>T _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>T p \<equiv> AxPT; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>

	lemma soundness_AxPT: \<open>AxPT p \<Longrightarrow> reflexive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	unfolding reflexive_def by (induct p rule: AxPT.induct) simp

	-lemma reflexive_restrict: \<open>reflexive M \<Longrightarrow> reflexive (restrict M p)\<close>
	+lemma reflexive_restrict: \<open>reflexive M \<Longrightarrow> reflexive (M[r!])\<close>
	unfolding reflexive_def by simp

	-lemma soundness\<^sub>P\<^sub>T: \<open>\<turnstile>\<^sub>!\<^sub>T p \<Longrightarrow> reflexive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using soundness[where A=AxPT and P=reflexive] soundness_AxPT reflexive_restrict by fastforce
	+lemma strong_soundness\<^sub>P\<^sub>T: \<open>G \<turnstile>\<^sub>!\<^sub>T p \<Longrightarrow> reflexive; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of AxPT reflexive \<open>\<lambda>_. True\<close> G p]
	+ soundness_AxPT reflexive_restrict by fast

	lemma AxT_AxPT: \<open>AxT = AxPT o lift\<close>
	unfolding comp_apply using lower_lift
	by (metis AxPT.simps AxT.simps lift.simps(5-6) lower.simps(5-6))

	-abbreviation \<open>valid\<^sub>P\<^sub>T \<equiv> valid\<^sub>P reflexive\<close>
	-
	-lemma completeness\<^sub>P\<^sub>T:
	- assumes \<open>valid\<^sub>P\<^sub>T p\<close>
	- shows \<open>\<turnstile>\<^sub>!\<^sub>T p\<close>
	- using assms completeness\<^sub>P[where p=p] completeness\<^sub>T AxT_AxPT by metis
	+abbreviation validPT (\<open>_ \<TTurnstile>\<^sub>!\<^sub>T _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>!\<^sub>T p \<equiv> reflexive; G \<TTurnstile>\<^sub>! p\<close>

	-theorem main\<^sub>P\<^sub>T: \<open>valid\<^sub>P\<^sub>T p \<longleftrightarrow> \<turnstile>\<^sub>!\<^sub>T p\<close>
	- using soundness\<^sub>P\<^sub>T completeness\<^sub>P\<^sub>T by fast
	+lemma strong_completeness\<^sub>P\<^sub>T:
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>T p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>T p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>T unfolding AxT_AxPT .

	-corollary
	- assumes \<open>reflexive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>P\<^sub>T p \<longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using assms soundness\<^sub>P\<^sub>T completeness\<^sub>P\<^sub>T by fast
	+theorem main\<^sub>P\<^sub>T: \<open>G \<TTurnstile>\<^sub>!\<^sub>T p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>T p\<close>
	+ using strong_soundness\<^sub>P\<^sub>T[of G p] strong_completeness\<^sub>P\<^sub>T[of G p] by fast

	-section \<open>System PKB\<close>
	+corollary \<open>G \<TTurnstile>\<^sub>!\<^sub>T p \<Longrightarrow> reflexive; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P\<^sub>T[of G p] strong_completeness\<^sub>P\<^sub>T[of G p] by fast
	+
	+section \<open>System PAL + KB\<close>

	inductive AxPB :: \<open>'i pfm \<Rightarrow> bool\<close> where
	\<open>AxPB (p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (L\<^sub>! i p))\<close>

	-abbreviation SystemPKB :: \<open>'i pfm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>!\<^sub>K\<^sub>B _" [50] 50) where
	- \<open>\<turnstile>\<^sub>!\<^sub>K\<^sub>B p \<equiv> AxPB \<turnstile>\<^sub>! p\<close>
	+abbreviation SystemPKB (\<open>_ \<turnstile>\<^sub>!\<^sub>K\<^sub>B _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>B p \<equiv> AxPB; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>

	lemma soundness_AxPB: \<open>AxPB p \<Longrightarrow> symmetric M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	unfolding symmetric_def by (induct p rule: AxPB.induct) auto

	-lemma symmetric_restrict: \<open>symmetric M \<Longrightarrow> symmetric (restrict M p)\<close>
	+lemma symmetric_restrict: \<open>symmetric M \<Longrightarrow> symmetric (M[r!])\<close>
	unfolding symmetric_def by simp

	-lemma soundness\<^sub>P\<^sub>K\<^sub>B: \<open>\<turnstile>\<^sub>!\<^sub>K\<^sub>B p \<Longrightarrow> symmetric M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using soundness[where A=AxPB and P=symmetric] soundness_AxPB symmetric_restrict by fastforce
	+lemma strong_soundness\<^sub>P\<^sub>K\<^sub>B: \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>B p \<Longrightarrow> symmetric; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of AxPB symmetric \<open>\<lambda>_. True\<close> G p]
	+ soundness_AxPB symmetric_restrict by fast

	lemma AxB_AxPB: \<open>AxB = AxPB o lift\<close>
	proof
	fix p :: \<open>'i fm\<close>
	show \<open>AxB p = (AxPB \<circ> lift) p\<close>
	unfolding comp_apply using lower_lift
	by (smt (verit, best) AxB.simps AxPB.simps lift.simps(1, 5-6) lower.simps(5-6))
	qed

	-abbreviation \<open>valid\<^sub>P\<^sub>K\<^sub>B \<equiv> valid\<^sub>P symmetric\<close>
	-
	-lemma completeness\<^sub>P\<^sub>K\<^sub>B:
	- assumes \<open>valid\<^sub>P\<^sub>K\<^sub>B p\<close>
	- shows \<open>\<turnstile>\<^sub>!\<^sub>K\<^sub>B p\<close>
	- using assms completeness\<^sub>P[where p=p] completeness\<^sub>K\<^sub>B AxB_AxPB by metis
	+abbreviation validPKB (\<open>_ \<TTurnstile>\<^sub>!\<^sub>K\<^sub>B _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>B p \<equiv> symmetric; G \<TTurnstile>\<^sub>! p\<close>

	-theorem main\<^sub>P\<^sub>K\<^sub>B: \<open>valid\<^sub>P\<^sub>K\<^sub>B p \<longleftrightarrow> \<turnstile>\<^sub>!\<^sub>K\<^sub>B p\<close>
	- using soundness\<^sub>P\<^sub>K\<^sub>B completeness\<^sub>P\<^sub>K\<^sub>B by fast
	+lemma strong_completeness\<^sub>P\<^sub>K\<^sub>B:
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>B p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>B p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>K\<^sub>B unfolding AxB_AxPB .

	-corollary
	- assumes \<open>symmetric M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>P\<^sub>K\<^sub>B p \<longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using assms soundness\<^sub>P\<^sub>K\<^sub>B completeness\<^sub>P\<^sub>K\<^sub>B by fast
	+theorem main\<^sub>P\<^sub>K\<^sub>B: \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>B p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>K\<^sub>B p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K\<^sub>B[of G p] strong_completeness\<^sub>P\<^sub>K\<^sub>B[of G p] by fast

	-section \<open>System PK4\<close>
	+corollary \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>B p \<Longrightarrow> symmetric; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K\<^sub>B[of G p] strong_completeness\<^sub>P\<^sub>K\<^sub>B[of G p] by fast
	+
	+section \<open>System PAL + K4\<close>

	inductive AxP4 :: \<open>'i pfm \<Rightarrow> bool\<close> where
	\<open>AxP4 (K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (K\<^sub>! i p))\<close>

	-abbreviation SystemPK4 :: \<open>'i pfm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>!\<^sub>K\<^sub>4 _" [50] 50) where
	- \<open>\<turnstile>\<^sub>!\<^sub>K\<^sub>4 p \<equiv> AxP4 \<turnstile>\<^sub>! p\<close>
	+abbreviation SystemPK4 (\<open>_ \<turnstile>\<^sub>!\<^sub>K\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>4 p \<equiv> AxP4; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>

	lemma pos_introspection:
	assumes \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	shows \<open>M, w \<Turnstile>\<^sub>! (K\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (K\<^sub>! i p))\<close>
	proof -
	{ assume \<open>M, w \<Turnstile>\<^sub>! K\<^sub>! i p\<close>
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile>\<^sub>! p\<close>
	by simp
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. \<forall>u \<in> \<W> M \<inter> \<K> M i v. M, u \<Turnstile>\<^sub>! p\<close>
	using \<open>transitive M\<close> \<open>w \<in> \<W> M\<close> unfolding transitive_def by blast
	then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile>\<^sub>! K\<^sub>! i p\<close>
	by simp
	then have \<open>M, w \<Turnstile>\<^sub>! K\<^sub>! i (K\<^sub>! i p)\<close>
	by simp }
	then show ?thesis
	by fastforce
	qed

	lemma soundness_AxP4: \<open>AxP4 p \<Longrightarrow> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	by (induct p rule: AxP4.induct) (metis pos_introspection)

	-lemma transitive_restrict: \<open>transitive M \<Longrightarrow> transitive (restrict M p)\<close>
	- unfolding transitive_def
	- by (metis (no_types, lifting) kripke.exhaust_sel kripke.inject mem_Collect_eq restrict.elims)
	+lemma transitive_restrict: \<open>transitive M \<Longrightarrow> transitive (M[r!])\<close>
	+ unfolding transitive_def by (cases M) (metis (no_types, lifting) frame.select_convs(1-2)
	+ frame.update_convs(1) mem_Collect_eq restrict.simps)

	-lemma soundness\<^sub>P\<^sub>K\<^sub>4: \<open>\<turnstile>\<^sub>!\<^sub>K\<^sub>4 p \<Longrightarrow> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using soundness[where A=AxP4 and P=transitive] soundness_AxP4 transitive_restrict by fastforce
	+lemma strong_soundness\<^sub>P\<^sub>K\<^sub>4: \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>4 p \<Longrightarrow> transitive; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of AxP4 transitive \<open>\<lambda>_. True\<close> G p]
	+ soundness_AxP4 transitive_restrict by fast

	lemma Ax4_AxP4: \<open>Ax4 = AxP4 o lift\<close>
	proof
	fix p :: \<open>'i fm\<close>
	show \<open>Ax4 p = (AxP4 \<circ> lift) p\<close>
	unfolding comp_apply using lower_lift
	by (smt (verit, best) Ax4.simps AxP4.simps lift.simps(1, 5-6) lower.simps(5-6))
	qed

	-abbreviation \<open>valid\<^sub>P\<^sub>K\<^sub>4 \<equiv> valid\<^sub>P transitive\<close>
	-
	-lemma completeness\<^sub>P\<^sub>K\<^sub>4:
	- assumes \<open>valid\<^sub>P\<^sub>K\<^sub>4 p\<close>
	- shows \<open>\<turnstile>\<^sub>!\<^sub>K\<^sub>4 p\<close>
	- using assms completeness\<^sub>P[where p=p] completeness\<^sub>K\<^sub>4 Ax4_AxP4 by metis
	-
	-theorem main\<^sub>P\<^sub>K\<^sub>4: \<open>valid\<^sub>P\<^sub>K\<^sub>4 p \<longleftrightarrow> \<turnstile>\<^sub>!\<^sub>K\<^sub>4 p\<close>
	- using soundness\<^sub>P\<^sub>K\<^sub>4 completeness\<^sub>P\<^sub>K\<^sub>4 by fast
	+abbreviation validPK4 (\<open>_ \<TTurnstile>\<^sub>!\<^sub>K\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>4 p \<equiv> transitive; G \<TTurnstile>\<^sub>! p\<close>

	-corollary
	- assumes \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>P\<^sub>K\<^sub>4 p \<longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using assms soundness\<^sub>P\<^sub>K\<^sub>4 completeness\<^sub>P\<^sub>K\<^sub>4 by fast
	+lemma strong_completeness\<^sub>P\<^sub>K\<^sub>4:
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>4 p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>4 p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>K\<^sub>4 unfolding Ax4_AxP4 .

	-section \<open>System PS4\<close>
	+theorem main\<^sub>P\<^sub>K\<^sub>4: \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>4 p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>K\<^sub>4 p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K\<^sub>4[of G p] strong_completeness\<^sub>P\<^sub>K\<^sub>4[of G p] by fast

	-abbreviation SystemPS4 :: \<open>'i pfm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>!\<^sub>S\<^sub>4 _" [50] 50) where
	- \<open>\<turnstile>\<^sub>!\<^sub>S\<^sub>4 p \<equiv> AxPT \<oplus> AxP4 \<turnstile>\<^sub>! p\<close>
	+corollary \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>4 p \<Longrightarrow> transitive; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K\<^sub>4[of G p] strong_completeness\<^sub>P\<^sub>K\<^sub>4[of G p] by fast

	-abbreviation \<open>refltrans M \<equiv> reflexive M \<and> transitive M\<close>
	+section \<open>System PAL + K5\<close>
	+
	+inductive AxP5 :: \<open>'i pfm \<Rightarrow> bool\<close> where
	+ \<open>AxP5 (L\<^sub>! i p \<^bold>\<longrightarrow>\<^sub>! K\<^sub>! i (L\<^sub>! i p))\<close>
	+
	+abbreviation SystemPK5 (\<open>_ \<turnstile>\<^sub>!\<^sub>K\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>5 p \<equiv> AxP5; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>
	+
	+lemma soundness_AxP5: \<open>AxP5 p \<Longrightarrow> Euclidean M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ by (induct p rule: AxP5.induct) (unfold Euclidean_def psemantics.simps, blast)
	+
	+lemma Euclidean_restrict: \<open>Euclidean M \<Longrightarrow> Euclidean (M[r!])\<close>
	+ unfolding Euclidean_def by auto
	+
	+lemma strong_soundness\<^sub>P\<^sub>K\<^sub>5: \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>5 p \<Longrightarrow> Euclidean; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of AxP5 Euclidean \<open>\<lambda>_. True\<close> G p]
	+ soundness_AxP5 Euclidean_restrict by fast
	+
	+lemma Ax5_AxP5: \<open>Ax5 = AxP5 o lift\<close>
	+proof
	+ fix p :: \<open>'i fm\<close>
	+ show \<open>Ax5 p = (AxP5 \<circ> lift) p\<close>
	+ unfolding comp_apply using lower_lift
	+ by (smt (verit, best) Ax5.simps AxP5.simps lift.simps(1, 5-6) lower.simps(5-6))
	+qed
	+
	+abbreviation validPK5 (\<open>_ \<TTurnstile>\<^sub>!\<^sub>K\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>5 p \<equiv> Euclidean; G \<TTurnstile>\<^sub>! p\<close>
	+
	+lemma strong_completeness\<^sub>P\<^sub>K\<^sub>5:
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>5 p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>K\<^sub>5 p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>K\<^sub>5 unfolding Ax5_AxP5 .
	+
	+theorem main\<^sub>P\<^sub>K\<^sub>5: \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>K\<^sub>5 p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K\<^sub>5[of G p] strong_completeness\<^sub>P\<^sub>K\<^sub>5[of G p] by fast
	+
	+corollary \<open>G \<TTurnstile>\<^sub>!\<^sub>K\<^sub>5 p \<Longrightarrow> Euclidean; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P\<^sub>K\<^sub>5[of G p] strong_completeness\<^sub>P\<^sub>K\<^sub>5[of G p] by fast
	+
	+section \<open>System PAL + S4\<close>
	+
	+abbreviation SystemPS4 (\<open>_ \<turnstile>\<^sub>!\<^sub>S\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>4 p \<equiv> AxPT \<oplus> AxP4; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>

	lemma soundness_AxPT4: \<open>(AxPT \<oplus> AxP4) p \<Longrightarrow> refltrans M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	using soundness_AxPT soundness_AxP4 by fast

	-lemma refltrans_restrict: \<open>refltrans M \<Longrightarrow> refltrans (restrict M p)\<close>
	+lemma refltrans_restrict: \<open>refltrans M \<Longrightarrow> refltrans (M[r!])\<close>
	using reflexive_restrict transitive_restrict by blast

	-lemma soundness\<^sub>P\<^sub>S\<^sub>4: \<open>\<turnstile>\<^sub>!\<^sub>S\<^sub>4 p \<Longrightarrow> reflexive M \<and> transitive M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using soundness[where A=\<open>AxPT \<oplus> AxP4\<close> and P=refltrans] soundness_AxPT4 refltrans_restrict
	- by fastforce
	+lemma strong_soundness\<^sub>P\<^sub>S\<^sub>4: \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>4 p \<Longrightarrow> refltrans; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of \<open>AxPT \<oplus> AxP4\<close> refltrans \<open>\<lambda>_. True\<close> G p]
	+ soundness_AxPT4 refltrans_restrict by fast

	lemma AxT4_AxPT4: \<open>(AxT \<oplus> Ax4) = (AxPT \<oplus> AxP4) o lift\<close>
	using AxT_AxPT Ax4_AxP4 unfolding comp_apply by metis

	-abbreviation \<open>valid\<^sub>P\<^sub>S\<^sub>4 \<equiv> valid\<^sub>P refltrans\<close>
	-
	-lemma completeness\<^sub>P\<^sub>S\<^sub>4:
	- assumes \<open>valid\<^sub>P\<^sub>S\<^sub>4 p\<close>
	- shows \<open>\<turnstile>\<^sub>!\<^sub>S\<^sub>4 p\<close>
	- using assms completeness\<^sub>P[where P=refltrans and p=p] completeness\<^sub>S\<^sub>4 AxT4_AxPT4
	- by (metis (mono_tags, lifting))
	+abbreviation validPS4 (\<open>_ \<TTurnstile>\<^sub>!\<^sub>S\<^sub>4 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>4 p \<equiv> refltrans; G \<TTurnstile>\<^sub>! p\<close>

	-theorem main\<^sub>P\<^sub>S\<^sub>4: \<open>valid\<^sub>P\<^sub>S\<^sub>4 p \<longleftrightarrow> \<turnstile>\<^sub>!\<^sub>S\<^sub>4 p\<close>
	- using soundness\<^sub>P\<^sub>S\<^sub>4 completeness\<^sub>P\<^sub>S\<^sub>4 by fast
	+theorem strong_completeness\<^sub>P\<^sub>S\<^sub>4:
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>4 p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>4 p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>S\<^sub>4 unfolding AxT4_AxPT4 .

	-corollary
	- assumes \<open>reflexive M\<close> \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>P\<^sub>S\<^sub>4 p \<longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using assms soundness\<^sub>P\<^sub>S\<^sub>4 completeness\<^sub>P\<^sub>S\<^sub>4 by fast
	+theorem main\<^sub>P\<^sub>S\<^sub>4: \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>4 p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>S\<^sub>4 p\<close>
	+ using strong_soundness\<^sub>P\<^sub>S\<^sub>4[of G p] strong_completeness\<^sub>P\<^sub>S\<^sub>4[of G p] by fast

	-section \<open>System PS5\<close>
	+corollary \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>4 p \<Longrightarrow> refltrans; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P\<^sub>S\<^sub>4[of G p] strong_completeness\<^sub>P\<^sub>S\<^sub>4[of G p] by fast

	-abbreviation SystemPS5 :: \<open>'i pfm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>!\<^sub>S\<^sub>5 _" [50] 50) where
	- \<open>\<turnstile>\<^sub>!\<^sub>S\<^sub>5 p \<equiv> AxPT \<oplus> AxPB \<oplus> AxP4 \<turnstile>\<^sub>! p\<close>
	+section \<open>System PAL + S5\<close>
	+
	+abbreviation SystemPS5 (\<open>_ \<turnstile>\<^sub>!\<^sub>S\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>5 p \<equiv> AxPT \<oplus> AxPB \<oplus> AxP4; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>

	abbreviation AxPTB4 :: \<open>'i pfm \<Rightarrow> bool\<close> where
	\<open>AxPTB4 \<equiv> AxPT \<oplus> AxPB \<oplus> AxP4\<close>

	lemma soundness_AxPTB4: \<open>AxPTB4 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	using soundness_AxPT soundness_AxPB soundness_AxP4 by fast

	-lemma equivalence_restrict: \<open>equivalence M \<Longrightarrow> equivalence (restrict M p)\<close>
	+lemma equivalence_restrict: \<open>equivalence M \<Longrightarrow> equivalence (M[r!])\<close>
	using reflexive_restrict symmetric_restrict transitive_restrict by blast

	-lemma soundness\<^sub>P\<^sub>S\<^sub>5: \<open>\<turnstile>\<^sub>!\<^sub>S\<^sub>5 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using soundness[where A=AxPTB4 and P=equivalence and M=M and w=w]
	+lemma strong_soundness\<^sub>P\<^sub>S\<^sub>5: \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>5 p \<Longrightarrow> equivalence; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of AxPTB4 equivalence \<open>\<lambda>_. True\<close> G p]
	soundness_AxPTB4 equivalence_restrict by fast

	lemma AxTB4_AxPTB4: \<open>AxTB4 = AxPTB4 o lift\<close>
	using AxT_AxPT AxB_AxPB Ax4_AxP4 unfolding comp_apply by metis

	-abbreviation \<open>valid\<^sub>P\<^sub>S\<^sub>5 \<equiv> valid\<^sub>P equivalence\<close>
	+abbreviation validPS5 (\<open>_ \<TTurnstile>\<^sub>!\<^sub>S\<^sub>5 _\<close> [50, 50] 50) where
	+ \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>5 p \<equiv> equivalence; G \<TTurnstile>\<^sub>! p\<close>

	-lemma completeness\<^sub>P\<^sub>S\<^sub>5:
	- assumes \<open>valid\<^sub>P\<^sub>S\<^sub>5 p\<close>
	- shows \<open>\<turnstile>\<^sub>!\<^sub>S\<^sub>5 p\<close>
	- using assms completeness\<^sub>P[where P=equivalence and p=p] completeness\<^sub>S\<^sub>5 AxTB4_AxPTB4
	- by (metis (mono_tags, lifting))
	+theorem strong_completeness\<^sub>P\<^sub>S\<^sub>5:
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>5 p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>5 p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>S\<^sub>5 unfolding AxTB4_AxPTB4 .

	-theorem main\<^sub>P\<^sub>S\<^sub>5: \<open>valid\<^sub>P\<^sub>S\<^sub>5 p \<longleftrightarrow> \<turnstile>\<^sub>!\<^sub>S\<^sub>5 p\<close>
	- using soundness\<^sub>P\<^sub>S\<^sub>5 completeness\<^sub>P\<^sub>S\<^sub>5 by fast
	+theorem main\<^sub>P\<^sub>S\<^sub>5: \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>S\<^sub>5 p\<close>
	+ using strong_soundness\<^sub>P\<^sub>S\<^sub>5[of G p] strong_completeness\<^sub>P\<^sub>S\<^sub>5[of G p] by fast

	-corollary
	- assumes \<open>reflexive M\<close> \<open>symmetric M\<close> \<open>transitive M\<close> \<open>w \<in> \<W> M\<close>
	- shows \<open>valid\<^sub>P\<^sub>S\<^sub>5 p \<longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	- using assms soundness\<^sub>P\<^sub>S\<^sub>5 completeness\<^sub>P\<^sub>S\<^sub>5 by fast
	+corollary \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>5 p \<Longrightarrow> equivalence; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P\<^sub>S\<^sub>5[of G p] strong_completeness\<^sub>P\<^sub>S\<^sub>5[of G p] by fast
	+
	+section \<open>System PAL + S5'\<close>
	+
	+abbreviation SystemPS5' (\<open>_ \<turnstile>\<^sub>!\<^sub>S\<^sub>5'' _\<close> [50, 50] 50) where
	+ \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>5' p \<equiv> AxPT \<oplus> AxP5; (\<lambda>_. True); G \<turnstile>\<^sub>! p\<close>
	+
	+abbreviation AxPT5 :: \<open>'i pfm \<Rightarrow> bool\<close> where
	+ \<open>AxPT5 \<equiv> AxPT \<oplus> AxP5\<close>
	+
	+lemma soundness_AxPT5: \<open>AxPT5 p \<Longrightarrow> equivalence M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile>\<^sub>! p\<close>
	+ using soundness_AxPT soundness_AxPT soundness_AxP5 symm_trans_Euclid by fast
	+
	+lemma strong_soundness\<^sub>P\<^sub>S\<^sub>5': \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>5' p \<Longrightarrow> equivalence; G \<TTurnstile>\<^sub>!\<star> p\<close>
	+ using strong_soundness\<^sub>P[of AxPT5 equivalence \<open>\<lambda>_. True\<close> G p]
	+ soundness_AxPT5 equivalence_restrict by fast
	+
	+lemma AxT5_AxPT5: \<open>AxT5 = AxPT5 o lift\<close>
	+ using AxT_AxPT Ax5_AxP5 unfolding comp_apply by metis
	+
	+theorem strong_completeness\<^sub>P\<^sub>S\<^sub>5':
	+ assumes \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>5 p\<close>
	+ shows \<open>G \<turnstile>\<^sub>!\<^sub>S\<^sub>5' p\<close>
	+ using strong_completeness\<^sub>P\<^sub>B assms strong_completeness\<^sub>S\<^sub>5' unfolding AxT5_AxPT5 .
	+
	+theorem main\<^sub>P\<^sub>S\<^sub>5': \<open>G \<TTurnstile>\<^sub>!\<^sub>S\<^sub>5 p \<longleftrightarrow> G \<turnstile>\<^sub>!\<^sub>S\<^sub>5' p\<close>
	+ using strong_soundness\<^sub>P\<^sub>S\<^sub>5'[of G p] strong_completeness\<^sub>P\<^sub>S\<^sub>5'[of G p] by fast

	end
	diff --git a/thys/Public_Announcement_Logic/document/root.tex b/thys/Public_Announcement_Logic/document/root.tex
	--- a/thys/Public_Announcement_Logic/document/root.tex
	+++ b/thys/Public_Announcement_Logic/document/root.tex
	@@ -1,67 +1,67 @@
	\documentclass[11pt,a4paper]{article}
	\usepackage[T1]{fontenc}
	\usepackage{isabelle,isabellesym}

	% further packages required for unusual symbols (see also
	% isabellesym.sty), use only when needed

	-%\usepackage{amssymb}
	+\usepackage{amssymb}
	%for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
	%\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
	%\<triangleq>, \<yen>, \<lozenge>

	%\usepackage{eurosym}
	%for \<euro>

	%\usepackage[only,bigsqcap]{stmaryrd}
	%for \<Sqinter>

	%\usepackage{eufrak}
	%for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)

	%\usepackage{textcomp}
	%for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	%\<currency>

	% this should be the last package used
	\usepackage{pdfsetup}

	% urls in roman style, theory text in math-similar italics
	\urlstyle{rm}
	\isabellestyle{it}

	% for uniform font size
	%\renewcommand{\isastyle}{\isastyleminor}


	\begin{document}

	\title{Public Announcement Logic}
	\author{Asta Halkjær From}
	\maketitle

	\begin{abstract}
	This work is a formalization of public announcement logic with countably many agents.
	- It includes proofs of soundness and completeness for a variant of the axiom system PA + DIST! + NEC!~\cite{WangC13}. The completeness proof builds on the Epistemic Logic theory.
	+ It includes proofs of soundness and completeness for variants of the axiom system PA + DIST! + NEC!~\cite{WangC13}. The completeness proofs build on the Epistemic Logic theory.
	\end{abstract}

	\tableofcontents

	\newpage

	% 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/Quasi_Borel_Spaces/Bayesian_Linear_Regression.thy b/thys/Quasi_Borel_Spaces/Bayesian_Linear_Regression.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Bayesian_Linear_Regression.thy
	@@ -0,0 +1,603 @@
	+(* Title: Bayesian_Linear_Regression.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open> Bayesian Linear Regression \<close>
	+
	+theory Bayesian_Linear_Regression
	+ imports "Measure_as_QuasiBorel_Measure"
	+begin
	+
	+text \<open> We formalize the Bayesian linear regression presented in \cite{Heunen_2017} section VI.\<close>
	+subsubsection \<open> Prior \<close>
	+abbreviation "\<nu> \<equiv> density lborel (\<lambda>x. ennreal (normal_density 0 3 x))"
	+
	+interpretation \<nu>: standard_borel_prob_space \<nu>
	+ by(simp add: standard_borel_prob_space_def prob_space_normal_density)
	+
	+term "\<nu>.as_qbs_measure :: real qbs_prob_space"
	+definition prior :: "(real \<Rightarrow> real) qbs_prob_space" where
	+ "prior \<equiv> do { s \<leftarrow> \<nu>.as_qbs_measure ;
	+ b \<leftarrow> \<nu>.as_qbs_measure ;
	+ qbs_return (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) (\<lambda>r. s * r + b)}"
	+
	+lemma \<nu>_as_qbs_measure_eq:
	+ "\<nu>.as_qbs_measure = qbs_prob_space (\<real>\<^sub>Q,id,\<nu>)"
	+ by(simp add: \<nu>.as_qbs_measure_retract[of id id] distr_id' measure_to_qbs_cong_sets[OF sets_density] measure_to_qbs_cong_sets[OF sets_lborel])
	+
	+interpretation \<nu>_qp: pair_qbs_prob "\<real>\<^sub>Q" id \<nu> "\<real>\<^sub>Q" id \<nu>
	+ by(auto intro!: qbs_probI prob_space_normal_density simp: pair_qbs_prob_def)
	+
	+lemma \<nu>_as_qbs_measure_in_Pr:
	+ "\<nu>.as_qbs_measure \<in> monadP_qbs_Px \<real>\<^sub>Q"
	+ by(simp add: \<nu>_as_qbs_measure_eq \<nu>_qp.qp1.qbs_prob_space_in_Px)
	+
	+lemma sets_real_real_real[measurable_cong]:
	+ "sets (qbs_to_measure ((\<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q)) = sets ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
	+ by (metis pair_standard_borel.l_r_r_sets pair_standard_borel_def r_preserves_product real.standard_borel_axioms real_real.standard_borel_axioms)
	+
	+lemma lin_morphism:
	+ "(\<lambda>(s, b) r. s * r + b) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ apply(simp add: split_beta')
	+ apply(rule curry_preserves_morphisms[of "\<lambda>(x,r). fst x * r + snd x",simplified curry_def split_beta',simplified])
	+ by auto
	+
	+lemma lin_measurable[measurable]:
	+ "(\<lambda>(s, b) r. s * r + b) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M qbs_to_measure (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q)"
	+ using lin_morphism l_preserves_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q" "exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q"]
	+ by auto
	+
	+lemma prior_computation:
	+ "qbs_prob (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ "prior = qbs_prob_space (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ using \<nu>_qp.qbs_bind_bind_return[OF lin_morphism]
	+ by(simp_all add: prior_def \<nu>_as_qbs_measure_eq map_prod_def)
	+
	+text \<open> The following lemma corresponds to the equation (5). \<close>
	+lemma prior_measure:
	+ "qbs_prob_measure prior = distr (\<nu> \<Otimes>\<^sub>M \<nu>) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) (\<lambda>(s,b) r. s * r + b)"
	+ by(simp add: prior_computation(2) qbs_prob.qbs_prob_measure_computation[OF prior_computation(1)]) (simp add: distr_distr comp_def)
	+
	+lemma prior_in_space:
	+ "prior \<in> qbs_space (monadP_qbs (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q))"
	+ using qbs_prob.qbs_prob_space_in_Px[OF prior_computation(1)]
	+ by(simp add: prior_computation(2))
	+
	+
	+subsubsection \<open> Likelihood \<close>
	+abbreviation "d \<mu> x \<equiv> normal_density \<mu> (1/2) x"
	+
	+lemma d_positive : "0 < d \<mu> x"
	+ by(simp add: normal_density_pos)
	+
	+definition obs :: "(real \<Rightarrow> real) \<Rightarrow> ennreal" where
	+"obs f \<equiv> d (f 1) 2.5 * d (f 2) 3.8 * d (f 3) 4.5 * d (f 4) 6.2 * d (f 5) 8"
	+
	+lemma obs_morphism:
	+ "obs \<in> \<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q)"
	+ then have [measurable]:"(\<lambda>(x,y). \<alpha> x y) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M real_borel"
	+ by(auto simp: exp_qbs_Mx_def)
	+ show "obs \<circ> \<alpha> \<in> qbs_Mx \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ by(auto simp: comp_def obs_def normal_density_def)
	+qed
	+
	+lemma obs_measurable[measurable]:
	+ "obs \<in> qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q) \<rightarrow>\<^sub>M ennreal_borel"
	+ using obs_morphism by auto
	+
	+
	+subsubsection \<open> Posterior \<close>
	+lemma id_obs_morphism:
	+ "(\<lambda>f. (f,obs f)) \<in> \<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ by(rule qbs_morphism_tuple[OF qbs_morphism_ident' obs_morphism])
	+
	+lemma push_forward_measure_in_space:
	+ "monadP_qbs_Pf (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>f. (f,obs f)) prior \<in> qbs_space (monadP_qbs ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0))"
	+ by(rule qbs_morphismE(2)[OF monadP_qbs_Pf_morphism[OF id_obs_morphism] prior_in_space])
	+
	+lemma push_forward_measure_computation:
	+ "qbs_prob ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>l. (((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) l, ((obs \<circ> (\<lambda>(s, b) r. s * r + b)) \<circ> real_real.g) l)) (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ "monadP_qbs_Pf (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>f. (f, obs f)) prior = qbs_prob_space ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, (\<lambda>l. (((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) l, ((obs \<circ> (\<lambda>(s, b) r. s * r + b)) \<circ> real_real.g) l)), distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ using qbs_prob.monadP_qbs_Pf_computation[OF prior_computation id_obs_morphism] by(auto simp: comp_def)
	+
	+subsubsection \<open> Normalizer \<close>
	+text \<open> We use the unit space for an error. \<close>
	+definition norm_qbs_measure :: "('a \<times> ennreal) qbs_prob_space \<Rightarrow> 'a qbs_prob_space + unit" where
	+"norm_qbs_measure p \<equiv> (let (XR,\<alpha>\<beta>,\<nu>) = rep_qbs_prob_space p in
	+ if emeasure (density \<nu> (snd \<circ> \<alpha>\<beta>)) UNIV = 0 then Inr ()
	+ else if emeasure (density \<nu> (snd \<circ> \<alpha>\<beta>)) UNIV = \<infinity> then Inr ()
	+ else Inl (qbs_prob_space (map_qbs fst XR, fst \<circ> \<alpha>\<beta>, density \<nu> (\<lambda>r. snd (\<alpha>\<beta> r) / emeasure (density \<nu> (snd \<circ> \<alpha>\<beta>)) UNIV))))"
	+
	+
	+lemma norm_qbs_measure_qbs_prob:
	+ assumes "qbs_prob (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>r. (\<alpha> r, \<beta> r)) \<mu>"
	+ "emeasure (density \<mu> \<beta>) UNIV \<noteq> 0"
	+ and "emeasure (density \<mu> \<beta>) UNIV \<noteq> \<infinity>"
	+ shows "qbs_prob X \<alpha> (density \<mu> (\<lambda>r. (\<beta> r) / emeasure (density \<mu> \<beta>) UNIV))"
	+proof -
	+ interpret qp: qbs_prob "X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" "\<lambda>r. (\<alpha> r, \<beta> r)" \<mu>
	+ by fact
	+ have ha[simp]: "\<alpha> \<in> qbs_Mx X"
	+ and hb[measurable] :"\<beta> \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ using assms by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
	+ show ?thesis
	+ proof(rule qbs_probI)
	+ show "prob_space (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))"
	+ proof(rule prob_spaceI)
	+ show "emeasure (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)) (space (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))) = 1"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = emeasure (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)) UNIV"
	+ by simp
	+ also have "... = (\<integral>\<^sup>+r\<in>UNIV. (\<beta> r / emeasure (density \<mu> \<beta>) UNIV) \<partial>\<mu>)"
	+ by(intro emeasure_density) auto
	+ also have "... = integral\<^sup>N \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)"
	+ by simp
	+ also have "... = (integral\<^sup>N \<mu> \<beta>) / emeasure (density \<mu> \<beta>) UNIV"
	+ by(simp add: nn_integral_divide)
	+ also have "... = (\<integral>\<^sup>+r\<in>UNIV. \<beta> r \<partial>\<mu>) / emeasure (density \<mu> \<beta>) UNIV"
	+ by(simp add: emeasure_density)
	+ also have "... = 1"
	+ using assms(2,3) by(simp add: emeasure_density divide_eq_1_ennreal)
	+ finally show ?thesis .
	+ qed
	+ qed
	+ qed simp_all
	+qed
	+
	+lemma norm_qbs_measure_computation:
	+ assumes "qbs_prob (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>r. (\<alpha> r, \<beta> r)) \<mu>"
	+ shows "norm_qbs_measure (qbs_prob_space (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, (\<lambda>r. (\<alpha> r, \<beta> r)), \<mu>)) = (if emeasure (density \<mu> \<beta>) UNIV = 0 then Inr ()
	+ else if emeasure (density \<mu> \<beta>) UNIV = \<infinity> then Inr ()
	+ else Inl (qbs_prob_space (X, \<alpha>, density \<mu> (\<lambda>r. (\<beta> r) / emeasure (density \<mu> \<beta>) UNIV))))"
	+proof -
	+ interpret qp: qbs_prob "X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" "\<lambda>r. (\<alpha> r, \<beta> r)" \<mu>
	+ by fact
	+ have ha: "\<alpha> \<in> qbs_Mx X"
	+ and hb[measurable] :"\<beta> \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ using assms by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
	+ show ?thesis
	+ unfolding norm_qbs_measure_def
	+ proof(rule qp.in_Rep_induct)
	+ fix XR \<alpha>\<beta>' \<mu>'
	+ assume "(XR,\<alpha>\<beta>',\<mu>') \<in> Rep_qbs_prob_space (qbs_prob_space (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, \<lambda>r. (\<alpha> r, \<beta> r), \<mu>))"
	+ from qp.if_in_Rep[OF this]
	+ have h:"XR = X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ "qbs_prob XR \<alpha>\<beta>' \<mu>'"
	+ "qbs_prob_eq (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, \<lambda>r. (\<alpha> r, \<beta> r), \<mu>) (XR, \<alpha>\<beta>', \<mu>')"
	+ by auto
	+ have hint: "\<And>f. f \<in> X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<Longrightarrow> (\<integral>\<^sup>+ x. f (\<alpha> x, \<beta> x) \<partial>\<mu>) = (\<integral>\<^sup>+ x. f (\<alpha>\<beta>' x) \<partial>\<mu>')"
	+ using h(3)[simplified qbs_prob_eq_equiv14] by(simp add: qbs_prob_eq4_def)
	+ interpret qp': qbs_prob XR \<alpha>\<beta>' \<mu>'
	+ by fact
	+ have ha': "fst \<circ> \<alpha>\<beta>' \<in> qbs_Mx X" "(\<lambda>x. fst (\<alpha>\<beta>' x)) \<in> qbs_Mx X"
	+ and hb'[measurable]: "snd \<circ> \<alpha>\<beta>' \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "(\<lambda>x. snd (\<alpha>\<beta>' x)) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "(\<lambda>x. fst (\<alpha>\<beta>' x)) \<in> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
	+ using h by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
	+ have fstX: "map_qbs fst XR = X"
	+ by(simp add: h(1) pair_qbs_fst)
	+ have he:"emeasure (density \<mu> \<beta>) UNIV = emeasure (density \<mu>' (snd \<circ> \<alpha>\<beta>')) UNIV"
	+ using hint[OF snd_qbs_morphism] by(simp add: emeasure_density)
	+
	+ show "(let a = (XR,\<alpha>\<beta>',\<mu>') in case a of (XR, \<alpha>\<beta>, \<nu>') \<Rightarrow> if emeasure (density \<nu>' (snd \<circ> \<alpha>\<beta>)) UNIV = 0 then Inr ()
	+ else if emeasure (density \<nu>' (snd \<circ> \<alpha>\<beta>)) UNIV = \<infinity> then Inr ()
	+ else Inl (qbs_prob_space (map_qbs fst XR, fst \<circ> \<alpha>\<beta>, density \<nu>' (\<lambda>r. snd (\<alpha>\<beta> r) / emeasure (density \<nu>' (snd \<circ> \<alpha>\<beta>)) UNIV))))
	+ = (if emeasure (density \<mu> \<beta>) UNIV = 0 then Inr ()
	+ else if emeasure (density \<mu> \<beta>) UNIV = \<infinity> then Inr ()
	+ else Inl (qbs_prob_space (X, \<alpha>, density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))))"
	+ proof(auto simp: he[symmetric] fstX)
	+ assume het0:"emeasure (density \<mu> \<beta>) UNIV \<noteq> \<top>"
	+ "emeasure (density \<mu> \<beta>) UNIV \<noteq> 0"
	+ interpret pqp: pair_qbs_prob X "fst \<circ> \<alpha>\<beta>'" "density \<mu>' (\<lambda>r. snd (\<alpha>\<beta>' r) / emeasure (density \<mu> \<beta>) UNIV)" X \<alpha> "density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)"
	+ apply(auto intro!: norm_qbs_measure_qbs_prob simp: pair_qbs_prob_def assms het0)
	+ using het0
	+ by(auto intro!: norm_qbs_measure_qbs_prob[of X "fst \<circ> \<alpha>\<beta>'" "snd \<circ> \<alpha>\<beta>'",simplified,OF h(2)[simplified h(1)]] simp: he)
	+
	+ show "qbs_prob_space (X, fst \<circ> \<alpha>\<beta>', density \<mu>' (\<lambda>r. snd (\<alpha>\<beta>' r) / emeasure (density \<mu> \<beta>) UNIV)) = qbs_prob_space (X, \<alpha>, density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))"
	+ proof(rule pqp.qbs_prob_space_eq4)
	+ fix f
	+ assume hf[measurable]:"f \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel"
	+ show "(\<integral>\<^sup>+ x. f ((fst \<circ> \<alpha>\<beta>') x) \<partial>density \<mu>' (\<lambda>r. snd (\<alpha>\<beta>' r) / emeasure (density \<mu> \<beta>) UNIV)) = (\<integral>\<^sup>+ x. f (\<alpha> x) \<partial>density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = (\<integral>\<^sup>+ x. (\<lambda>xr. (snd xr) / emeasure (density \<mu> \<beta>) UNIV * f (fst xr)) (\<alpha>\<beta>' x) \<partial>\<mu>')"
	+ by(auto simp: nn_integral_density)
	+ also have "... = (\<integral>\<^sup>+ x. (\<lambda>xr. (snd xr) / emeasure (density \<mu> \<beta>) UNIV * f (fst xr)) (\<alpha> x,\<beta> x) \<partial>\<mu>)"
	+ by(intro hint[symmetric]) (auto intro!: pair_qbs_morphismI)
	+ also have "... = ?rhs"
	+ by(simp add: nn_integral_density)
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+ qed
	+ qed
	+qed
	+
	+lemma norm_qbs_measure_morphism:
	+ "norm_qbs_measure \<in> monadP_qbs (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) \<rightarrow>\<^sub>Q monadP_qbs X <+>\<^sub>Q 1\<^sub>Q"
	+proof(rule qbs_morphismI)
	+ fix \<gamma>
	+ assume "\<gamma> \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0))"
	+ then obtain \<alpha> g where hc:
	+ "\<alpha> \<in> qbs_Mx (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<gamma> = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, \<alpha>, g r))"
	+ using rep_monadP_qbs_MPx[of "\<gamma>" "(X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)"] by auto
	+ note [measurable] = hc(2) measurable_prob_algebraD[OF hc(2)]
	+ have setsg[measurable_cong]:"\<And>r. sets (g r) = sets real_borel"
	+ using measurable_space[OF hc(2)] by(simp add: space_prob_algebra)
	+ then have ha: "fst \<circ> \<alpha> \<in> qbs_Mx X"
	+ and hb[measurable]: "snd \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "(\<lambda>x. snd (\<alpha> x)) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "\<And>r. snd \<circ> \<alpha> \<in> g r \<rightarrow>\<^sub>M ennreal_borel" "\<And>r. (\<lambda>x. snd (\<alpha> x)) \<in> g r \<rightarrow>\<^sub>M ennreal_borel"
	+ using hc(1) by(auto simp add: pair_qbs_Mx_def measurable_cong_sets[OF setsg refl] comp_def)
	+ have emeas_den_meas[measurable]: "\<And>U. U \<in> sets real_borel \<Longrightarrow> (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) U) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ by(simp add: emeasure_density)
	+ have S_setsc:"UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>} \<in> sets real_borel"
	+ using measurable_sets_borel[OF emeas_den_meas] by simp
	+ have space_non_empty:"qbs_space (monadP_qbs X) \<noteq> {}"
	+ using ha qbs_empty_equiv monadP_qbs_empty_iff[of X] by auto
	+ have g_meas:"(\<lambda>r. if r \<in> (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>}) then density (g r) (\<lambda>l. ((snd \<circ> \<alpha>) l) / emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) else return real_borel 0) \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ proof -
	+ have H:"\<And>\<Omega> M N c f. \<Omega> \<inter> space M \<in> sets M \<Longrightarrow> c \<in> space N \<Longrightarrow>
	+ f \<in> measurable (restrict_space M \<Omega>) N \<Longrightarrow> (\<lambda>x. if x \<in> \<Omega> then f x else c) \<in> measurable M N"
	+ by(simp add: measurable_restrict_space_iff)
	+ show ?thesis
	+ proof(rule H)
	+ show "(UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0, \<infinity>}) \<inter> space real_borel \<in> sets real_borel"
	+ using S_setsc by simp
	+ next
	+ show "(\<lambda>r. density (g r) (\<lambda>l. ((snd \<circ> \<alpha>) l) / emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV)) \<in> restrict_space real_borel (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>}) \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G="sets real_borel"])
	+
	+ fix a
	+ assume "a \<in> space (restrict_space real_borel (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0, \<infinity>}))"
	+ then have 1:"(\<integral>\<^sup>+ x. snd (\<alpha> x) \<partial>g a) \<noteq> 0" "(\<integral>\<^sup>+ x. snd (\<alpha> x) \<partial>g a) \<noteq> \<infinity>"
	+ by(simp_all add: space_restrict_space emeasure_density)
	+ show "prob_space (density (g a) (\<lambda>l. (snd \<circ> \<alpha>) l / emeasure (density (g a) (snd \<circ> \<alpha>)) UNIV))"
	+ using 1
	+ by(auto intro!: prob_spaceI simp: emeasure_density nn_integral_divide divide_eq_1_ennreal)
	+ next
	+ fix U
	+ assume 1:"U \<in> sets real_borel"
	+ then have 2:"\<And>a. U \<in> sets (g a)" by auto
	+ show "(\<lambda>a. emeasure (density (g a) (\<lambda>l. (snd \<circ> \<alpha>) l / emeasure (density (g a) (snd \<circ> \<alpha>)) UNIV)) U) \<in> (restrict_space real_borel (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0, \<infinity>})) \<rightarrow>\<^sub>M ennreal_borel"
	+ using 1
	+ by(auto intro!: measurable_restrict_space1 nn_integral_measurable_subprob_algebra2[where N=real_borel] simp: emeasure_density emeasure_density[OF _ 2])
	+ qed (simp_all add: setsg sets.Int_stable sets.sigma_sets_eq[of real_borel,simplified])
	+ qed (simp add:space_prob_algebra prob_space_return)
	+ qed
	+
	+ show "norm_qbs_measure \<circ> \<gamma> \<in> qbs_Mx (monadP_qbs X <+>\<^sub>Q unit_quasi_borel)"
	+ apply(auto intro!: bexI[OF _ S_setsc] bexI[where x="(\<lambda>r. ())"] bexI[where x="\<lambda>r. qbs_prob_space (X,fst \<circ> \<alpha>,if r \<in> (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>}) then density (g r) (\<lambda>l. ((snd \<circ> \<alpha>) l) / emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) else return real_borel 0)"]
	+ simp: copair_qbs_Mx_equiv copair_qbs_Mx2_def space_non_empty[simplified])
	+ apply standard
	+ apply(simp add: hc(3) norm_qbs_measure_computation[of _ "fst \<circ> \<alpha>" "snd \<circ> \<alpha>",simplified,OF qbs_prob_MPx[OF hc(1,2)]])
	+ apply(simp add: monadP_qbs_MPx_def in_MPx_def)
	+ apply(auto intro!: bexI[OF _ ha] bexI[OF _ g_meas])
	+ done
	+qed
	+
	+
	+text \<open> The following is the semantics of the entire program. \<close>
	+definition program :: "(real \<Rightarrow> real) qbs_prob_space + unit" where
	+ "program \<equiv> norm_qbs_measure (monadP_qbs_Pf (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>f. (f,obs f)) prior)"
	+
	+lemma program_in_space:
	+ "program \<in> qbs_space (monadP_qbs (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) <+>\<^sub>Q 1\<^sub>Q)"
	+ unfolding program_def
	+ by(rule qbs_morphismE(2)[OF norm_qbs_measure_morphism push_forward_measure_in_space])
	+
	+
	+text \<open> We calculate the normalizing constant. \<close>
	+lemma complete_the_square:
	+ fixes a b c x :: real
	+ assumes "a \<noteq> 0"
	+ shows "ax\<^sup>2 + b x + c = a * (x + (b / (2a)))\<^sup>2 - ((b\<^sup>2 - 4 a * c)/(4*a))"
	+ using assms by(simp add: comm_semiring_1_class.power2_sum power2_eq_square[of "b / (2 * a)"] ring_class.ring_distribs(1) division_ring_class.diff_divide_distrib power2_eq_square[of b])
	+
	+lemma complete_the_square2':
	+ fixes a b c x :: real
	+ assumes "a \<noteq> 0"
	+ shows "ax\<^sup>2 - 2 b * x + c = a * (x - (b / a))\<^sup>2 - ((b\<^sup>2 - a*c)/a)"
	+ using complete_the_square[OF assms,where b="-2 * b" and x=x and c=c]
	+ by(simp add: division_ring_class.diff_divide_distrib assms)
	+
	+
	+lemma normal_density_mu_x_swap:
	+ "normal_density \<mu> \<sigma> x = normal_density x \<sigma> \<mu>"
	+ by(simp add: normal_density_def power2_commute)
	+
	+lemma normal_density_plus_shift:
	+ "normal_density \<mu> \<sigma> (x + y) = normal_density (\<mu> - x) \<sigma> y"
	+ by(simp add: normal_density_def add.commute diff_diff_eq2)
	+
	+lemma normal_density_times:
	+ assumes "\<sigma> > 0" "\<sigma>' > 0"
	+ shows "normal_density \<mu> \<sigma> x * normal_density \<mu>' \<sigma>' x = (1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * normal_density ((\<mu>\<sigma>'\<^sup>2 + \<mu>'\<sigma>\<^sup>2)/(\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) x"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have non0: "2\<sigma>\<^sup>2 \<noteq> 0" "2\<sigma>'\<^sup>2 \<noteq> 0" "\<sigma>\<^sup>2 + \<sigma>'\<^sup>2 \<noteq> 0"
	+ using assms by auto
	+ have "?lhs = exp (- ((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2))) * exp (- ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2)) "
	+ by(simp add: normal_density_def)
	+ also have "... = exp (- ((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2)) - ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2))"
	+ by(simp add: exp_add[of "- ((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2))" "- ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2))",simplified add_uminus_conv_diff])
	+ also have "... = exp (- (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) - (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2))"
	+ proof -
	+ have "((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2)) + ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2)) = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) + (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))"
	+ (is "?lhs' = ?rhs'")
	+ proof -
	+ have "?lhs' = (2 * ((x - \<mu>)\<^sup>2 * \<sigma>'\<^sup>2) + 2 * ((x - \<mu>')\<^sup>2 * \<sigma>\<^sup>2)) / (4 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
	+ by(simp add: field_class.add_frac_eq[OF non0(1,2)])
	+ also have "... = ((x - \<mu>)\<^sup>2 * \<sigma>'\<^sup>2 + (x - \<mu>')\<^sup>2 * \<sigma>\<^sup>2) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
	+ by(simp add: power2_eq_square division_ring_class.add_divide_distrib)
	+ also have "... = ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * x\<^sup>2 - 2 * (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) * x + (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
	+ by(simp add: comm_ring_1_class.power2_diff ring_class.left_diff_distrib semiring_class.distrib_right)
	+ also have "... = ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 - ((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)\<^sup>2 - (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
	+ by(simp only: complete_the_square2'[OF non0(3),of x "(\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)" "(\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)"])
	+ also have "... = ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)) - (((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)\<^sup>2 - (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
	+ by(simp add: division_ring_class.diff_divide_distrib)
	+ also have "... = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * ((\<sigma> * \<sigma>') / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) - (((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)\<^sup>2 - (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
	+ by(simp add: monoid_mult_class.power2_eq_square[of "(\<sigma> * \<sigma>') / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)"] ab_semigroup_mult_class.mult.commute[of "\<sigma>\<^sup>2 + \<sigma>'\<^sup>2"] )
	+ (simp add: monoid_mult_class.power2_eq_square[of \<sigma>] monoid_mult_class.power2_eq_square[of \<sigma>'])
	+ also have "... = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) - ((\<mu> * \<sigma>'\<^sup>2)\<^sup>2 + (\<mu>' * \<sigma>\<^sup>2)\<^sup>2 + 2 * (\<mu> * \<sigma>'\<^sup>2) * (\<mu>' * \<sigma>\<^sup>2) - (\<sigma>\<^sup>2 * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2) + \<sigma>\<^sup>2 * (\<mu>\<^sup>2 * \<sigma>'\<^sup>2) + (\<sigma>'\<^sup>2 * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2) + \<sigma>'\<^sup>2 * (\<mu>\<^sup>2 * \<sigma>'\<^sup>2)))) / ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)))"
	+ by(simp add: comm_semiring_1_class.power2_sum[of "\<mu> * \<sigma>'\<^sup>2" "\<mu>' * \<sigma>\<^sup>2"] semiring_class.distrib_right[of "\<sigma>\<^sup>2" "\<sigma>'\<^sup>2" "\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2"] )
	+ (simp add: semiring_class.distrib_left[of _ "\<mu>'\<^sup>2 * \<sigma>\<^sup>2 " "\<mu>\<^sup>2 * \<sigma>'\<^sup>2"])
	+ also have "... = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) + ((\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)\<mu>\<^sup>2 + (\<sigma>\<^sup>2 \<sigma>'\<^sup>2)\<mu>'\<^sup>2 - (\<sigma>\<^sup>2 \<sigma>'\<^sup>2) * 2 * (\<mu>\<mu>')) / ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)))"
	+ by(simp add: monoid_mult_class.power2_eq_square division_ring_class.minus_divide_left)
	+ also have "... = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) + (\<mu>\<^sup>2 + \<mu>'\<^sup>2 - 2 * (\<mu>\<mu>')) / ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) 2)"
	+ using assms by(simp add: division_ring_class.add_divide_distrib division_ring_class.diff_divide_distrib)
	+ also have "... = ?rhs'"
	+ by(simp add: comm_ring_1_class.power2_diff ab_semigroup_mult_class.mult.commute[of 2])
	+ finally show ?thesis .
	+ qed
	+ thus ?thesis
	+ by simp
	+ qed
	+ also have "... = (exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2))) * sqrt (2 * pi * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) * normal_density ((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) x"
	+ by(simp add: exp_add[of "- (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2)" "- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))",simplified] normal_density_def)
	+ also have "... = ?rhs"
	+ proof -
	+ have "exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2)) * sqrt (2 * pi * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)))"
	+ using assms by(simp add: real_sqrt_mult)
	+ thus ?thesis
	+ by simp
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+lemma normal_density_times':
	+ assumes "\<sigma> > 0" "\<sigma>' > 0"
	+ shows "a * normal_density \<mu> \<sigma> x * normal_density \<mu>' \<sigma>' x = a * (1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * normal_density ((\<mu>\<sigma>'\<^sup>2 + \<mu>'\<sigma>\<^sup>2)/(\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) x"
	+ using normal_density_times[OF assms,of \<mu> x \<mu>']
	+ by (simp add: mult.assoc)
	+
	+lemma normal_density_times_minusx:
	+ assumes "\<sigma> > 0" "\<sigma>' > 0" "a \<noteq> a'"
	+ shows "normal_density (\<mu> - ax) \<sigma> y normal_density (\<mu>' - a'x) \<sigma>' y = (1 / \<bar>a' - a\<bar>) normal_density ((\<mu>'- \<mu>)/(a'-a)) (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)/(a' - a)\<^sup>2)) x * normal_density (((\<mu> - ax)\<sigma>'\<^sup>2 + (\<mu>' - a'x)\<sigma>\<^sup>2)/(\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) y"
	+proof -
	+ have non0:"a' - a \<noteq> 0"
	+ using assms(3) by simp
	+ have "1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- (\<mu> - a * x - (\<mu>' - a' * x))\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) = 1 / \<bar>a' - a\<bar> * normal_density ((\<mu>' - \<mu>) / (a' - a)) (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) / (a' - a)\<^sup>2)) x"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- ((a' - a) * x - (\<mu>' - \<mu>))\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)))"
	+ by(simp add: ring_class.left_diff_distrib group_add_class.diff_diff_eq2 add.commute add_diff_eq)
	+ also have "... = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- ((a' - a)\<^sup>2 * (x - (\<mu>' - \<mu>)/(a' - a))\<^sup>2) / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)))"
	+ proof -
	+ have "((a' - a) * x - (\<mu>' - \<mu>))\<^sup>2 = ((a' - a) * (x - (\<mu>' - \<mu>)/(a' - a)))\<^sup>2"
	+ using non0 by(simp add: ring_class.right_diff_distrib[of "a'-a" x])
	+ also have "... = (a' - a)\<^sup>2 * (x - (\<mu>' - \<mu>)/(a' - a))\<^sup>2"
	+ by(simp add: monoid_mult_class.power2_eq_square)
	+ finally show ?thesis
	+ by simp
	+ qed
	+ also have "... = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * sqrt (2 * pi * (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)/(a' - a)\<^sup>2))\<^sup>2) * normal_density ((\<mu>' - \<mu>) / (a' - a)) (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) / (a' - a)\<^sup>2)) x"
	+ using non0 by (simp add: normal_density_def)
	+ also have "... = ?rhs"
	+ proof -
	+ have "1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * sqrt (2 * pi * (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)/(a' - a)\<^sup>2))\<^sup>2) = 1 / \<bar>a' - a\<bar>"
	+ using assms by(simp add: real_sqrt_divide[symmetric]) (simp add: real_sqrt_divide)
	+ thus ?thesis
	+ by simp
	+ qed
	+ finally show ?thesis .
	+ qed
	+ thus ?thesis
	+ by(simp add:normal_density_times[OF assms(1,2),of "\<mu> - ax" y "\<mu>' - a'x"])
	+qed
	+
	+text \<open> The following is the normalizing constant of the program. \<close>
	+abbreviation "C \<equiv> ennreal ((4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * (exp (- (1674761 / 1674025))))"
	+
	+lemma program_normalizing_constant:
	+ "emeasure (density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g)) UNIV = C"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have "?lhs = (\<integral>\<^sup>+ x. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) x \<partial> (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f))"
	+ by(simp add: emeasure_density)
	+ also have "... = (\<integral>\<^sup>+ z. (obs \<circ> (\<lambda>(s, b) r. s * r + b)) z \<partial>(\<nu> \<Otimes>\<^sub>M \<nu>))"
	+ using nn_integral_distr[of real_real.f "\<nu> \<Otimes>\<^sub>M \<nu>" real_borel "obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g",simplified]
	+ by(simp add: comp_def)
	+ also have "... = (\<integral>\<^sup>+ x. \<integral>\<^sup>+ y. (obs \<circ> (\<lambda>(s, b) r. s * r + b)) (x, y) \<partial>\<nu> \<partial>\<nu>)"
	+ by(simp only: \<nu>_qp.nn_integral_snd[where f="(obs \<circ> (\<lambda>(s, b) r. s * r + b))",simplified,symmetric])
	+ (simp add: \<nu>_qp.Fubini[where f="(obs \<circ> (\<lambda>(s, b) r. s * r + b))",simplified])
	+ also have "... = (\<integral>\<^sup>+ x. 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x \<partial>\<nu>)"
	+ proof(rule nn_integral_cong[where M=\<nu>,simplified])
	+ fix x
	+ have [measurable]: "(\<lambda>y. obs (\<lambda>r. x * r + y)) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ using measurable_Pair2[of "obs \<circ> (\<lambda>(s, b) r. s * r + b)"] by auto
	+ show "(\<integral>\<^sup>+ y. (obs \<circ> (\<lambda>(s, b) r. s * r + b)) (x, y) \<partial>\<nu>) = 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x"
	+ (is "?lhs' = ?rhs'")
	+ proof -
	+ have "?lhs' = (\<integral>\<^sup>+ y. ennreal (d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y) \<partial>lborel)"
	+ by(simp add: nn_integral_density obs_def normal_density_mu_x_swap[where x="5/2"] normal_density_mu_x_swap[where x="19/5"] normal_density_mu_x_swap[where x="9/2"] normal_density_mu_x_swap[where x="31/5"] normal_density_mu_x_swap[where x="8"] normal_density_plus_shift ab_semigroup_mult_class.mult.commute[of "ennreal (normal_density 0 3 _)"] ennreal_mult'[symmetric])
	+ also have "... = (\<integral>\<^sup>+ y. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y) \<partial>lborel)"
	+ proof(rule nn_integral_cong[where M=lborel,simplified])
	+ fix y
	+ have "d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y = 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y"
	+ (is "?lhs'' = ?rhs''")
	+ proof -
	+ have "?lhs'' = normal_density (13 / 10) (1 / sqrt 2) x * normal_density (63 / 20 - (3 / 2) * x) (sqrt 2 / 4) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y"
	+ proof -
	+ have "d (5 / 2 - x) y * d (19 / 5 - x * 2) y = normal_density (13 / 10) (1 / sqrt 2) x * normal_density (63 / 20 - (3 / 2) * x) (sqrt 2 / 4) y"
	+ by(simp add: normal_density_times_minusx[of "1/2" "1/2" 1 2 "5/2" x y "19/5",simplified ab_semigroup_mult_class.mult.commute[of 2 x],simplified])
	+ (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
	+ thus ?thesis
	+ by simp
	+ qed
	+ also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y"
	+ proof -
	+ have 1:"sqrt 2 * sqrt 8 / (8 * sqrt 3) = 1 / (2 * sqrt 3)"
	+ by(simp add: real_sqrt_divide[symmetric] real_sqrt_mult[symmetric])
	+ have "normal_density (63 / 20 - 3 / 2 * x) (sqrt 2 / 4) y * d (9 / 2 - x * 3) y = (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y"
	+ by(simp add: normal_density_times_minusx[of "sqrt 2 / 4" "1 / 2" "3 / 2" 3 "63 / 20" x y "9 / 2",simplified ab_semigroup_mult_class.mult.commute[of 3 x],simplified])
	+ (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib 1)
	+ thus ?thesis
	+ by simp
	+ qed
	+ also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (17 / 4 - (5 / 2) * x) (1 / 4) y * d (8 - x * 5) y * normal_density 0 3 y"
	+ proof -
	+ have 1:"normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y * d (31 / 5 - x * 4) y = (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (17 / 4 - 5 / 2 * x) (1 / 4) y"
	+ by(simp add: normal_density_times_minusx[of "1 / (2 * sqrt 3)" "1 / 2" 2 4 "18 / 5" x y "31 / 5",simplified ab_semigroup_mult_class.mult.commute[of 4 x],simplified])
	+ (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
	+ show ?thesis
	+ by(simp add: 1 mult.assoc)
	+ qed
	+ also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y * normal_density 0 3 y"
	+ proof -
	+ have 1:"normal_density (17 / 4 - 5 / 2 * x) (1 / 4) y * d (8 - x * 5) y = (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y"
	+ by(simp add: normal_density_times_minusx[of "1 / 4" "1 / 2" "5 / 2" 5 "17 / 4" x y 8,simplified ab_semigroup_mult_class.mult.commute[of 5 x],simplified])
	+ (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
	+ show ?thesis
	+ by(simp only: 1 mult.assoc)
	+ qed
	+ also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * (1 / 3) * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) ((3 / (2 * sqrt 5))/ sqrt (181 / 20)) y"
	+ proof -
	+ have "normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y * normal_density 0 3 y = (1 / 3) * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) ((3 / (2 * sqrt 5))/ sqrt (181 / 20)) y"
	+ by(simp add: normal_density_times_minusx[of "1 / (2 * sqrt 5)" 3 3 0 5 x y 0,simplified] monoid_mult_class.power2_eq_square)
	+ thus ?thesis
	+ by(simp only: mult.assoc)
	+ qed
	+ also have "... = ?rhs''"
	+ by simp
	+ finally show ?thesis .
	+ qed
	+ thus "ennreal( d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y) = ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y )"
	+ by simp
	+ qed
	+ also have "... = (\<integral>\<^sup>+ y. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y) * ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x) \<partial>lborel)"
	+ by(simp add: ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
	+ also have "... = (\<integral>\<^sup>+ y. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x) \<partial> (density lborel (\<lambda>y. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y))))"
	+ by(simp add: nn_integral_density[of "\<lambda>y. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y)" lborel,simplified,symmetric])
	+ also have "... = ?rhs'"
	+ by(simp add: prob_space.emeasure_space_1[OF prob_space_normal_density[of "3 / (2 * sqrt 5 * sqrt (181 / 20))" "20 / 181 * 9 * (5 - 3 * x)"],simplified])
	+ finally show ?thesis .
	+ qed
	+ qed
	+ also have "... = (\<integral>\<^sup>+ x. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x) \<partial>lborel)"
	+ by(simp add: nn_integral_density ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
	+ also have "... = (\<integral>\<^sup>+ x. (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x \<partial>lborel)"
	+ proof(rule nn_integral_cong[where M=lborel,simplified])
	+ fix x
	+ show "ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x) = ennreal ((4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x)"
	+ proof -
	+ have "2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x = (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x"
	+ (is "?lhs' = ?rhs'")
	+ proof -
	+ have "?lhs' = 2 / 45 * exp (- (3 / 25)) / sqrt (4 * pi / 3) * normal_density 1 (1 / sqrt 8) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
	+ by(simp add: normal_density_times' monoid_mult_class.power2_eq_square real_sqrt_mult[symmetric])
	+ also have "... = (2 / (15 * pi * sqrt 5)) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
	+ proof -
	+ have 1:"sqrt 8 * sqrt 12 * sqrt (5 / 24) = sqrt 20"
	+ by(simp add:real_sqrt_mult[symmetric])
	+ have 2:"sqrt (5 * pi / 12) * (45 * sqrt (4 * pi / 3)) = 15 * (pi * sqrt 5)"
	+ by(simp add: real_sqrt_mult[symmetric] real_sqrt_divide) (simp add: real_sqrt_mult real_sqrt_mult[of 4 5,simplified])
	+ have "2 / 45 * exp (- (3 / 25)) / sqrt (4 * pi / 3) * normal_density 1 (1 / sqrt 8) x * normal_density (13 / 10) (1 / sqrt 12) x = (6 / (45 * pi * sqrt 5)) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x"
	+ by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (3 / 25)" "- (27 / 125)",simplified,symmetric] 1 2)
	+ thus ?thesis
	+ by simp
	+ qed
	+ also have "... = 2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 / 20 ) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
	+ proof -
	+ have "2 / (15 * pi * sqrt 5) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x * normal_density (3 / 2) (1 / sqrt 20) x = 2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 /20) x"
	+ by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (42 / 125)" "- (64 / 125)",simplified,symmetric] real_sqrt_divide)
	+ (simp add: mult.commute)
	+ thus ?thesis
	+ by simp
	+ qed
	+ also have "... = ((4 * sqrt 5) / (5 * pi\<^sup>2 * sqrt 371)) * exp (- (5961 / 6625)) * normal_density (1786 / 1325) (sqrt 905 / (10 * sqrt 371)) x * normal_density 0 3 x"
	+ proof -
	+ have 1:"sqrt (371 * pi / 180) * (15 * pi * sqrt pi) = 5 * pi * pi * sqrt 371 / (2 * sqrt 5)"
	+ by(simp add: real_sqrt_mult real_sqrt_divide real_sqrt_mult[of 36 5,simplified])
	+ have 22:"10 = sqrt 5 * 2 * sqrt 5" by simp
	+ have 2:"sqrt 10 * sqrt (181 / 180) / (20 * sqrt (371 / 360)) = sqrt 905 / (10 * sqrt 371)"
	+ by(simp add: real_sqrt_mult real_sqrt_divide real_sqrt_mult[of 36 5,simplified] real_sqrt_mult[of 36 10,simplified] real_sqrt_mult[of 181 5,simplified])
	+ (simp add: mult.assoc[symmetric] 22)
	+ have "2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 / 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x = 4 * sqrt 5 / (5 * pi\<^sup>2 * sqrt 371) * exp (- (5961 / 6625)) * normal_density (1786 / 1325) (sqrt 905 / (10 * sqrt 371)) x"
	+ by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (106 / 125)" "- (343 / 6625)",simplified,symmetric] 1 2)
	+ (simp add: mult.assoc)
	+ thus ?thesis
	+ by simp
	+ qed
	+ also have "... = ?rhs'"
	+ proof -
	+ have 1: "4 * sqrt 5 / (sqrt (66961 * pi / 3710) * (5 * (pi * pi) * sqrt 371)) = 4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))"
	+ by(simp add: real_sqrt_mult[of 10 371,simplified] real_sqrt_mult[of 5 2,simplified] real_sqrt_divide monoid_mult_class.power2_eq_square mult.assoc)
	+ (simp add: mult.assoc[symmetric])
	+ have 2: "sqrt 905 * 3 / (10 * sqrt 371 * sqrt (66961 / 7420)) = 3 * sqrt 181 / sqrt 66961"
	+ by(simp add: real_sqrt_mult[of 371 20,simplified] real_sqrt_divide real_sqrt_mult[of 4 5,simplified] real_sqrt_mult[of 181 5,simplified] mult.commute[of _ 3])
	+ (simp add: mult.assoc)
	+ show ?thesis
	+ by(simp only: 1[symmetric]) (simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (5961 / 6625)" "- (44657144 / 443616625)",simplified,symmetric] 2)
	+ qed
	+ finally show ?thesis .
	+ qed
	+ thus ?thesis
	+ by simp
	+ qed
	+ qed
	+ also have "... = (\<integral>\<^sup>+ x. ennreal (normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x) * (ennreal (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025))) \<partial>lborel)"
	+ by(simp add: ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
	+ also have "... = (\<integral>\<^sup>+ x. (ennreal (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025))) \<partial>(density lborel (\<lambda>x. ennreal (normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x))))"
	+ by(simp add: nn_integral_density[symmetric])
	+ also have "... = ?rhs"
	+ by(simp add: prob_space.emeasure_space_1[OF prob_space_normal_density,simplified] ennreal_mult'[symmetric])
	+ finally show ?thesis .
	+qed
	+
	+text \<open> The program returns a probability measure, rather than error. \<close>
	+lemma program_result:
	+ "qbs_prob (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) (density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C))"
	+ "program = Inl (qbs_prob_space (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)))"
	+ using norm_qbs_measure_computation[OF push_forward_measure_computation(1),simplified program_normalizing_constant]
	+ norm_qbs_measure_qbs_prob[OF push_forward_measure_computation(1),simplified program_normalizing_constant]
	+ by(simp_all add: push_forward_measure_computation program_def comp_def)
	+
	+lemma program_inl:
	+ "program \<in> Inl ` (qbs_space (monadP_qbs (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q)))"
	+ using program_in_space[simplified program_result(2)]
	+ by(auto simp: image_def program_result(2))
	+
	+lemma program_result_measure:
	+ "qbs_prob_measure (qbs_prob_space (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)))
	+ = density (qbs_prob_measure prior) (\<lambda>k. obs k / C)"
	+ (is "?lhs = ?rhs")
	+proof -
	+ interpret qp: qbs_prob "exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q" "(\<lambda>(s, b) r. s * r + b) \<circ> real_real.g" "density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)"
	+ by(rule program_result(1))
	+ have "?lhs = distr (density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. obs (((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r) / C)) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g)"
	+ using qp.qbs_prob_measure_computation by simp
	+ also have "... = density (distr (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g)) (\<lambda>k. obs k / C)"
	+ by(simp add: density_distr)
	+ also have "... = ?rhs"
	+ by(simp add: distr_distr comp_def prior_measure)
	+ finally show ?thesis .
	+qed
	+
	+lemma program_result_measure':
	+ "qbs_prob_measure (qbs_prob_space (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)))
	+ = distr (density (\<nu> \<Otimes>\<^sub>M \<nu>) (\<lambda>(s,b). obs (\<lambda>r. s * r + b) / C)) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) (\<lambda>(s, b) r. s * r + b)"
	+ by(simp only: program_result_measure distr_distr) (simp add: density_distr split_beta' prior_measure)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Binary_CoProduct_QuasiBorel.thy b/thys/Quasi_Borel_Spaces/Binary_CoProduct_QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Binary_CoProduct_QuasiBorel.thy
	@@ -0,0 +1,625 @@
	+(* Title: Binary_CoProduct_QuasiBorel.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open>Coproduct Spaces\<close>
	+
	+theory Binary_CoProduct_QuasiBorel
	+ imports "Measure_QuasiBorel_Adjunction"
	+begin
	+
	+subsubsection \<open> Binary Coproduct Spaces \<close>
	+definition copair_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> (real => 'a + 'b) set" where
	+"copair_qbs_Mx X Y \<equiv>
	+ {g. \<exists> S \<in> sets real_borel.
	+ (S = {} \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
	+ (S = UNIV \<longrightarrow> (\<exists> \<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
	+ ((S \<noteq> {} \<and> S \<noteq> UNIV) \<longrightarrow>
	+ (\<exists> \<alpha>1\<in> qbs_Mx X.
	+ \<exists> \<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))))}"
	+
	+
	+definition copair_qbs :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a + 'b) quasi_borel" (infixr "<+>\<^sub>Q" 65) where
	+"copair_qbs X Y \<equiv> Abs_quasi_borel (qbs_space X <+> qbs_space Y, copair_qbs_Mx X Y)"
	+
	+
	+text \<open> The followin is an equivalent definition of @{term copair_qbs_Mx}. \<close>
	+definition copair_qbs_Mx2 :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> (real => 'a + 'b) set" where
	+"copair_qbs_Mx2 X Y \<equiv>
	+ {g. (if qbs_space X = {} \<and> qbs_space Y = {} then False
	+ else if qbs_space X \<noteq> {} \<and> qbs_space Y = {} then
	+ (\<exists>\<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r)))
	+ else if qbs_space X = {} \<and> qbs_space Y \<noteq> {} then
	+ (\<exists>\<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r)))
	+ else
	+ (\<exists>S \<in> sets real_borel. \<exists>\<alpha>1\<in> qbs_Mx X. \<exists>\<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))) }"
	+
	+lemma copair_qbs_Mx_equiv :"copair_qbs_Mx (X :: 'a quasi_borel) (Y :: 'b quasi_borel) = copair_qbs_Mx2 X Y"
	+proof(auto)
	+(* \<subseteq> *)
	+ fix g :: "real \<Rightarrow> 'a + 'b"
	+ assume "g \<in> copair_qbs_Mx X Y"
	+ then obtain S where hs:"S\<in> sets real_borel \<and>
	+ (S = {} \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
	+ (S = UNIV \<longrightarrow> (\<exists> \<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
	+ ((S \<noteq> {} \<and> S \<noteq> UNIV) \<longrightarrow>
	+ (\<exists> \<alpha>1\<in> qbs_Mx X.
	+ \<exists> \<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))))"
	+ by (auto simp add: copair_qbs_Mx_def)
	+ consider "S = {}" \| "S = UNIV" \| "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
	+ then show "g \<in> copair_qbs_Mx2 X Y"
	+ proof cases
	+ assume "S = {}"
	+ from hs this have "\<exists> \<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r))" by simp
	+ then obtain \<alpha>1 where h1:"\<alpha>1\<in> qbs_Mx X \<and> g = (\<lambda>r. Inl (\<alpha>1 r))" by auto
	+ have "qbs_space X \<noteq> {}"
	+ using qbs_empty_equiv h1
	+ by auto
	+ then have "(qbs_space X \<noteq> {} \<and> qbs_space Y = {}) \<or> (qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {})"
	+ by simp
	+ then show "g \<in> copair_qbs_Mx2 X Y"
	+ proof
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y = {}"
	+ then show "g \<in> copair_qbs_Mx2 X Y"
	+ by(simp add: copair_qbs_Mx2_def \<open>\<exists> \<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r))\<close>)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}"
	+ then obtain \<alpha>2 where "\<alpha>2 \<in> qbs_Mx Y" using qbs_empty_equiv by force
	+ define S' :: "real set"
	+ where "S' \<equiv> UNIV"
	+ define g' :: "real \<Rightarrow> 'a + 'b"
	+ where "g' \<equiv> (\<lambda>r::real. (if (r \<in> S') then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
	+ from \<open>qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}\<close> h1 \<open>\<alpha>2 \<in> qbs_Mx Y\<close>
	+ have "g' \<in> copair_qbs_Mx2 X Y"
	+ by(force simp add: S'_def g'_def copair_qbs_Mx2_def)
	+ moreover have "g = g'"
	+ using h1 by(simp add: g'_def S'_def)
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+ next
	+ assume "S = UNIV"
	+ from hs this have "\<exists> \<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r))" by simp
	+ then obtain \<alpha>2 where h2:"\<alpha>2\<in> qbs_Mx Y \<and> g = (\<lambda>r. Inr (\<alpha>2 r))" by auto
	+ have "qbs_space Y \<noteq> {}"
	+ using qbs_empty_equiv h2
	+ by auto
	+ then have "(qbs_space X = {} \<and> qbs_space Y \<noteq> {}) \<or> (qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {})"
	+ by simp
	+ then show "g \<in> copair_qbs_Mx2 X Y"
	+ proof
	+ assume "qbs_space X = {} \<and> qbs_space Y \<noteq> {}"
	+ then show ?thesis
	+ by(simp add: copair_qbs_Mx2_def \<open>\<exists> \<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r))\<close>)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}"
	+ then obtain \<alpha>1 where "\<alpha>1 \<in> qbs_Mx X" using qbs_empty_equiv by force
	+ define S' :: "real set"
	+ where "S' \<equiv> {}"
	+ define g' :: "real \<Rightarrow> 'a + 'b"
	+ where "g' \<equiv> (\<lambda>r::real. (if (r \<in> S') then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
	+ from \<open>qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}\<close> h2 \<open>\<alpha>1 \<in> qbs_Mx X\<close>
	+ have "g' \<in> copair_qbs_Mx2 X Y"
	+ by(force simp add: S'_def g'_def copair_qbs_Mx2_def)
	+ moreover have "g = g'"
	+ using h2 by(simp add: g'_def S'_def)
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+ next
	+ assume "S \<noteq> {} \<and> S \<noteq> UNIV"
	+ then have
	+ h: "\<exists> \<alpha>1\<in> qbs_Mx X.
	+ \<exists> \<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
	+ using hs by simp
	+ then have "qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}"
	+ by (metis empty_iff qbs_empty_equiv)
	+ thus ?thesis
	+ using hs h by(auto simp add: copair_qbs_Mx2_def)
	+ qed
	+
	+(* \<supseteq> *)
	+next
	+ fix g :: "real \<Rightarrow> 'a + 'b"
	+ assume "g \<in> copair_qbs_Mx2 X Y"
	+ then have
	+ h: "if qbs_space X = {} \<and> qbs_space Y = {} then False
	+ else if qbs_space X \<noteq> {} \<and> qbs_space Y = {} then
	+ (\<exists>\<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r)))
	+ else if qbs_space X = {} \<and> qbs_space Y \<noteq> {} then
	+ (\<exists>\<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r)))
	+ else
	+ (\<exists>S \<in> sets real_borel. \<exists>\<alpha>1\<in> qbs_Mx X. \<exists>\<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))"
	+ by(simp add: copair_qbs_Mx2_def)
	+ consider "(qbs_space X = {} \<and> qbs_space Y = {})" \|
	+ "(qbs_space X \<noteq> {} \<and> qbs_space Y = {})" \|
	+ "(qbs_space X = {} \<and> qbs_space Y \<noteq> {})" \|
	+ "(qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {})" by auto
	+ then show "g \<in> copair_qbs_Mx X Y"
	+ proof cases
	+ assume "qbs_space X = {} \<and> qbs_space Y = {}"
	+ then show ?thesis
	+ using \<open>g \<in> copair_qbs_Mx2 X Y\<close> by(simp add: copair_qbs_Mx2_def)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y = {}"
	+ from h this have "\<exists>\<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r))" by simp
	+ thus ?thesis
	+ by(auto simp add: copair_qbs_Mx_def)
	+ next
	+ assume "qbs_space X = {} \<and> qbs_space Y \<noteq> {}"
	+ from h this have "\<exists>\<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r))" by simp
	+ thus ?thesis
	+ unfolding copair_qbs_Mx_def
	+ by(force simp add: copair_qbs_Mx_def)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}"
	+ from h this have
	+ "\<exists>S \<in> sets real_borel. \<exists>\<alpha>1\<in> qbs_Mx X. \<exists>\<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))" by simp
	+ then show ?thesis
	+ proof(auto simp add: exE)
	+ fix S
	+ fix \<alpha>1
	+ fix \<alpha>2
	+ assume "S \<in> sets real_borel"
	+ "\<alpha>1 \<in> qbs_Mx X"
	+ "\<alpha>2 \<in> qbs_Mx Y"
	+ "g = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r)
	+ else Inr (\<alpha>2 r))"
	+ consider "S = {}" \| "S = UNIV" \| "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
	+ then show "(\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)) \<in> copair_qbs_Mx X Y"
	+ proof cases
	+ assume "S = {}"
	+ then have [simp]: "(\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)) = (\<lambda>r. Inr (\<alpha>2 r))"
	+ by simp
	+ have "UNIV \<in> sets real_borel" by simp
	+ then show ?thesis
	+ using \<open>\<alpha>2 \<in> qbs_Mx Y\<close> unfolding copair_qbs_Mx_def
	+ by(auto intro! : bexI[where x=UNIV])
	+ next
	+ assume "S = UNIV"
	+ then have "(\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)) = (\<lambda>r. Inl (\<alpha>1 r))"
	+ by simp
	+ then show ?thesis
	+ using \<open>\<alpha>1 \<in> qbs_Mx X\<close>
	+ by(auto simp add: copair_qbs_Mx_def)
	+ next
	+ assume "S \<noteq> {} \<and> S \<noteq> UNIV"
	+ then show ?thesis
	+ using \<open>S \<in> sets real_borel\<close> \<open>\<alpha>1 \<in> qbs_Mx X\<close> \<open>\<alpha>2 \<in> qbs_Mx Y\<close>
	+ by(auto simp add: copair_qbs_Mx_def)
	+ qed
	+ qed
	+ qed
	+qed
	+
	+
	+lemma copair_qbs_f[simp]: "copair_qbs_Mx X Y \<subseteq> UNIV \<rightarrow> qbs_space X <+> qbs_space Y"
	+proof
	+ fix g
	+ assume "g \<in> copair_qbs_Mx X Y"
	+ then obtain S where hs:"S\<in> sets real_borel \<and>
	+ (S = {} \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. g = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
	+ (S = UNIV \<longrightarrow> (\<exists> \<alpha>2\<in> qbs_Mx Y. g = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
	+ ((S \<noteq> {} \<and> S \<noteq> UNIV) \<longrightarrow>
	+ (\<exists> \<alpha>1\<in> qbs_Mx X.
	+ \<exists> \<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))))"
	+ by (auto simp add: copair_qbs_Mx_def)
	+ consider "S = {}" \| "S = UNIV" \| "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
	+ then show "g \<in> UNIV \<rightarrow> qbs_space X <+> qbs_space Y"
	+ proof cases
	+ assume "S = {}"
	+ then show ?thesis
	+ using hs by auto
	+ next
	+ assume "S = UNIV"
	+ then show ?thesis
	+ using hs by auto
	+ next
	+ assume "S \<noteq> {} \<and> S \<noteq> UNIV"
	+ then have "\<exists> \<alpha>1\<in> qbs_Mx X. \<exists> \<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))" using hs by simp
	+ then show ?thesis
	+ by(auto simp add: exE)
	+ qed
	+qed
	+
	+lemma copair_qbs_closed1: "qbs_closed1 (copair_qbs_Mx X Y)"
	+proof(auto simp add: qbs_closed1_def)
	+ fix g
	+ fix f
	+ assume "g \<in> copair_qbs_Mx X Y"
	+ "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ then have "g \<in> copair_qbs_Mx2 X Y" using copair_qbs_Mx_equiv by auto
	+ consider "(qbs_space X = {} \<and> qbs_space Y = {})" \|
	+ "(qbs_space X \<noteq> {} \<and> qbs_space Y = {})" \|
	+ "(qbs_space X = {} \<and> qbs_space Y \<noteq> {})" \|
	+ "(qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {})" by auto
	+ then have "g \<circ> f \<in> copair_qbs_Mx2 X Y"
	+ proof cases
	+ assume "qbs_space X = {} \<and> qbs_space Y = {}"
	+ then show ?thesis
	+ using \<open>g \<in> copair_qbs_Mx2 X Y\<close> qbs_empty_equiv by(simp add: copair_qbs_Mx2_def)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y = {}"
	+ then obtain \<alpha>1 where h1:"\<alpha>1\<in> qbs_Mx X \<and> g = (\<lambda>r. Inl (\<alpha>1 r))"
	+ using \<open>g \<in> copair_qbs_Mx2 X Y\<close> by(auto simp add: copair_qbs_Mx2_def)
	+ then have "\<alpha>1 \<circ> f \<in> qbs_Mx X"
	+ using \<open>f \<in> real_borel \<rightarrow>\<^sub>M real_borel\<close> by auto
	+ moreover have "g \<circ> f = (\<lambda>r. Inl ((\<alpha>1 \<circ> f) r))"
	+ using h1 by auto
	+ ultimately show ?thesis
	+ using \<open>qbs_space X \<noteq> {} \<and> qbs_space Y = {}\<close> by(force simp add: copair_qbs_Mx2_def)
	+ next
	+ assume "(qbs_space X = {} \<and> qbs_space Y \<noteq> {})"
	+ then obtain \<alpha>2 where h2:"\<alpha>2\<in> qbs_Mx Y \<and> g = (\<lambda>r. Inr (\<alpha>2 r))"
	+ using \<open>g \<in> copair_qbs_Mx2 X Y\<close> by(auto simp add: copair_qbs_Mx2_def)
	+ then have "\<alpha>2 \<circ> f \<in> qbs_Mx Y"
	+ using \<open>f \<in> real_borel \<rightarrow>\<^sub>M real_borel\<close> by auto
	+ moreover have "g \<circ> f = (\<lambda>r. Inr ((\<alpha>2 \<circ> f) r))"
	+ using h2 by auto
	+ ultimately show ?thesis
	+ using \<open>(qbs_space X = {} \<and> qbs_space Y \<noteq> {})\<close> by(force simp add: copair_qbs_Mx2_def)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}"
	+ then have "\<exists>S \<in> sets real_borel. \<exists>\<alpha>1\<in> qbs_Mx X. \<exists>\<alpha>2\<in> qbs_Mx Y.
	+ g = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
	+ using \<open>g \<in> copair_qbs_Mx2 X Y\<close> by(simp add: copair_qbs_Mx2_def)
	+ then show ?thesis
	+ proof(auto simp add: exE)
	+ fix S
	+ fix \<alpha>1
	+ fix \<alpha>2
	+ assume "S \<in> sets real_borel"
	+ "\<alpha>1\<in> qbs_Mx X"
	+ "\<alpha>2 \<in> qbs_Mx Y"
	+ "g = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))"
	+ have "f -` S \<in> sets real_borel"
	+ using \<open>f \<in> real_borel \<rightarrow>\<^sub>M real_borel\<close> \<open>S \<in> sets real_borel\<close>
	+ by (simp add: measurable_sets_borel)
	+ moreover have "\<alpha>1 \<circ> f \<in> qbs_Mx X"
	+ using \<open>\<alpha>1\<in> qbs_Mx X\<close> \<open>f \<in> real_borel \<rightarrow>\<^sub>M real_borel\<close> qbs_decomp
	+ by(auto simp add: qbs_closed1_def)
	+ moreover have "\<alpha>2 \<circ> f \<in> qbs_Mx Y"
	+ using \<open>\<alpha>2\<in> qbs_Mx Y\<close> \<open>f \<in> real_borel \<rightarrow>\<^sub>M real_borel\<close> qbs_decomp
	+ by(auto simp add: qbs_closed1_def)
	+ moreover have
	+ "(\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)) \<circ> f = (\<lambda>r. if r \<in> f -` S then Inl ((\<alpha>1 \<circ> f) r) else Inr ((\<alpha>2 \<circ> f) r))"
	+ by auto
	+ ultimately show "(\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)) \<circ> f \<in> copair_qbs_Mx2 X Y"
	+ using \<open>qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}\<close> by(force simp add: copair_qbs_Mx2_def)
	+ qed
	+ qed
	+ thus "g \<circ> f \<in> copair_qbs_Mx X Y"
	+ using copair_qbs_Mx_equiv by auto
	+qed
	+
	+lemma copair_qbs_closed2: "qbs_closed2 (qbs_space X <+> qbs_space Y) (copair_qbs_Mx X Y)"
	+proof(auto simp add: qbs_closed2_def)
	+ fix x
	+ assume "x \<in> qbs_space X"
	+ define \<alpha>1 :: "real \<Rightarrow> _" where "\<alpha>1 \<equiv> (\<lambda>r. x)"
	+ have "\<alpha>1 \<in> qbs_Mx X" using \<open>x \<in> qbs_space X\<close> qbs_decomp
	+ by(force simp add: qbs_closed2_def \<alpha>1_def )
	+ moreover have "(\<lambda>r. Inl x) = (\<lambda>l. Inl (\<alpha>1 l))" by (simp add: \<alpha>1_def)
	+ moreover have "{} \<in> sets real_borel" by auto
	+ ultimately show "(\<lambda>r. Inl x) \<in> copair_qbs_Mx X Y"
	+ by(auto simp add: copair_qbs_Mx_def)
	+next
	+ fix y
	+ assume "y \<in> qbs_space Y"
	+ define \<alpha>2 :: "real \<Rightarrow> _" where "\<alpha>2 \<equiv> (\<lambda>r. y)"
	+ have "\<alpha>2 \<in> qbs_Mx Y" using \<open>y \<in> qbs_space Y\<close> qbs_decomp
	+ by(force simp add: qbs_closed2_def \<alpha>2_def )
	+ moreover have "(\<lambda>r. Inr y) = (\<lambda>l. Inr (\<alpha>2 l))" by (simp add: \<alpha>2_def)
	+ moreover have "UNIV \<in> sets real_borel" by auto
	+ ultimately show "(\<lambda>r. Inr y) \<in> copair_qbs_Mx X Y"
	+ unfolding copair_qbs_Mx_def
	+ by(auto intro!: bexI[where x=UNIV])
	+qed
	+
	+lemma copair_qbs_closed3: "qbs_closed3 (copair_qbs_Mx X Y)"
	+proof(auto simp add: qbs_closed3_def)
	+ fix P :: "real \<Rightarrow> nat"
	+ fix Fi :: "nat \<Rightarrow> real \<Rightarrow>_ + _"
	+ assume "\<forall>i. P -` {i} \<in> sets real_borel"
	+ "\<forall>i. Fi i \<in> copair_qbs_Mx X Y"
	+ then have "\<forall>i. Fi i \<in> copair_qbs_Mx2 X Y" using copair_qbs_Mx_equiv by blast
	+ consider "(qbs_space X = {} \<and> qbs_space Y = {})" \|
	+ "(qbs_space X \<noteq> {} \<and> qbs_space Y = {})" \|
	+ "(qbs_space X = {} \<and> qbs_space Y \<noteq> {})" \|
	+ "(qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {})" by auto
	+ then have "(\<lambda>r. Fi (P r) r) \<in> copair_qbs_Mx2 X Y"
	+ proof cases
	+ assume "qbs_space X = {} \<and> qbs_space Y = {}"
	+ then show ?thesis
	+ using \<open>\<forall>i. Fi i \<in> copair_qbs_Mx2 X Y\<close> qbs_empty_equiv
	+ by(simp add: copair_qbs_Mx2_def)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y = {}"
	+ then have "\<forall>i. \<exists>\<alpha>i. \<alpha>i \<in> qbs_Mx X \<and> Fi i = (\<lambda>r. Inl (\<alpha>i r))"
	+ using \<open>\<forall>i. Fi i \<in> copair_qbs_Mx2 X Y\<close> by(auto simp add: copair_qbs_Mx2_def)
	+ then have "\<exists>\<alpha>1. \<forall>i. \<alpha>1 i \<in> qbs_Mx X \<and> Fi i = (\<lambda>r. Inl (\<alpha>1 i r))"
	+ by(rule choice)
	+ then obtain \<alpha>1 :: "nat \<Rightarrow> real \<Rightarrow> _"
	+ where h1: "\<forall>i. \<alpha>1 i \<in> qbs_Mx X \<and> Fi i = (\<lambda>r. Inl (\<alpha>1 i r))" by auto
	+ define \<beta> :: "real \<Rightarrow> _"
	+ where "\<beta> \<equiv> (\<lambda>r. \<alpha>1 (P r) r)"
	+ from \<open>\<forall>i. P -` {i} \<in> sets real_borel\<close> h1
	+ have "\<beta> \<in> qbs_Mx X"
	+ by (simp add: \<beta>_def)
	+ moreover have "(\<lambda>r. Fi (P r) r) = (\<lambda>r. Inl (\<beta> r))"
	+ using h1 by(simp add: \<beta>_def)
	+ ultimately show ?thesis
	+ using \<open>qbs_space X \<noteq> {} \<and> qbs_space Y = {}\<close> by (auto simp add: copair_qbs_Mx2_def)
	+ next
	+ assume "qbs_space X = {} \<and> qbs_space Y \<noteq> {}"
	+ then have "\<forall>i. \<exists>\<alpha>i. \<alpha>i \<in> qbs_Mx Y \<and> Fi i = (\<lambda>r. Inr (\<alpha>i r))"
	+ using \<open>\<forall>i. Fi i \<in> copair_qbs_Mx2 X Y\<close> by(auto simp add: copair_qbs_Mx2_def)
	+ then have "\<exists>\<alpha>2. \<forall>i. \<alpha>2 i \<in> qbs_Mx Y \<and> Fi i = (\<lambda>r. Inr (\<alpha>2 i r))"
	+ by(rule choice)
	+ then obtain \<alpha>2 :: "nat \<Rightarrow> real \<Rightarrow> _"
	+ where h2: "\<forall>i. \<alpha>2 i \<in> qbs_Mx Y \<and> Fi i = (\<lambda>r. Inr (\<alpha>2 i r))" by auto
	+ define \<beta> :: "real \<Rightarrow> _"
	+ where "\<beta> \<equiv> (\<lambda>r. \<alpha>2 (P r) r)"
	+ from \<open>\<forall>i. P -` {i} \<in> sets real_borel\<close> h2 qbs_decomp
	+ have "\<beta> \<in> qbs_Mx Y"
	+ by(simp add: \<beta>_def)
	+ moreover have "(\<lambda>r. Fi (P r) r) = (\<lambda>r. Inr (\<beta> r))"
	+ using h2 by(simp add: \<beta>_def)
	+ ultimately show ?thesis
	+ using \<open>qbs_space X = {} \<and> qbs_space Y \<noteq> {}\<close> by (auto simp add: copair_qbs_Mx2_def)
	+ next
	+ assume "qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}"
	+ then have "\<forall>i. \<exists>Si. Si \<in> sets real_borel \<and> (\<exists>\<alpha>1i\<in> qbs_Mx X. \<exists>\<alpha>2i\<in> qbs_Mx Y.
	+ Fi i = (\<lambda>r::real. (if (r \<in> Si) then Inl (\<alpha>1i r) else Inr (\<alpha>2i r))))"
	+ using \<open>\<forall>i. Fi i \<in> copair_qbs_Mx2 X Y\<close> by (auto simp add: copair_qbs_Mx2_def)
	+ then have "\<exists>S. \<forall>i. S i \<in> sets real_borel \<and> (\<exists>\<alpha>1i\<in> qbs_Mx X. \<exists>\<alpha>2i\<in> qbs_Mx Y.
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1i r) else Inr (\<alpha>2i r))))"
	+ by(rule choice)
	+ then obtain S :: "nat \<Rightarrow> real set"
	+ where hs :"\<forall>i. S i \<in> sets real_borel \<and> (\<exists>\<alpha>1i\<in> qbs_Mx X. \<exists>\<alpha>2i\<in> qbs_Mx Y.
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1i r) else Inr (\<alpha>2i r))))"
	+ by auto
	+ then have "\<forall>i. \<exists>\<alpha>1i. \<alpha>1i \<in> qbs_Mx X \<and> (\<exists>\<alpha>2i\<in> qbs_Mx Y.
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1i r) else Inr (\<alpha>2i r))))"
	+ by blast
	+ then have "\<exists>\<alpha>1. \<forall>i. \<alpha>1 i \<in> qbs_Mx X \<and> (\<exists>\<alpha>2i\<in> qbs_Mx Y.
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1 i r) else Inr (\<alpha>2i r))))"
	+ by(rule choice)
	+ then obtain \<alpha>1
	+ where h1: "\<forall>i. \<alpha>1 i \<in> qbs_Mx X \<and> (\<exists>\<alpha>2i\<in> qbs_Mx Y.
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1 i r) else Inr (\<alpha>2i r))))"
	+ by auto
	+ define \<beta>1 :: "real \<Rightarrow> _"
	+ where "\<beta>1 \<equiv> (\<lambda>r. \<alpha>1 (P r) r)"
	+ from \<open>\<forall>i. P -` {i} \<in> sets real_borel\<close> h1 qbs_decomp
	+ have "\<beta>1 \<in> qbs_Mx X"
	+ by(simp add: \<beta>1_def)
	+ from h1 have "\<forall>i. \<exists>\<alpha>2i. \<alpha>2i\<in> qbs_Mx Y \<and>
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1 i r) else Inr (\<alpha>2i r)))"
	+ by auto
	+ then have "\<exists>\<alpha>2. \<forall>i. \<alpha>2 i\<in> qbs_Mx Y \<and>
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1 i r) else Inr (\<alpha>2 i r)))"
	+ by(rule choice)
	+ then obtain \<alpha>2
	+ where h2: "\<forall>i. \<alpha>2 i\<in> qbs_Mx Y \<and>
	+ Fi i = (\<lambda>r::real. (if (r \<in> S i) then Inl (\<alpha>1 i r) else Inr (\<alpha>2 i r)))"
	+ by auto
	+ define \<beta>2 :: "real \<Rightarrow> _"
	+ where "\<beta>2 \<equiv> (\<lambda>r. \<alpha>2 (P r) r)"
	+ from \<open>\<forall>i. P -` {i} \<in> sets real_borel\<close> h2 qbs_decomp
	+ have "\<beta>2 \<in> qbs_Mx Y"
	+ by(simp add: \<beta>2_def)
	+ define A :: "nat \<Rightarrow> real set"
	+ where "A \<equiv> (\<lambda>i. S i \<inter> P -` {i})"
	+ have "\<forall>i. A i \<in> sets real_borel"
	+ using A_def \<open>\<forall>i. P -` {i} \<in> sets real_borel\<close> hs by blast
	+ define S' :: "real set"
	+ where "S' \<equiv> {r. r \<in> S (P r)}"
	+ have "S' = (\<Union>i::nat. A i)"
	+ by(auto simp add: S'_def A_def)
	+ hence "S' \<in> sets real_borel"
	+ using \<open>\<forall>i. A i \<in> sets real_borel\<close> by auto
	+ from h2 have "(\<lambda>r. Fi (P r) r) = (\<lambda>r. (if r \<in> S' then Inl (\<beta>1 r)
	+ else Inr (\<beta>2 r)))"
	+ by(auto simp add: \<beta>1_def \<beta>2_def S'_def)
	+ thus "(\<lambda>r. Fi (P r) r) \<in> copair_qbs_Mx2 X Y"
	+ using \<open>qbs_space X \<noteq> {} \<and> qbs_space Y \<noteq> {}\<close> \<open>S' \<in> sets real_borel\<close> \<open>\<beta>1 \<in> qbs_Mx X\<close> \<open>\<beta>2 \<in> qbs_Mx Y\<close>
	+ by(auto simp add: copair_qbs_Mx2_def)
	+ qed
	+ thus "(\<lambda>r. Fi (P r) r) \<in> copair_qbs_Mx X Y"
	+ using copair_qbs_Mx_equiv by auto
	+qed
	+
	+lemma copair_qbs_correct: "Rep_quasi_borel (copair_qbs X Y) = (qbs_space X <+> qbs_space Y, copair_qbs_Mx X Y)"
	+ unfolding copair_qbs_def
	+ by(auto intro!: Abs_quasi_borel_inverse copair_qbs_f simp: copair_qbs_closed2 copair_qbs_closed1 copair_qbs_closed3)
	+
	+lemma copair_qbs_space[simp]: "qbs_space (copair_qbs X Y) = qbs_space X <+> qbs_space Y"
	+ by(simp add: qbs_space_def copair_qbs_correct)
	+
	+lemma copair_qbs_Mx[simp]: "qbs_Mx (copair_qbs X Y) = copair_qbs_Mx X Y"
	+ by(simp add: qbs_Mx_def copair_qbs_correct)
	+
	+
	+lemma Inl_qbs_morphism:
	+ "Inl \<in> X \<rightarrow>\<^sub>Q X <+>\<^sub>Q Y"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx X"
	+ moreover have "Inl \<circ> \<alpha> = (\<lambda>r. Inl (\<alpha> r))" by auto
	+ ultimately show "Inl \<circ> \<alpha> \<in> qbs_Mx (X <+>\<^sub>Q Y)"
	+ by(auto simp add: copair_qbs_Mx_def)
	+qed
	+
	+lemma Inr_qbs_morphism:
	+ "Inr \<in> Y \<rightarrow>\<^sub>Q X <+>\<^sub>Q Y"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx Y"
	+ moreover have "Inr \<circ> \<alpha> = (\<lambda>r. Inr (\<alpha> r))" by auto
	+ ultimately show "Inr \<circ> \<alpha> \<in> qbs_Mx (X <+>\<^sub>Q Y)"
	+ by(auto intro!: bexI[where x=UNIV] simp add: copair_qbs_Mx_def)
	+qed
	+
	+lemma case_sum_preserves_morphisms:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Z"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q Z"
	+ shows "case_sum f g \<in> X <+>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+proof(rule qbs_morphismI;auto)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> copair_qbs_Mx X Y"
	+ then obtain S where hs:"S\<in> sets real_borel \<and>
	+ (S = {} \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. \<alpha> = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
	+ (S = UNIV \<longrightarrow> (\<exists> \<alpha>2\<in> qbs_Mx Y. \<alpha> = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
	+ ((S \<noteq> {} \<and> S \<noteq> UNIV) \<longrightarrow>
	+ (\<exists> \<alpha>1\<in> qbs_Mx X.
	+ \<exists> \<alpha>2\<in> qbs_Mx Y.
	+ \<alpha> = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))))"
	+ by (auto simp add: copair_qbs_Mx_def)
	+ consider "S = {}" \| "S = UNIV" \| "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
	+ then show "case_sum f g \<circ> \<alpha> \<in> qbs_Mx Z"
	+ proof cases
	+ assume "S = {}"
	+ then obtain \<alpha>1 where h1: "\<alpha>1\<in> qbs_Mx X \<and> \<alpha> = (\<lambda>r. Inl (\<alpha>1 r))"
	+ using hs by auto
	+ then have "f \<circ> \<alpha>1 \<in> qbs_Mx Z"
	+ using assms by(auto simp add: qbs_morphism_def)
	+ moreover have "case_sum f g \<circ> \<alpha> = f \<circ> \<alpha>1"
	+ using h1 by auto
	+ ultimately show ?thesis by simp
	+ next
	+ assume "S = UNIV"
	+ then obtain \<alpha>2 where h2: "\<alpha>2\<in> qbs_Mx Y \<and> \<alpha> = (\<lambda>r. Inr (\<alpha>2 r))"
	+ using hs by auto
	+ then have "g \<circ> \<alpha>2 \<in> qbs_Mx Z"
	+ using assms by(auto simp add: qbs_morphism_def)
	+ moreover have "case_sum f g \<circ> \<alpha> = g \<circ> \<alpha>2"
	+ using h2 by auto
	+ ultimately show ?thesis by simp
	+ next
	+ assume "S \<noteq> {} \<and> S \<noteq> UNIV"
	+ then obtain \<alpha>1 \<alpha>2 where h: "\<alpha>1\<in> qbs_Mx X \<and> \<alpha>2\<in> qbs_Mx Y \<and>
	+ \<alpha> = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
	+ using hs by auto
	+ define F :: "nat \<Rightarrow> real \<Rightarrow> _"
	+ where "F \<equiv> (\<lambda>i r. (if i = 0 then (f \<circ> \<alpha>1) r
	+ else (g \<circ> \<alpha>2) r))"
	+ define P :: "real \<Rightarrow> nat"
	+ where "P \<equiv> (\<lambda>r. if r \<in> S then 0 else 1)"
	+ have "f \<circ> \<alpha>1 \<in> qbs_Mx Z"
	+ using assms h by(simp add: qbs_morphism_def)
	+ have "g \<circ> \<alpha>2 \<in> qbs_Mx Z"
	+ using assms h by(simp add: qbs_morphism_def)
	+ have "\<forall>i. F i \<in> qbs_Mx Z"
	+ proof(auto simp add: F_def)
	+ fix i :: nat
	+ consider "i = 0" \| "i \<noteq> 0" by auto
	+ then show "(\<lambda>r. if i = 0 then (f \<circ> \<alpha>1) r else (g \<circ> \<alpha>2) r) \<in> qbs_Mx Z"
	+ proof cases
	+ assume "i = 0"
	+ then have "(\<lambda>r. if i = 0 then (f \<circ> \<alpha>1) r else (g \<circ> \<alpha>2) r) = f \<circ> \<alpha>1" by auto
	+ then show ?thesis
	+ using \<open>f \<circ> \<alpha>1 \<in> qbs_Mx Z\<close> by simp
	+ next
	+ assume "i \<noteq> 0"
	+ then have "(\<lambda>r. if i = 0 then (f \<circ> \<alpha>1) r else (g \<circ> \<alpha>2) r) = g \<circ> \<alpha>2" by auto
	+ then show ?thesis
	+ using \<open>g \<circ> \<alpha>2 \<in> qbs_Mx Z\<close> by simp
	+ qed
	+ qed
	+ moreover have "\<forall>i. P -`{i} \<in> sets real_borel"
	+ proof
	+ fix i :: nat
	+ consider "i = 0" \| "i = 1" \| "i \<noteq> 0 \<and> i \<noteq> 1" by auto
	+ then show "P -`{i} \<in> sets real_borel"
	+ proof cases
	+ assume "i = 0"
	+ then show ?thesis
	+ using hs by(simp add: P_def)
	+ next
	+ assume "i = 1"
	+ then show ?thesis
	+ using hs by (simp add: P_def borel_comp)
	+ next
	+ assume "i \<noteq> 0 \<and> i \<noteq> 1"
	+ then show ?thesis by(simp add: P_def)
	+ qed
	+ qed
	+ ultimately have "(\<lambda>r. F (P r) r) \<in> qbs_Mx Z"
	+ by simp
	+ moreover have "case_sum f g \<circ> \<alpha> = (\<lambda>r. F (P r) r)"
	+ using h by(auto simp add: F_def P_def)
	+ ultimately show "case_sum f g \<circ> \<alpha> \<in> qbs_Mx Z" by simp
	+ qed
	+qed
	+
	+
	+lemma map_sum_preserves_morphisms:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ and "g \<in> X' \<rightarrow>\<^sub>Q Y'"
	+ shows "map_sum f g \<in> X <+>\<^sub>Q X' \<rightarrow>\<^sub>Q Y <+>\<^sub>Q Y'"
	+proof(rule qbs_morphismI,simp)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> copair_qbs_Mx X X'"
	+ then obtain S where hs:"S\<in> sets real_borel \<and>
	+ (S = {} \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. \<alpha> = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
	+ (S = UNIV \<longrightarrow> (\<exists> \<alpha>2\<in> qbs_Mx X'. \<alpha> = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
	+ ((S \<noteq> {} \<and> S \<noteq> UNIV) \<longrightarrow>
	+ (\<exists> \<alpha>1\<in> qbs_Mx X.
	+ \<exists> \<alpha>2\<in> qbs_Mx X'.
	+ \<alpha> = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))))"
	+ by (auto simp add: copair_qbs_Mx_def)
	+ consider "S = {}" \| "S = UNIV" \| "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
	+ then show "map_sum f g \<circ> \<alpha> \<in> copair_qbs_Mx Y Y'"
	+ proof cases
	+ assume "S = {}"
	+ then obtain \<alpha>1 where h1: "\<alpha>1\<in> qbs_Mx X \<and> \<alpha> = (\<lambda>r. Inl (\<alpha>1 r))"
	+ using hs by auto
	+ define f' :: "real \<Rightarrow> _" where "f' \<equiv> f \<circ> \<alpha>1"
	+ then have "f' \<in> qbs_Mx Y"
	+ using assms h1 by(simp add: qbs_morphism_def)
	+ moreover have "map_sum f g \<circ> \<alpha> = (\<lambda>r. Inl (f' r))"
	+ using h1 by (auto simp add: f'_def)
	+ moreover have "{} \<in> sets real_borel" by simp
	+ ultimately show ?thesis
	+ by(auto simp add: copair_qbs_Mx_def)
	+ next
	+ assume "S = UNIV"
	+ then obtain \<alpha>2 where h2: "\<alpha>2\<in> qbs_Mx X' \<and> \<alpha> = (\<lambda>r. Inr (\<alpha>2 r))"
	+ using hs by auto
	+ define g' :: "real \<Rightarrow> _" where "g' \<equiv> g \<circ> \<alpha>2"
	+ then have "g' \<in> qbs_Mx Y'"
	+ using assms h2 by(simp add: qbs_morphism_def)
	+ moreover have "map_sum f g \<circ> \<alpha> = (\<lambda>r. Inr (g' r))"
	+ using h2 by (auto simp add: g'_def)
	+ ultimately show ?thesis
	+ by(auto intro!: bexI[where x=UNIV] simp add: copair_qbs_Mx_def)
	+ next
	+ assume "S \<noteq> {} \<and> S \<noteq> UNIV"
	+ then obtain \<alpha>1 \<alpha>2 where h: "\<alpha>1\<in> qbs_Mx X \<and> \<alpha>2\<in> qbs_Mx X' \<and>
	+ \<alpha> = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
	+ using hs by auto
	+ define f' :: "real \<Rightarrow> _" where "f' \<equiv> f \<circ> \<alpha>1"
	+ define g' :: "real \<Rightarrow> _" where "g' \<equiv> g \<circ> \<alpha>2"
	+ have "f' \<in> qbs_Mx Y"
	+ using assms h by(auto simp: f'_def)
	+ moreover have "g' \<in> qbs_Mx Y'"
	+ using assms h by(auto simp: g'_def)
	+ moreover have "map_sum f g \<circ> \<alpha> = (\<lambda>r::real. (if (r \<in> S) then Inl (f' r) else Inr (g' r)))"
	+ using h by(auto simp add: f'_def g'_def)
	+ moreover have "S \<in> sets real_borel" using hs by simp
	+ ultimately show ?thesis
	+ using \<open>S \<noteq> {} \<and> S \<noteq> UNIV\<close> by(auto simp add: copair_qbs_Mx_def)
	+ qed
	+qed
	+
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Binary_Product_QuasiBorel.thy b/thys/Quasi_Borel_Spaces/Binary_Product_QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Binary_Product_QuasiBorel.thy
	@@ -0,0 +1,249 @@
	+(* Title: Binary_Product_QuasiBorel.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open>Product Spaces\<close>
	+
	+theory Binary_Product_QuasiBorel
	+ imports "Measure_QuasiBorel_Adjunction"
	+begin
	+
	+subsubsection \<open> Binary Product Spaces \<close>
	+definition pair_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> (real => 'a \<times> 'b) set" where
	+"pair_qbs_Mx X Y \<equiv> {f. fst \<circ> f \<in> qbs_Mx X \<and> snd \<circ> f \<in> qbs_Mx Y}"
	+
	+definition pair_qbs :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a \<times> 'b) quasi_borel" (infixr "\<Otimes>\<^sub>Q" 80) where
	+"pair_qbs X Y = Abs_quasi_borel (qbs_space X \<times> qbs_space Y, pair_qbs_Mx X Y)"
	+
	+
	+lemma pair_qbs_f[simp]: "pair_qbs_Mx X Y \<subseteq> UNIV \<rightarrow> qbs_space X \<times> qbs_space Y"
	+ unfolding pair_qbs_Mx_def
	+ by (auto simp: mem_Times_iff[of _ "qbs_space X" "qbs_space Y"]; fastforce)
	+
	+lemma pair_qbs_closed1: "qbs_closed1 (pair_qbs_Mx (X::'a quasi_borel) (Y::'b quasi_borel))"
	+ unfolding pair_qbs_Mx_def qbs_closed1_def
	+ by (metis (no_types, lifting) comp_assoc mem_Collect_eq qbs_closed1_dest)
	+
	+lemma pair_qbs_closed2: "qbs_closed2 (qbs_space X \<times> qbs_space Y) (pair_qbs_Mx X Y)"
	+ unfolding qbs_closed2_def pair_qbs_Mx_def
	+ by auto
	+
	+lemma pair_qbs_closed3: "qbs_closed3 (pair_qbs_Mx (X::'a quasi_borel) (Y::'b quasi_borel))"
	+proof(auto simp add: qbs_closed3_def pair_qbs_Mx_def)
	+ fix P :: "real \<Rightarrow> nat"
	+ fix Fi :: "nat \<Rightarrow> real \<Rightarrow> 'a \<times> 'b"
	+ define Fj :: "nat \<Rightarrow> real \<Rightarrow> 'a" where "Fj \<equiv> \<lambda>j.(fst \<circ> Fi j)"
	+ assume "\<forall>i. fst \<circ> Fi i \<in> qbs_Mx X \<and> snd \<circ> Fi i \<in> qbs_Mx Y"
	+ then have "\<forall>i. Fj i \<in> qbs_Mx X" by (simp add: Fj_def)
	+ moreover assume "\<forall>i. P -` {i} \<in> sets real_borel"
	+ ultimately have "(\<lambda>r. Fj (P r) r) \<in> qbs_Mx X"
	+ by auto
	+ moreover have "fst \<circ> (\<lambda>r. Fi (P r) r) = (\<lambda>r. Fj (P r) r)" by (auto simp add: Fj_def)
	+ ultimately show "fst \<circ> (\<lambda>r. Fi (P r) r) \<in> qbs_Mx X" by simp
	+next
	+ fix P :: "real \<Rightarrow> nat"
	+ fix Fi :: "nat \<Rightarrow> real \<Rightarrow> 'a \<times> 'b"
	+ define Fj :: "nat \<Rightarrow> real \<Rightarrow> 'b" where "Fj \<equiv> \<lambda>j.(snd \<circ> Fi j)"
	+ assume "\<forall>i. fst \<circ> Fi i \<in> qbs_Mx X \<and> snd \<circ> Fi i \<in> qbs_Mx Y"
	+ then have "\<forall>i. Fj i \<in> qbs_Mx Y" by (simp add: Fj_def)
	+ moreover assume "\<forall>i. P -` {i} \<in> sets real_borel"
	+ ultimately have "(\<lambda>r. Fj (P r) r) \<in> qbs_Mx Y"
	+ by auto
	+ moreover have "snd \<circ> (\<lambda>r. Fi (P r) r) = (\<lambda>r. Fj (P r) r)" by (auto simp add: Fj_def)
	+ ultimately show "snd \<circ> (\<lambda>r. Fi (P r) r) \<in> qbs_Mx Y" by simp
	+qed
	+
	+lemma pair_qbs_correct: "Rep_quasi_borel (X \<Otimes>\<^sub>Q Y) = (qbs_space X \<times> qbs_space Y, pair_qbs_Mx X Y)"
	+ unfolding pair_qbs_def
	+ by(auto intro!: Abs_quasi_borel_inverse pair_qbs_f simp: pair_qbs_closed3 pair_qbs_closed2 pair_qbs_closed1)
	+
	+lemma pair_qbs_space[simp]: "qbs_space (X \<Otimes>\<^sub>Q Y) = qbs_space X \<times> qbs_space Y"
	+ by (simp add: qbs_space_def pair_qbs_correct)
	+
	+lemma pair_qbs_Mx[simp]: "qbs_Mx (X \<Otimes>\<^sub>Q Y) = pair_qbs_Mx X Y"
	+ by (simp add: qbs_Mx_def pair_qbs_correct)
	+
	+
	+lemma pair_qbs_morphismI:
	+ assumes "\<And>\<alpha> \<beta>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> \<beta> \<in> qbs_Mx Y
	+ \<Longrightarrow> f \<circ> (\<lambda>r. (\<alpha> r, \<beta> r)) \<in> qbs_Mx Z"
	+ shows "f \<in> (X \<Otimes>\<^sub>Q Y) \<rightarrow>\<^sub>Q Z"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume 1:"\<alpha> \<in> qbs_Mx (X \<Otimes>\<^sub>Q Y)"
	+ have "f \<circ> \<alpha> = f \<circ> (\<lambda>r. ((fst \<circ> \<alpha>) r, (snd \<circ> \<alpha>) r))"
	+ by auto
	+ also have "... \<in> qbs_Mx Z"
	+ using 1 assms[of "fst \<circ> \<alpha>" "snd \<circ> \<alpha>"]
	+ by(simp add: pair_qbs_Mx_def)
	+ finally show "f \<circ> \<alpha> \<in> qbs_Mx Z" .
	+qed
	+
	+
	+lemma fst_qbs_morphism:
	+ "fst \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q X"
	+ by(auto simp add: qbs_morphism_def pair_qbs_Mx_def)
	+
	+lemma snd_qbs_morphism:
	+ "snd \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Y"
	+ by(auto simp add: qbs_morphism_def pair_qbs_Mx_def)
	+
	+lemma qbs_morphism_pair_iff:
	+ "f \<in> X \<rightarrow>\<^sub>Q Y \<Otimes>\<^sub>Q Z \<longleftrightarrow> fst \<circ> f \<in> X \<rightarrow>\<^sub>Q Y \<and> snd \<circ> f \<in> X \<rightarrow>\<^sub>Q Z"
	+ by(auto intro!: qbs_morphismI qbs_morphism_comp[OF _ fst_qbs_morphism,of f X Y Z ]qbs_morphism_comp[OF _ snd_qbs_morphism,of f X Y Z]
	+ simp: pair_qbs_Mx_def comp_assoc[symmetric])
	+
	+lemma qbs_morphism_Pair1:
	+ assumes "x \<in> qbs_space X"
	+ shows "Pair x \<in> Y \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y"
	+ using assms
	+ by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def comp_def)
	+
	+lemma qbs_morphism_Pair1':
	+ assumes "x \<in> qbs_space X"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ shows "(\<lambda>y. f (x,y)) \<in> Y \<rightarrow>\<^sub>Q Z"
	+ using qbs_morphism_comp[OF qbs_morphism_Pair1[OF assms(1)] assms(2)]
	+ by(simp add: comp_def)
	+
	+lemma qbs_morphism_Pair2:
	+ assumes "y \<in> qbs_space Y"
	+ shows "(\<lambda>x. (x,y)) \<in> X \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y"
	+ using assms
	+ by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def comp_def)
	+
	+lemma qbs_morphism_Pair2':
	+ assumes "y \<in> qbs_space Y"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ shows "(\<lambda>x. f (x,y)) \<in> X \<rightarrow>\<^sub>Q Z"
	+ using qbs_morphism_comp[OF qbs_morphism_Pair2[OF assms(1)] assms(2)]
	+ by(simp add: comp_def)
	+
	+lemma qbs_morphism_fst'':
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ shows "(\<lambda>k. f (fst k)) \<in> X \<Otimes>\<^sub>Q Z \<rightarrow>\<^sub>Q Y"
	+ using qbs_morphism_comp[OF fst_qbs_morphism assms,of Z]
	+ by(simp add: comp_def)
	+
	+lemma qbs_morphism_snd'':
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ shows "(\<lambda>k. f (snd k)) \<in> Z \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
	+ using qbs_morphism_comp[OF snd_qbs_morphism assms,of Z]
	+ by(simp add: comp_def)
	+
	+lemma qbs_morphism_tuple:
	+ assumes "f \<in> Z \<rightarrow>\<^sub>Q X"
	+ and "g \<in> Z \<rightarrow>\<^sub>Q Y"
	+ shows "(\<lambda>z. (f z, g z)) \<in> Z \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y"
	+proof(rule qbs_morphismI,simp)
	+ fix \<alpha>
	+ assume h:"\<alpha> \<in> qbs_Mx Z"
	+ then have "(\<lambda>z. (f z, g z)) \<circ> \<alpha> \<in> UNIV \<rightarrow> qbs_space X \<times> qbs_space Y"
	+ using assms qbs_morphismE(2)[OF assms(1)] qbs_morphismE(2)[OF assms(2)]
	+ by fastforce
	+ moreover have "fst \<circ> ((\<lambda>z. (f z, g z)) \<circ> \<alpha>) = f \<circ> \<alpha>" by auto
	+ moreover have "... \<in> qbs_Mx X"
	+ using assms(1) h by auto
	+ moreover have "snd \<circ> ((\<lambda>z. (f z, g z)) \<circ> \<alpha>) = g \<circ> \<alpha>" by auto
	+ moreover have "... \<in> qbs_Mx Y"
	+ using assms(2) h by auto
	+ ultimately show "(\<lambda>z. (f z, g z)) \<circ> \<alpha> \<in> pair_qbs_Mx X Y"
	+ by (simp add: pair_qbs_Mx_def)
	+qed
	+
	+lemma qbs_morphism_map_prod:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ and "g \<in> X' \<rightarrow>\<^sub>Q Y'"
	+ shows "map_prod f g \<in> X \<Otimes>\<^sub>Q X'\<rightarrow>\<^sub>Q Y \<Otimes>\<^sub>Q Y'"
	+proof(rule pair_qbs_morphismI)
	+ fix \<alpha> \<beta>
	+ assume h:"\<alpha> \<in> qbs_Mx X"
	+ "\<beta> \<in> qbs_Mx X'"
	+ have [simp]: "fst \<circ> (map_prod f g \<circ> (\<lambda>r. (\<alpha> r, \<beta> r))) = f \<circ> \<alpha>" by auto
	+ have [simp]: "snd \<circ> (map_prod f g \<circ> (\<lambda>r. (\<alpha> r, \<beta> r))) = g \<circ> \<beta>" by auto
	+ show "map_prod f g \<circ> (\<lambda>r. (\<alpha> r, \<beta> r)) \<in> qbs_Mx (Y \<Otimes>\<^sub>Q Y')"
	+ using h assms by(auto simp: pair_qbs_Mx_def)
	+qed
	+
	+lemma qbs_morphism_pair_swap':
	+ "(\<lambda>(x,y). (y,x)) \<in> (X::'a quasi_borel) \<Otimes>\<^sub>Q (Y::'b quasi_borel) \<rightarrow>\<^sub>Q Y \<Otimes>\<^sub>Q X"
	+ by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)
	+
	+lemma qbs_morphism_pair_swap:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ shows "(\<lambda>(x,y). f (y,x)) \<in> Y \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Z"
	+proof -
	+ have "(\<lambda>(x,y). f (y,x)) = f \<circ> (\<lambda>(x,y). (y,x))" by auto
	+ thus ?thesis
	+ using qbs_morphism_comp[of "(\<lambda>(x,y). (y,x))" "Y \<Otimes>\<^sub>Q X" _ f] qbs_morphism_pair_swap' assms
	+ by auto
	+qed
	+
	+lemma qbs_morphism_pair_assoc1:
	+ "(\<lambda>((x,y),z). (x,(y,z))) \<in> (X \<Otimes>\<^sub>Q Y) \<Otimes>\<^sub>Q Z \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q (Y \<Otimes>\<^sub>Q Z)"
	+ by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)
	+
	+lemma qbs_morphism_pair_assoc2:
	+ "(\<lambda>(x,(y,z)). ((x,y),z)) \<in> X \<Otimes>\<^sub>Q (Y \<Otimes>\<^sub>Q Z) \<rightarrow>\<^sub>Q (X \<Otimes>\<^sub>Q Y) \<Otimes>\<^sub>Q Z"
	+ by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)
	+
	+lemma pair_qbs_fst:
	+ assumes "qbs_space Y \<noteq> {}"
	+ shows "map_qbs fst (X \<Otimes>\<^sub>Q Y) = X"
	+proof(rule qbs_eqI)
	+ show "qbs_Mx (map_qbs fst (X \<Otimes>\<^sub>Q Y)) = qbs_Mx X"
	+ proof auto
	+ fix \<alpha>x
	+ assume hx:"\<alpha>x \<in> qbs_Mx X"
	+ obtain \<alpha>y where hy:"\<alpha>y \<in> qbs_Mx Y"
	+ using qbs_empty_equiv[of Y] assms
	+ by auto
	+ show "\<exists>\<alpha>\<in>pair_qbs_Mx X Y. \<alpha>x = fst \<circ> \<alpha>"
	+ by(auto intro!: exI[where x="\<lambda>r. (\<alpha>x r, \<alpha>y r)"] simp: pair_qbs_Mx_def hx hy comp_def)
	+ qed (simp add: pair_qbs_Mx_def)
	+qed
	+
	+lemma pair_qbs_snd:
	+ assumes "qbs_space X \<noteq> {}"
	+ shows "map_qbs snd (X \<Otimes>\<^sub>Q Y) = Y"
	+proof(rule qbs_eqI)
	+ show "qbs_Mx (map_qbs snd (X \<Otimes>\<^sub>Q Y)) = qbs_Mx Y"
	+ proof auto
	+ fix \<alpha>y
	+ assume hy:"\<alpha>y \<in> qbs_Mx Y"
	+ obtain \<alpha>x where hx:"\<alpha>x \<in> qbs_Mx X"
	+ using qbs_empty_equiv[of X] assms
	+ by auto
	+ show "\<exists>\<alpha>\<in>pair_qbs_Mx X Y. \<alpha>y = snd \<circ> \<alpha>"
	+ by(auto intro!: exI[where x="\<lambda>r. (\<alpha>x r, \<alpha>y r)"] simp: pair_qbs_Mx_def hx hy comp_def)
	+ qed (simp add: pair_qbs_Mx_def)
	+qed
	+
	+text \<open> The following lemma corresponds to \cite{Heunen_2017} Proposition 19(1). \<close>
	+lemma r_preserves_product :
	+ "measure_to_qbs (X \<Otimes>\<^sub>M Y) = measure_to_qbs X \<Otimes>\<^sub>Q measure_to_qbs Y"
	+ by(auto intro!: qbs_eqI simp: measurable_pair_iff pair_qbs_Mx_def)
	+
	+lemma l_product_sets[simp,measurable_cong]:
	+ "sets (qbs_to_measure X \<Otimes>\<^sub>M qbs_to_measure Y) \<subseteq> sets (qbs_to_measure (X \<Otimes>\<^sub>Q Y))"
	+proof(rule sets_pair_in_sets,simp)
	+ fix A B
	+ assume h:"A \<in> sigma_Mx X"
	+ "B \<in> sigma_Mx Y"
	+ then obtain Ua Ub where hu:
	+ "A = Ua \<inter> qbs_space X" "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel"
	+ "B = Ub \<inter> qbs_space Y" "\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` Ub \<in> sets real_borel"
	+ by(auto simp add: sigma_Mx_def)
	+ show "A \<times> B \<in> sigma_Mx (X \<Otimes>\<^sub>Q Y)"
	+ proof(simp add: sigma_Mx_def, rule exI[where x="Ua \<times> Ub"])
	+ show "A \<times> B = Ua \<times> Ub \<inter> qbs_space X \<times> qbs_space Y \<and>
	+ (\<forall>\<alpha>\<in>pair_qbs_Mx X Y. \<alpha> -` (Ua \<times> Ub) \<in> sets real_borel)"
	+ using hu by(auto simp add: pair_qbs_Mx_def vimage_Times)
	+ qed
	+qed
	+
	+lemma(in pair_standard_borel) l_r_r_sets[simp,measurable_cong]:
	+ "sets (qbs_to_measure (measure_to_qbs M \<Otimes>\<^sub>Q measure_to_qbs N)) = sets (M \<Otimes>\<^sub>M N)"
	+ by(simp only: r_preserves_product[symmetric]) (rule standard_borel_lr_sets_ident)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/CoProduct_QuasiBorel.thy b/thys/Quasi_Borel_Spaces/CoProduct_QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/CoProduct_QuasiBorel.thy
	@@ -0,0 +1,510 @@
	+(* Title: CoProduct_QuasiBorel.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsubsection \<open> Countable Coproduct Spaces \<close>
	+theory CoProduct_QuasiBorel
	+
	+imports
	+ "Product_QuasiBorel"
	+ "Binary_CoProduct_QuasiBorel"
	+begin
	+
	+definition coprod_qbs_Mx :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a \<times> 'b) set" where
	+"coprod_qbs_Mx I X \<equiv> { \<lambda>r. (f r, \<alpha> (f r) r) \|f \<alpha>. f \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>i\<in>range f. \<alpha> i \<in> qbs_Mx (X i))}"
	+
	+lemma coprod_qbs_MxI:
	+ assumes "f \<in> real_borel \<rightarrow>\<^sub>M count_space I"
	+ and "\<And>i. i \<in> range f \<Longrightarrow> \<alpha> i \<in> qbs_Mx (X i)"
	+ shows "(\<lambda>r. (f r, \<alpha> (f r) r)) \<in> coprod_qbs_Mx I X"
	+ using assms unfolding coprod_qbs_Mx_def by blast
	+
	+definition coprod_qbs_Mx' :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a \<times> 'b) set" where
	+"coprod_qbs_Mx' I X \<equiv> { \<lambda>r. (f r, \<alpha> (f r) r) \|f \<alpha>. f \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>i. (i \<in> range f \<or> qbs_space (X i) \<noteq> {}) \<longrightarrow> \<alpha> i \<in> qbs_Mx (X i))}"
	+
	+lemma coproduct_qbs_Mx_eq:
	+ "coprod_qbs_Mx I X = coprod_qbs_Mx' I X"
	+proof auto
	+ fix \<alpha>
	+ assume "\<alpha> \<in> coprod_qbs_Mx I X"
	+ then obtain f \<beta> where hfb:
	+ "f \<in> real_borel \<rightarrow>\<^sub>M count_space I"
	+ "\<And>i. i \<in> range f \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)" "\<alpha> = (\<lambda>r. (f r, \<beta> (f r) r))"
	+ unfolding coprod_qbs_Mx_def by blast
	+ define \<beta>' where "\<beta>' \<equiv> (\<lambda>i. if i \<in> range f then \<beta> i
	+ else if qbs_space (X i) \<noteq> {} then (SOME \<gamma>. \<gamma> \<in> qbs_Mx (X i))
	+ else \<beta> i)"
	+ have 1:"\<alpha> = (\<lambda>r. (f r, \<beta>' (f r) r))"
	+ by(simp add: hfb(3) \<beta>'_def)
	+ have 2:"\<And>i. qbs_space (X i) \<noteq> {} \<Longrightarrow> \<beta>' i \<in> qbs_Mx (X i)"
	+ proof -
	+ fix i
	+ assume hne:"qbs_space (X i) \<noteq> {}"
	+ then obtain x where "x \<in> qbs_space (X i)" by auto
	+ hence "(\<lambda>r. x) \<in> qbs_Mx (X i)" by auto
	+ thus "\<beta>' i \<in> qbs_Mx (X i)"
	+ by(cases "i \<in> range f") (auto simp: \<beta>'_def hfb(2) hne intro!: someI2[where a="\<lambda>r. x"])
	+ qed
	+ show "\<alpha> \<in> coprod_qbs_Mx' I X"
	+ using hfb(1,2) 1 2 by(auto simp: coprod_qbs_Mx'_def intro!: exI[where x=f] exI[where x=\<beta>'])
	+next
	+ fix \<alpha>
	+ assume "\<alpha> \<in> coprod_qbs_Mx' I X"
	+ then obtain f \<beta> where hfb:
	+ "f \<in> real_borel \<rightarrow>\<^sub>M count_space I" "\<And>i. qbs_space (X i) \<noteq> {} \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)"
	+ "\<And>i. i \<in> range f \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)" "\<alpha> = (\<lambda>r. (f r, \<beta> (f r) r))"
	+ unfolding coprod_qbs_Mx'_def by blast
	+ show "\<alpha> \<in> coprod_qbs_Mx I X"
	+ by(auto simp: hfb(4) intro!: coprod_qbs_MxI[OF hfb(1) hfb(3)])
	+qed
	+
	+definition coprod_qbs :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> ('a \<times> 'b) quasi_borel" where
	+"coprod_qbs I X \<equiv> Abs_quasi_borel (SIGMA i:I. qbs_space (X i), coprod_qbs_Mx I X)"
	+
	+syntax
	+ "_coprod_qbs" :: "pttrn \<Rightarrow> 'i set \<Rightarrow> 'a quasi_borel \<Rightarrow> ('i \<times> 'a) quasi_borel" ("(3\<amalg>\<^sub>Q _\<in>_./ _)" 10)
	+translations
	+ "\<amalg>\<^sub>Q x\<in>I. M" \<rightleftharpoons> "CONST coprod_qbs I (\<lambda>x. M)"
	+
	+lemma coprod_qbs_f[simp]: "coprod_qbs_Mx I X \<subseteq> UNIV \<rightarrow> (SIGMA i:I. qbs_space (X i))"
	+ by(fastforce simp: coprod_qbs_Mx_def dest: measurable_space)
	+
	+lemma coprod_qbs_closed1: "qbs_closed1 (coprod_qbs_Mx I X)"
	+proof(rule qbs_closed1I)
	+ fix \<alpha> f
	+ assume "\<alpha> \<in> coprod_qbs_Mx I X"
	+ and 1[measurable]: "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ then obtain \<beta> g where ha:
	+ "\<And>i. i \<in> range g \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)" "\<alpha> = (\<lambda>r. (g r, \<beta> (g r) r))" and [measurable]:"g \<in> real_borel \<rightarrow>\<^sub>M count_space I"
	+ by(fastforce simp: coprod_qbs_Mx_def)
	+ then have "\<And>i. i \<in> range g \<Longrightarrow> \<beta> i \<circ> f \<in> qbs_Mx (X i)"
	+ by simp
	+ thus "\<alpha> \<circ> f \<in> coprod_qbs_Mx I X"
	+ by(auto intro!: coprod_qbs_MxI[where f="g \<circ> f" and \<alpha>="\<lambda>i. \<beta> i \<circ> f",simplified comp_def] simp: ha(2) comp_def)
	+qed
	+
	+lemma coprod_qbs_closed2: "qbs_closed2 (SIGMA i:I. qbs_space (X i)) (coprod_qbs_Mx I X)"
	+proof(rule qbs_closed2I,auto)
	+ fix i x
	+ assume "i \<in> I" "x \<in> qbs_space (X i)"
	+ then show "(\<lambda>r. (i,x)) \<in> coprod_qbs_Mx I X"
	+ by(auto simp: coprod_qbs_Mx_def intro!: exI[where x="\<lambda>r. i"])
	+qed
	+
	+lemma coprod_qbs_closed3:
	+ "qbs_closed3 (coprod_qbs_Mx I X)"
	+proof(rule qbs_closed3I)
	+ fix P Fi
	+ assume h:"\<And>i :: nat. P -` {i} \<in> sets real_borel"
	+ "\<And>i :: nat. Fi i \<in> coprod_qbs_Mx I X"
	+ then have "\<forall>i. \<exists>fi \<alpha>i. Fi i = (\<lambda>r. (fi r, \<alpha>i (fi r) r)) \<and> fi \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>j. (j \<in> range fi \<or> qbs_space (X j) \<noteq> {}) \<longrightarrow> \<alpha>i j \<in> qbs_Mx (X j))"
	+ by(auto simp: coproduct_qbs_Mx_eq coprod_qbs_Mx'_def)
	+ then obtain fi where
	+ "\<forall>i. \<exists>\<alpha>i. Fi i = (\<lambda>r. (fi i r, \<alpha>i (fi i r) r)) \<and> fi i \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>j. (j \<in> range (fi i) \<or> qbs_space (X j) \<noteq> {}) \<longrightarrow> \<alpha>i j \<in> qbs_Mx (X j))"
	+ by(fastforce intro!: choice)
	+ then obtain \<alpha>i where
	+ "\<forall>i. Fi i = (\<lambda>r. (fi i r, \<alpha>i i (fi i r) r)) \<and> fi i \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>j. (j \<in> range (fi i) \<or> qbs_space (X j) \<noteq> {}) \<longrightarrow> \<alpha>i i j \<in> qbs_Mx (X j))"
	+ by(fastforce intro!: choice)
	+ then have hf:
	+ "\<And>i. Fi i = (\<lambda>r. (fi i r, \<alpha>i i (fi i r) r))" "\<And>i. fi i \<in> real_borel \<rightarrow>\<^sub>M count_space I" "\<And>i j. j \<in> range (fi i) \<Longrightarrow> \<alpha>i i j \<in> qbs_Mx (X j)" "\<And>i j. qbs_space (X j) \<noteq> {} \<Longrightarrow> \<alpha>i i j \<in> qbs_Mx (X j)"
	+ by auto
	+
	+ define f' where "f' \<equiv> (\<lambda>r. fi (P r) r)"
	+ define \<alpha>' where "\<alpha>' \<equiv> (\<lambda>i r. \<alpha>i (P r) i r)"
	+ have 1:"(\<lambda>r. Fi (P r) r) = (\<lambda>r. (f' r, \<alpha>' (f' r) r))"
	+ by(simp add: \<alpha>'_def f'_def hf)
	+ have "f' \<in> real_borel \<rightarrow>\<^sub>M count_space I"
	+ proof -
	+ note [measurable] = separate_measurable[OF h(1)]
	+ have "(\<lambda>(n,r). fi n r) \<in> count_space UNIV \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M count_space I"
	+ by(auto intro!: measurable_pair_measure_countable1 simp: hf)
	+ hence [measurable]:"(\<lambda>(n,r). fi n r) \<in> nat_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M count_space I"
	+ using measurable_cong_sets[OF sets_pair_measure_cong[OF sets_borel_eq_count_space],of real_borel real_borel]
	+ by auto
	+ thus ?thesis
	+ using measurable_comp[of "\<lambda>r. (P r, r)" _ _ "(\<lambda>(n,r). fi n r)"]
	+ by(simp add: f'_def)
	+ qed
	+ moreover have "\<And>i. i \<in> range f' \<Longrightarrow> \<alpha>' i \<in> qbs_Mx (X i)"
	+ proof -
	+ fix i
	+ assume hi:"i \<in> range f'"
	+ then obtain r where hr:
	+ "i = fi (P r) r" by(auto simp: f'_def)
	+ hence "i \<in> range (fi (P r))" by simp
	+ hence "\<alpha>i (P r) i \<in> qbs_Mx (X i)" by(simp add: hf)
	+ hence "qbs_space (X i) \<noteq> {}"
	+ by(auto simp: qbs_empty_equiv)
	+ hence "\<And>j. \<alpha>i j i \<in> qbs_Mx (X i)"
	+ by(simp add: hf(4))
	+ then show "\<alpha>' i \<in> qbs_Mx (X i)"
	+ by(auto simp: \<alpha>'_def h(1) intro!: qbs_closed3_dest[of P "\<lambda>j. \<alpha>i j i"])
	+ qed
	+ ultimately show "(\<lambda>r. Fi (P r) r) \<in> coprod_qbs_Mx I X"
	+ by(auto intro!: coprod_qbs_MxI simp: 1)
	+qed
	+
	+lemma coprod_qbs_correct: "Rep_quasi_borel (coprod_qbs I X) = (SIGMA i:I. qbs_space (X i), coprod_qbs_Mx I X)"
	+ unfolding coprod_qbs_def
	+ using is_quasi_borel_intro[OF coprod_qbs_f coprod_qbs_closed1 coprod_qbs_closed2 coprod_qbs_closed3]
	+ by(fastforce intro!: Abs_quasi_borel_inverse)
	+
	+lemma coproduct_qbs_space[simp]: "qbs_space (coprod_qbs I X) = (SIGMA i:I. qbs_space (X i))"
	+ by(simp add: coprod_qbs_correct qbs_space_def)
	+
	+lemma coproduct_qbs_Mx[simp]: "qbs_Mx (coprod_qbs I X) = coprod_qbs_Mx I X"
	+ by(simp add: coprod_qbs_correct qbs_Mx_def)
	+
	+
	+lemma ini_morphism:
	+ assumes "j \<in> I"
	+ shows "(\<lambda>x. (j,x)) \<in> X j \<rightarrow>\<^sub>Q (\<amalg>\<^sub>Q i\<in>I. X i)"
	+ by(fastforce intro!: qbs_morphismI exI[where x="\<lambda>r. j"] simp: coprod_qbs_Mx_def comp_def assms)
	+
	+lemma coprod_qbs_canonical1:
	+ assumes "countable I"
	+ and "\<And>i. i \<in> I \<Longrightarrow> f i \<in> X i \<rightarrow>\<^sub>Q Y"
	+ shows "(\<lambda>(i,x). f i x) \<in> (\<amalg>\<^sub>Q i \<in>I. X i) \<rightarrow>\<^sub>Q Y"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx (coprod_qbs I X)"
	+ then obtain \<beta> g where ha:
	+ "\<And>i. i \<in> range g \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)" "\<alpha> = (\<lambda>r. (g r, \<beta> (g r) r))" and hg[measurable]:"g \<in> real_borel \<rightarrow>\<^sub>M count_space I"
	+ by(fastforce simp: coprod_qbs_Mx_def)
	+ define f' where "f' \<equiv> (\<lambda>i r. f i (\<beta> i r))"
	+ have "range g \<subseteq> I"
	+ using measurable_space[OF hg] by auto
	+ hence 1:"(\<And>i. i \<in> range g \<Longrightarrow> f' i \<in> qbs_Mx Y)"
	+ using qbs_morphismE(3)[OF assms(2) ha(1),simplified comp_def]
	+ by(auto simp: f'_def)
	+ have "(\<lambda>(i, x). f i x) \<circ> \<alpha> = (\<lambda>r. f' (g r) r)"
	+ by(auto simp: ha(2) f'_def)
	+ also have "... \<in> qbs_Mx Y"
	+ by(auto intro!: qbs_closed3_dest2'[OF assms(1) hg,of f',OF 1])
	+ finally show "(\<lambda>(i, x). f i x) \<circ> \<alpha> \<in> qbs_Mx Y " .
	+qed
	+
	+lemma coprod_qbs_canonical1':
	+ assumes "countable I"
	+ and "\<And>i. i \<in> I \<Longrightarrow> (\<lambda>x. f (i,x)) \<in> X i \<rightarrow>\<^sub>Q Y"
	+ shows "f \<in> (\<amalg>\<^sub>Q i \<in>I. X i) \<rightarrow>\<^sub>Q Y"
	+ using coprod_qbs_canonical1[where f="curry f"] assms by(auto simp: curry_def)
	+
	+
	+text \<open> $\coprod_{i=0,1} X_i \cong X_1 + X_2$. \<close>
	+lemma coproduct_binary_coproduct:
	+ "\<exists>f g. f \<in> (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y) \<rightarrow>\<^sub>Q X <+>\<^sub>Q Y \<and> g \<in> X <+>\<^sub>Q Y \<rightarrow>\<^sub>Q (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y) \<and>
	+ g \<circ> f = id \<and> f \<circ> g = id"
	+proof(auto intro!: exI[where x="\<lambda>(b,z). if b then Inl z else Inr z"] exI[where x="case_sum (\<lambda>z. (True,z)) (\<lambda>z. (False,z))"])
	+ show "(\<lambda>(b, z). if b then Inl z else Inr z) \<in> (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y) \<rightarrow>\<^sub>Q X <+>\<^sub>Q Y"
	+ proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume " \<alpha> \<in> qbs_Mx (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y)"
	+ then obtain f \<beta> where hf:
	+ "\<alpha> = (\<lambda>r. (f r, \<beta> (f r) r))" "f \<in> real_borel \<rightarrow>\<^sub>M count_space UNIV" "\<And>i. i \<in> range f \<Longrightarrow> \<beta> i \<in> qbs_Mx (if i then X else Y)"
	+ by(auto simp: coprod_qbs_Mx_def)
	+ consider "range f = {True}" \| "range f = {False}" \| "range f = {True,False}"
	+ by auto
	+ thus "(\<lambda>(b, z). if b then Inl z else Inr z) \<circ> \<alpha> \<in> qbs_Mx (X <+>\<^sub>Q Y)"
	+ proof cases
	+ case 1
	+ then have "\<And>r. f r = True"
	+ by auto
	+ then show ?thesis
	+ using hf(3)
	+ by(auto intro!: bexI[where x="{}"] bexI[where x="\<beta> True"] simp: copair_qbs_Mx_def split_beta' comp_def hf(1))
	+ next
	+ case 2
	+ then have "\<And>r. f r = False"
	+ by auto
	+ then show ?thesis
	+ using hf(3)
	+ by(auto intro!: bexI[where x="UNIV"] bexI[where x="\<beta> False"] simp: copair_qbs_Mx_def split_beta' comp_def hf(1))
	+ next
	+ case 3
	+ then have 4:"f -` {True} \<in> sets real_borel"
	+ using measurable_sets[OF hf(2)] by simp
	+ have 5:"f -` {True} \<noteq> {} \<and> f -` {True} \<noteq> UNIV"
	+ using 3
	+ by (metis empty_iff imageE insertCI vimage_singleton_eq)
	+ have 6:"\<beta> True \<in> qbs_Mx X" "\<beta> False \<in> qbs_Mx Y"
	+ using hf(3)[of True] hf(3)[of False] by(auto simp: 3)
	+ show ?thesis
	+ apply(simp add: copair_qbs_Mx_def)
	+ apply(intro bexI[OF _ 4])
	+ apply(simp add: 5)
	+ apply(intro bexI[OF _ 6(1)] bexI[OF _ 6(2)])
	+ apply(auto simp add: hf(1) comp_def)
	+ done
	+ qed
	+ qed
	+next
	+ show "case_sum (Pair True) (Pair False) \<in> X <+>\<^sub>Q Y \<rightarrow>\<^sub>Q (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y)"
	+ proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx (X <+>\<^sub>Q Y)"
	+ then obtain S where hs:
	+ "S \<in> sets real_borel" "S = {} \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. \<alpha> = (\<lambda>r. Inl (\<alpha>1 r)))" "S = UNIV \<longrightarrow> (\<exists> \<alpha>2\<in> qbs_Mx Y. \<alpha> = (\<lambda>r. Inr (\<alpha>2 r)))"
	+ "(S \<noteq> {} \<and> S \<noteq> UNIV) \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. \<exists> \<alpha>2\<in> qbs_Mx Y. \<alpha> = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))"
	+ by(auto simp: copair_qbs_Mx_def)
	+ consider "S = {}" \| "S = UNIV" \| "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
	+ thus "case_sum (Pair True) (Pair False) \<circ> \<alpha> \<in> qbs_Mx (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y)"
	+ proof cases
	+ case 1
	+ then obtain \<alpha>1 where ha:
	+ "\<alpha>1\<in> qbs_Mx X" "\<alpha> = (\<lambda>r. Inl (\<alpha>1 r))"
	+ using hs(2) by auto
	+ hence "case_sum (Pair True) (Pair False) \<circ> \<alpha> = (\<lambda>r. (True, \<alpha>1 r))"
	+ by auto
	+ thus ?thesis
	+ by(auto intro!: coprod_qbs_MxI simp: ha)
	+ next
	+ case 2
	+ then obtain \<alpha>2 where ha:
	+ "\<alpha>2\<in> qbs_Mx Y" "\<alpha> = (\<lambda>r. Inr (\<alpha>2 r))"
	+ using hs(3) by auto
	+ hence "case_sum (Pair True) (Pair False) \<circ> \<alpha> = (\<lambda>r. (False, \<alpha>2 r))"
	+ by auto
	+ thus ?thesis
	+ by(auto intro!: coprod_qbs_MxI simp: ha)
	+ next
	+ case 3
	+ then obtain \<alpha>1 \<alpha>2 where ha:
	+ "\<alpha>1\<in> qbs_Mx X" "\<alpha>2\<in> qbs_Mx Y" "\<alpha> = (\<lambda>r. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
	+ using hs(4) by auto
	+ define f :: "real \<Rightarrow> bool" where "f \<equiv> (\<lambda>r. r \<in> S)"
	+ define \<alpha>' where "\<alpha>' \<equiv> (\<lambda>i. if i then \<alpha>1 else \<alpha>2)"
	+ have "case_sum (Pair True) (Pair False) \<circ> \<alpha> = (\<lambda>r. (f r, \<alpha>' (f r) r))"
	+ by(auto simp: f_def \<alpha>'_def ha(3))
	+ thus ?thesis
	+ using hs(1)
	+ by(auto intro!: coprod_qbs_MxI simp: ha \<alpha>'_def f_def)
	+ qed
	+ qed
	+next
	+ show "(\<lambda>(b, z). if b then Inl z else Inr z) \<circ> case_sum (Pair True) (Pair False) = id"
	+ by (auto simp add: sum.case_eq_if )
	+qed
	+
	+
	+subsubsection \<open> Lists \<close>
	+abbreviation "list_of X \<equiv> \<amalg>\<^sub>Q n\<in>(UNIV :: nat set). (\<Pi>\<^sub>Q i\<in>{..<n}. X)"
	+abbreviation list_nil :: "nat \<times> (nat \<Rightarrow> 'a)" where
	+"list_nil \<equiv> (0, \<lambda>n. undefined)"
	+abbreviation list_cons :: "['a, nat \<times> (nat \<Rightarrow> 'a)] \<Rightarrow> nat \<times> (nat \<Rightarrow> 'a)" where
	+"list_cons x l \<equiv> (Suc (fst l), (\<lambda>n. if n = 0 then x else (snd l) (n - 1)))"
	+
	+definition list_head :: "nat \<times> (nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
	+"list_head l = snd l 0"
	+definition list_tail :: "nat \<times> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<times> (nat \<Rightarrow> 'a)" where
	+"list_tail l = (fst l - 1, \<lambda>m. (snd l) (Suc m))"
	+
	+
	+lemma list_simp1:
	+ "list_nil \<noteq> list_cons x l"
	+ by simp
	+
	+lemma list_simp2:
	+ assumes "list_cons a al = list_cons b bl"
	+ shows "a = b" "al = bl"
	+proof -
	+ have "a = snd (list_cons a al) 0"
	+ "b = snd (list_cons b bl) 0"
	+ by auto
	+ thus "a = b"
	+ by(simp add: assms)
	+next
	+ have "fst al = fst bl"
	+ using assms by simp
	+ moreover have "snd al = snd bl"
	+ proof
	+ fix n
	+ have "snd al n = snd (list_cons a al) (Suc n)"
	+ by simp
	+ also have "... = snd (list_cons b bl) (Suc n)"
	+ by (simp add: assms)
	+ also have "... = snd bl n"
	+ by simp
	+ finally show "snd al n = snd bl n" .
	+ qed
	+ ultimately show "al = bl"
	+ by (simp add: prod.expand)
	+qed
	+
	+lemma list_simp3:
	+ shows "list_head (list_cons a l) = a"
	+ by(simp add: list_head_def)
	+
	+lemma list_simp4:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ shows "list_tail (list_cons a l) = l"
	+ using assms by(simp_all add: list_tail_def)
	+
	+lemma list_decomp1:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ shows "l = list_nil \<or>
	+ (\<exists>a l'. a \<in> qbs_space X \<and> l' \<in> qbs_space (list_of X) \<and> l = list_cons a l')"
	+proof(cases l)
	+ case hl:(Pair n f)
	+ show ?thesis
	+ proof(cases n)
	+ case 0
	+ then show ?thesis
	+ using assms hl by simp
	+ next
	+ case hn:(Suc n')
	+ define f' where "f' \<equiv> \<lambda>m. f (Suc m)"
	+ have "l = list_cons (f 0) (n',f')"
	+ proof(simp add: hl hn, standard)
	+ fix m
	+ show "f m = (if m = 0 then f 0 else snd (n', f') (m - 1))"
	+ using assms hl by(cases m; fastforce simp: f'_def)
	+ qed
	+ moreover have "(n', f') \<in> qbs_space (list_of X)"
	+ proof(simp,rule PiE_I)
	+ show "\<And>x. x \<in> {..<n'} \<Longrightarrow> f' x \<in> qbs_space X"
	+ using assms hl hn by(fastforce simp: f'_def)
	+ next
	+ fix x
	+ assume 1:"x \<notin> {..<n'}"
	+ thus " f' x = undefined"
	+ using hl assms hn by(auto simp: f'_def)
	+ qed
	+ ultimately show ?thesis
	+ using hl assms
	+ by(auto intro!: exI[where x="f 0"] exI[where x="(n',\<lambda>m. if m = 0 then undefined else f (Suc m))"])
	+ qed
	+qed
	+
	+lemma list_simp5:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ and "l \<noteq> list_nil"
	+ shows "l = list_cons (list_head l) (list_tail l)"
	+proof -
	+ obtain a l' where hl:
	+ "a \<in> qbs_space X" "l' \<in> qbs_space (list_of X)" "l = list_cons a l'"
	+ using list_decomp1[OF assms(1)] assms(2) by blast
	+ hence "list_head l = a" "list_tail l = l'"
	+ using list_simp3 list_simp4 by auto
	+ thus ?thesis
	+ using hl(3) list_simp2 by auto
	+qed
	+
	+lemma list_simp6:
	+ "list_nil \<in> qbs_space (list_of X)"
	+ by simp
	+
	+lemma list_simp7:
	+ assumes "a \<in> qbs_space X"
	+ and "l \<in> qbs_space (list_of X)"
	+ shows "list_cons a l \<in> qbs_space (list_of X)"
	+ using assms by(fastforce simp: PiE_def extensional_def)
	+
	+lemma list_destruct_rule:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ "P list_nil"
	+ and "\<And>a l'. a \<in> qbs_space X \<Longrightarrow> l' \<in> qbs_space (list_of X) \<Longrightarrow> P (list_cons a l')"
	+ shows "P l"
	+ by(rule disjE[OF list_decomp1[OF assms(1)]]) (use assms in auto)
	+
	+lemma list_induct_rule:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ "P list_nil"
	+ and "\<And>a l'. a \<in> qbs_space X \<Longrightarrow> l' \<in> qbs_space (list_of X) \<Longrightarrow> P l' \<Longrightarrow> P (list_cons a l')"
	+ shows "P l"
	+proof(cases l)
	+ case hl:(Pair n f)
	+ then show ?thesis
	+ using assms(1)
	+ proof(induction n arbitrary: f l)
	+ case 0
	+ then show ?case
	+ using assms(1,2) by simp
	+ next
	+ case ih:(Suc n)
	+ then obtain a l' where hl:
	+ "a \<in> qbs_space X" "l' \<in> qbs_space (list_of X)" "l = list_cons a l'"
	+ using list_decomp1 by blast
	+ have "P l'"
	+ using ih hl(3)
	+ by(auto intro!: ih(1)[OF _ hl(2),of "snd l'"])
	+ from assms(3)[OF hl(1,2) this]
	+ show ?case
	+ by(simp add: hl(3))
	+ qed
	+qed
	+
	+
	+fun from_list :: "'a list \<Rightarrow> nat \<times> (nat \<Rightarrow> 'a)" where
	+ "from_list [] = list_nil" \|
	+ "from_list (a#l) = list_cons a (from_list l)"
	+
	+fun to_list' :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list" where
	+ "to_list' 0 _ = []" \|
	+ "to_list' (Suc n) f = f 0 # to_list' n (\<lambda>n. f (Suc n))"
	+
	+definition to_list :: "nat \<times> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list" where
	+"to_list \<equiv> case_prod to_list'"
	+
	+lemma to_list_simp1:
	+ shows "to_list list_nil = []"
	+ by(simp add: to_list_def)
	+
	+lemma to_list_simp2:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ shows "to_list (list_cons a l) = a # to_list l"
	+ using assms by(auto simp:PiE_def to_list_def)
	+
	+lemma from_list_length:
	+ "fst (from_list l) = length l"
	+ by(induction l, simp_all)
	+
	+lemma from_list_in_list_of:
	+ assumes "set l \<subseteq> qbs_space X"
	+ shows "from_list l \<in> qbs_space (list_of X)"
	+ using assms by(induction l) (auto simp: PiE_def extensional_def Pi_def)
	+
	+lemma from_list_in_list_of':
	+ shows "from_list l \<in> qbs_space (list_of (Abs_quasi_borel (UNIV,UNIV)))"
	+proof -
	+ have "set l \<subseteq> qbs_space (Abs_quasi_borel (UNIV,UNIV))"
	+ by(simp add: qbs_space_def Abs_quasi_borel_inverse[of "(UNIV,UNIV)",simplified is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def,simplified])
	+ thus ?thesis
	+ using from_list_in_list_of by blast
	+qed
	+
	+lemma list_cons_in_list_of:
	+ assumes "set (a#l) \<subseteq> qbs_space X"
	+ shows "list_cons a (from_list l) \<in> qbs_space (list_of X)"
	+ using from_list_in_list_of[OF assms] by simp
	+
	+lemma from_list_to_list_ident:
	+ "(to_list \<circ> from_list) l = l"
	+ by(induction l)
	+ (simp add: to_list_def,simp add: to_list_simp2[OF from_list_in_list_of'])
	+
	+lemma to_list_from_list_ident:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ shows "(from_list \<circ> to_list) l = l"
	+proof(rule list_induct_rule[OF assms])
	+ fix a l'
	+ assume h: "l' \<in> qbs_space (list_of X)"
	+ and ih:"(from_list \<circ> to_list) l' = l'"
	+ show "(from_list \<circ> to_list) (list_cons a l') = list_cons a l'"
	+ by(auto simp add: to_list_simp2[OF h] ih[simplified])
	+qed (simp add: to_list_simp1)
	+
	+
	+definition rec_list' :: "'b \<Rightarrow> ('a \<Rightarrow> (nat \<times> (nat \<Rightarrow> 'a)) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (nat \<times> (nat \<Rightarrow> 'a)) \<Rightarrow> 'b" where
	+"rec_list' t0 f l \<equiv> (rec_list t0 (\<lambda>x l'. f x (from_list l')) (to_list l))"
	+
	+lemma rec_list'_simp1:
	+ "rec_list' t f list_nil = t"
	+ by(simp add: rec_list'_def to_list_simp1)
	+
	+lemma rec_list'_simp2:
	+ assumes "l \<in> qbs_space (list_of X)"
	+ shows "rec_list' t f (list_cons x l) = f x l (rec_list' t f l)"
	+ by(simp add: rec_list'_def to_list_simp2[OF assms] to_list_from_list_ident[OF assms,simplified])
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Exponent_QuasiBorel.thy b/thys/Quasi_Borel_Spaces/Exponent_QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Exponent_QuasiBorel.thy
	@@ -0,0 +1,518 @@
	+(* Title: Exponent_QuasiBorel.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open>Function Spaces\<close>
	+
	+theory Exponent_QuasiBorel
	+ imports "CoProduct_QuasiBorel"
	+begin
	+
	+subsubsection \<open> Function Spaces \<close>
	+definition exp_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a => 'b) set" where
	+"exp_qbs_Mx X Y \<equiv> {g :: real \<Rightarrow> 'a \<Rightarrow> 'b. case_prod g \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y} "
	+
	+definition exp_qbs :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a \<Rightarrow> 'b) quasi_borel" (infixr "\<Rightarrow>\<^sub>Q" 61) where
	+"X \<Rightarrow>\<^sub>Q Y \<equiv> Abs_quasi_borel (X \<rightarrow>\<^sub>Q Y, exp_qbs_Mx X Y)"
	+
	+
	+lemma exp_qbs_f[simp]: "exp_qbs_Mx X Y \<subseteq> UNIV \<rightarrow> (X :: 'a quasi_borel) \<rightarrow>\<^sub>Q (Y :: 'b quasi_borel)"
	+proof(auto intro!: qbs_morphismI)
	+ fix f \<alpha> r
	+ assume h:"f \<in> exp_qbs_Mx X Y"
	+ "\<alpha> \<in> qbs_Mx X"
	+ have "f r \<circ> \<alpha> = (\<lambda>y. case_prod f (r,y)) \<circ> \<alpha>"
	+ by auto
	+ also have "... \<in> qbs_Mx Y"
	+ using qbs_morphism_Pair1'[of r "\<real>\<^sub>Q" "case_prod f" X Y] h
	+ by(auto simp: exp_qbs_Mx_def)
	+ finally show "f r \<circ> \<alpha> \<in> qbs_Mx Y" .
	+qed
	+
	+lemma exp_qbs_closed1: "qbs_closed1 (exp_qbs_Mx X Y)"
	+proof(rule qbs_closed1I)
	+ fix a
	+ fix f
	+ assume h:"a \<in> exp_qbs_Mx X Y"
	+ "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ have "a \<circ> f = (\<lambda>r y. case_prod a (f r,y))" by auto
	+ moreover have "case_prod ... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
	+ proof -
	+ have "case_prod (\<lambda>r y. case_prod a (f r,y)) = case_prod a \<circ> map_prod f id"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
	+ using h
	+ by(auto intro!: qbs_morphism_comp qbs_morphism_map_prod simp: exp_qbs_Mx_def)
	+ finally show ?thesis .
	+ qed
	+ ultimately show "a \<circ> f \<in> exp_qbs_Mx X Y"
	+ by (simp add: exp_qbs_Mx_def)
	+qed
	+
	+lemma exp_qbs_closed2: "qbs_closed2 (X \<rightarrow>\<^sub>Q Y) (exp_qbs_Mx X Y)"
	+ by(auto intro!: qbs_closed2I qbs_morphism_snd'' simp: exp_qbs_Mx_def split_beta')
	+
	+lemma exp_qbs_closed3:"qbs_closed3 (exp_qbs_Mx X Y)"
	+proof(rule qbs_closed3I)
	+ fix P :: "real \<Rightarrow> nat"
	+ fix Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
	+ assume h:"\<And>i. P -` {i} \<in> sets real_borel"
	+ "\<And>i. Fi i \<in> exp_qbs_Mx X Y"
	+ show "(\<lambda>r. Fi (P r) r) \<in> exp_qbs_Mx X Y"
	+ unfolding exp_qbs_Mx_def
	+ proof(auto intro!: qbs_morphismI)
	+ fix \<alpha> \<beta>
	+ assume h':"\<alpha> \<in> pair_qbs_Mx \<real>\<^sub>Q X "
	+ have 1:"\<And>i. (\<lambda>(r,x). Fi i r x) \<circ> \<alpha> \<in> qbs_Mx Y"
	+ using qbs_morphismE(3)[OF h(2)[simplified exp_qbs_Mx_def,simplified]] h'
	+ by(simp add: exp_qbs_Mx_def)
	+ have 2:"\<And>i. (P \<circ> (\<lambda>r. fst (\<alpha> r))) -` {i} \<in> sets real_borel"
	+ using separate_measurable[OF h(1)] h'
	+ by(auto intro!: measurable_separate simp: pair_qbs_Mx_def comp_def)
	+ show "(\<lambda>(r, y). Fi (P r) r y) \<circ> \<alpha> \<in> qbs_Mx Y"
	+ using qbs_closed3_dest[OF 2,of "\<lambda>i. (\<lambda>(r,x). Fi i r x) \<circ> \<alpha>",OF 1]
	+ by(simp add: comp_def split_beta')
	+ qed
	+qed
	+
	+
	+lemma exp_qbs_correct: "Rep_quasi_borel (exp_qbs X Y) = (X \<rightarrow>\<^sub>Q Y, exp_qbs_Mx X Y)"
	+ unfolding exp_qbs_def
	+ by(auto intro!: Abs_quasi_borel_inverse exp_qbs_f simp: exp_qbs_closed1 exp_qbs_closed2 exp_qbs_closed3)
	+
	+lemma exp_qbs_space[simp]: "qbs_space (exp_qbs X Y) = X \<rightarrow>\<^sub>Q Y"
	+ by(simp add: qbs_space_def exp_qbs_correct)
	+
	+lemma exp_qbs_Mx[simp]: "qbs_Mx (exp_qbs X Y) = exp_qbs_Mx X Y"
	+ by(simp add: qbs_Mx_def exp_qbs_correct)
	+
	+
	+lemma qbs_exp_morphismI:
	+ assumes "\<And>\<alpha> \<beta>. \<alpha> \<in> qbs_Mx X \<Longrightarrow>
	+ \<beta> \<in> pair_qbs_Mx real_quasi_borel Y \<Longrightarrow>
	+ (\<lambda>(r,x). (f \<circ> \<alpha>) r x) \<circ> \<beta> \<in> qbs_Mx Z"
	+ shows "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
	+ using assms
	+ by(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def comp_def)
	+
	+definition qbs_eval :: "(('a \<Rightarrow> 'b) \<times> 'a) \<Rightarrow> 'b" where
	+"qbs_eval a \<equiv> (fst a) (snd a)"
	+
	+lemma qbs_eval_morphism:
	+ "qbs_eval \<in> (exp_qbs X Y) \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
	+proof(rule qbs_morphismI,simp)
	+ fix f
	+ assume "f \<in> pair_qbs_Mx (exp_qbs X Y) X"
	+ let ?f1 = "fst \<circ> f"
	+ let ?f2 = "snd \<circ> f"
	+ define g :: "real \<Rightarrow> real \<times> _"
	+ where "g \<equiv> \<lambda>r.(r,?f2 r)"
	+ have "g \<in> qbs_Mx (real_quasi_borel \<Otimes>\<^sub>Q X)"
	+ proof(auto simp add: pair_qbs_Mx_def)
	+ have "fst \<circ> g = id" by(auto simp add: g_def comp_def)
	+ thus "fst \<circ> g \<in> real_borel \<rightarrow>\<^sub>M real_borel" by(auto simp add: measurable_ident)
	+ next
	+ have "snd \<circ> g = ?f2" by(auto simp add: g_def)
	+ thus "snd \<circ> g \<in> qbs_Mx X"
	+ using \<open>f \<in> pair_qbs_Mx (exp_qbs X Y) X\<close> pair_qbs_Mx_def by auto
	+ qed
	+ moreover have "?f1 \<in> exp_qbs_Mx X Y"
	+ using \<open>f \<in> pair_qbs_Mx (exp_qbs X Y) X\<close>
	+ by(simp add: pair_qbs_Mx_def)
	+ ultimately have "(\<lambda>(r,x). (?f1 r x)) \<circ> g \<in> qbs_Mx Y"
	+ by (auto simp add: exp_qbs_Mx_def qbs_morphism_def)
	+ (metis (mono_tags, lifting) case_prod_conv comp_apply cond_case_prod_eta)
	+ moreover have "(\<lambda>(r,x). (?f1 r x)) \<circ> g = qbs_eval \<circ> f"
	+ by(auto simp add: case_prod_unfold g_def qbs_eval_def)
	+ ultimately show "qbs_eval \<circ> f \<in> qbs_Mx Y" by simp
	+qed
	+
	+lemma curry_morphism:
	+ "curry \<in> exp_qbs (X \<Otimes>\<^sub>Q Y) Z \<rightarrow>\<^sub>Q exp_qbs X (exp_qbs Y Z)"
	+proof(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def)
	+ fix k \<alpha> \<alpha>'
	+ assume h:"(\<lambda>(r, xy). k r xy) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ "\<alpha> \<in> pair_qbs_Mx \<real>\<^sub>Q X"
	+ "\<alpha>' \<in> pair_qbs_Mx \<real>\<^sub>Q Y"
	+ define \<beta> where
	+ "\<beta> \<equiv> (\<lambda>r. (fst (\<alpha> (fst (\<alpha>' r))),(snd (\<alpha> (fst (\<alpha>' r))), snd (\<alpha>' r))))"
	+ have "(\<lambda>(x, y). ((\<lambda>(x, y). (curry \<circ> k) x y) \<circ> \<alpha>) x y) \<circ> \<alpha>' = (\<lambda>(r, xy). k r xy) \<circ> \<beta>"
	+ by(simp add: curry_def split_beta' comp_def \<beta>_def)
	+ also have "... \<in> qbs_Mx Z"
	+ proof -
	+ have "\<beta> \<in> qbs_Mx (\<real>\<^sub>Q \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q Y)"
	+ using h(2,3) qbs_closed1_dest[of _ _ "(\<lambda>x. fst (\<alpha>' x))"]
	+ by(auto simp: pair_qbs_Mx_def \<beta>_def comp_def)
	+ thus ?thesis
	+ using h by auto
	+ qed
	+ finally show "(\<lambda>(x, y). ((\<lambda>(x, y). (curry \<circ> k) x y) \<circ> \<alpha>) x y) \<circ> \<alpha>' \<in> qbs_Mx Z" .
	+qed
	+
	+lemma curry_preserves_morphisms:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ shows "curry f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
	+ by(rule qbs_morphismE(2)[OF curry_morphism,simplified,OF assms])
	+
	+lemma uncurry_morphism:
	+ "case_prod \<in> exp_qbs X (exp_qbs Y Z) \<rightarrow>\<^sub>Q exp_qbs (X \<Otimes>\<^sub>Q Y) Z"
	+proof(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def)
	+ fix k \<alpha>
	+ assume h:"(\<lambda>(x, y). k x y) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q exp_qbs Y Z"
	+ "\<alpha> \<in> pair_qbs_Mx \<real>\<^sub>Q (X \<Otimes>\<^sub>Q Y)"
	+ have "(\<lambda>(x, y). (case_prod \<circ> k) x y) \<circ> \<alpha> = (\<lambda>(r,y). k (fst (\<alpha> r)) (fst (snd (\<alpha> r))) y) \<circ> (\<lambda>r. (r,snd (snd (\<alpha> r))))"
	+ by(simp add: split_beta' comp_def)
	+ also have "... \<in> qbs_Mx Z"
	+ proof(rule qbs_morphismE(3)[where X="\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"])
	+ have "(\<lambda>r. k (fst (\<alpha> r)) (fst (snd (\<alpha> r)))) = (\<lambda>(x, y). k x y) \<circ> (\<lambda>r. (fst (\<alpha> r),fst (snd (\<alpha> r))))"
	+ by auto
	+ also have "... \<in> qbs_Mx (exp_qbs Y Z)"
	+ apply(rule qbs_morphismE(3)[where X="\<real>\<^sub>Q \<Otimes>\<^sub>Q X"])
	+ using h(2) by(auto simp: h(1) pair_qbs_Mx_def comp_def)
	+ finally show " (\<lambda>(r, y). k (fst (\<alpha> r)) (fst (snd (\<alpha> r))) y) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ by(simp add: exp_qbs_Mx_def)
	+ next
	+ show "(\<lambda>r. (r, snd (snd (\<alpha> r)))) \<in> qbs_Mx (\<real>\<^sub>Q \<Otimes>\<^sub>Q Y)"
	+ using h(2) by(simp add: pair_qbs_Mx_def comp_def)
	+ qed
	+ finally show "(\<lambda>(x, y). (case_prod \<circ> k) x y) \<circ> \<alpha> \<in> qbs_Mx Z" .
	+qed
	+
	+lemma uncurry_preserves_morphisms:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
	+ shows "case_prod f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ by(rule qbs_morphismE(2)[OF uncurry_morphism,simplified,OF assms])
	+
	+lemma arg_swap_morphism:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
	+ shows "(\<lambda>y x. f x y) \<in> Y \<rightarrow>\<^sub>Q exp_qbs X Z"
	+ using curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF uncurry_preserves_morphisms[OF assms]]]
	+ by simp
	+
	+lemma exp_qbs_comp_morphism:
	+ assumes "f \<in> W \<rightarrow>\<^sub>Q exp_qbs X Y"
	+ and "g \<in> W \<rightarrow>\<^sub>Q exp_qbs Y Z"
	+ shows "(\<lambda>w. g w \<circ> f w) \<in> W \<rightarrow>\<^sub>Q exp_qbs X Z"
	+proof(rule qbs_exp_morphismI)
	+ fix \<alpha> \<beta>
	+ assume h: "\<alpha> \<in> qbs_Mx W"
	+ "\<beta> \<in> pair_qbs_Mx \<real>\<^sub>Q X"
	+ have "(\<lambda>(r, x). ((\<lambda>w. g w \<circ> f w) \<circ> \<alpha>) r x) \<circ> \<beta>= case_prod g \<circ> (\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, case_prod f ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r)))"
	+ by(simp add: split_beta' comp_def)
	+ also have "... \<in> qbs_Mx Z"
	+ proof -
	+ have "(\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, case_prod f ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r))) \<in> qbs_Mx (W \<Otimes>\<^sub>Q Y)"
	+ proof(auto simp add: pair_qbs_Mx_def)
	+ have "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) = \<alpha> \<circ> (fst \<circ> \<beta>)"
	+ by (simp add: comp_def)
	+ also have "... \<in> qbs_Mx W"
	+ using qbs_decomp[of W] h
	+ by(simp add: pair_qbs_Mx_def qbs_closed1_def)
	+ finally show "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) \<in> qbs_Mx W" .
	+ next
	+ have [simp]:"snd \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) = case_prod f \<circ> (\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r))"
	+ by(simp add: comp_def)
	+ have "(\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r)) \<in> qbs_Mx (W \<Otimes>\<^sub>Q X)"
	+ proof(auto simp add: pair_qbs_Mx_def)
	+ have "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), snd (\<beta> r)))= \<alpha> \<circ> (fst \<circ> \<beta>)"
	+ by (simp add: comp_def)
	+ also have "... \<in> qbs_Mx W"
	+ using qbs_decomp[of W] h
	+ by(simp add: pair_qbs_Mx_def qbs_closed1_def)
	+ finally show "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), snd (\<beta> r))) \<in> qbs_Mx W" .
	+ next
	+ show "snd \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), snd (\<beta> r))) \<in> qbs_Mx X"
	+ using h
	+ by(simp add: pair_qbs_Mx_def comp_def)
	+ qed
	+ hence "case_prod f \<circ> (\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r)) \<in> qbs_Mx Y"
	+ using uncurry_preserves_morphisms[OF assms(1)] by auto
	+ thus "snd \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) \<in> qbs_Mx Y"
	+ by simp
	+ qed
	+ thus ?thesis
	+ using uncurry_preserves_morphisms[OF assms(2)]
	+ by auto
	+ qed
	+ finally show "(\<lambda>(r, x). ((\<lambda>w. g w \<circ> f w) \<circ> \<alpha>) r x) \<circ> \<beta> \<in> qbs_Mx Z" .
	+qed
	+
	+lemma case_sum_morphism:
	+ "case_prod case_sum \<in> exp_qbs X Z \<Otimes>\<^sub>Q exp_qbs Y Z \<rightarrow>\<^sub>Q exp_qbs (X <+>\<^sub>Q Y) Z"
	+proof(rule qbs_exp_morphismI)
	+ fix \<alpha> \<beta>
	+ assume h0:"\<alpha> \<in> qbs_Mx (exp_qbs X Z \<Otimes>\<^sub>Q exp_qbs Y Z)"
	+ "\<beta> \<in> pair_qbs_Mx \<real>\<^sub>Q (X <+>\<^sub>Q Y)"
	+ let ?\<alpha>1 = "fst \<circ> \<alpha>"
	+ let ?\<alpha>2 = "snd \<circ> \<alpha>"
	+ let ?\<beta>1 = "fst \<circ> \<beta>"
	+ let ?\<beta>2 = "snd \<circ> \<beta>"
	+ have h:"?\<alpha>1 \<in> exp_qbs_Mx X Z"
	+ "?\<alpha>2 \<in> exp_qbs_Mx Y Z"
	+ "?\<beta>1 \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ "?\<beta>2 \<in> copair_qbs_Mx X Y"
	+ using h0 by (auto simp add: pair_qbs_Mx_def)
	+ hence "\<exists>S\<in>sets real_borel. (S = {} \<longrightarrow> (\<exists>\<alpha>1\<in>qbs_Mx X. ?\<beta>2 = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
	+ (S = UNIV \<longrightarrow> (\<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
	+ (S \<noteq> {} \<and> S \<noteq> UNIV \<longrightarrow>
	+ (\<exists>\<alpha>1\<in>qbs_Mx X. \<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))"
	+ by(simp add: copair_qbs_Mx_def)
	+ then obtain S :: "real set" where hs:
	+ "S\<in>sets real_borel \<and> (S = {} \<longrightarrow> (\<exists>\<alpha>1\<in>qbs_Mx X. ?\<beta>2 = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
	+ (S = UNIV \<longrightarrow> (\<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
	+ (S \<noteq> {} \<and> S \<noteq> UNIV \<longrightarrow>
	+ (\<exists>\<alpha>1\<in>qbs_Mx X. \<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))"
	+ by auto
	+ show "(\<lambda>(r, x). ((\<lambda>(x, y). case_sum x y) \<circ> \<alpha>) r x) \<circ> \<beta> \<in> qbs_Mx Z"
	+ proof -
	+ have "(\<lambda>(r, x). ((\<lambda>(x, y). case_sum x y) \<circ> \<alpha>) r x) \<circ> \<beta> = (\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r))"
	+ (is "?lhs = ?rhs")
	+ by(auto simp: split_beta' comp_def) (metis comp_apply)
	+ also have "... \<in> qbs_Mx Z"
	+ (is "?f \<in> _")
	+ proof -
	+ consider "S = {}" \| "S = UNIV" \| "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
	+ then show ?thesis
	+ proof cases
	+ case 1
	+ then obtain \<alpha>1 where h1:
	+ "\<alpha>1\<in>qbs_Mx X \<and> ?\<beta>2 = (\<lambda>r. Inl (\<alpha>1 r))"
	+ using hs by auto
	+ then have "(\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r)) = (\<lambda>r. ?\<alpha>1 (?\<beta>1 r) (\<alpha>1 r))"
	+ by simp
	+ also have "... = case_prod ?\<alpha>1 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>1 r))"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
	+ apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"])
	+ apply(rule qbs_morphism_tuple)
	+ using h(3)
	+ apply blast
	+ using qbs_Mx_is_morphisms h1
	+ apply blast
	+ using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"] h(1)
	+ by (simp add: exp_qbs_Mx_def)
	+ finally show ?thesis
	+ using qbs_Mx_is_morphisms by auto
	+ next
	+ case 2
	+ then obtain \<alpha>2 where h2:
	+ "\<alpha>2\<in>qbs_Mx Y \<and> ?\<beta>2 = (\<lambda>r. Inr (\<alpha>2 r))"
	+ using hs by auto
	+ then have "(\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r)) = (\<lambda>r. ?\<alpha>2 (?\<beta>1 r) (\<alpha>2 r))"
	+ by simp
	+ also have "... = case_prod ?\<alpha>2 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>2 r))"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
	+ apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"])
	+ apply(rule qbs_morphism_tuple)
	+ using h(3)
	+ apply blast
	+ using qbs_Mx_is_morphisms h2
	+ apply blast
	+ using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"] h(2)
	+ by (simp add: exp_qbs_Mx_def)
	+ finally show ?thesis
	+ using qbs_Mx_is_morphisms by auto
	+ next
	+ case 3
	+ then obtain \<alpha>1 \<alpha>2 where h3:
	+ "\<alpha>1\<in>qbs_Mx X \<and> \<alpha>2\<in>qbs_Mx Y \<and> ?\<beta>2 = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))"
	+ using hs by auto
	+ define P :: "real \<Rightarrow> nat"
	+ where "P \<equiv> (\<lambda>r. if r \<in> S then 0 else 1)"
	+ define \<gamma> :: "nat \<Rightarrow> real \<Rightarrow> _"
	+ where "\<gamma> \<equiv> (\<lambda>n r. if n = 0 then ?\<alpha>1 (?\<beta>1 r) (\<alpha>1 r) else ?\<alpha>2 (?\<beta>1 r) (\<alpha>2 r))"
	+ then have "(\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r)) =(\<lambda>r. \<gamma> (P r) r)"
	+ by(auto simp add: P_def \<gamma>_def h3)
	+ also have "... \<in> qbs_Mx Z"
	+ proof -
	+ have "\<forall>i. P -` {i} \<in> sets real_borel"
	+ using hs borel_comp[of S] by(simp add: P_def)
	+ moreover have"\<forall>i. \<gamma> i \<in> qbs_Mx Z"
	+ proof
	+ fix i :: nat
	+ consider "i = 0" \| "i \<noteq> 0" by auto
	+ then show "\<gamma> i \<in> qbs_Mx Z"
	+ proof cases
	+ case 1
	+ then have "\<gamma> i = (\<lambda>r. ?\<alpha>1 (?\<beta>1 r) (\<alpha>1 r))"
	+ by(simp add: \<gamma>_def)
	+ also have "... = case_prod ?\<alpha>1 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>1 r))"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
	+ apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"])
	+ apply(rule qbs_morphism_tuple)
	+ using h(3)
	+ apply blast
	+ using qbs_Mx_is_morphisms h3
	+ apply blast
	+ using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"] h(1)
	+ by (simp add: exp_qbs_Mx_def)
	+ finally show ?thesis
	+ using qbs_Mx_is_morphisms by auto
	+ next
	+ case 2
	+ then have "\<gamma> i = (\<lambda>r. ?\<alpha>2 (?\<beta>1 r) (\<alpha>2 r))"
	+ by(simp add: \<gamma>_def)
	+ also have "... = case_prod ?\<alpha>2 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>2 r))"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
	+ apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"])
	+ apply(rule qbs_morphism_tuple)
	+ using h(3)
	+ apply blast
	+ using qbs_Mx_is_morphisms h3
	+ apply blast
	+ using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"] h(2)
	+ by (simp add: exp_qbs_Mx_def)
	+ finally show ?thesis
	+ using qbs_Mx_is_morphisms by auto
	+ qed
	+ qed
	+ ultimately show ?thesis
	+ using qbs_decomp[of Z]
	+ by(simp add: qbs_closed3_def)
	+ qed
	+ finally show ?thesis .
	+ qed
	+ qed
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+
	+lemma not_qbs_morphism:
	+ "Not \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q \<bool>\<^sub>Q"
	+ by(auto intro!: bool_qbs_morphism)
	+
	+lemma or_qbs_morphism:
	+ "(\<or>) \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<bool>\<^sub>Q \<bool>\<^sub>Q"
	+ by(auto intro!: bool_qbs_morphism)
	+
	+lemma and_qbs_morphism:
	+ "(\<and>) \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<bool>\<^sub>Q \<bool>\<^sub>Q"
	+ by(auto intro!: bool_qbs_morphism)
	+
	+lemma implies_qbs_morphism:
	+ "(\<longrightarrow>) \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q \<bool>\<^sub>Q \<Rightarrow>\<^sub>Q \<bool>\<^sub>Q"
	+ by(auto intro!: bool_qbs_morphism)
	+
	+
	+lemma less_nat_qbs_morphism:
	+ "(<) \<in> \<nat>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<nat>\<^sub>Q \<bool>\<^sub>Q"
	+ by(auto intro!: nat_qbs_morphism)
	+
	+lemma less_real_qbs_morphism:
	+ "(<) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q \<bool>\<^sub>Q"
	+proof(rule curry_preserves_morphisms[where f="(\<lambda>(z :: real \<times> real). fst z < snd z)",simplified curry_def,simplified])
	+ have "(\<lambda>z. fst z < snd z) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M bool_borel"
	+ using borel_measurable_pred_less[OF measurable_fst measurable_snd,simplified measurable_cong_sets[OF refl sets_borel_eq_count_space[symmetric],of "borel \<Otimes>\<^sub>M borel"]]
	+ by simp
	+ thus "(\<lambda>z. fst z < snd z) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<bool>\<^sub>Q"
	+ by auto
	+qed
	+
	+
	+lemma rec_list_morphism':
	+ "rec_list' \<in> qbs_space (exp_qbs Y (exp_qbs (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) (exp_qbs (list_of X) Y)))"
	+ apply(simp,rule curry_preserves_morphisms[where f="\<lambda>yf. rec_list' (fst yf) (snd yf)",simplified curry_def, simplified])
	+ apply(rule arg_swap_morphism)
	+proof(rule coprod_qbs_canonical1')
	+ fix n
	+ show "(\<lambda>x y. rec_list' (fst y) (snd y) (n, x)) \<in> (\<Pi>\<^sub>Q i\<in>{..<n}. X) \<rightarrow>\<^sub>Q exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y"
	+ proof(induction n)
	+ case 0
	+ show ?case
	+ proof(rule curry_preserves_morphisms[of " (\<lambda>(x,y). rec_list' (fst y) (snd y) (0, x))", simplified],rule qbs_morphismI)
	+ fix \<alpha>
	+ assume h:"\<alpha> \<in> qbs_Mx ((\<Pi>\<^sub>Q i\<in>{..<0::nat}. X) \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)))"
	+ have "\<And>r. fst (\<alpha> r) = (\<lambda>n. undefined)"
	+ proof -
	+ fix r
	+ have "\<And>i. (\<lambda>r. fst (\<alpha> r) i) = (\<lambda>r. undefined)"
	+ using h by(auto simp: exp_qbs_Mx_def prod_qbs_Mx_def pair_qbs_Mx_def comp_def split_beta')
	+ thus "fst (\<alpha> r) = (\<lambda>n. undefined)"
	+ by(fastforce dest: fun_cong)
	+ qed
	+ hence "(\<lambda>(x, y). rec_list' (fst y) (snd y) (0, x)) \<circ> \<alpha> = (\<lambda>x. fst (snd (\<alpha> x)))"
	+ by(auto simp: rec_list'_simp1 comp_def split_beta')
	+ also have "... \<in> qbs_Mx Y"
	+ using h by(auto simp: pair_qbs_Mx_def comp_def)
	+ finally show "(\<lambda>(x, y). rec_list' (fst y) (snd y) (0, x)) \<circ> \<alpha> \<in> qbs_Mx Y" .
	+ qed
	+ next
	+ case ih:(Suc n)
	+ show ?case
	+ proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume h:"\<alpha> \<in> qbs_Mx (\<Pi>\<^sub>Q i\<in>{..<Suc n}. X)"
	+ define \<alpha>' where "\<alpha>' \<equiv> (\<lambda>r. snd (list_tail (Suc n, \<alpha> r)))"
	+ define a where "a \<equiv> (\<lambda>r. \<alpha> r 0)"
	+ then have ha:"a \<in> qbs_Mx X"
	+ using h by(auto simp: prod_qbs_Mx_def)
	+ have 1:"\<alpha>' \<in> qbs_Mx (\<Pi>\<^sub>Q i\<in>{..<n}. X)"
	+ using h by(fastforce simp: prod_qbs_Mx_def list_tail_def \<alpha>'_def)
	+ hence 2: "\<And>r. (n, \<alpha>' r) \<in> qbs_space (list_of X)"
	+ using qbs_Mx_to_X[of \<alpha>'] by fastforce
	+ have 3: "\<And>r. (Suc n, \<alpha> r) \<in> qbs_space (list_of X)"
	+ using qbs_Mx_to_X[of \<alpha>] h by fastforce
	+ have 4: "\<And>r. (n, \<alpha>' r) = list_tail (Suc n, \<alpha> r)"
	+ by(simp add: list_tail_def \<alpha>'_def)
	+ have 5: "\<And>r. (Suc n, \<alpha> r) = list_cons (a r) (n, \<alpha>' r)"
	+ unfolding a_def by(simp add: list_simp5[OF 3,simplified 4[symmetric],simplified list_head_def]) auto
	+ have 6: "(\<lambda>r. (n, \<alpha>' r)) \<in> qbs_Mx (list_of X)"
	+ using 1 by(auto intro!: coprod_qbs_MxI)
	+
	+ have "(\<lambda>x y. rec_list' (fst y) (snd y) (Suc n, x)) \<circ> \<alpha> = (\<lambda>r y. rec_list' (fst y) (snd y) (Suc n, \<alpha> r))"
	+ by auto
	+ also have "... = (\<lambda>r y. snd y (a r) (n, \<alpha>' r) (rec_list' (fst y) (snd y) (n, \<alpha>' r)))"
	+ by(simp only: 5 rec_list'_simp2[OF 2])
	+ also have "... \<in> qbs_Mx (exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y)"
	+ proof -
	+ have "(\<lambda>(r,y). snd y (a r) (n, \<alpha>' r) (rec_list' (fst y) (snd y) (n, \<alpha>' r))) = (\<lambda>(y,x1,x2,x3). y x1 x2 x3) \<circ> (\<lambda>(r,y). (snd y, a r, (n, \<alpha>' r), rec_list' (fst y) (snd y) (n, \<alpha>' r)))"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) \<rightarrow>\<^sub>Q Y"
	+ proof(rule qbs_morphism_comp[where Y="exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y"])
	+ show "(\<lambda>(r, y). (snd y, a r, (n, \<alpha>' r), rec_list' (fst y) (snd y) (n, \<alpha>' r))) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y"
	+ proof(auto simp: split_beta' intro!: qbs_morphism_tuple[OF qbs_morphism_snd''[OF snd_qbs_morphism] qbs_morphism_tuple[of "\<lambda>(r, y). a r" "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))" X], OF _ qbs_morphism_tuple[of "\<lambda>(r,y). (n, \<alpha>' r)"],of "list_of X" "\<lambda>(r,y). rec_list' (fst y) (snd y) (n, \<alpha>' r)",simplified split_beta'])
	+ show "(\<lambda>x. a (fst x)) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q X"
	+ using ha qbs_Mx_is_morphisms[of X] qbs_morphism_fst''[of a "\<real>\<^sub>Q" X] by auto
	+ next
	+ show "(\<lambda>x. (n, \<alpha>' (fst x))) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q list_of X"
	+ using qbs_morphism_fst''[of "\<lambda>r. (n, \<alpha>' r)" "\<real>\<^sub>Q" "list_of X"] qbs_Mx_is_morphisms[of "list_of X"] 6 by auto
	+ next
	+ show "(\<lambda>x. rec_list' (fst (snd x)) (snd (snd x)) (n, \<alpha>' (fst x))) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q Y"
	+ using qbs_morphismE(3)[OF ih 1, simplified comp_def] uncurry_preserves_morphisms[of "(\<lambda>x y. rec_list' (fst y) (snd y) (n, \<alpha>' x))" "\<real>\<^sub>Q" "Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))" Y] qbs_Mx_is_morphisms[of "exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y"]
	+ by(fastforce simp: split_beta')
	+ qed
	+ next
	+ show "(\<lambda>(y, x1, x2, x3). y x1 x2 x3) \<in> exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Y"
	+ proof(rule qbs_morphismI)
	+ fix \<beta>
	+ assume "\<beta> \<in> qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y)"
	+ then have "\<exists> \<beta>1 \<beta>2 \<beta>3 \<beta>4. \<beta> = (\<lambda>r. (\<beta>1 r, \<beta>2 r, \<beta>3 r, \<beta>4 r)) \<and> \<beta>1 \<in> qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) \<and> \<beta>2 \<in> qbs_Mx X \<and> \<beta>3 \<in> qbs_Mx (list_of X) \<and> \<beta>4 \<in> qbs_Mx Y"
	+ by(auto intro!: exI[where x="fst \<circ> \<beta>"] exI[where x="fst \<circ> snd \<circ> \<beta>"] exI[where x="fst \<circ> snd \<circ> snd \<circ> \<beta>"] exI[where x="snd \<circ> snd \<circ> snd \<circ> \<beta>"] simp:pair_qbs_Mx_def comp_def)
	+ then obtain \<beta>1 \<beta>2 \<beta>3 \<beta>4 where hb:
	+ "\<beta> = (\<lambda>r. (\<beta>1 r, \<beta>2 r, \<beta>3 r, \<beta>4 r))" "\<beta>1 \<in> qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)))" "\<beta>2 \<in> qbs_Mx X" "\<beta>3 \<in> qbs_Mx (list_of X)" "\<beta>4 \<in> qbs_Mx Y"
	+ by auto
	+ hence hbq:"(\<lambda>(((r,x1),x2),x3). \<beta>1 r x1 x2 x3) \<in> ((\<real>\<^sub>Q \<Otimes>\<^sub>Q X) \<Otimes>\<^sub>Q list_of X) \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Y"
	+ by(simp add: exp_qbs_Mx_def) (meson uncurry_preserves_morphisms)
	+ have "(\<lambda>(y, x1, x2, x3). y x1 x2 x3) \<circ> \<beta> = (\<lambda>(((r,x1),x2),x3). \<beta>1 r x1 x2 x3) \<circ> (\<lambda>r. (((r,\<beta>2 r), \<beta>3 r), \<beta>4 r))"
	+ by(auto simp: hb(1))
	+ also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Y"
	+ using hb(2-5)
	+ by(auto intro!: qbs_morphism_comp[OF qbs_morphism_tuple[OF qbs_morphism_tuple[OF qbs_morphism_tuple[OF qbs_morphism_ident']]] hbq] simp: qbs_Mx_is_morphisms)
	+ finally show "(\<lambda>(y, x1, x2, x3). y x1 x2 x3) \<circ> \<beta> \<in> qbs_Mx Y"
	+ by(simp add: qbs_Mx_is_morphisms)
	+ qed
	+ qed
	+ finally show ?thesis
	+ by(simp add: exp_qbs_Mx_def)
	+ qed
	+ finally show "(\<lambda>x y. rec_list' (fst y) (snd y) (Suc n, x)) \<circ> \<alpha> \<in> qbs_Mx (exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y)" .
	+ qed
	+ qed
	+qed simp
	+
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Measure_QuasiBorel_Adjunction.thy b/thys/Quasi_Borel_Spaces/Measure_QuasiBorel_Adjunction.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Measure_QuasiBorel_Adjunction.thy
	@@ -0,0 +1,731 @@
	+(* Title: Measure_QuasiBorel_Adjunction.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open>Relation to Measurable Spaces\<close>
	+
	+theory Measure_QuasiBorel_Adjunction
	+ imports "QuasiBorel"
	+begin
	+
	+text \<open> We construct the adjunction between \textbf{Meas} and \textbf{QBS},
	+ where \textbf{Meas} is the category of measurable spaces and measurable functions
	+ and \textbf{QBS} is the category of quasi-Borel spaces and morphisms.\<close>
	+
	+subsubsection \<open> The Functor $R$ \<close>
	+definition measure_to_qbs :: "'a measure \<Rightarrow> 'a quasi_borel" where
	+"measure_to_qbs X \<equiv> Abs_quasi_borel (space X, real_borel \<rightarrow>\<^sub>M X)"
	+
	+lemma R_Mx_correct: "real_borel \<rightarrow>\<^sub>M X \<subseteq> UNIV \<rightarrow> space X"
	+ by (simp add: measurable_space subsetI)
	+
	+lemma R_qbs_closed1: "qbs_closed1 (real_borel \<rightarrow>\<^sub>M X)"
	+ by (simp add: qbs_closed1_def)
	+
	+lemma R_qbs_closed2: "qbs_closed2 (space X) (real_borel \<rightarrow>\<^sub>M X)"
	+ by (simp add: qbs_closed2_def)
	+
	+lemma R_qbs_closed3: "qbs_closed3 (real_borel \<rightarrow>\<^sub>M (X :: 'a measure))"
	+proof(rule qbs_closed3I)
	+ fix P::"real \<Rightarrow> nat"
	+ fix Fi::"nat \<Rightarrow> real \<Rightarrow> 'a"
	+ assume h:"\<And>i. P -` {i} \<in> sets real_borel"
	+ "\<And>i. Fi i \<in> real_borel \<rightarrow>\<^sub>M X"
	+ show "(\<lambda>r. Fi (P r) r) \<in> real_borel \<rightarrow>\<^sub>M X"
	+ proof(rule measurableI)
	+ fix x
	+ assume "x \<in> space real_borel"
	+ then show "Fi (P x) x \<in> space X"
	+ using h(2) measurable_space[of "Fi (P x)" real_borel X x]
	+ by auto
	+ next
	+ fix A
	+ assume h':"A \<in> sets X"
	+ have "(\<lambda>r. Fi (P r) r) -` A = (\<Union>i::nat. ((Fi i -` A) \<inter> (P -` {i})))"
	+ by auto
	+ also have "... \<in> sets real_borel"
	+ using sets.Int measurable_sets[OF h(2) h'] h(1)
	+ by(auto intro!: countable_Un_Int(1))
	+ finally show "(\<lambda>r. Fi (P r) r) -` A \<inter> space real_borel \<in> sets real_borel"
	+ by simp
	+ qed
	+qed
	+
	+lemma R_correct[simp]: "Rep_quasi_borel (measure_to_qbs X) = (space X, real_borel \<rightarrow>\<^sub>M X)"
	+ unfolding measure_to_qbs_def
	+ by (rule Abs_quasi_borel_inverse) (simp add: R_Mx_correct R_qbs_closed1 R_qbs_closed2 R_qbs_closed3)
	+
	+lemma qbs_space_R[simp]: "qbs_space (measure_to_qbs X) = space X"
	+ by (simp add: qbs_space_def)
	+
	+lemma qbs_Mx_R[simp]: "qbs_Mx (measure_to_qbs X) = real_borel \<rightarrow>\<^sub>M X"
	+ by (simp add: qbs_Mx_def)
	+
	+
	+text \<open> The following lemma says that @{term measure_to_qbs} is a functor from \textbf{Meas} to \textbf{QBS}. \<close>
	+lemma r_preserves_morphisms:
	+ "X \<rightarrow>\<^sub>M Y \<subseteq> (measure_to_qbs X) \<rightarrow>\<^sub>Q (measure_to_qbs Y)"
	+ by(auto intro!: qbs_morphismI)
	+
	+subsubsection \<open> The Functor $L$ \<close>
	+definition sigma_Mx :: "'a quasi_borel \<Rightarrow> 'a set set" where
	+"sigma_Mx X \<equiv> {U \<inter> qbs_space X \|U. \<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` U \<in> sets real_borel}"
	+
	+definition qbs_to_measure :: "'a quasi_borel \<Rightarrow> 'a measure" where
	+"qbs_to_measure X \<equiv> Abs_measure (qbs_space X, sigma_Mx X, \<lambda>A. (if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>))"
	+
	+lemma measure_space_L: "measure_space (qbs_space X) (sigma_Mx X) (\<lambda>A. (if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>))"
	+ unfolding measure_space_def
	+proof auto
	+
	+ show "sigma_algebra (qbs_space X) (sigma_Mx X)"
	+ proof(rule sigma_algebra.intro)
	+ show "algebra (qbs_space X) (sigma_Mx X)"
	+ proof
	+ have "\<forall> U \<in> sigma_Mx X. U \<subseteq> qbs_space X"
	+ using sigma_Mx_def subset_iff by fastforce
	+ thus "sigma_Mx X \<subseteq> Pow (qbs_space X)" by auto
	+ next
	+ show "{} \<in> sigma_Mx X"
	+ unfolding sigma_Mx_def by auto
	+ next
	+ fix A
	+ fix B
	+ assume "A \<in> sigma_Mx X"
	+ "B \<in> sigma_Mx X"
	+ then have "\<exists> Ua. A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)"
	+ by (simp add: sigma_Mx_def)
	+ then obtain Ua where pa:"A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)" by auto
	+ have "\<exists> Ub. B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)"
	+ using \<open>B \<in> sigma_Mx X\<close> sigma_Mx_def by auto
	+ then obtain Ub where pb:"B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)" by auto
	+ from pa pb have [simp]:"\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (Ua \<inter> Ub) \<in> sets real_borel"
	+ by auto
	+ from this pa pb sigma_Mx_def have [simp]:"(Ua \<inter> Ub) \<inter> qbs_space X \<in> sigma_Mx X" by blast
	+ from pa pb have [simp]:"A \<inter> B = (Ua \<inter> Ub) \<inter> qbs_space X" by auto
	+ thus "A \<inter> B \<in> sigma_Mx X" by simp
	+ next
	+ fix A
	+ fix B
	+ assume "A \<in> sigma_Mx X"
	+ "B \<in> sigma_Mx X"
	+ then have "\<exists> Ua. A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)"
	+ by (simp add: sigma_Mx_def)
	+ then obtain Ua where pa:"A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)" by auto
	+ have "\<exists> Ub. B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)"
	+ using \<open>B \<in> sigma_Mx X\<close> sigma_Mx_def by auto
	+ then obtain Ub where pb:"B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)" by auto
	+ from pa pb have [simp]:"A - B = (Ua \<inter> -Ub) \<inter> qbs_space X" by auto
	+ from pa pb have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -`(Ua \<inter> -Ub) \<in> sets real_borel"
	+ by (metis Diff_Compl double_compl sets.Diff vimage_Compl vimage_Int)
	+ hence 1:"A - B \<in> sigma_Mx X"
	+ using sigma_Mx_def \<open>A - B = Ua \<inter> - Ub \<inter> qbs_space X\<close> by blast
	+ show "\<exists>C\<subseteq>sigma_Mx X. finite C \<and> disjoint C \<and> A - B = \<Union> C"
	+ proof
	+ show "{A - B} \<subseteq>sigma_Mx X \<and> finite {A-B} \<and> disjoint {A-B} \<and> A - B = \<Union> {A-B}"
	+ using 1 by auto
	+ qed
	+ next
	+ fix A
	+ fix B
	+ assume "A \<in> sigma_Mx X"
	+ "B \<in> sigma_Mx X"
	+ then have "\<exists> Ua. A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)"
	+ by (simp add: sigma_Mx_def)
	+ then obtain Ua where pa:"A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)" by auto
	+ have "\<exists> Ub. B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)"
	+ using \<open>B \<in> sigma_Mx X\<close> sigma_Mx_def by auto
	+ then obtain Ub where pb:"B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)" by auto
	+ from pa pb have "A \<union> B = (Ua \<union> Ub) \<inter> qbs_space X" by auto
	+ from pa pb have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -`(Ua \<union> Ub) \<in> sets real_borel" by auto
	+ then show "A \<union> B \<in> sigma_Mx X"
	+ unfolding sigma_Mx_def
	+ using \<open>A \<union> B = (Ua \<union> Ub) \<inter> qbs_space X\<close> by blast
	+ next
	+ have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (UNIV) \<in> sets real_borel"
	+ by simp
	+ thus "qbs_space X \<in> sigma_Mx X"
	+ unfolding sigma_Mx_def
	+ by blast
	+ qed
	+ next
	+ show "sigma_algebra_axioms (sigma_Mx X)"
	+ unfolding sigma_algebra_axioms_def
	+ proof(auto)
	+ fix A :: "nat \<Rightarrow> _"
	+ assume 1:"range A \<subseteq> sigma_Mx X"
	+ then have 2:"\<forall>i. \<exists>Ui. A i = Ui \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ui \<in> sets real_borel)"
	+ unfolding sigma_Mx_def by auto
	+ then have "\<exists> U :: nat \<Rightarrow> _. \<forall>i. A i = U i \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (U i) \<in> sets real_borel)"
	+ by (rule choice)
	+ from this obtain U where pu:"\<forall>i. A i = U i \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (U i) \<in> sets real_borel)"
	+ by auto
	+ hence "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (\<Union> (range U)) \<in> sets real_borel"
	+ by (simp add: countable_Un_Int(1) vimage_UN)
	+ from pu have "\<Union> (range A) = (\<Union>i::nat. (U i \<inter> qbs_space X))" by blast
	+ hence "\<Union> (range A) = \<Union> (range U) \<inter> qbs_space X" by auto
	+ thus "\<Union> (range A) \<in> sigma_Mx X"
	+ using sigma_Mx_def \<open>\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` \<Union> (range U) \<in> sets real_borel\<close> by blast
	+ qed
	+ qed
	+next
	+ show "countably_additive (sigma_Mx X) (\<lambda>A. if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>)"
	+ proof(rule countably_additiveI)
	+ fix A :: "nat \<Rightarrow> _"
	+ assume h:"range A \<subseteq> sigma_Mx X"
	+ "\<Union> (range A) \<in> sigma_Mx X"
	+ consider "\<Union> (range A) = {}" \| "\<Union> (range A) \<noteq> {}"
	+ by auto
	+ then show "(\<Sum>i. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else \<infinity>) =
	+ (if \<Union> (range A) = {} then 0 else if \<Union> (range A) \<in> - sigma_Mx X then 0 else (\<infinity> :: ennreal))"
	+ proof cases
	+ case 1
	+ then have "\<And>i. A i = {}"
	+ by simp
	+ thus ?thesis
	+ by(simp add: 1)
	+ next
	+ case 2
	+ then obtain j where hj:"A j \<noteq> {}"
	+ by auto
	+ have "(\<Sum>i. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
	+ proof -
	+ have hsum:"\<And>N f. sum f {..<N} \<le> (\<Sum>n. (f n :: ennreal))"
	+ by (simp add: sum_le_suminf)
	+ have hsum':"\<And>P f. (\<exists>j. j \<in> P \<and> f j = (\<infinity> :: ennreal)) \<Longrightarrow> finite P \<Longrightarrow> sum f P = \<infinity>"
	+ by auto
	+ have h1:"(\<Sum>i<j+1. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
	+ proof(rule hsum')
	+ show "\<exists>ja. ja \<in> {..<j + 1} \<and> (if A ja = {} then 0 else if A ja \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
	+ proof(rule exI[where x=j],rule conjI)
	+ have "A j \<in> sigma_Mx X"
	+ using h(1) by auto
	+ then show "(if A j = {} then 0 else if A j \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
	+ using hj by simp
	+ qed simp
	+ qed simp
	+ have "(\<Sum>i<j+1. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else \<infinity>) \<le> (\<Sum>i. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else (\<infinity> :: ennreal))"
	+ by(rule hsum)
	+ thus ?thesis
	+ by(simp only: h1) (simp add: top.extremum_unique)
	+ qed
	+ moreover have "(if \<Union> (range A) = {} then 0 else if \<Union> (range A) \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
	+ using 2 h(2) by simp
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+ qed
	+qed(simp add: positive_def)
	+
	+
	+lemma L_correct[simp]:"Rep_measure (qbs_to_measure X) = (qbs_space X, sigma_Mx X, \<lambda>A. (if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>))"
	+ unfolding qbs_to_measure_def
	+ by(auto intro!: Abs_measure_inverse simp: measure_space_L)
	+
	+lemma space_L[simp]: "space (qbs_to_measure X) = qbs_space X"
	+ by (simp add: space_def)
	+
	+lemma sets_L[simp]: "sets (qbs_to_measure X) = sigma_Mx X"
	+ by (simp add: sets_def)
	+
	+lemma emeasure_L[simp]: "emeasure (qbs_to_measure X) = (\<lambda>A. if A = {} \<or> A \<notin> sigma_Mx X then 0 else \<infinity>)"
	+ by(auto simp: emeasure_def)
	+
	+lemma qbs_Mx_sigma_Mx_contra:
	+ assumes "qbs_space X = qbs_space Y"
	+ and "qbs_Mx X \<subseteq> qbs_Mx Y"
	+ shows "sigma_Mx Y \<subseteq> sigma_Mx X"
	+ using assms by(auto simp: sigma_Mx_def)
	+
	+
	+text \<open> The following lemma says that @{term qbs_to_measure} is a functor from \textbf{QBS} to \textbf{Meas}. \<close>
	+lemma l_preserves_morphisms:
	+ "X \<rightarrow>\<^sub>Q Y \<subseteq> (qbs_to_measure X) \<rightarrow>\<^sub>M (qbs_to_measure Y)"
	+proof(auto)
	+ fix f
	+ assume h:"f \<in> X \<rightarrow>\<^sub>Q Y"
	+ show "f \<in> (qbs_to_measure X) \<rightarrow>\<^sub>M (qbs_to_measure Y)"
	+ proof(rule measurableI)
	+ fix x
	+ assume "x \<in> space (qbs_to_measure X)"
	+ then show "f x \<in> space (qbs_to_measure Y)"
	+ using h by auto
	+ next
	+ fix A
	+ assume "A \<in> sets (qbs_to_measure Y)"
	+ then obtain Ua where pa:"A = Ua \<inter> qbs_space Y \<and> (\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` Ua \<in> sets real_borel)"
	+ by (auto simp: sigma_Mx_def)
	+ have "\<forall>\<alpha>\<in>qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx Y"
	+ "\<forall>\<alpha>\<in> qbs_Mx X. \<alpha> -` (f -` (qbs_space Y)) = UNIV"
	+ using h by auto
	+ hence "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (f -` A) = \<alpha> -` (f -` Ua)"
	+ by (simp add: pa)
	+ from pa this qbs_morphism_def have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (f -` A) \<in> sets real_borel"
	+ by (simp add: vimage_comp \<open>\<forall>\<alpha>\<in>qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx Y\<close>)
	+ thus "f -` A \<inter> space (qbs_to_measure X) \<in> sets (qbs_to_measure X)"
	+ using sigma_Mx_def by auto
	+ qed
	+qed
	+
	+
	+abbreviation "qbs_borel \<equiv> measure_to_qbs borel"
	+
	+declare [[coercion measure_to_qbs]]
	+
	+abbreviation real_quasi_borel :: "real quasi_borel" ("\<real>\<^sub>Q") where
	+"real_quasi_borel \<equiv> qbs_borel"
	+abbreviation nat_quasi_borel :: "nat quasi_borel" ("\<nat>\<^sub>Q") where
	+"nat_quasi_borel \<equiv> qbs_borel"
	+abbreviation ennreal_quasi_borel :: "ennreal quasi_borel" ("\<real>\<^sub>Q\<^sub>\<ge>\<^sub>0") where
	+"ennreal_quasi_borel \<equiv> qbs_borel"
	+abbreviation bool_quasi_borel :: "bool quasi_borel" ("\<bool>\<^sub>Q") where
	+"bool_quasi_borel \<equiv> qbs_borel"
	+
	+
	+lemma qbs_Mx_is_morphisms:
	+ "qbs_Mx X = real_quasi_borel \<rightarrow>\<^sub>Q X"
	+proof(auto)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx X"
	+ then have "\<alpha> \<in> UNIV \<rightarrow> qbs_space X \<and> (\<forall> f \<in> real_borel \<rightarrow>\<^sub>M real_borel. \<alpha> \<circ> f \<in> qbs_Mx X)"
	+ by fastforce
	+ thus "\<alpha> \<in> real_quasi_borel \<rightarrow>\<^sub>Q X"
	+ by(simp add: qbs_morphism_def)
	+next
	+ fix \<alpha>
	+ assume "\<alpha> \<in> real_quasi_borel \<rightarrow>\<^sub>Q X"
	+ have "id \<in> qbs_Mx real_quasi_borel" by simp
	+ then have "\<alpha> \<circ> id \<in> qbs_Mx X"
	+ using \<open>\<alpha> \<in> real_quasi_borel \<rightarrow>\<^sub>Q X\<close> qbs_morphism_def[of real_quasi_borel X]
	+ by blast
	+ then show "\<alpha> \<in> qbs_Mx X" by simp
	+qed
	+
	+lemma qbs_Mx_subset_of_measurable:
	+ "qbs_Mx X \<subseteq> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
	+proof
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx X"
	+ show "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
	+ proof(rule measurableI)
	+ fix x
	+ show "\<alpha> x \<in> space (qbs_to_measure X)"
	+ using qbs_decomp \<open>\<alpha> \<in> qbs_Mx X\<close> by auto
	+ next
	+ fix A
	+ assume "A \<in> sets (qbs_to_measure X)"
	+ then have "\<alpha> -`(qbs_space X) = UNIV"
	+ using \<open>\<alpha> \<in> qbs_Mx X\<close> qbs_decomp by auto
	+ then show "\<alpha> -` A \<inter> space real_borel \<in> sets real_borel"
	+ using \<open>\<alpha> \<in> qbs_Mx X\<close> \<open>A \<in> sets (qbs_to_measure X)\<close>
	+ by(auto simp add: sigma_Mx_def)
	+ qed
	+qed
	+
	+lemma L_max_of_measurables:
	+ assumes "space M = qbs_space X"
	+ and "qbs_Mx X \<subseteq> real_borel \<rightarrow>\<^sub>M M"
	+ shows "sets M \<subseteq> sets (qbs_to_measure X)"
	+proof
	+ fix U
	+ assume "U \<in> sets M"
	+ from sets.sets_into_space[OF this] in_mono[OF assms(2)] measurable_sets_borel[OF _ this]
	+ show "U \<in> sets (qbs_to_measure X)"
	+ using assms(1)
	+ by(auto intro!: exI[where x=U] simp: sigma_Mx_def)
	+qed
	+
	+
	+lemma qbs_Mx_are_measurable[simp,measurable]:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ shows "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
	+ using assms qbs_Mx_subset_of_measurable by auto
	+
	+lemma measure_to_qbs_cong_sets:
	+ assumes "sets M = sets N"
	+ shows "measure_to_qbs M = measure_to_qbs N"
	+ by(rule qbs_eqI) (simp add: measurable_cong_sets[OF _ assms])
	+
	+lemma lr_sets[simp,measurable_cong]:
	+ "sets X \<subseteq> sets (qbs_to_measure (measure_to_qbs X))"
	+proof auto
	+ fix U
	+ assume "U \<in> sets X"
	+ then have "U \<inter> space X = U" by simp
	+ moreover have "\<forall>\<alpha>\<in>real_borel \<rightarrow>\<^sub>M X. \<alpha> -` U \<in> sets real_borel"
	+ using \<open>U \<in> sets X\<close> by(auto simp add: measurable_def)
	+ ultimately show "U \<in> sigma_Mx (measure_to_qbs X)"
	+ by(auto simp add: sigma_Mx_def)
	+qed
	+
	+lemma(in standard_borel) standard_borel_lr_sets_ident[simp, measurable_cong]:
	+ "sets (qbs_to_measure (measure_to_qbs M)) = sets M"
	+proof auto
	+ fix V
	+ assume "V \<in> sigma_Mx (measure_to_qbs M)"
	+ then obtain U where H2: "V = U \<inter> space M \<and> (\<forall>\<alpha>\<in>real_borel \<rightarrow>\<^sub>M M. \<alpha> -` U \<in> sets real_borel)"
	+ by(auto simp: sigma_Mx_def)
	+ hence "g -` V = g -` (U \<inter> space M)" by auto
	+ have "... = g -` U" using g_meas by(auto simp add: measurable_def)
	+ hence "f -` g -` U \<inter> space M \<in> sets M"
	+ by (meson f_meas g_meas measurable_sets H2)
	+ moreover have "f -` g -` U \<inter> space M = U \<inter> space M"
	+ by auto
	+ ultimately show "V \<in> sets M" using H2 by simp
	+next
	+ fix U
	+ assume "U \<in> sets M"
	+ then show "U \<in> sigma_Mx (measure_to_qbs M)"
	+ using lr_sets by auto
	+qed
	+
	+
	+subsubsection \<open> The Adjunction \<close>
	+lemma lr_adjunction_correspondence :
	+ "X \<rightarrow>\<^sub>Q (measure_to_qbs Y) = (qbs_to_measure X) \<rightarrow>\<^sub>M Y"
	+proof(auto)
	+(* \<subseteq> *)
	+ fix f
	+ assume "f \<in> X \<rightarrow>\<^sub>Q (measure_to_qbs Y)"
	+ show "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
	+ proof(rule measurableI)
	+ fix x
	+ assume "x \<in> space (qbs_to_measure X)"
	+ hence "x \<in> qbs_space X" by simp
	+ thus "f x \<in> space Y"
	+ using \<open>f \<in> X \<rightarrow>\<^sub>Q (measure_to_qbs Y)\<close> qbs_morphismE[of f X "measure_to_qbs Y"]
	+ by auto
	+ next
	+ fix A
	+ assume "A \<in> sets Y"
	+ have "\<forall>\<alpha> \<in> qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx (measure_to_qbs Y)"
	+ using \<open>f \<in> X \<rightarrow>\<^sub>Q (measure_to_qbs Y)\<close> by auto
	+ hence "\<forall>\<alpha> \<in> qbs_Mx X. f \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M Y" by simp
	+ hence "\<forall>\<alpha> \<in> qbs_Mx X. \<alpha> -` (f -` A) \<in> sets real_borel"
	+ using \<open>A\<in> sets Y\<close> measurable_sets_borel vimage_comp by metis
	+ thus "f -` A \<inter> space (qbs_to_measure X) \<in> sets (qbs_to_measure X)"
	+ using sigma_Mx_def by auto
	+ qed
	+
	+(* \<supseteq> *)
	+next
	+ fix f
	+ assume "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
	+ show "f \<in> X \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+ proof(rule qbs_morphismI,simp)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx X"
	+ show "f \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M Y"
	+ proof(rule measurableI)
	+ fix x
	+ assume "x \<in> space real_borel"
	+ from this \<open>\<alpha> \<in> qbs_Mx X \<close>qbs_decomp have "\<alpha> x \<in> qbs_space X" by auto
	+ hence "\<alpha> x \<in> space (qbs_to_measure X)" by simp
	+ thus "(f \<circ> \<alpha>) x \<in> space Y"
	+ using \<open>f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y\<close>
	+ by (metis comp_def measurable_space)
	+ next
	+ fix A
	+ assume "A \<in> sets Y"
	+ from \<open>f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y\<close> measurable_sets this measurable_def
	+ have "f -` A \<inter> space (qbs_to_measure X) \<in> sets (qbs_to_measure X)"
	+ by blast
	+ hence "f -` A \<inter> qbs_space X \<in> sigma_Mx X" by simp
	+ then have "\<exists> V. f -` A \<inter> qbs_space X = V \<inter> qbs_space X \<and> (\<forall>\<beta>\<in> qbs_Mx X. \<beta> -` V \<in> sets real_borel)"
	+ by (simp add:sigma_Mx_def)
	+ then obtain V where h:"f -` A \<inter> qbs_space X = V \<inter> qbs_space X \<and> (\<forall>\<beta>\<in> qbs_Mx X. \<beta> -` V \<in> sets real_borel)" by auto
	+ have 1:"\<alpha> -` (f -` A) = \<alpha> -` (f -` A \<inter> qbs_space X)"
	+ using \<open>\<alpha> \<in> qbs_Mx X\<close> by blast
	+ have 2:"\<alpha> -` (V \<inter> qbs_space X) = \<alpha> -` V"
	+ using \<open>\<alpha> \<in> qbs_Mx X\<close> by blast
	+ from 1 2 h have "(f \<circ> \<alpha>) -` A = \<alpha> -` V" by (simp add: vimage_comp)
	+ from this h \<open>\<alpha> \<in> qbs_Mx X \<close>show "(f \<circ> \<alpha>) -` A \<inter> space real_borel \<in> sets real_borel" by simp
	+ qed
	+ qed
	+qed
	+
	+lemma(in standard_borel) standard_borel_r_full_faithful:
	+ "M \<rightarrow>\<^sub>M Y = measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+proof(standard;standard)
	+ fix h
	+ assume "h \<in> M \<rightarrow>\<^sub>M Y"
	+ then show "h \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+ using r_preserves_morphisms by auto
	+next
	+ fix h
	+ assume h:"h \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+ show "h \<in> M \<rightarrow>\<^sub>M Y"
	+ proof(rule measurableI)
	+ fix x
	+ assume "x \<in> space M"
	+ then show "h x \<in> space Y"
	+ using h by auto
	+ next
	+ fix U
	+ assume "U \<in> sets Y"
	+ have "h \<circ> g \<in> real_borel \<rightarrow>\<^sub>M Y"
	+ using \<open>h \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y\<close>
	+ by(simp add: qbs_morphism_def)
	+ hence "(h \<circ> g) -` U \<in> sets real_borel"
	+ by (simp add: \<open>U \<in> sets Y\<close> measurable_sets_borel)
	+ hence "f -` ((h \<circ> g) -` U) \<inter> space M \<in> sets M"
	+ using f_meas in_borel_measurable_borel by blast
	+ moreover have "f -` ((h \<circ> g) -` U) \<inter> space M = h -` U \<inter> space M"
	+ using f_meas by auto
	+ ultimately show "h -` U \<inter> space M \<in> sets M" by simp
	+ qed
	+qed
	+
	+lemma qbs_morphism_dest[dest]:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+ shows "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
	+ using assms lr_adjunction_correspondence by auto
	+
	+lemma(in standard_borel) qbs_morphism_dest[dest]:
	+ assumes "k \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+ shows "k \<in> M \<rightarrow>\<^sub>M Y"
	+ using standard_borel_r_full_faithful assms by auto
	+
	+lemma qbs_morphism_measurable_intro[intro!]:
	+ assumes "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
	+ shows "f \<in> X \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+ using assms lr_adjunction_correspondence by auto
	+
	+lemma(in standard_borel) qbs_morphism_measurable_intro[intro!]:
	+ assumes "k \<in> M \<rightarrow>\<^sub>M Y"
	+ shows "k \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
	+ using standard_borel_r_full_faithful assms by auto
	+
	+text \<open> We can use the measurability prover when we reason about morphisms. \<close>
	+lemma
	+ assumes "f \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ shows "(\<lambda>x. 2 * f x + (f x)^2) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using assms by auto
	+
	+lemma
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "\<alpha> \<in> qbs_Mx X"
	+ shows "(\<lambda>x. 2 * f (\<alpha> x) + (f (\<alpha> x))^2) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using assms by auto
	+
	+
	+lemma qbs_morphisn_from_countable:
	+ fixes X :: "'a quasi_borel"
	+ assumes "countable (qbs_space X)"
	+ "qbs_Mx X \<subseteq> real_borel \<rightarrow>\<^sub>M count_space (qbs_space X)"
	+ and "\<And>i. i \<in> qbs_space X \<Longrightarrow> f i \<in> qbs_space Y"
	+ shows "f \<in> X \<rightarrow>\<^sub>Q Y"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx X"
	+ then have [measurable]: "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M count_space (qbs_space X)"
	+ using assms(2) ..
	+ define k :: "'a \<Rightarrow> real \<Rightarrow> _"
	+ where "k \<equiv> (\<lambda>i _. f i)"
	+ have "f \<circ> \<alpha> = (\<lambda>r. k (\<alpha> r) r)"
	+ by(auto simp add: k_def)
	+ also have "... \<in> qbs_Mx Y"
	+ by(rule qbs_closed3_dest2[OF assms(1)]) (use assms(3) k_def in simp_all)
	+ finally show "f \<circ> \<alpha> \<in> qbs_Mx Y" .
	+qed
	+
	+corollary nat_qbs_morphism:
	+ assumes "\<And>n. f n \<in> qbs_space Y"
	+ shows "f \<in> \<nat>\<^sub>Q \<rightarrow>\<^sub>Q Y"
	+ using assms measurable_cong_sets[OF refl sets_borel_eq_count_space,of real_borel]
	+ by(auto intro!: qbs_morphisn_from_countable)
	+
	+corollary bool_qbs_morphism:
	+ assumes "\<And>b. f b \<in> qbs_space Y"
	+ shows "f \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q Y"
	+ using assms measurable_cong_sets[OF refl sets_borel_eq_count_space,of real_borel]
	+ by(auto intro!: qbs_morphisn_from_countable)
	+
	+
	+subsubsection \<open> The Adjunction w.r.t. Ordering\<close>
	+lemma l_mono:
	+ "mono qbs_to_measure"
	+ apply standard
	+ subgoal for X Y
	+ proof(induction rule: less_eq_quasi_borel.induct)
	+ case (1 X Y)
	+ then show ?case
	+ by(simp add: less_eq_measure.intros(1))
	+ next
	+ case (2 X Y)
	+ then have "sigma_Mx X \<subseteq> sigma_Mx Y"
	+ by(auto simp add: sigma_Mx_def)
	+ then consider "sigma_Mx X \<subset> sigma_Mx Y" \| "sigma_Mx X = sigma_Mx Y"
	+ by auto
	+ then show ?case
	+ apply(cases)
	+ apply(rule less_eq_measure.intros(2))
	+ apply(simp_all add: 2)
	+ by(rule less_eq_measure.intros(3),simp_all add: 2)
	+ qed
	+ done
	+
	+lemma r_mono:
	+ "mono measure_to_qbs"
	+ apply standard
	+ subgoal for M N
	+ proof(induction rule: less_eq_measure.inducts)
	+ case (1 M N)
	+ then show ?case
	+ by(simp add: less_eq_quasi_borel.intros(1))
	+ next
	+ case (2 M N)
	+ then have "real_borel \<rightarrow>\<^sub>M N \<subseteq> real_borel \<rightarrow>\<^sub>M M"
	+ by(simp add: measurable_mono)
	+ then consider "real_borel \<rightarrow>\<^sub>M N \<subset> real_borel \<rightarrow>\<^sub>M M" \| "real_borel \<rightarrow>\<^sub>M N = real_borel \<rightarrow>\<^sub>M M"
	+ by auto
	+ then show ?case
	+ by cases (rule less_eq_quasi_borel.intros(2),simp_all add: 2)+
	+ next
	+ case (3 M N)
	+ then show ?case
	+ apply -
	+ by(rule less_eq_quasi_borel.intros(2)) (simp_all add: measurable_mono)
	+ qed
	+ done
	+
	+lemma rl_order_adjunction:
	+ "X \<le> qbs_to_measure Y \<longleftrightarrow> measure_to_qbs X \<le> Y"
	+proof
	+ assume 1: "X \<le> qbs_to_measure Y"
	+ then show "measure_to_qbs X \<le> Y"
	+ proof(induction rule: less_eq_measure.cases)
	+ case (1 M N)
	+ then have [simp]:"qbs_space Y = space N"
	+ by(simp add: 1(2)[symmetric])
	+ show ?case
	+ by(rule less_eq_quasi_borel.intros(1),simp add: 1)
	+ next
	+ case (2 M N)
	+ then have [simp]:"qbs_space Y = space N"
	+ by(simp add: 2(2)[symmetric])
	+ show ?case
	+ proof(rule less_eq_quasi_borel.intros(2),simp add:2,auto)
	+ fix \<alpha>
	+ assume h:"\<alpha> \<in> qbs_Mx Y"
	+ show "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
	+ proof(rule measurableI,simp_all)
	+ show "\<And>x. \<alpha> x \<in> space X"
	+ using h by (auto simp add: 2)
	+ next
	+ fix A
	+ assume "A \<in> sets X"
	+ then have "A \<in> sets (qbs_to_measure Y)"
	+ using 2 by auto
	+ then obtain U where
	+ hu:"A = U \<inter> space N"
	+ "(\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` U \<in> sets real_borel)"
	+ by(auto simp add: sigma_Mx_def)
	+ have "\<alpha> -` A = \<alpha> -` U"
	+ using h qbs_decomp[of Y]
	+ by(auto simp add: hu)
	+ thus "\<alpha> -` A \<in> sets borel"
	+ using h hu(2) by simp
	+ qed
	+ qed
	+ next
	+ case (3 M N)
	+ then have [simp]:"qbs_space Y = space N"
	+ by(simp add: 3(2)[symmetric])
	+ show ?case
	+ proof(rule less_eq_quasi_borel.intros(2),simp add: 3,auto)
	+ fix \<alpha>
	+ assume h:"\<alpha> \<in> qbs_Mx Y"
	+ show "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
	+ proof(rule measurableI,simp_all)
	+ show "\<And>x. \<alpha> x \<in> space X"
	+ using h by(auto simp: 3)
	+ next
	+ fix A
	+ assume "A \<in> sets X"
	+ then have "A \<in> sets (qbs_to_measure Y)"
	+ using 3 by auto
	+ then obtain U where
	+ hu:"A = U \<inter> space N"
	+ "(\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` U \<in> sets real_borel)"
	+ by(auto simp add: sigma_Mx_def)
	+ have "\<alpha> -` A = \<alpha> -` U"
	+ using h qbs_decomp[of Y]
	+ by(auto simp add: hu)
	+ thus "\<alpha> -` A \<in> sets borel"
	+ using h hu(2) by simp
	+ qed
	+ qed
	+ qed
	+next
	+ assume "measure_to_qbs X \<le> Y"
	+ then show "X \<le> qbs_to_measure Y"
	+ proof(induction rule: less_eq_quasi_borel.cases)
	+ case (1 A B)
	+ have [simp]: "space X = qbs_space A"
	+ by(simp add: 1(1)[symmetric])
	+ show ?case
	+ by(rule less_eq_measure.intros(1)) (simp add: 1)
	+ next
	+ case (2 A B)
	+ then have hmy:"qbs_Mx Y \<subseteq> real_borel \<rightarrow>\<^sub>M X"
	+ by auto
	+ have [simp]: "space X = qbs_space A"
	+ by(simp add: 2(1)[symmetric])
	+ have "sets X \<subseteq> sigma_Mx Y"
	+ proof
	+ fix U
	+ assume hu:"U \<in> sets X"
	+ show "U \<in> sigma_Mx Y"
	+ proof(simp add: sigma_Mx_def,rule exI[where x=U],auto)
	+ show "\<And>x. x \<in> U \<Longrightarrow> x \<in> qbs_space Y"
	+ using sets.sets_into_space[OF hu]
	+ by(auto simp add: 2)
	+ next
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx Y"
	+ then have "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
	+ using hmy by(auto)
	+ thus "\<alpha> -` U \<in> sets real_borel"
	+ using hu by(simp add: measurable_sets_borel)
	+ qed
	+ qed
	+ then consider "sets X = sigma_Mx Y" \| "sets X \<subset> sigma_Mx Y"
	+ by auto
	+ then show ?case
	+ proof cases
	+ case 1
	+ show ?thesis
	+ apply(rule less_eq_measure.intros(3),simp_all add: 1 2)
	+ proof(rule le_funI)
	+ fix U
	+ consider "U = {}" \| "U \<notin> sigma_Mx B" \| "U \<noteq> {} \<and> U \<in> sigma_Mx B"
	+ by auto
	+ then show "emeasure X U \<le> (if U = {} \<or> U \<notin> sigma_Mx B then 0 else \<infinity>)"
	+ proof cases
	+ case 1
	+ then show ?thesis by simp
	+ next
	+ case h:2
	+ then have "U \<notin> sigma_Mx A"
	+ using qbs_Mx_sigma_Mx_contra[OF 2(3)[symmetric] 2(4)]
	+ by auto
	+ hence "U \<notin> sets X"
	+ using lr_sets 2(1) by auto
	+ thus ?thesis
	+ by(simp add: h emeasure_notin_sets)
	+ next
	+ case 3
	+ then show ?thesis
	+ by simp
	+ qed
	+ qed
	+ next
	+ case h2:2
	+ show ?thesis
	+ by(rule less_eq_measure.intros(2)) (simp add: 2,simp add: h2)
	+ qed
	+ qed
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Measure_as_QuasiBorel_Measure.thy b/thys/Quasi_Borel_Spaces/Measure_as_QuasiBorel_Measure.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Measure_as_QuasiBorel_Measure.thy
	@@ -0,0 +1,385 @@
	+(* Title: Measure_as_QuasiBorel_Measure.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open> Measure as QBS Measure\<close>
	+theory Measure_as_QuasiBorel_Measure
	+ imports "Pair_QuasiBorel_Measure"
	+
	+begin
	+
	+lemma distr_id':
	+ assumes "sets N = sets M"
	+ "f \<in> N \<rightarrow>\<^sub>M N"
	+ and "\<And>x. x \<in> space N \<Longrightarrow> f x = x"
	+ shows "distr N M f = N"
	+proof(rule measure_eqI)
	+ fix A
	+ assume 0:"A \<in> sets (distr N M f)"
	+ then have 1:"A \<subseteq> space N"
	+ by (auto simp: assms(1) sets.sets_into_space)
	+
	+ have 2:"A \<in> sets M"
	+ using 0 by simp
	+ have 3:"f \<in> N \<rightarrow>\<^sub>M M"
	+ using assms(2) by(simp add: measurable_cong_sets[OF _ assms(1)])
	+ have "f -` A \<inter> space N = A"
	+ proof -
	+ have "f -` A = A \<union> {x. x \<notin> space N \<and> f x \<in> A}"
	+ proof(standard;standard)
	+ fix x
	+ assume h:"x \<in> f -` A"
	+ consider "x \<in> A" \| "x \<notin> A"
	+ by auto
	+ thus "x \<in> A \<union> {x. x \<notin> space N \<and> f x \<in> A}"
	+ proof cases
	+ case 1
	+ then show ?thesis
	+ by simp
	+ next
	+ case 2
	+ have "x \<notin> space N"
	+ proof(rule ccontr)
	+ assume "\<not> x \<notin> space N"
	+ then have "x \<in> space N"
	+ by simp
	+ hence "f x = x"
	+ by(simp add: assms(3))
	+ hence "f x \<notin> A"
	+ by(simp add: 2)
	+ thus False
	+ using h by simp
	+ qed
	+ thus ?thesis
	+ using h by simp
	+ qed
	+ next
	+ fix x
	+ show "x \<in> A \<union> {x. x \<notin> space N \<and> f x \<in> A} \<Longrightarrow> x \<in> f -` A"
	+ using 1 assms by auto
	+ qed
	+ thus ?thesis
	+ using "1" by blast
	+ qed
	+ thus "emeasure (distr N M f) A = emeasure N A"
	+ by(simp add: emeasure_distr[OF 3 2])
	+qed (simp add: assms(1))
	+
	+text \<open> Every probability measure on a standard Borel space can be represented as a measure on
	+ a quasi-Borel space~\cite{Heunen_2017}, Proposition 23.\<close>
	+locale standard_borel_prob_space = standard_borel P + p:prob_space P
	+ for P :: "'a measure"
	+begin
	+
	+sublocale qbs_prob "measure_to_qbs P" g "distr P real_borel f"
	+ by(auto intro!: qbs_probI p.prob_space_distr)
	+
	+lift_definition as_qbs_measure :: "'a qbs_prob_space" is
	+"(measure_to_qbs P, g, distr P real_borel f)"
	+ by simp
	+
	+lemma as_qbs_measure_retract:
	+ assumes [measurable]:"a \<in> P \<rightarrow>\<^sub>M real_borel"
	+ and [measurable]:"b \<in> real_borel \<rightarrow>\<^sub>M P"
	+ and [simp]:"\<And>x. x \<in> space P \<Longrightarrow> (b \<circ> a) x = x"
	+ shows "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
	+ "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
	+proof -
	+ interpret pqp: pair_qbs_prob "measure_to_qbs P" g "distr P real_borel f" "measure_to_qbs P" b "distr P real_borel a"
	+ by(auto intro!: qbs_probI p.prob_space_distr simp: pair_qbs_prob_def)
	+ show "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
	+ "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
	+ by(auto intro!: pqp.qbs_prob_space_eq
	+ simp: distr_distr distr_id'[OF standard_borel_lr_sets_ident[symmetric]] distr_id'[OF standard_borel_lr_sets_ident[symmetric] _ assms(3)] pqp.qp2.qbs_prob_axioms as_qbs_measure.abs_eq)
	+qed
	+
	+lemma measure_as_qbs_measure_qbs:
	+ "qbs_prob_space_qbs as_qbs_measure = measure_to_qbs P"
	+ by transfer auto
	+
	+lemma measure_as_qbs_measure_image:
	+ "as_qbs_measure \<in> monadP_qbs_Px (measure_to_qbs P)"
	+ by(auto simp: measure_as_qbs_measure_qbs monadP_qbs_Px_def)
	+
	+lemma as_qbs_measure_as_measure[simp]:
	+ "distr (distr P real_borel f) (qbs_to_measure (measure_to_qbs P)) g = P"
	+ by(auto intro!: distr_id'[OF standard_borel_lr_sets_ident[symmetric]] simp : qbs_prob_t_measure_def distr_distr )
	+
	+
	+lemma measure_as_qbs_measure_recover:
	+ "qbs_prob_measure as_qbs_measure = P"
	+ by transfer (simp add: qbs_prob_t_measure_def)
	+
	+end
	+
	+lemma(in standard_borel) qbs_prob_measure_recover:
	+ assumes "q \<in> monadP_qbs_Px (measure_to_qbs M)"
	+ shows "standard_borel_prob_space.as_qbs_measure (qbs_prob_measure q) = q"
	+proof -
	+ obtain \<alpha> \<mu> where hq:
	+ "q = qbs_prob_space (measure_to_qbs M, \<alpha>, \<mu>)" "qbs_prob (measure_to_qbs M) \<alpha> \<mu>"
	+ using rep_monadP_qbs_Px[OF assms] by auto
	+ then interpret qp: qbs_prob "measure_to_qbs M" \<alpha> \<mu> by simp
	+ interpret sp: standard_borel_prob_space "distr \<mu> (qbs_to_measure (measure_to_qbs M)) \<alpha>"
	+ using qp.in_Mx
	+ by(auto intro!: prob_space.prob_space_distr
	+ simp: standard_borel_prob_space_def standard_borel_sets[OF sets_distr[of \<mu> "qbs_to_measure (measure_to_qbs M)" \<alpha>,simplified standard_borel_lr_sets_ident,symmetric]])
	+ interpret st: standard_borel "distr \<mu> M \<alpha>"
	+ by(auto intro!: standard_borel_sets)
	+ have [measurable]:"st.g \<in> real_borel \<rightarrow>\<^sub>M M"
	+ using measurable_distr_eq2 st.g_meas by blast
	+ show ?thesis
	+ by(auto intro!: pair_qbs_prob.qbs_prob_space_eq
	+ simp add: hq(1) sp.as_qbs_measure.abs_eq pair_qbs_prob_def qp.qbs_prob_axioms sp.qbs_prob_axioms)
	+ (simp_all add: measure_to_qbs_cong_sets[OF sets_distr[of \<mu> "qbs_to_measure (measure_to_qbs M)" \<alpha>,simplified standard_borel_lr_sets_ident]])
	+qed
	+
	+lemma(in standard_borel_prob_space) ennintegral_as_qbs_ennintegral:
	+ assumes "k \<in> borel_measurable P"
	+ shows "(\<integral>\<^sup>+\<^sub>Q x. k x \<partial>as_qbs_measure) = (\<integral>\<^sup>+ x. k x \<partial>P)"
	+proof -
	+ have 1:"k \<in> measure_to_qbs P \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ using assms by auto
	+ thus ?thesis
	+ by(simp add: as_qbs_measure.abs_eq qbs_prob_ennintegral_def2[OF 1])
	+qed
	+
	+lemma(in standard_borel_prob_space) integral_as_qbs_integral:
	+ "(\<integral>\<^sub>Q x. k x \<partial>as_qbs_measure) = (\<integral> x. k x \<partial>P)"
	+ by(simp add: as_qbs_measure.abs_eq qbs_prob_integral_def2)
	+
	+lemma(in standard_borel) measure_with_args_morphism:
	+ assumes [measurable]:"\<mu> \<in> X \<rightarrow>\<^sub>M prob_algebra M"
	+ shows "standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<in> measure_to_qbs X \<rightarrow>\<^sub>Q monadP_qbs (measure_to_qbs M)"
	+proof(auto intro!: qbs_morphismI)
	+ fix \<alpha>
	+ assume h[measurable]:"\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
	+ have "\<forall>r. (standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<circ> \<alpha>) r = qbs_prob_space (measure_to_qbs M, g, ((\<lambda>l. distr (\<mu> l) real_borel f) \<circ> \<alpha>) r)"
	+ proof auto
	+ fix r
	+ interpret sp: standard_borel_prob_space "\<mu> (\<alpha> r)"
	+ using measurable_space[OF assms measurable_space[OF h]]
	+ by(simp add: standard_borel_prob_space_def space_prob_algebra)
	+ have 1[measurable_cong]: "sets (\<mu> (\<alpha> r)) = sets M"
	+ using measurable_space[OF assms measurable_space[OF h]] by(simp add: space_prob_algebra)
	+ have 2:"f \<in> \<mu> (\<alpha> r) \<rightarrow>\<^sub>M real_borel" "g \<in> real_borel \<rightarrow>\<^sub>M \<mu> (\<alpha> r)" "\<And>x. x \<in> space (\<mu> (\<alpha> r)) \<Longrightarrow> (g \<circ> f) x = x"
	+ using measurable_space[OF assms measurable_space[OF h]]
	+ by(simp_all add: standard_borel_prob_space_def sets_eq_imp_space_eq[OF 1])
	+ show "standard_borel_prob_space.as_qbs_measure (\<mu> (\<alpha> r)) = qbs_prob_space (measure_to_qbs M, g, distr (\<mu> (\<alpha> r)) real_borel f)"
	+ by(simp add: sp.as_qbs_measure_retract[OF 2] measure_to_qbs_cong_sets[OF subprob_measurableD(2)[OF measurable_prob_algebraD[OF assms] measurable_space[OF h]]])
	+ qed
	+ thus "standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<circ> \<alpha> \<in> monadP_qbs_MPx (measure_to_qbs M)"
	+ by(auto intro!: bexI[where x=g] bexI[where x="(\<lambda>l. distr (\<mu> l) real_borel f) \<circ> \<alpha>"] simp: monadP_qbs_MPx_def in_MPx_def)
	+qed
	+
	+lemma(in standard_borel) measure_with_args_recover:
	+ assumes "\<mu> \<in> space X \<rightarrow> space (prob_algebra M)"
	+ and "x \<in> space X"
	+ shows "qbs_prob_measure (standard_borel_prob_space.as_qbs_measure (\<mu> x)) = \<mu> x"
	+ using standard_borel_sets[of "\<mu> x"] funcset_mem[OF assms]
	+ by(simp add: standard_borel_prob_space_def space_prob_algebra standard_borel_prob_space.measure_as_qbs_measure_recover)
	+
	+subsection \<open>Example of Probability Measures\<close>
	+text \<open>Probability measures on $\mathbb{R}$ can be represented as probability measures on the quasi-Borel space $\mathbb{R}$.\<close>
	+subsubsection \<open> Normal Distribution \<close>
	+definition normal_distribution :: "real \<times> real \<Rightarrow> real measure" where
	+"normal_distribution \<mu>\<sigma> = (if 0 < (snd \<mu>\<sigma>) then density lborel (\<lambda>x. ennreal (normal_density (fst \<mu>\<sigma>) (snd \<mu>\<sigma>) x))
	+ else return lborel 0)"
	+
	+lemma normal_distribution_measurable:
	+ "normal_distribution \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G=borel])
	+ fix A :: "real set"
	+ assume h:"A \<in> sets borel"
	+ have "(\<lambda>x. emeasure (normal_distribution x) A) = (\<lambda>x. if 0 < (snd x) then emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A
	+ else emeasure (return lborel 0) A)"
	+ by(auto simp add: normal_distribution_def)
	+ also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
	+ proof(rule measurable_If)
	+ have [simp]:"(\<lambda>x. indicat_real A (snd x)) \<in> borel_measurable ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
	+ proof -
	+ have "(\<lambda>x. indicat_real A (snd x)) = indicat_real A \<circ> snd"
	+ by auto
	+ also have "... \<in> borel_measurable ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
	+ by (meson borel_measurable_indicator h measurable_comp measurable_snd)
	+ finally show ?thesis .
	+ qed
	+ have "(\<lambda>x. emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A) = (\<lambda>x. set_nn_integral lborel A (\<lambda>r. ennreal (normal_density (fst x) (snd x) r)))"
	+ using h by(auto intro!: emeasure_density)
	+ also have "... = (\<lambda>x. \<integral>\<^sup>+r. ennreal (normal_density (fst x) (snd x) r * indicat_real A r)\<partial>lborel)"
	+ by(simp add: nn_integral_set_ennreal)
	+ also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
	+ apply(auto intro!: lborel.borel_measurable_nn_integral
	+ simp: split_beta' measurable_cong_sets[OF sets_pair_measure_cong[OF refl sets_lborel]] )
	+ unfolding normal_density_def
	+ by(rule borel_measurable_times) simp_all
	+ finally show "(\<lambda>x. emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
	+ qed simp_all
	+ finally show "(\<lambda>x. emeasure (normal_distribution x) A) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
	+qed (auto simp add: sets.sigma_sets_eq[of borel,simplified] sets.Int_stable prob_space_normal_density normal_distribution_def prob_space_return)
	+
	+definition qbs_normal_distribution :: "real \<Rightarrow> real \<Rightarrow> real qbs_prob_space" where
	+"qbs_normal_distribution \<equiv> curry (standard_borel_prob_space.as_qbs_measure \<circ> normal_distribution)"
	+
	+lemma qbs_normal_distribution_morphism:
	+ "qbs_normal_distribution \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q)"
	+ unfolding qbs_normal_distribution_def
	+ by(rule curry_preserves_morphisms[OF real.measure_with_args_morphism[OF normal_distribution_measurable,simplified r_preserves_product]])
	+
	+
	+context
	+ fixes \<mu> \<sigma> :: real
	+ assumes sigma:"\<sigma> > 0"
	+begin
	+
	+interpretation n_dist:standard_borel_prob_space "normal_distribution (\<mu>,\<sigma>)"
	+ by(simp add: standard_borel_prob_space_def sigma prob_space_normal_density normal_distribution_def)
	+
	+lemma qbs_normal_distribution_def2:
	+ "qbs_normal_distribution \<mu> \<sigma> = n_dist.as_qbs_measure"
	+ by(simp add: qbs_normal_distribution_def)
	+
	+lemma qbs_normal_distribution_integral:
	+ "(\<integral>\<^sub>Q x. f x \<partial> (qbs_normal_distribution \<mu> \<sigma>)) = (\<integral> x. f x \<partial> (density lborel (\<lambda>x. ennreal (normal_density \<mu> \<sigma> x))))"
	+ by(simp add: qbs_normal_distribution_def2 n_dist.integral_as_qbs_integral)
	+ (simp add: normal_distribution_def sigma)
	+
	+lemma qbs_normal_distribution_expectation:
	+ assumes "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ shows "(\<integral>\<^sub>Q x. f x \<partial> (qbs_normal_distribution \<mu> \<sigma>)) = (\<integral> x. normal_density \<mu> \<sigma> x * f x \<partial> lborel)"
	+ by(simp add: qbs_normal_distribution_integral assms integral_real_density integral_density)
	+
	+end
	+
	+subsubsection \<open> Uniform Distribution \<close>
	+definition interval_uniform_distribution :: "real \<Rightarrow> real \<Rightarrow> real measure" where
	+"interval_uniform_distribution a b \<equiv> (if a < b then uniform_measure lborel {a<..<b}
	+ else return lborel 0)"
	+
	+lemma sets_interval_uniform_distribution[measurable_cong]:
	+ "sets (interval_uniform_distribution a b) = borel"
	+ by(simp add: interval_uniform_distribution_def)
	+
	+lemma interval_uniform_distribution_meaurable:
	+ "(\<lambda>r. interval_uniform_distribution (fst r) (snd r)) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G="range (\<lambda>(a, b). {a<..<b})"])
	+ show "sets real_borel = sigma_sets UNIV (range (\<lambda>(a, b). {a<..<b}))"
	+ by(simp add: borel_eq_box)
	+next
	+ show "Int_stable (range (\<lambda>(a, b). {a<..<b::real}))"
	+ by(fastforce intro!: Int_stableI simp: split_beta' image_iff)
	+next
	+ show "range (\<lambda>(a, b). {a<..<b}) \<subseteq> Pow UNIV"
	+ by simp
	+next
	+ fix a
	+ show "prob_space (interval_uniform_distribution (fst a) (snd a))"
	+ by(simp add: interval_uniform_distribution_def prob_space_return prob_space_uniform_measure)
	+next
	+ fix a
	+ show " sets (interval_uniform_distribution (fst a) (snd a)) = sets real_borel"
	+ by(simp add: interval_uniform_distribution_def)
	+next
	+ fix A
	+ assume "A \<in> range (\<lambda>(a, b). {a<..<b::real})"
	+ then obtain a b where ha:"A = {a<..<b}" by auto
	+ consider "b \<le> a" \| "a < b" by fastforce
	+ then show "(\<lambda>x. emeasure (interval_uniform_distribution (fst x) (snd x)) A) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ (is "?f \<in> ?meas")
	+ proof cases
	+ case 1
	+ then show ?thesis
	+ by(simp add: ha)
	+ next
	+ case h2:2
	+ have "?f = (\<lambda>x. if fst x < snd x then ennreal (min (snd x) b - max (fst x) a) / ennreal (snd x - fst x) else indicator A 0)"
	+ proof(standard; auto simp: interval_uniform_distribution_def ha)
	+ fix x y :: real
	+ assume hxy:"x < y"
	+ consider "b \<le> x" \| "a \<le> x \<and> x < b" \| "x < a \<and> a < y" \| "y \<le> a"
	+ using h2 by fastforce
	+ thus "emeasure lborel ({max x a<..<min y b}) / ennreal (y - x) = ennreal (min y b - max x a) / ennreal (y - x)"
	+ by cases (use hxy ennreal_neg h2 in auto)
	+ qed
	+ also have "... \<in> ?meas"
	+ by simp
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+definition qbs_interval_uniform_distribution :: "real \<Rightarrow> real \<Rightarrow> real qbs_prob_space" where
	+"qbs_interval_uniform_distribution \<equiv> curry (standard_borel_prob_space.as_qbs_measure \<circ> (\<lambda>r. interval_uniform_distribution (fst r) (snd r)))"
	+
	+lemma qbs_interval_uniform_distribution_morphism:
	+ "qbs_interval_uniform_distribution \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q)"
	+ unfolding qbs_interval_uniform_distribution_def
	+ using curry_preserves_morphisms[OF real.measure_with_args_morphism[OF interval_uniform_distribution_meaurable,simplified r_preserves_product]] .
	+
	+context
	+ fixes a b :: real
	+ assumes a_less_than_b:"a < b"
	+begin
	+
	+definition "ab_qbs_uniform_distribution \<equiv> qbs_interval_uniform_distribution a b"
	+
	+interpretation ab_u_dist: standard_borel_prob_space "interval_uniform_distribution a b"
	+ by(auto intro!: prob_space_uniform_measure simp: interval_uniform_distribution_def standard_borel_prob_space_def prob_space_return)
	+
	+lemma qbs_interval_uniform_distribution_def2:
	+ "ab_qbs_uniform_distribution = ab_u_dist.as_qbs_measure"
	+ by(simp add: qbs_interval_uniform_distribution_def ab_qbs_uniform_distribution_def)
	+
	+lemma qbs_uniform_distribution_expectation:
	+ assumes "f \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<integral>\<^sup>+\<^sub>Q x. f x \<partial>ab_qbs_uniform_distribution) = (\<integral>\<^sup>+x \<in> {a<..<b}. f x \<partial>lborel) / (b - a)"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have "?lhs = (\<integral>\<^sup>+x. f x \<partial>(interval_uniform_distribution a b))"
	+ using assms by(auto simp: qbs_interval_uniform_distribution_def2 intro!:ab_u_dist.ennintegral_as_qbs_ennintegral dest:ab_u_dist.qbs_morphism_dest[simplified measure_to_qbs_cong_sets[OF sets_interval_uniform_distribution]])
	+ also have "... = ?rhs"
	+ using assms
	+ by(auto simp: interval_uniform_distribution_def a_less_than_b intro!:nn_integral_uniform_measure[where M=lborel and S="{a<..<b}",simplified emeasure_lborel_Ioo[OF order.strict_implies_order[OF a_less_than_b]]])
	+ finally show ?thesis .
	+qed
	+
	+end
	+
	+subsubsection \<open> Bernoulli Distribution \<close>
	+definition qbs_bernoulli :: "real \<Rightarrow> bool qbs_prob_space" where
	+"qbs_bernoulli \<equiv> standard_borel_prob_space.as_qbs_measure \<circ> (\<lambda>x. measure_pmf (bernoulli_pmf x))"
	+
	+lemma bernoulli_measurable:
	+ "(\<lambda>x. measure_pmf (bernoulli_pmf x)) \<in> real_borel \<rightarrow>\<^sub>M prob_algebra bool_borel"
	+proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G=UNIV],simp_all)
	+ fix A :: "bool set"
	+ have "A \<subseteq> {True,False}"
	+ by auto
	+ then consider "A = {}" \| "A = {True}" \| "A = {False}" \| "A = {False,True}"
	+ by auto
	+ thus "(\<lambda>a. emeasure (measure_pmf (bernoulli_pmf a)) A) \<in> borel_measurable borel"
	+ by(cases,simp_all add: emeasure_measure_pmf_finite bernoulli_pmf.rep_eq UNIV_bool[symmetric])
	+qed (auto simp add: sets_borel_eq_count_space Int_stable_def measure_pmf.prob_space_axioms)
	+
	+lemma qbs_bernoulli_morphism:
	+ "qbs_bernoulli \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q monadP_qbs \<bool>\<^sub>Q"
	+ using bool.measure_with_args_morphism[OF bernoulli_measurable]
	+ by (simp add: qbs_bernoulli_def)
	+
	+
	+lemma qbs_bernoulli_measure:
	+ "qbs_prob_measure (qbs_bernoulli p) = measure_pmf (bernoulli_pmf p)"
	+ using bool.measure_with_args_recover[of "\<lambda>x. measure_pmf (bernoulli_pmf x)" real_borel p] bernoulli_measurable
	+ by(simp add: measurable_def qbs_bernoulli_def)
	+
	+context
	+ fixes p :: real
	+ assumes pgeq_0[simp]:"0 \<le> p" and pleq_1[simp]:"p \<le> 1"
	+begin
	+
	+lemma qbs_bernoulli_expectation:
	+ "(\<integral>\<^sub>Q x. f x \<partial>qbs_bernoulli p) = f True * p + f False * (1 - p)"
	+ by(simp add: qbs_prob_integral_def2 qbs_bernoulli_measure)
	+
	+end
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Monad_QuasiBorel.thy b/thys/Quasi_Borel_Spaces/Monad_QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Monad_QuasiBorel.thy
	@@ -0,0 +1,1591 @@
	+(* Title: Monad_QuasiBorel.thy
	+ Author: Michikazu Hirata, Tetsuya Sato, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open>The Probability Monad\<close>
	+
	+theory Monad_QuasiBorel
	+ imports "Probability_Space_QuasiBorel"
	+begin
	+
	+subsubsection \<open> The Probability Monad $P$ \<close>
	+definition monadP_qbs_Px :: "'a quasi_borel \<Rightarrow> 'a qbs_prob_space set" where
	+"monadP_qbs_Px X \<equiv> {s. qbs_prob_space_qbs s = X}"
	+
	+locale in_Px =
	+ fixes X :: "'a quasi_borel" and s :: "'a qbs_prob_space"
	+ assumes in_Px:"s \<in> monadP_qbs_Px X"
	+begin
	+
	+lemma qbs_prob_space_X[simp]:
	+ "qbs_prob_space_qbs s = X"
	+ using in_Px by(simp add: monadP_qbs_Px_def)
	+
	+end
	+
	+locale in_MPx =
	+ fixes X :: "'a quasi_borel" and \<beta> :: "real \<Rightarrow> 'a qbs_prob_space"
	+ assumes ex:"\<exists>\<alpha>\<in> qbs_Mx X. \<exists>g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel.
	+ \<forall>r. \<beta> r = qbs_prob_space (X,\<alpha>,g r)"
	+begin
	+
	+lemma rep_inMPx:
	+ "\<exists>\<alpha> g. \<alpha> \<in> qbs_Mx X \<and> g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel \<and>
	+ \<beta> = (\<lambda>r. qbs_prob_space (X,\<alpha>,g r))"
	+proof -
	+ obtain \<alpha> g where hb:
	+ "\<alpha> \<in> qbs_Mx X" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<beta> = (\<lambda>r. qbs_prob_space (X,\<alpha>,g r))"
	+ using ex by auto
	+ thus ?thesis
	+ by(auto intro!: exI[where x=\<alpha>] exI[where x=g] simp: hb)
	+qed
	+
	+end
	+
	+definition monadP_qbs_MPx :: "'a quasi_borel \<Rightarrow> (real \<Rightarrow> 'a qbs_prob_space) set" where
	+"monadP_qbs_MPx X \<equiv> {\<beta>. in_MPx X \<beta>}"
	+
	+definition monadP_qbs :: "'a quasi_borel \<Rightarrow> 'a qbs_prob_space quasi_borel" where
	+"monadP_qbs X \<equiv> Abs_quasi_borel (monadP_qbs_Px X, monadP_qbs_MPx X)"
	+
	+lemma(in qbs_prob) qbs_prob_space_in_Px:
	+ "qbs_prob_space (X,\<alpha>,\<mu>) \<in> monadP_qbs_Px X"
	+ using qbs_prob_axioms by(simp add: monadP_qbs_Px_def)
	+
	+lemma rep_monadP_qbs_Px:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ shows "\<exists>\<alpha> \<mu>. s = qbs_prob_space (X, \<alpha>, \<mu>) \<and> qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space' assms in_Px.qbs_prob_space_X
	+ by(auto simp: monadP_qbs_Px_def)
	+
	+lemma rep_monadP_qbs_MPx:
	+ assumes "\<beta> \<in> monadP_qbs_MPx X"
	+ shows "\<exists>\<alpha> g. \<alpha> \<in> qbs_Mx X \<and> g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel \<and>
	+ \<beta> = (\<lambda>r. qbs_prob_space (X,\<alpha>,g r))"
	+ using assms in_MPx.rep_inMPx
	+ by(auto simp: monadP_qbs_MPx_def)
	+
	+lemma qbs_prob_MPx:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ and "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ shows "qbs_prob X \<alpha> (g r)"
	+ using measurable_space[OF assms(2)]
	+ by(auto intro!: qbs_prob.intro simp: space_prob_algebra in_Mx_def real_distribution_def real_distribution_axioms_def assms(1))
	+
	+lemma monadP_qbs_f[simp]: "monadP_qbs_MPx X \<subseteq> UNIV \<rightarrow> monadP_qbs_Px X"
	+ unfolding monadP_qbs_MPx_def
	+proof auto
	+ fix \<beta> r
	+ assume "in_MPx X \<beta>"
	+ then obtain \<alpha> g where hb:
	+ "\<alpha> \<in> qbs_Mx X" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<beta> = (\<lambda>r. qbs_prob_space (X,\<alpha>,g r))"
	+ using in_MPx.rep_inMPx by blast
	+ then interpret qp : qbs_prob X \<alpha> "g r"
	+ by(simp add: qbs_prob_MPx)
	+ show "\<beta> r \<in> monadP_qbs_Px X"
	+ by(simp add: hb(3) qp.qbs_prob_space_in_Px)
	+qed
	+
	+lemma monadP_qbs_closed1: "qbs_closed1 (monadP_qbs_MPx X)"
	+ unfolding monadP_qbs_MPx_def in_MPx_def
	+ apply(rule qbs_closed1I)
	+ subgoal for \<alpha> f
	+ apply auto
	+ subgoal for \<beta> g
	+ apply(auto intro!: bexI[where x=\<beta>] bexI[where x="g\<circ>f"])
	+ done
	+ done
	+ done
	+
	+lemma monadP_qbs_closed2: "qbs_closed2 (monadP_qbs_Px X) (monadP_qbs_MPx X)"
	+ unfolding qbs_closed2_def
	+proof
	+ fix s
	+ assume "s \<in> monadP_qbs_Px X"
	+ then obtain \<alpha> \<mu> where h:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_qbs_prob_space'[of s X] monadP_qbs_Px_def by blast
	+ then interpret qp : qbs_prob X \<alpha> \<mu>
	+ by simp
	+ define g :: "real \<Rightarrow> real measure"
	+ where "g \<equiv> (\<lambda>_. \<mu>)"
	+ have "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ using h prob_algebra_real_prob_measure[of \<mu>]
	+ by(simp add: qbs_prob_def g_def)
	+ thus "(\<lambda>r. s) \<in> monadP_qbs_MPx X"
	+ by(auto intro!: bexI[where x=\<alpha>] bexI[where x=g] simp: monadP_qbs_MPx_def in_MPx_def g_def h)
	+qed
	+
	+lemma monadP_qbs_closed3: "qbs_closed3 (monadP_qbs_MPx (X :: 'a quasi_borel))"
	+proof(rule qbs_closed3I)
	+ fix P :: "real \<Rightarrow> nat"
	+ fix Fi
	+ assume "\<And>i. P -` {i} \<in> sets real_borel"
	+ then have HP_mble[measurable] : "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
	+ by (simp add: separate_measurable)
	+ assume "\<And>i :: nat. Fi i \<in> monadP_qbs_MPx X"
	+ then have "\<forall>i. \<exists>\<alpha>i. \<exists>gi. \<alpha>i \<in> qbs_Mx X \<and> gi \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel \<and>
	+ Fi i = (\<lambda>r. qbs_prob_space (X, \<alpha>i, gi r))"
	+ using in_MPx.rep_inMPx[of X] by(simp add: monadP_qbs_MPx_def)
	+ hence "\<exists>\<alpha>. \<forall>i. \<exists>gi. \<alpha> i \<in> qbs_Mx X \<and> gi \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel \<and>
	+ Fi i = (\<lambda>r. qbs_prob_space (X, \<alpha> i, gi r))"
	+ by(rule choice)
	+ then obtain \<alpha> :: "nat \<Rightarrow> real \<Rightarrow> _" where
	+ "\<forall>i. \<exists>gi. \<alpha> i \<in> qbs_Mx X \<and> gi \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel \<and>
	+ Fi i = (\<lambda>r. qbs_prob_space (X, \<alpha> i, gi r))"
	+ by auto
	+ hence "\<exists>g. \<forall>i. \<alpha> i \<in> qbs_Mx X \<and> g i \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel \<and>
	+ Fi i = (\<lambda>r. qbs_prob_space (X, \<alpha> i, g i r))"
	+ by(rule choice)
	+ then obtain g :: "nat \<Rightarrow> real \<Rightarrow> real measure" where
	+ H0: "\<And>i. \<alpha> i \<in> qbs_Mx X" "\<And>i. g i \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<And>i. Fi i = (\<lambda>r. qbs_prob_space (X, \<alpha> i, g i r))"
	+ by blast
	+ hence LHS: "(\<lambda>r. Fi (P r) r) = (\<lambda>r. qbs_prob_space (X, \<alpha> (P r), g (P r) r))"
	+ by auto
	+
	+ \<comment> \<open> Since \<open>\<nat>\<times>\<real>\<close> is standard, we have measurable functions
	+ \<open>nat_real.f \<in> \<nat> \<Otimes>\<^sub>M \<real> \<rightarrow>\<^sub>M \<real>\<close> and \<open>nat_real.g \<in> \<real> \<rightarrow>\<^sub>M \<nat> \<Otimes>\<^sub>M \<real>\<close>
	+ such that @{thm nat_real.gf_comp_id'(1)}. \<close>
	+
	+ \<comment> \<open> The proof is divided into 3 steps.
	+ \begin{enumerate}
	+ \item Let \<open>\<alpha>'' = uncurry \<alpha> \<circ> nat_real.g\<close>. Then \<open>\<alpha>'' \<in> qbs_Mx X\<close>.
	+ \item Let \<open>g'' = G(nat_real.f) \<circ> (\<lambda>r. \<delta>\<^sub>P\<^sub>(\<^sub>r\<^sub>) \<Otimes>\<^sub>M g\<^sub>P\<^sub>(\<^sub>r\<^sub>) r\<close>.
	+ Then \<open>g''\<close> is \<open>\<real>\<close>/\<open>G(\<real>)\<close> measurable.
	+ \item Show that \<open>(\<lambda>r. Fi (P r) r) = (\<lambda>r. qbs_prob_space (X, \<alpha>'', g'' r))\<close>.
	+ \end{enumerate}\<close>
	+
	+ \<comment> \<open> Step 1.\<close>
	+ define \<alpha>' :: "nat \<times> real \<Rightarrow> 'a"
	+ where "\<alpha>' \<equiv> case_prod \<alpha>"
	+ define \<alpha>'' :: "real \<Rightarrow> 'a"
	+ where "\<alpha>'' \<equiv> \<alpha>' \<circ> nat_real.g"
	+
	+ have \<alpha>_morp: "\<alpha> \<in> \<nat>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q X"
	+ using qbs_Mx_is_morphisms[of X] H0(1)
	+ by(auto intro!: nat_qbs_morphism)
	+ hence \<alpha>'_morp: "\<alpha>' \<in> \<nat>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q X"
	+ unfolding \<alpha>'_def
	+ by(intro uncurry_preserves_morphisms)
	+ hence [measurable]:"\<alpha>' \<in> nat_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
	+ using l_preserves_morphisms[of "\<nat>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q" X]
	+ by(auto simp add: r_preserves_product)
	+ have H_Mx:"\<alpha>'' \<in> qbs_Mx X"
	+ unfolding \<alpha>''_def
	+ using qbs_morphism_comp[OF real.qbs_morphism_measurable_intro[OF nat_real.g_meas,simplified r_preserves_product] \<alpha>'_morp] qbs_Mx_is_morphisms[of X]
	+ by simp
	+
	+
	+ \<comment> \<open> Step 2.\<close>
	+ define g' :: "real \<Rightarrow> (nat \<times> real) measure"
	+ where "g' \<equiv> (\<lambda>r. return nat_borel (P r) \<Otimes>\<^sub>M g (P r) r)"
	+ define g'' :: "real \<Rightarrow> real measure"
	+ where "g'' \<equiv> (\<lambda>M. distr M real_borel nat_real.f) \<circ> g'"
	+
	+ have [measurable]:"(\<lambda>nr. g (fst nr) (snd nr)) \<in> nat_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ using measurable_pair_measure_countable1[of "UNIV :: nat set" "\<lambda>nr. g (fst nr) (snd nr)",simplified,OF H0(2)] measurable_cong_sets[OF sets_pair_measure_cong[of nat_borel "count_space UNIV" real_borel real_borel,OF sets_borel_eq_count_space refl] refl,of "prob_algebra real_borel"]
	+ by auto
	+ hence [measurable]:"(\<lambda>r. g (P r) r) \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ proof -
	+ have "(\<lambda>r. g (P r) r) = (\<lambda>nr. g (fst nr) (snd nr)) \<circ> (\<lambda>r. (P r, r))" by auto
	+ also have "... \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ by simp
	+ finally show ?thesis .
	+ qed
	+ have g'_mble[measurable]:"g' \<in> real_borel \<rightarrow>\<^sub>M prob_algebra (nat_borel \<Otimes>\<^sub>M real_borel)"
	+ unfolding g'_def by simp
	+ have H_mble: "g'' \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ unfolding g''_def by simp
	+
	+ \<comment> \<open> Step 3.\<close>
	+ have H_equiv:
	+ "qbs_prob_space (X, \<alpha> (P r), g (P r) r) = qbs_prob_space (X, \<alpha>'', g'' r)" for r
	+ proof -
	+ interpret pqp: pair_qbs_prob X "\<alpha> (P r)" "g (P r) r" X \<alpha>'' "g'' r"
	+ using qbs_prob_MPx[OF H0(1,2)] measurable_space[OF H_mble,of r] space_prob_algebra[of real_borel] H_Mx
	+ by (simp add: pair_qbs_prob.intro qbs_probI)
	+ interpret pps: pair_prob_space "return nat_borel (P r)" "g (P r) r"
	+ using prob_space_return[of "P r" nat_borel]
	+ by(simp add: pair_prob_space_def pair_sigma_finite_def prob_space_imp_sigma_finite)
	+ have [measurable_cong]: "sets (return nat_borel (P r)) = sets nat_borel"
	+ "sets (g' r) = sets (nat_borel \<Otimes>\<^sub>M real_borel)"
	+ using measurable_space[OF g'_mble,of r] space_prob_algebra by auto
	+ show "qbs_prob_space (X, \<alpha> (P r), g (P r) r) = qbs_prob_space (X, \<alpha>'', g'' r)"
	+ proof(rule pqp.qbs_prob_space_eq4)
	+ fix f
	+ assume [measurable]:"f \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel"
	+ show "(\<integral>\<^sup>+ x. f (\<alpha> (P r) x) \<partial>g (P r) r) = (\<integral>\<^sup>+ x. f (\<alpha>'' x) \<partial>g'' r)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = (\<integral>\<^sup>+s. f (\<alpha>' ((P r),s)) \<partial> (g (P r) r))"
	+ by(simp add: \<alpha>'_def)
	+ also have "... = (\<integral>\<^sup>+s. (\<integral>\<^sup>+i. f (\<alpha>' (i, s)) \<partial> (return nat_borel (P r))) \<partial> (g (P r) r))"
	+ by(auto intro!: nn_integral_cong simp: nn_integral_return[of "P r" nat_borel])
	+ also have "... = (\<integral>\<^sup>+k. (f \<circ> \<alpha>') k \<partial> ((return nat_borel (P r)) \<Otimes>\<^sub>M (g (P r) r)))"
	+ by(auto intro!: pps.nn_integral_snd)
	+ also have "... = (\<integral>\<^sup>+k. f (\<alpha>' k) \<partial> (g' r))"
	+ by(simp add: g'_def)
	+ also have "... = (\<integral>\<^sup>+x. f x \<partial> (distr (g' r) (qbs_to_measure X) \<alpha>'))"
	+ by(simp add: nn_integral_distr)
	+ also have "... = (\<integral>\<^sup>+x. f x \<partial> (distr (g'' r) (qbs_to_measure X) \<alpha>''))"
	+ by(simp add: distr_distr comp_def g''_def \<alpha>''_def)
	+ also have "... = ?rhs"
	+ by(simp add: nn_integral_distr)
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+ qed
	+
	+ have "\<forall>r. Fi (P r) r = qbs_prob_space (X, \<alpha>'', g'' r)"
	+ by (metis H_equiv LHS)
	+ thus "(\<lambda>r. Fi (P r) r) \<in> monadP_qbs_MPx X"
	+ using H_mble H_Mx by(auto simp add: monadP_qbs_MPx_def in_MPx_def)
	+qed
	+
	+lemma monadP_qbs_correct: "Rep_quasi_borel (monadP_qbs X) = (monadP_qbs_Px X, monadP_qbs_MPx X)"
	+ by(auto intro!: Abs_quasi_borel_inverse monadP_qbs_f simp: monadP_qbs_closed2 monadP_qbs_closed1 monadP_qbs_closed3 monadP_qbs_def)
	+
	+lemma monadP_qbs_space[simp] : "qbs_space (monadP_qbs X) = monadP_qbs_Px X"
	+ by(simp add: qbs_space_def monadP_qbs_correct)
	+
	+lemma monadP_qbs_Mx[simp] : "qbs_Mx (monadP_qbs X) = monadP_qbs_MPx X"
	+ by(simp add: qbs_Mx_def monadP_qbs_correct)
	+
	+lemma monadP_qbs_empty_iff:
	+ "qbs_space X = {} \<longleftrightarrow> qbs_space (monadP_qbs X) = {}"
	+proof auto
	+ fix x
	+ assume 1:"qbs_space X = {}"
	+ "x \<in> monadP_qbs_Px X"
	+ then obtain \<alpha> \<mu> where "qbs_prob X \<alpha> \<mu>"
	+ using rep_monadP_qbs_Px by blast
	+ thus False
	+ using empty_quasi_borel_iff[of X] qbs_empty_not_qbs_prob[of \<alpha> \<mu>] 1(1)
	+ by auto
	+next
	+ fix x
	+ assume 1:"monadP_qbs_Px X = {}"
	+ "x \<in> qbs_space X"
	+ then interpret qp: qbs_prob X "\<lambda>r. x" "return real_borel 0"
	+ by(auto intro!: qbs_probI prob_space_return)
	+ have "qbs_prob_space (X,\<lambda>r. x,return real_borel 0) \<in> monadP_qbs_Px X"
	+ by(simp add: monadP_qbs_Px_def)
	+ thus False
	+ by(simp add: 1)
	+qed
	+
	+text \<open> If \<open>\<beta> \<in> MPx\<close>, there exists \<open>X\<close> \<open>\<alpha>\<close> \<open>g\<close> s.t.\<open>\<beta> r = [X,\<alpha>,g r]\<close>.
	+ We define a function which picks \<open>X\<close> \<open>\<alpha>\<close> \<open>g\<close> from \<open>\<beta> \<in> MPx\<close>.\<close>
	+definition rep_monadP_qbs_MPx :: "(real \<Rightarrow> 'a qbs_prob_space) \<Rightarrow> 'a quasi_borel \<times> (real \<Rightarrow> 'a) \<times> (real \<Rightarrow> real measure)" where
	+"rep_monadP_qbs_MPx \<beta> \<equiv> let X = qbs_prob_space_qbs (\<beta> undefined);
	+ \<alpha>g = (SOME k. (fst k) \<in> qbs_Mx X \<and> (snd k) \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel
	+ \<and> \<beta> = (\<lambda>r. qbs_prob_space (X,fst k,snd k r)))
	+ in (X,\<alpha>g)"
	+
	+lemma qbs_prob_measure_measurable[measurable]:
	+ "qbs_prob_measure \<in> qbs_to_measure (monadP_qbs (X :: 'a quasi_borel)) \<rightarrow>\<^sub>M prob_algebra (qbs_to_measure X)"
	+proof(rule qbs_morphism_dest,rule qbs_morphismI,simp)
	+ fix \<beta>
	+ assume "\<beta> \<in> monadP_qbs_MPx X"
	+ then obtain \<alpha> g where hb:
	+ "\<alpha> \<in> qbs_Mx X" "\<beta> = (\<lambda>r. qbs_prob_space (X, \<alpha>, g r))"
	+ and g[measurable]: "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ using in_MPx.rep_inMPx[of X \<beta>] monadP_qbs_MPx_def by blast
	+ have "qbs_prob_measure \<circ> \<beta> = (\<lambda>r. distr (g r) (qbs_to_measure X) \<alpha>)"
	+ proof
	+ fix r
	+ interpret qp : qbs_prob X \<alpha> "g r"
	+ using qbs_prob_MPx[OF hb(1) g] by simp
	+ show "(qbs_prob_measure \<circ> \<beta>) r = distr (g r) (qbs_to_measure X) \<alpha>"
	+ by(simp add: hb(2))
	+ qed
	+ also have "... \<in> real_borel \<rightarrow>\<^sub>M prob_algebra (qbs_to_measure X) "
	+ using hb by simp
	+ finally show "qbs_prob_measure \<circ> \<beta> \<in> real_borel \<rightarrow>\<^sub>M prob_algebra (qbs_to_measure X)" .
	+qed
	+
	+lemma qbs_l_inj:
	+ "inj_on qbs_prob_measure (monadP_qbs_Px X)"
	+ apply standard
	+ apply (unfold monadP_qbs_Px_def)
	+ apply simp
	+ apply transfer
	+ apply (auto simp: qbs_prob_eq_def qbs_prob_t_measure_def)
	+ done
	+
	+lemma qbs_prob_measure_measurable'[measurable]:
	+ "qbs_prob_measure \<in> qbs_to_measure (monadP_qbs (X :: 'a quasi_borel)) \<rightarrow>\<^sub>M subprob_algebra (qbs_to_measure X)"
	+ by(auto simp: measurable_prob_algebraD)
	+
	+subsubsection \<open> Return \<close>
	+definition qbs_return :: "['a quasi_borel, 'a] \<Rightarrow> 'a qbs_prob_space" where
	+"qbs_return X x \<equiv> qbs_prob_space (X,\<lambda>r. x,Eps real_distribution)"
	+
	+lemma(in real_distribution) qbs_return_qbs_prob:
	+ assumes "x \<in> qbs_space X"
	+ shows "qbs_prob X (\<lambda>r. x) M"
	+ using assms
	+ by(simp add: qbs_prob_def in_Mx_def real_distribution_axioms)
	+
	+lemma(in real_distribution) qbs_return_computation :
	+ assumes "x \<in> qbs_space X"
	+ shows "qbs_return X x = qbs_prob_space (X,\<lambda>r. x,M)"
	+ unfolding qbs_return_def
	+proof(rule someI2[where a=M])
	+ fix N
	+ assume "real_distribution N"
	+ then interpret pqp: pair_qbs_prob X "\<lambda>r. x" N X "\<lambda>r. x" M
	+ by(simp_all add: pair_qbs_prob_def real_distribution_axioms real_distribution.qbs_return_qbs_prob[OF _ assms])
	+ show "qbs_prob_space (X, \<lambda>r. x, N) = qbs_prob_space (X, \<lambda>r. x, M)"
	+ by(auto intro!: pqp.qbs_prob_space_eq simp: distr_const[of x "qbs_to_measure X"] assms)
	+qed (rule real_distribution_axioms)
	+
	+lemma qbs_return_morphism:
	+ "qbs_return X \<in> X \<rightarrow>\<^sub>Q monadP_qbs X"
	+proof -
	+ interpret rr : real_distribution "return real_borel 0"
	+ by(simp add: real_distribution_def real_distribution_axioms_def prob_space_return)
	+ show ?thesis
	+ proof(rule qbs_morphismI,simp)
	+ fix \<alpha>
	+ assume h:"\<alpha> \<in> qbs_Mx X"
	+ then have h':"\<And>l:: real. \<alpha> l \<in> qbs_space X"
	+ by auto
	+ have "\<And>l. (qbs_return X \<circ> \<alpha>) l = qbs_prob_space (X, \<alpha>, return real_borel l)"
	+ proof -
	+ fix l
	+ interpret pqp: pair_qbs_prob X "\<lambda>r. \<alpha> l" "return real_borel 0" X \<alpha> "return real_borel l"
	+ using h' by(simp add: pair_qbs_prob_def qbs_prob_def in_Mx_def h real_distribution_def prob_space_return real_distribution_axioms_def)
	+ have "(qbs_return X \<circ> \<alpha>) l = qbs_prob_space (X,\<lambda>r. \<alpha> l,return real_borel 0)"
	+ using rr.qbs_return_computation[OF h'[of l]] by simp
	+ also have "... = qbs_prob_space (X, \<alpha>, return real_borel l)"
	+ by(auto intro!: pqp.qbs_prob_space_eq simp: distr_return)
	+ finally show "(qbs_return X \<circ> \<alpha>) l = qbs_prob_space (X, \<alpha>, return real_borel l)" .
	+ qed
	+ thus "qbs_return X \<circ> \<alpha> \<in> monadP_qbs_MPx X"
	+ by(auto intro!: bexI[where x="\<alpha>"] bexI[where x="\<lambda>l. return real_borel l"] simp: h monadP_qbs_MPx_def in_MPx_def)
	+ qed
	+qed
	+
	+lemma qbs_return_morphism':
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ shows "(\<lambda>x. qbs_return Y (f x)) \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ using qbs_morphism_comp[OF assms(1) qbs_return_morphism[of Y]]
	+ by (simp add: comp_def)
	+
	+subsubsection \<open>Bind\<close>
	+definition qbs_bind :: "'a qbs_prob_space \<Rightarrow> ('a \<Rightarrow> 'b qbs_prob_space) \<Rightarrow> 'b qbs_prob_space" where
	+"qbs_bind s f \<equiv> (let (qbsx,\<alpha>,\<mu>) = rep_qbs_prob_space s;
	+ (qbsy,\<beta>,g) = rep_monadP_qbs_MPx (f \<circ> \<alpha>)
	+ in qbs_prob_space (qbsy,\<beta>,\<mu> \<bind> g))"
	+
	+adhoc_overloading Monad_Syntax.bind qbs_bind
	+
	+lemma(in qbs_prob) qbs_bind_computation:
	+ assumes"s = qbs_prob_space (X,\<alpha>,\<mu>)"
	+ "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ "\<beta> \<in> qbs_Mx Y"
	+ and [measurable]: "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ and "(f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y,\<beta>, g r))"
	+ shows "qbs_prob Y \<beta> (\<mu> \<bind> g)"
	+ "s \<bind> f = qbs_prob_space (Y,\<beta>,\<mu> \<bind> g)"
	+proof -
	+ interpret qp_bind: qbs_prob Y \<beta> "\<mu> \<bind> g"
	+ using assms(3,4) space_prob_algebra[of real_borel] measurable_space[OF assms(4)] events_eq_borel measurable_cong_sets[OF events_eq_borel refl,of "subprob_algebra real_borel"] measurable_prob_algebraD[OF assms(4)]
	+ by(auto intro!: prob_space_bind[of g real_borel] simp: qbs_prob_def in_Mx_def real_distribution_def real_distribution_axioms_def)
	+ show "qbs_prob Y \<beta> (\<mu> \<bind> g)"
	+ by (rule qp_bind.qbs_prob_axioms)
	+ show "s \<bind> f = qbs_prob_space (Y, \<beta>, \<mu> \<bind> g)"
	+ apply(simp add: assms(1) qbs_bind_def rep_qbs_prob_space_def qbs_prob_space.rep_def)
	+ apply(rule someI2[where a= "(X, \<alpha>, \<mu>)"])
	+ proof auto
	+ fix X' \<alpha>' \<mu>'
	+ assume h':"(X',\<alpha>',\<mu>') \<in> Rep_qbs_prob_space (qbs_prob_space (X, \<alpha>, \<mu>))"
	+ from if_in_Rep[OF this] interpret pqp1: pair_qbs_prob X \<alpha> \<mu> X' \<alpha>' \<mu>'
	+ by(simp add: pair_qbs_prob_def qbs_prob_axioms)
	+ have h_eq: "qbs_prob_space (X, \<alpha>, \<mu>) = qbs_prob_space (X',\<alpha>',\<mu>')"
	+ using if_in_Rep(3)[OF h'] by (simp add: qbs_prob_space_eq)
	+ note [simp] = if_in_Rep(1)[OF h']
	+ then obtain \<beta>' g' where hb':
	+ "\<beta>' \<in> qbs_Mx Y" "g' \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "f \<circ> \<alpha>' = (\<lambda>r. qbs_prob_space (Y, \<beta>', g' r))"
	+ using in_MPx.rep_inMPx[of Y "f \<circ> \<alpha>'"] qbs_morphismE(3)[OF assms(2),of \<alpha>'] pqp1.qp2.qbs_prob_axioms[simplified qbs_prob_def in_Mx_def]
	+ by(auto simp: monadP_qbs_MPx_def)
	+ note [measurable] = hb'(2)
	+ have [simp]:"\<And>r. qbs_prob_space_qbs (f (\<alpha>' r)) = Y"
	+ subgoal for r
	+ using fun_cong[OF hb'(3)] qbs_prob.qbs_prob_space_qbs_computation[OF qbs_prob_MPx[OF hb'(1,2),of r]]
	+ by simp
	+ done
	+ show "(case rep_monadP_qbs_MPx (\<lambda>a. f (\<alpha>' a)) of (qbsy, \<beta>, g) \<Rightarrow> qbs_prob_space (qbsy, \<beta>, \<mu>' \<bind> g)) =
	+ qbs_prob_space (Y, \<beta>, \<mu> \<bind> g)"
	+ unfolding rep_monadP_qbs_MPx_def Let_def
	+ proof(rule someI2[where a="(\<beta>',g')"],auto simp: hb'[simplified comp_def])
	+ fix \<alpha>'' g''
	+ assume h'':"\<alpha>'' \<in> qbs_Mx Y"
	+ "g'' \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(\<lambda>r. qbs_prob_space (Y, \<beta>', g' r)) = (\<lambda>r. qbs_prob_space (Y, \<alpha>'', g'' r))"
	+ then interpret pqp2: pair_qbs_prob Y \<alpha>'' "\<mu>' \<bind> g''" Y \<beta> "\<mu> \<bind> g"
	+ using space_prob_algebra[of real_borel] measurable_space[OF h''(2)] events_eq_borel measurable_cong_sets[OF events_eq_borel refl,of "subprob_algebra real_borel"] measurable_prob_algebraD[OF h''(2)] h''(3)
	+ by (meson pair_qbs_prob_def in_Mx_def pqp1.qp2.real_distribution_axioms prob_algebra_real_prob_measure prob_space_bind' qbs_probI qbs_prob_def qp_bind.qbs_prob_axioms sets_bind')
	+ note [measurable] = h''(2)
	+ have [measurable]:"f \<in> qbs_to_measure X \<rightarrow>\<^sub>M qbs_to_measure (monadP_qbs Y)"
	+ using assms(2) l_preserves_morphisms by auto
	+ show "qbs_prob_space (Y, \<alpha>'', \<mu>' \<bind> g'') = qbs_prob_space (Y, \<beta>, \<mu> \<bind> g)"
	+ proof(rule pqp2.qbs_prob_space_eq)
	+ show "distr (\<mu>' \<bind> g'') (qbs_to_measure Y) \<alpha>'' = distr (\<mu> \<bind> g) (qbs_to_measure Y) \<beta>"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = \<mu>' \<bind> (\<lambda>x. distr (g'' x) (qbs_to_measure Y) \<alpha>'')"
	+ by(auto intro!: distr_bind[where K=real_borel] simp: measurable_prob_algebraD)
	+ also have "... = \<mu>' \<bind> (\<lambda>x. qbs_prob_measure (qbs_prob_space (Y,\<alpha>'',g'' x)))"
	+ by(auto intro!: bind_cong simp: qbs_prob_MPx[OF h''(1,2)] qbs_prob.qbs_prob_measure_computation)
	+ also have "... = \<mu>' \<bind> (\<lambda>x. (qbs_prob_measure ((f \<circ> \<alpha>') x)))"
	+ by(simp add: hb'(3) h''(3))
	+ also have "... = \<mu>' \<bind> (\<lambda>x. (qbs_prob_measure \<circ> f) (\<alpha>' x))"
	+ by(simp add: comp_def)
	+ also have "... = distr \<mu>' (qbs_to_measure X) \<alpha>' \<bind> qbs_prob_measure \<circ> f"
	+ by(rule bind_distr[where K="qbs_to_measure Y",symmetric],auto)
	+ also have "... = distr \<mu> (qbs_to_measure X) \<alpha> \<bind> qbs_prob_measure \<circ> f"
	+ using pqp1.qbs_prob_space_eq_inverse(1)[OF h_eq]
	+ by(simp add: qbs_prob_eq_def)
	+ also have "... = \<mu> \<bind> (\<lambda>x. (qbs_prob_measure \<circ> f) (\<alpha> x))"
	+ by(rule bind_distr[where K="qbs_to_measure Y"],auto)
	+ also have "... = \<mu> \<bind> (\<lambda>x. (qbs_prob_measure ((f \<circ> \<alpha>) x)))"
	+ by(simp add: comp_def)
	+ also have "... = \<mu> \<bind> (\<lambda>x. qbs_prob_measure (qbs_prob_space (Y,\<beta>,g x)))"
	+ by(auto simp: assms(5))
	+ also have "... = \<mu> \<bind> (\<lambda>x. distr (g x) (qbs_to_measure Y) \<beta>)"
	+ by(auto intro!: bind_cong simp: qbs_prob_MPx[OF assms(3)] qbs_prob.qbs_prob_measure_computation)
	+ also have "... = ?rhs"
	+ by(auto intro!: distr_bind[where K=real_borel,symmetric] simp: measurable_prob_algebraD)
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+ qed
	+ qed (rule in_Rep)
	+qed
	+
	+lemma qbs_bind_morphism':
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ shows "(\<lambda>x. x \<bind> f) \<in> monadP_qbs X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+proof(rule qbs_morphismI,simp)
	+ fix \<beta>
	+ assume "\<beta> \<in> monadP_qbs_MPx X"
	+ then obtain \<alpha> g where hb:
	+ "\<alpha> \<in> qbs_Mx X" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<beta> = (\<lambda>r. qbs_prob_space (X, \<alpha>, g r))"
	+ using rep_monadP_qbs_MPx by blast
	+ obtain \<gamma> g' where hc:
	+ "\<gamma> \<in> qbs_Mx Y" "g' \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "f \<circ> \<alpha> = (\<lambda>r. qbs_prob_space (Y, \<gamma>, g' r))"
	+ using rep_monadP_qbs_MPx[of "f \<circ> \<alpha>" Y] qbs_morphismE(3)[OF assms hb(1),simplified]
	+ by auto
	+ note [measurable] = hb(2) hc(2)
	+ show "(\<lambda>x. x \<bind> f) \<circ> \<beta> \<in> monadP_qbs_MPx Y"
	+ proof -
	+ have "(\<lambda>x. x \<bind> f) \<circ> \<beta> = (\<lambda>r. \<beta> r \<bind> f)"
	+ by auto
	+ also have "... \<in> monadP_qbs_MPx Y"
	+ unfolding monadP_qbs_MPx_def in_MPx_def
	+ by(auto intro!: bexI[where x="\<gamma>"] bexI[where x="\<lambda>r. g r \<bind> g'"] simp: hc(1) hb(3) qbs_prob.qbs_bind_computation[OF qbs_prob_MPx[OF hb(1,2)] _ assms hc])
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+lemma qbs_return_comp:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ shows "(qbs_return X \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (X,\<alpha>,return real_borel r))"
	+proof
	+ fix r
	+ interpret pqp: pair_qbs_prob X "\<lambda>k. \<alpha> r" "return real_borel 0" X \<alpha> "return real_borel r"
	+ by(simp add: assms qbs_Mx_to_X(2)[OF assms] pair_qbs_prob_def qbs_prob_def in_Mx_def real_distribution_def real_distribution_axioms_def prob_space_return)
	+ show "(qbs_return X \<circ> \<alpha>) r = qbs_prob_space (X, \<alpha>, return real_borel r)"
	+ by(auto intro!: pqp.qbs_prob_space_eq simp: distr_return pqp.qp1.qbs_return_computation qbs_Mx_to_X(2)[OF assms])
	+qed
	+
	+lemma qbs_bind_return':
	+ assumes "x \<in> monadP_qbs_Px X"
	+ shows "x \<bind> qbs_return X = x"
	+proof -
	+ obtain \<alpha> \<mu> where h1:"qbs_prob X \<alpha> \<mu>" "x = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using assms rep_monadP_qbs_Px by blast
	+ then interpret qp: qbs_prob X \<alpha> \<mu>
	+ by simp
	+ show ?thesis
	+ using qp.qbs_bind_computation[OF h1(2) qbs_return_morphism _ measurable_return_prob_space qbs_return_comp[OF qp.in_Mx]]
	+ by(simp add: h1(2) bind_return'' prob_space_return qbs_probI)
	+qed
	+
	+lemma qbs_bind_return:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ and "x \<in> qbs_space X"
	+ shows "qbs_return X x \<bind> f = f x"
	+proof -
	+ have "f x \<in> monadP_qbs_Px Y"
	+ using assms by auto
	+ then obtain \<beta> \<mu> where hf:"qbs_prob Y \<beta> \<mu>" "f x = qbs_prob_space (Y, \<beta>, \<mu>)"
	+ using rep_monadP_qbs_Px by blast
	+ then interpret rd: real_distribution "return real_borel 0"
	+ by(simp add: qbs_prob_def prob_space_return real_distribution_def real_distribution_axioms_def)
	+ interpret rd': real_distribution \<mu>
	+ using hf(1) by(simp add: qbs_prob_def)
	+ interpret qp: qbs_prob X "\<lambda>r. x" "return real_borel 0"
	+ using assms(2) by(auto simp: qbs_prob_def in_Mx_def rd.real_distribution_axioms)
	+ show ?thesis
	+ by(auto intro!: qp.qbs_bind_computation(2)[OF rd.qbs_return_computation[OF assms(2)] assms(1) _ measurable_const[of \<mu>],of \<beta>,simplified bind_const'[OF rd.prob_space_axioms rd'.subprob_space_axioms]]
	+ simp: hf[simplified qbs_prob_def in_Mx_def] prob_algebra_real_prob_measure)
	+qed
	+
	+lemma qbs_bind_assoc:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ shows "s \<bind> (\<lambda>x. f x \<bind> g) = (s \<bind> f) \<bind> g"
	+proof -
	+ obtain \<alpha> \<mu> where H0:"qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using assms rep_monadP_qbs_Px by blast
	+ then have "f \<circ> \<alpha> \<in> monadP_qbs_MPx Y"
	+ using assms(2) by(auto simp: qbs_prob_def in_Mx_def)
	+ from rep_monadP_qbs_MPx[OF this] obtain \<beta> g1 where H1:
	+ "\<beta> \<in> qbs_Mx Y" "g1 \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ " (f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, g1 r))"
	+ by auto
	+ hence "g \<circ> \<beta> \<in> monadP_qbs_MPx Z"
	+ using assms by(simp add: qbs_morphism_def)
	+ from rep_monadP_qbs_MPx[OF this] obtain \<gamma> g2 where H2:
	+ "\<gamma> \<in> qbs_Mx Z" "g2 \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(g \<circ> \<beta>) = (\<lambda>r. qbs_prob_space (Z, \<gamma>, g2 r))"
	+ by auto
	+ note [measurable] = H1(2) H2(2)
	+ interpret rd: real_distribution \<mu>
	+ using H0(1) by(simp add: qbs_prob_def)
	+ have LHS: "(s \<bind> f) \<bind> g = qbs_prob_space (Z, \<gamma>, \<mu> \<bind> g1 \<bind> g2)"
	+ by(rule qbs_prob.qbs_bind_computation(2)[OF qbs_prob.qbs_bind_computation[OF H0 assms(2) H1] assms(3) H2])
	+ have RHS: "s \<bind> (\<lambda>x. f x \<bind> g) = qbs_prob_space (Z, \<gamma>, \<mu> \<bind> (\<lambda>x. g1 x \<bind> g2))"
	+ apply(auto intro!: qbs_prob.qbs_bind_computation[OF H0 qbs_morphism_comp[OF assms(2) qbs_bind_morphism'[OF assms(3)],simplified comp_def]]
	+ simp: real_distribution_def real_distribution_axioms_def qbs_prob_def qbs_prob_MPx[OF H2(1,2),simplified qbs_prob_def] sets_bind'[OF measurable_space[OF H1(2)] H2(2)] prob_space_bind'[OF measurable_space[OF H1(2)] H2(2)] measurable_space[OF H2(2)] space_prob_algebra[of real_borel] H2(1))
	+ proof
	+ fix r
	+ show "((\<lambda>x. f x \<bind> g) \<circ> \<alpha>) r = qbs_prob_space (Z, \<gamma>, g1 r \<bind> g2)" (is "?lhs = ?rhs") for r
	+ by(auto intro!: qbs_prob.qbs_bind_computation(2)[of Y \<beta>]
	+ simp: qbs_prob_MPx[OF H1(1,2),of r] assms(3) H2 fun_cong[OF H1(3),simplified comp_def])
	+ qed
	+ have ba: "\<mu> \<bind> g1 \<bind> g2 = \<mu> \<bind> (\<lambda>x. g1 x \<bind> g2)"
	+ by(auto intro!: bind_assoc[where N=real_borel and R=real_borel] simp: measurable_prob_algebraD)
	+ show ?thesis
	+ by(simp add: LHS RHS ba)
	+qed
	+
	+lemma qbs_bind_cong:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x = g x"
	+ and "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ shows "s \<bind> f = s \<bind> g"
	+proof -
	+ obtain \<alpha> \<mu> where h0:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ then have "f \<circ> \<alpha> \<in> monadP_qbs_MPx Y"
	+ using assms(3) h0(1) by(auto simp: qbs_prob_def in_Mx_def)
	+ from rep_monadP_qbs_MPx[OF this] obtain \<gamma> k where h1:
	+ "\<gamma> \<in> qbs_Mx Y" "k \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<gamma>, k r))"
	+ by auto
	+ have hg:"g \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ using qbs_morphism_cong[OF assms(2,3)] by simp
	+ have hgs: "f \<circ> \<alpha> = g \<circ> \<alpha>"
	+ using h0(1) assms(2) by(force simp: qbs_prob_def in_Mx_def)
	+
	+ show ?thesis
	+ by(simp add: qbs_prob.qbs_bind_computation(2)[OF h0 assms(3) h1]
	+ qbs_prob.qbs_bind_computation(2)[OF h0 hg h1[simplified hgs]])
	+qed
	+
	+subsubsection \<open> The Functorial Action $P(f)$\<close>
	+definition monadP_qbs_Pf :: "['a quasi_borel, 'b quasi_borel,'a \<Rightarrow> 'b,'a qbs_prob_space] \<Rightarrow> 'b qbs_prob_space" where
	+"monadP_qbs_Pf _ Y f sx \<equiv> sx \<bind> qbs_return Y \<circ> f"
	+
	+lemma monadP_qbs_Pf_morphism:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ shows "monadP_qbs_Pf X Y f \<in> monadP_qbs X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ unfolding monadP_qbs_Pf_def
	+ by(rule qbs_bind_morphism'[OF qbs_morphism_comp[OF assms qbs_return_morphism]])
	+
	+lemma(in qbs_prob) monadP_qbs_Pf_computation:
	+ assumes "s = qbs_prob_space (X,\<alpha>,\<mu>)"
	+ and "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ shows "qbs_prob Y (f \<circ> \<alpha>) \<mu>"
	+ and "monadP_qbs_Pf X Y f s = qbs_prob_space (Y,f \<circ> \<alpha>,\<mu>)"
	+ by(auto intro!: qbs_bind_computation[OF assms(1) qbs_morphism_comp[OF assms(2) qbs_return_morphism],of "f \<circ> \<alpha>" "return real_borel" ,simplified bind_return''[OF M_is_borel]]
	+ simp: monadP_qbs_Pf_def qbs_return_comp[OF qbs_morphismE(3)[OF assms(2) in_Mx],simplified comp_assoc[symmetric]] qbs_morphismE(3)[OF assms(2) in_Mx] prob_space_return)
	+
	+text \<open> We show that P is a functor i.e. P preserves identity and composition.\<close>
	+lemma monadP_qbs_Pf_id:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ shows "monadP_qbs_Pf X X id s = s"
	+ using qbs_bind_return'[OF assms] by(simp add: monadP_qbs_Pf_def)
	+
	+lemma monadP_qbs_Pf_comp:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q Z"
	+ shows "((monadP_qbs_Pf Y Z g) \<circ> (monadP_qbs_Pf X Y f)) s = monadP_qbs_Pf X Z (g \<circ> f) s"
	+proof -
	+ obtain \<alpha> \<mu> where h:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ hence "qbs_prob Y (f \<circ> \<alpha>) \<mu>"
	+ "monadP_qbs_Pf X Y f s = qbs_prob_space (Y,f \<circ> \<alpha>,\<mu>)"
	+ using qbs_prob.monadP_qbs_Pf_computation[OF _ _ assms(2)] by auto
	+ from qbs_prob.monadP_qbs_Pf_computation[OF this assms(3)] qbs_prob.monadP_qbs_Pf_computation[OF h qbs_morphism_comp[OF assms(2,3)]]
	+ show ?thesis
	+ by(simp add: comp_assoc)
	+qed
	+
	+subsubsection \<open> Join \<close>
	+definition qbs_join :: "'a qbs_prob_space qbs_prob_space \<Rightarrow> 'a qbs_prob_space" where
	+"qbs_join \<equiv> (\<lambda>sst. sst \<bind> id)"
	+
	+lemma qbs_join_morphism:
	+ "qbs_join \<in> monadP_qbs (monadP_qbs X) \<rightarrow>\<^sub>Q monadP_qbs X"
	+ by(simp add: qbs_join_def qbs_bind_morphism'[OF qbs_morphism_ident])
	+
	+lemma qbs_join_computation:
	+ assumes "qbs_prob (monadP_qbs X) \<beta> \<mu>"
	+ "ssx = qbs_prob_space (monadP_qbs X,\<beta>,\<mu>)"
	+ "\<alpha> \<in> qbs_Mx X"
	+ "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ and "\<beta> =(\<lambda>r. qbs_prob_space (X,\<alpha>,g r))"
	+ shows "qbs_prob X \<alpha> (\<mu> \<bind> g)" "qbs_join ssx = qbs_prob_space (X,\<alpha>, \<mu> \<bind> g)"
	+ using qbs_prob.qbs_bind_computation[OF assms(1,2) qbs_morphism_ident assms(3,4)]
	+ by(auto simp: assms(5) qbs_join_def)
	+
	+subsubsection \<open> Strength \<close>
	+definition qbs_strength :: "['a quasi_borel,'b quasi_borel,'a \<times> 'b qbs_prob_space] \<Rightarrow> ('a \<times> 'b) qbs_prob_space" where
	+"qbs_strength W X = (\<lambda>(w,sx). let (_,\<alpha>,\<mu>) = rep_qbs_prob_space sx
	+ in qbs_prob_space (W \<Otimes>\<^sub>Q X, \<lambda>r. (w,\<alpha> r), \<mu>))"
	+
	+lemma(in qbs_prob) qbs_strength_computation:
	+ assumes "w \<in> qbs_space W"
	+ and "sx = qbs_prob_space (X,\<alpha>,\<mu>)"
	+ shows "qbs_prob (W \<Otimes>\<^sub>Q X) (\<lambda>r. (w,\<alpha> r)) \<mu>"
	+ "qbs_strength W X (w,sx) = qbs_prob_space (W \<Otimes>\<^sub>Q X, \<lambda>r. (w,\<alpha> r), \<mu>)"
	+proof -
	+ interpret qp1: qbs_prob "W \<Otimes>\<^sub>Q X" "\<lambda>r. (w,\<alpha> r)" \<mu>
	+ by(auto intro!: qbs_probI simp: assms(1) pair_qbs_Mx_def comp_def)
	+ show "qbs_prob (W \<Otimes>\<^sub>Q X) (\<lambda>r. (w,\<alpha> r)) \<mu>"
	+ "qbs_strength W X (w,sx) = qbs_prob_space (W \<Otimes>\<^sub>Q X, \<lambda>r. (w,\<alpha> r), \<mu>)"
	+ apply(simp_all add: qp1.qbs_prob_axioms qbs_strength_def rep_qbs_prob_space_def qbs_prob_space.rep_def)
	+ apply(rule someI2[where a="(X,\<alpha>,\<mu>)"])
	+ proof(auto simp: in_Rep assms(2))
	+ fix X' \<alpha>' \<mu>'
	+ assume h:"(X',\<alpha>',\<mu>') \<in> Rep_qbs_prob_space (qbs_prob_space (X, \<alpha>, \<mu>))"
	+ from if_in_Rep(1,2)[OF this] interpret pqp: pair_qbs_prob "W \<Otimes>\<^sub>Q X" "\<lambda>r. (w, \<alpha>' r)" \<mu>' "W \<Otimes>\<^sub>Q X" "\<lambda>r. (w,\<alpha> r)" \<mu>
	+ by(simp add: pair_qbs_prob_def qp1.qbs_prob_axioms)
	+ (auto intro!: qbs_probI simp: pair_qbs_Mx_def comp_def assms(1) qbs_prob_def in_Mx_def)
	+ note [simp] = qbs_prob_eq2_dest[OF if_in_Rep(3)[OF h,simplified qbs_prob_eq_equiv12]]
	+ show "qbs_prob_space (W \<Otimes>\<^sub>Q X, \<lambda>r. (w, \<alpha>' r), \<mu>') = qbs_prob_space (W \<Otimes>\<^sub>Q X, \<lambda>r. (w, \<alpha> r), \<mu>)"
	+ proof(rule pqp.qbs_prob_space_eq2)
	+ fix f
	+ assume "f \<in> qbs_to_measure (W \<Otimes>\<^sub>Q X) \<rightarrow>\<^sub>M real_borel"
	+ note qbs_morphism_dest[OF qbs_morphismE(2)[OF curry_preserves_morphisms[OF qbs_morphism_measurable_intro[OF this]] assms(1),simplified]]
	+ show "(\<integral>y. f ((\<lambda>r. (w, \<alpha>' r)) y) \<partial> \<mu>') = (\<integral>y. f ((\<lambda>r. (w, \<alpha> r)) y) \<partial> \<mu>)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = (\<integral>y. curry f w (\<alpha>' y) \<partial> \<mu>')" by auto
	+ also have "... = (\<integral>y. curry f w (\<alpha> y) \<partial> \<mu>)"
	+ by(rule qbs_prob_eq2_dest(4)[OF if_in_Rep(3)[OF h,simplified qbs_prob_eq_equiv12],symmetric]) fact
	+ also have "... = ?rhs" by auto
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+ qed
	+qed
	+
	+lemma qbs_strength_natural:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q X'"
	+ "g \<in> Y \<rightarrow>\<^sub>Q Y'"
	+ "x \<in> qbs_space X"
	+ and "sy \<in> monadP_qbs_Px Y"
	+ shows "(monadP_qbs_Pf (X \<Otimes>\<^sub>Q Y) (X' \<Otimes>\<^sub>Q Y') (map_prod f g) \<circ> qbs_strength X Y) (x,sy) = (qbs_strength X' Y' \<circ> map_prod f (monadP_qbs_Pf Y Y' g)) (x,sy)"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain \<beta> \<nu> where hy:
	+ "qbs_prob Y \<beta> \<nu>" "sy = qbs_prob_space (Y,\<beta>,\<nu>)"
	+ using rep_monadP_qbs_Px[OF assms(4)] by auto
	+ have "qbs_prob (X \<Otimes>\<^sub>Q Y) (\<lambda>r. (x, \<beta> r)) \<nu>"
	+ "qbs_strength X Y (x, sy) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, \<lambda>r. (x, \<beta> r), \<nu>)"
	+ using qbs_prob.qbs_strength_computation[OF hy(1) assms(3) hy(2)] by auto
	+ hence LHS:"?lhs = qbs_prob_space (X' \<Otimes>\<^sub>Q Y',map_prod f g \<circ> (\<lambda>r. (x, \<beta> r)),\<nu>)"
	+ by(simp add: qbs_prob.monadP_qbs_Pf_computation[OF _ _ qbs_morphism_map_prod[OF assms(1,2)]])
	+
	+ have "map_prod f (monadP_qbs_Pf Y Y' g) (x,sy) = (f x,qbs_prob_space (Y',g \<circ> \<beta>,\<nu>))"
	+ "qbs_prob Y' (g \<circ> \<beta>) \<nu>"
	+ by(auto simp: qbs_prob.monadP_qbs_Pf_computation[OF hy assms(2)])
	+ hence RHS:"?rhs = qbs_prob_space (X' \<Otimes>\<^sub>Q Y',\<lambda>r. (f x, (g \<circ> \<beta>) r),\<nu>)"
	+ using qbs_prob.qbs_strength_computation[OF _ _ refl,of Y' "g \<circ> \<beta>" \<nu> "f x" X'] assms(1,3)
	+ by auto
	+
	+ show "?lhs = ?rhs"
	+ unfolding LHS RHS
	+ by(simp add: comp_def)
	+qed
	+
	+lemma qbs_strength_ab_r:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ "\<beta> \<in> monadP_qbs_MPx Y"
	+ "\<gamma> \<in> qbs_Mx Y"
	+ and [measurable]:"g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ and "\<beta> = (\<lambda>r. qbs_prob_space (Y,\<gamma>,g r))"
	+ shows "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<gamma> \<circ> real_real.g) (distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f)"
	+ "qbs_strength X Y (\<alpha> r, \<beta> r) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<gamma> \<circ> real_real.g, distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f)"
	+proof -
	+ have [measurable_cong]: "sets (g r) = sets real_borel"
	+ "sets (return real_borel r) = sets real_borel"
	+ using measurable_space[OF assms(4),of r]
	+ by(simp_all add: space_prob_algebra)
	+ interpret qp: qbs_prob "X \<Otimes>\<^sub>Q Y" "map_prod \<alpha> \<gamma> \<circ> real_real.g" "distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f"
	+ proof(auto intro!: qbs_probI)
	+ show "map_prod \<alpha> \<gamma> \<circ> real_real.g \<in> pair_qbs_Mx X Y"
	+ using qbs_closed1_dest[OF assms(1)] qbs_closed1_dest[OF assms(3)]
	+ by(auto simp: comp_def qbs_prob_def in_Mx_def pair_qbs_Mx_def)
	+ next
	+ show "prob_space (distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f) "
	+ using measurable_space[OF assms(4),of r]
	+ by(auto intro!: prob_space.prob_space_distr simp: prob_algebra_real_prob_measure prob_space_pair prob_space_return real_distribution.axioms(1))
	+ qed
	+ interpret pqp: pair_qbs_prob "X \<Otimes>\<^sub>Q Y" "\<lambda>l. (\<alpha> r, \<gamma> l)" "g r" "X \<Otimes>\<^sub>Q Y" "map_prod \<alpha> \<gamma> \<circ> real_real.g" "distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f"
	+ by(simp add: qbs_prob.qbs_strength_computation[OF qbs_prob_MPx[OF assms(3,4)] qbs_Mx_to_X(2)[OF assms(1)] fun_cong[OF assms(5)],of r] pair_qbs_prob_def qp.qbs_prob_axioms)
	+ have [measurable]: "map_prod \<alpha> \<gamma> \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M qbs_to_measure (X \<Otimes>\<^sub>Q Y)"
	+ proof -
	+ have "map_prod \<alpha> \<gamma> \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y"
	+ using assms(1,3) by(auto intro!: qbs_morphism_map_prod simp: qbs_Mx_is_morphisms)
	+ hence "map_prod \<alpha> \<gamma> \<in> qbs_to_measure (\<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q) \<rightarrow>\<^sub>M qbs_to_measure (X \<Otimes>\<^sub>Q Y)"
	+ using l_preserves_morphisms by auto
	+ thus ?thesis
	+ by simp
	+ qed
	+ hence [measurable]:"(\<lambda>l. (\<alpha> r, \<gamma> l)) \<in> real_borel \<rightarrow>\<^sub>M qbs_to_measure (X \<Otimes>\<^sub>Q Y)"
	+ using pqp.qp1.in_Mx qbs_Mx_are_measurable by blast
	+
	+ show "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<gamma> \<circ> real_real.g) (distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f)"
	+ "qbs_strength X Y (\<alpha> r, \<beta> r) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<gamma> \<circ> real_real.g, distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f)"
	+ apply(simp_all add: qp.qbs_prob_axioms qbs_prob.qbs_strength_computation(2)[OF qbs_prob_MPx[OF assms(3,4)] qbs_Mx_to_X(2)[OF assms(1)] fun_cong[OF assms(5)],of r])
	+ proof(rule pqp.qbs_prob_space_eq)
	+ show "distr (g r) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (\<lambda>l. (\<alpha> r, \<gamma> l)) = distr (distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (map_prod \<alpha> \<gamma> \<circ> real_real.g)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = distr (g r) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (map_prod \<alpha> \<gamma> \<circ> Pair r)"
	+ by(simp add: comp_def)
	+ also have "... = distr (distr (g r) (real_borel \<Otimes>\<^sub>M real_borel) (Pair r)) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (map_prod \<alpha> \<gamma>)"
	+ by(auto intro!: distr_distr[symmetric])
	+ also have "... = distr (return real_borel r \<Otimes>\<^sub>M g r) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (map_prod \<alpha> \<gamma>)"
	+ proof -
	+ have "return real_borel r \<Otimes>\<^sub>M g r = distr (g r) (real_borel \<Otimes>\<^sub>M real_borel) (\<lambda>l. (r,l))"
	+ proof(auto intro!: measure_eqI)
	+ fix A
	+ assume h':"A \<in> sets (real_borel \<Otimes>\<^sub>M real_borel)"
	+ show "emeasure (return real_borel r \<Otimes>\<^sub>M g r) A = emeasure (distr (g r) (real_borel \<Otimes>\<^sub>M real_borel) (Pair r)) A"
	+ (is "?lhs' = ?rhs'")
	+ proof -
	+ have "?lhs' = \<integral>\<^sup>+ x. emeasure (g r) (Pair x -` A) \<partial>return real_borel r"
	+ by(auto intro!: pqp.qp1.emeasure_pair_measure_alt simp: h')
	+ also have "... = emeasure (g r) (Pair r -` A)"
	+ by(auto intro!: nn_integral_return pqp.qp1.measurable_emeasure_Pair simp: h')
	+ also have "... = ?rhs'"
	+ by(simp add: emeasure_distr[OF _ h'])
	+ finally show ?thesis .
	+ qed
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = ?rhs"
	+ by(rule distr_distr[of "map_prod \<alpha> \<gamma> \<circ> real_real.g" real_borel "qbs_to_measure (X \<Otimes>\<^sub>Q Y)" real_real.f "return real_borel r \<Otimes>\<^sub>M g r",simplified comp_assoc,simplified,symmetric])
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+qed
	+
	+
	+lemma qbs_strength_morphism:
	+ "qbs_strength X Y \<in> X \<Otimes>\<^sub>Q monadP_qbs Y \<rightarrow>\<^sub>Q monadP_qbs (X \<Otimes>\<^sub>Q Y)"
	+proof(rule pair_qbs_morphismI,simp)
	+ fix \<alpha> \<beta>
	+ assume h:"\<alpha> \<in> qbs_Mx X"
	+ "\<beta> \<in> monadP_qbs_MPx Y"
	+ then obtain \<gamma> g where hb:
	+ "\<gamma> \<in> qbs_Mx Y" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<beta> = (\<lambda>r. qbs_prob_space (Y, \<gamma>, g r))"
	+ using rep_monadP_qbs_MPx[of \<beta>] by blast
	+ note [measurable] = hb(2)
	+ show "qbs_strength X Y \<circ> (\<lambda>r. (\<alpha> r, \<beta> r)) \<in> monadP_qbs_MPx (X \<Otimes>\<^sub>Q Y)"
	+ using qbs_strength_ab_r[OF h hb]
	+ by(auto intro!: bexI[where x="map_prod \<alpha> \<gamma> \<circ> real_real.g"] bexI[where x="\<lambda>r. distr (return real_borel r \<Otimes>\<^sub>M g r) real_borel real_real.f"]
	+ simp: monadP_qbs_MPx_def in_MPx_def qbs_prob_def in_Mx_def)
	+qed
	+
	+lemma qbs_bind_morphism'':
	+ "(\<lambda>(f,x). x \<bind> f) \<in> exp_qbs X (monadP_qbs Y) \<Otimes>\<^sub>Q (monadP_qbs X) \<rightarrow>\<^sub>Q (monadP_qbs Y)"
	+proof(rule qbs_morphism_cong[of _ "qbs_join \<circ> (monadP_qbs_Pf (exp_qbs X (monadP_qbs Y) \<Otimes>\<^sub>Q X) (monadP_qbs Y) qbs_eval) \<circ> (qbs_strength (exp_qbs X (monadP_qbs Y)) X)"], auto)
	+ fix f
	+ fix sx
	+ assume h:"f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ "sx \<in> monadP_qbs_Px X"
	+ then obtain \<alpha> \<mu> where h0:"qbs_prob X \<alpha> \<mu>" "sx = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[of sx X] by auto
	+ hence "f \<circ> \<alpha> \<in> monadP_qbs_MPx Y"
	+ using h(1) by(auto simp: qbs_prob_def in_Mx_def)
	+ then obtain \<beta> g where h1:
	+ "\<beta> \<in> qbs_Mx Y" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, g r))"
	+ using rep_monadP_qbs_MPx[of "f \<circ> \<alpha>" Y] by blast
	+
	+ show "qbs_join (monadP_qbs_Pf (exp_qbs X (monadP_qbs Y) \<Otimes>\<^sub>Q X) (monadP_qbs Y) qbs_eval (qbs_strength (exp_qbs X (monadP_qbs Y)) X (f, sx))) =
	+ sx \<bind> f"
	+ by(simp add: qbs_join_computation[OF qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h0(1) _ h0(2),of f "exp_qbs X (monadP_qbs Y)"] qbs_eval_morphism] h1(1,2),simplified qbs_eval_def comp_def,simplified,OF h(1) h1(3)[simplified comp_def]] qbs_prob.qbs_bind_computation[OF h0 h(1) h1])
	+next
	+ show "qbs_join \<circ> monadP_qbs_Pf (exp_qbs X (monadP_qbs Y) \<Otimes>\<^sub>Q X) (monadP_qbs Y) qbs_eval \<circ> qbs_strength (exp_qbs X (monadP_qbs Y)) X \<in> exp_qbs X (monadP_qbs Y) \<Otimes>\<^sub>Q monadP_qbs X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ using qbs_join_morphism monadP_qbs_Pf_morphism[OF qbs_eval_morphism]
	+ by(auto intro!: qbs_morphism_comp simp: qbs_strength_morphism)
	+qed
	+
	+lemma qbs_bind_morphism''':
	+ "(\<lambda>f x. x \<bind> f) \<in> exp_qbs X (monadP_qbs Y) \<rightarrow>\<^sub>Q exp_qbs (monadP_qbs X) (monadP_qbs Y)"
	+ using qbs_bind_morphism'' curry_preserves_morphisms[of "\<lambda>(f, x). qbs_bind x f"]
	+ by fastforce
	+
	+lemma qbs_bind_morphism:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ and "g \<in> X \<rightarrow>\<^sub>Q exp_qbs Y (monadP_qbs Z)"
	+ shows "(\<lambda>x. f x \<bind> g x) \<in> X \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ using qbs_morphism_comp[OF qbs_morphism_tuple[OF assms(2,1)] qbs_bind_morphism'']
	+ by(simp add: comp_def)
	+
	+lemma qbs_bind_morphism'''':
	+ assumes "x \<in> monadP_qbs_Px X"
	+ shows "(\<lambda>f. x \<bind> f) \<in> exp_qbs X (monadP_qbs Y) \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ by(rule qbs_morphismE(2)[OF arg_swap_morphism[OF qbs_bind_morphism'''],simplified,OF assms])
	+
	+lemma qbs_strength_law1:
	+ assumes "x \<in> qbs_space (unit_quasi_borel \<Otimes>\<^sub>Q monadP_qbs X)"
	+ shows "snd x = (monadP_qbs_Pf (unit_quasi_borel \<Otimes>\<^sub>Q X) X snd \<circ> qbs_strength unit_quasi_borel X) x"
	+proof -
	+ obtain \<alpha> \<mu> where h:
	+ "qbs_prob X \<alpha> \<mu>" "(snd x) = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[of "snd x" X] assms by auto
	+ have [simp]: "((),snd x) = x"
	+ using SigmaE assms by auto
	+ show ?thesis
	+ using qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h(1) _ h(2),of "fst x" "unit_quasi_borel",simplified] snd_qbs_morphism]
	+ by(simp add: h(2) comp_def)
	+qed
	+
	+lemma qbs_strength_law2:
	+ assumes "x \<in> qbs_space ((X \<Otimes>\<^sub>Q Y) \<Otimes>\<^sub>Q monadP_qbs Z)"
	+ shows "(qbs_strength X (Y \<Otimes>\<^sub>Q Z) \<circ> (map_prod id (qbs_strength Y Z)) \<circ> (\<lambda>((x,y),z). (x,(y,z)))) x =
	+ (monadP_qbs_Pf ((X \<Otimes>\<^sub>Q Y) \<Otimes>\<^sub>Q Z) (X \<Otimes>\<^sub>Q (Y \<Otimes>\<^sub>Q Z)) (\<lambda>((x,y),z). (x,(y,z))) \<circ> qbs_strength (X \<Otimes>\<^sub>Q Y) Z) x"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain \<alpha> \<mu> where h:
	+ "qbs_prob Z \<alpha> \<mu>" "snd x = qbs_prob_space (Z, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[of "snd x" Z] assms by auto
	+ have "?lhs = qbs_prob_space (X \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q Z, \<lambda>r. (fst (fst x), snd (fst x), \<alpha> r), \<mu>)"
	+ using assms qbs_prob.qbs_strength_computation[OF h(1) _ h(2),of "snd (fst x)" Y]
	+ by(auto intro!: qbs_prob.qbs_strength_computation)
	+ also have "... = ?rhs"
	+ using qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h(1) _ h(2),of "fst x" "X \<Otimes>\<^sub>Q Y"] qbs_morphism_pair_assoc1] assms
	+ by(auto simp: comp_def)
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_strength_law3:
	+ assumes "x \<in> qbs_space (X \<Otimes>\<^sub>Q Y)"
	+ shows "qbs_return (X \<Otimes>\<^sub>Q Y) x = (qbs_strength X Y \<circ> (map_prod id (qbs_return Y))) x"
	+proof -
	+ interpret qp: qbs_prob Y "\<lambda>r. snd x" "return real_borel 0"
	+ using assms by(auto intro!: qbs_probI simp: prob_space_return)
	+ show ?thesis
	+ using qp.qbs_strength_computation[OF _ qp.qbs_return_computation[of "snd x" Y],of "fst x" X] assms
	+ by(auto simp: qp.qbs_return_computation[OF assms])
	+qed
	+
	+lemma qbs_strength_law4:
	+ assumes "x \<in> qbs_space (X \<Otimes>\<^sub>Q monadP_qbs (monadP_qbs Y))"
	+ shows "(qbs_strength X Y \<circ> map_prod id qbs_join) x = (qbs_join \<circ> monadP_qbs_Pf (X \<Otimes>\<^sub>Q monadP_qbs Y) (monadP_qbs (X \<Otimes>\<^sub>Q Y))(qbs_strength X Y) \<circ> qbs_strength X (monadP_qbs Y)) x"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain \<beta> \<mu> where h0:
	+ "qbs_prob (monadP_qbs Y) \<beta> \<mu>" "snd x = qbs_prob_space (monadP_qbs Y, \<beta>, \<mu>)"
	+ using rep_monadP_qbs_Px[of "snd x" "monadP_qbs Y"] assms by auto
	+ then obtain \<gamma> g where h1:
	+ "\<gamma> \<in> qbs_Mx Y" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<beta> = (\<lambda>r. qbs_prob_space (Y, \<gamma>, g r))"
	+ using rep_monadP_qbs_MPx[of \<beta> Y] by(auto simp: qbs_prob_def in_Mx_def)
	+ have "?lhs = qbs_prob_space (X \<Otimes>\<^sub>Q Y, \<lambda>r. (fst x, \<gamma> r), \<mu> \<bind> g)"
	+ using qbs_prob.qbs_strength_computation[OF qbs_join_computation(1)[OF h0 h1] _ qbs_join_computation(2)[OF h0 h1],of "fst x" X] assms
	+ by auto
	+ also have "... = ?rhs"
	+ proof -
	+ have "qbs_strength X Y \<circ> (\<lambda>r. (fst x, \<beta> r)) = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q Y, \<lambda>r. (fst x, \<gamma> r), g r))"
	+ proof
	+ show "(qbs_strength X Y \<circ> (\<lambda>r. (fst x, \<beta> r))) r = qbs_prob_space (X \<Otimes>\<^sub>Q Y, \<lambda>r. (fst x, \<gamma> r), g r)" for r
	+ using qbs_prob.qbs_strength_computation(2)[OF qbs_prob_MPx[OF h1(1,2),of r] _ fun_cong[OF h1(3)],of "fst x" X] assms
	+ by auto
	+ qed
	+ thus ?thesis
	+ using qbs_join_computation(2)[OF qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h0(1) _ h0(2),of "fst x" X] qbs_strength_morphism] _ h1(2),of "\<lambda>r. (fst x, \<gamma> r)",symmetric] assms h1(1)
	+ by(auto simp: pair_qbs_Mx_def comp_def)
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+
	+lemma qbs_return_Mxpair:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ and "\<beta> \<in> qbs_Mx Y"
	+ shows "qbs_return (X \<Otimes>\<^sub>Q Y) (\<alpha> r, \<beta> k) = qbs_prob_space (X \<Otimes>\<^sub>Q Y,map_prod \<alpha> \<beta> \<circ> real_real.g, distr (return real_borel r \<Otimes>\<^sub>M return real_borel k) real_borel real_real.f)"
	+ "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (return real_borel r \<Otimes>\<^sub>M return real_borel k) real_borel real_real.f)"
	+proof -
	+ note [measurable_cong] = sets_return[of real_borel]
	+ interpret qp: qbs_prob "X \<Otimes>\<^sub>Q Y" "map_prod \<alpha> \<beta> \<circ> real_real.g" "distr (return real_borel r \<Otimes>\<^sub>M return real_borel k) real_borel real_real.f"
	+ using qbs_closed1_dest[OF assms(1)] qbs_closed1_dest[OF assms(2)]
	+ by(auto intro!: qbs_probI prob_space.prob_space_distr prob_space_pair
	+ simp: pair_qbs_Mx_def comp_def prob_space_return)
	+ show "qbs_return (X \<Otimes>\<^sub>Q Y) (\<alpha> r, \<beta> k) = qbs_prob_space (X \<Otimes>\<^sub>Q Y,map_prod \<alpha> \<beta> \<circ> real_real.g, distr (return real_borel r \<Otimes>\<^sub>M return real_borel k) real_borel real_real.f)"
	+ "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (return real_borel r \<Otimes>\<^sub>M return real_borel k) real_borel real_real.f)"
	+ proof -
	+ show "qbs_return (X \<Otimes>\<^sub>Q Y) (\<alpha> r, \<beta> k) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (return real_borel r \<Otimes>\<^sub>M return real_borel k) real_borel real_real.f)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have 1:"(\<lambda>r. qbs_prob_space (Y, \<beta>, return real_borel k)) \<in> monadP_qbs_MPx Y"
	+ by(auto intro!: in_MPx.intro bexI[where x=\<beta>] bexI[where x="\<lambda>r. return real_borel k"] simp: monadP_qbs_MPx_def assms(2))
	+ have "?lhs = (qbs_strength X Y \<circ> map_prod id (qbs_return Y)) (\<alpha> r, \<beta> k)"
	+ by(intro qbs_strength_law3[of "(\<alpha> r, \<beta> k)" X Y]) (use assms in auto)
	+ also have "... = qbs_strength X Y (\<alpha> r, qbs_prob_space (Y, \<beta>, return real_borel k))"
	+ using fun_cong[OF qbs_return_comp[OF assms(2)]] by simp
	+ also have "... = ?rhs"
	+ by(intro qbs_strength_ab_r(2)[OF assms(1) 1 assms(2) _ refl,of r]) auto
	+ finally show ?thesis .
	+ qed
	+ qed(rule qp.qbs_prob_axioms)
	+qed
	+
	+
	+lemma pair_return_return:
	+ assumes "l \<in> space M"
	+ and "r \<in> space N"
	+ shows "return M l \<Otimes>\<^sub>M return N r = return (M \<Otimes>\<^sub>M N) (l,r)"
	+proof(auto intro!: measure_eqI)
	+ fix A
	+ assume h:"A \<in> sets (M \<Otimes>\<^sub>M N)"
	+ show "emeasure (return M l \<Otimes>\<^sub>M return N r) A = indicator A (l, r)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = (\<integral>\<^sup>+ x. \<integral>\<^sup>+ y. indicator A (x, y) \<partial>return N r \<partial>return M l)"
	+ by(auto intro!: sigma_finite_measure.emeasure_pair_measure prob_space_imp_sigma_finite simp: h prob_space_return assms)
	+ also have "... = (\<integral>\<^sup>+ x. indicator A (x, r) \<partial>return M l)"
	+ using h by(auto intro!: nn_integral_cong nn_integral_return simp: assms(2))
	+ also have "... = ?rhs"
	+ using h by(auto intro!: nn_integral_return simp: assms)
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+lemma bind_bind_return_distr:
	+ assumes "real_distribution \<mu>"
	+ and "real_distribution \<nu>"
	+ shows "\<mu> \<bind> (\<lambda>r. \<nu> \<bind> (\<lambda>l. distr (return real_borel r \<Otimes>\<^sub>M return real_borel l) real_borel real_real.f))
	+ = distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f"
	+ (is "?lhs = ?rhs")
	+proof -
	+ interpret rd1: real_distribution \<mu> by fact
	+ interpret rd2: real_distribution \<nu> by fact
	+ interpret pp: pair_prob_space \<mu> \<nu>
	+ by (simp add: pair_prob_space.intro pair_sigma_finite_def rd1.prob_space_axioms rd1.sigma_finite_measure_axioms rd2.prob_space_axioms rd2.sigma_finite_measure_axioms)
	+ have "?lhs = \<mu> \<bind> (\<lambda>r. \<nu> \<bind> (\<lambda>l. distr (return (real_borel \<Otimes>\<^sub>M real_borel) (r,l)) real_borel real_real.f))"
	+ using pair_return_return[of _ real_borel _ real_borel] by simp
	+ also have "... = \<mu> \<bind> (\<lambda>r. \<nu> \<bind> (\<lambda>l. distr (return (\<mu> \<Otimes>\<^sub>M \<nu>) (r, l)) real_borel real_real.f))"
	+ proof -
	+ have "return (real_borel \<Otimes>\<^sub>M real_borel) = return (\<mu> \<Otimes>\<^sub>M \<nu>)"
	+ by(auto intro!: return_sets_cong sets_pair_measure_cong)
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<mu> \<bind> (\<lambda>r. distr (\<nu> \<bind> (\<lambda>l. (return (\<mu> \<Otimes>\<^sub>M \<nu>) (r, l)))) real_borel real_real.f)"
	+ by(auto intro!: bind_cong distr_bind[symmetric,where K="\<mu> \<Otimes>\<^sub>M \<nu>"])
	+ also have "... = distr (\<mu> \<bind> (\<lambda>r. \<nu> \<bind> (\<lambda>l. return (\<mu> \<Otimes>\<^sub>M \<nu>) (r, l)))) real_borel real_real.f"
	+ by(auto intro!: distr_bind[symmetric,where K="\<mu> \<Otimes>\<^sub>M \<nu>"])
	+ also have "... = ?rhs"
	+ by(simp add: pp.pair_measure_eq_bind[symmetric])
	+ finally show ?thesis .
	+qed
	+
	+lemma(in pair_qbs_probs) qbs_bind_return_qp:
	+ shows "qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y))) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+proof -
	+ show "qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, \<nu> \<bind> (\<lambda>l. \<mu> \<bind> (\<lambda>r. distr (return real_borel r \<Otimes>\<^sub>M return real_borel l) real_borel real_real.f)))"
	+ proof(auto intro!: qp2.qbs_bind_computation(2) measurable_bind_prob_space2[where N=real_borel] simp: in_Mx[simplified])
	+ show "(\<lambda>y. qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) \<in> Y \<rightarrow>\<^sub>Q monadP_qbs (X \<Otimes>\<^sub>Q Y)"
	+ using qbs_morphism_const[of _ "monadP_qbs X" Y,simplified,OF qp1.qbs_prob_space_in_Px] curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]]
	+ by (auto intro!: qbs_bind_morphism)
	+ next
	+ show "(\<lambda>y. qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) \<circ> \<beta> = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, \<mu> \<bind> (\<lambda>l. distr (return real_borel l \<Otimes>\<^sub>M return real_borel r) real_borel real_real.f)))"
	+ by standard
	+ (auto intro!: qp1.qbs_bind_computation(2) qbs_morphism_comp[OF qbs_morphism_Pair2[of _ Y] qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"],simplified comp_def]
	+ simp: in_Mx[simplified] qbs_return_Mxpair[OF qp1.in_Mx qp2.in_Mx] qbs_Mx_to_X(2))
	+ qed
	+ also have "... = ?rhs"
	+ proof -
	+ have "\<nu> \<bind> (\<lambda>l. \<mu> \<bind> (\<lambda>r. distr (return real_borel r \<Otimes>\<^sub>M return real_borel l) real_borel real_real.f)) = distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f"
	+ by(auto intro!: bind_rotate[symmetric,where N=real_borel] measurable_prob_algebraD
	+ simp: bind_bind_return_distr[symmetric,OF qp1.real_distribution_axioms qp2.real_distribution_axioms])
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis .
	+ qed
	+ show "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ by(rule qbs_prob_axioms)
	+qed
	+
	+lemma(in pair_qbs_probs) qbs_bind_return_pq:
	+ shows "qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y))) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+proof(simp_all add: qbs_bind_return_qp(2))
	+ show "qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ (is "?lhs = _")
	+ proof -
	+ have "?lhs = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, \<mu> \<bind> (\<lambda>r. \<nu> \<bind> (\<lambda>l. distr (return real_borel r \<Otimes>\<^sub>M return real_borel l) real_borel real_real.f)))"
	+ proof(auto intro!: qp1.qbs_bind_computation(2) measurable_bind_prob_space2[where N=real_borel])
	+ show "(\<lambda>x. qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) \<in> X \<rightarrow>\<^sub>Q monadP_qbs (X \<Otimes>\<^sub>Q Y)"
	+ using qbs_morphism_const[of _ "monadP_qbs Y" X,simplified,OF qp2.qbs_prob_space_in_Px] curry_preserves_morphisms[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
	+ by(auto intro!: qbs_bind_morphism simp: curry_def)
	+ next
	+ show "(\<lambda>x. qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) \<circ> \<alpha> = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, \<nu> \<bind> (\<lambda>l. distr (return real_borel r \<Otimes>\<^sub>M return real_borel l) real_borel real_real.f)))"
	+ by standard
	+ (auto intro!: qp2.qbs_bind_computation(2) qbs_morphism_comp[OF qbs_morphism_Pair1[of _ X] qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"],simplified comp_def]
	+ simp: qbs_return_Mxpair[OF qp1.in_Mx qp2.in_Mx] qbs_Mx_to_X(2))
	+ qed
	+ thus ?thesis
	+ by(simp add: bind_bind_return_distr[OF qp1.real_distribution_axioms qp2.real_distribution_axioms])
	+ qed
	+qed
	+
	+lemma qbs_bind_return_rotate:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ and "q \<in> monadP_qbs_Px Y"
	+ shows "q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y))) = p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))"
	+proof -
	+ obtain \<alpha> \<mu> where hp:
	+ "qbs_prob X \<alpha> \<mu>" "p = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ obtain \<beta> \<nu> where hq:
	+ "qbs_prob Y \<beta> \<nu>" "q = qbs_prob_space (Y, \<beta>, \<nu>)"
	+ using rep_monadP_qbs_Px[OF assms(2)] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: pair_qbs_probs_def hp hq)
	+ show ?thesis
	+ by(simp add: hp(2) hq(2) pqp.qbs_bind_return_pq(1) pqp.qbs_bind_return_qp)
	+qed
	+
	+lemma qbs_pair_bind_return1:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ "p \<in> monadP_qbs_Px X"
	+ and "q \<in> monadP_qbs_Px Y"
	+ shows "q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. f (x,y))) = (q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))) \<bind> f"
	+ (is "?lhs = ?rhs")
	+proof -
	+ note [simp] = qbs_morphism_const[of _ "monadP_qbs X",simplified,OF assms(2)]
	+ qbs_morphism_Pair1'[OF _ assms(1)] qbs_morphism_Pair2'[OF _ assms(1)]
	+ curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]],simplified curry_def,simplified]
	+ qbs_morphism_Pair2'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
	+ arg_swap_morphism[OF curry_preserves_morphisms[OF assms(1)],simplified curry_def]
	+ curry_preserves_morphisms[OF qbs_morphism_comp[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]] qbs_bind_morphism'[OF assms(1)]],simplified curry_def comp_def,simplified]
	+ have [simp]:"(\<lambda>y. p \<bind> (\<lambda>x. f (x,y))) \<in> Y \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ "(\<lambda>y. p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y) \<bind> f)) \<in> Y \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ by(auto intro!: qbs_bind_morphism[where Y=X] simp: curry_def)
	+ have "?lhs = q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y) \<bind> f))"
	+ by(auto intro!: qbs_bind_cong[OF assms(3),where Y=Z] qbs_bind_cong[OF assms(2),where Y=Z] simp: qbs_bind_return[OF assms(1)])
	+ also have "... = q \<bind> (\<lambda>y. (p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y))) \<bind> f)"
	+ by(auto intro!: qbs_bind_cong[OF assms(3),where Y=Z] qbs_bind_assoc[OF assms(2) _ assms(1)] simp: )
	+ also have "... = ?rhs"
	+ by(auto intro!: qbs_bind_assoc[OF assms(3)_ assms(1)] qbs_bind_morphism[where Y=X])
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_pair_bind_return2:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ "p \<in> monadP_qbs_Px X"
	+ and "q \<in> monadP_qbs_Px Y"
	+ shows "p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. f (x,y))) = (p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))) \<bind> f"
	+ (is "?lhs = ?rhs")
	+proof -
	+ note [simp] = qbs_morphism_const[of _ "monadP_qbs Y",simplified,OF assms(3)]
	+ qbs_morphism_Pair1'[OF _ assms(1)] curry_preserves_morphisms[OF assms(1),simplified curry_def]
	+ qbs_morphism_Pair1'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
	+ curry_preserves_morphisms[OF qbs_morphism_comp[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"] qbs_bind_morphism'[OF assms(1)]],simplified curry_def comp_def,simplified]
	+ curry_preserves_morphisms[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"],simplified curry_def]
	+ have [simp]: "(\<lambda>x. q \<bind> (\<lambda>y. f (x, y))) \<in> X \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ "(\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y) \<bind> f)) \<in> X \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ by(auto intro!: qbs_bind_morphism[where Y=Y])
	+ have "?lhs = p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y) \<bind> f))"
	+ by(auto intro!: qbs_bind_cong[OF assms(2),where Y=Z] qbs_bind_cong[OF assms(3),where Y=Z] simp: qbs_bind_return[OF assms(1)])
	+ also have "... = p \<bind> (\<lambda>x. (q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y))) \<bind> f)"
	+ by(auto intro!: qbs_bind_cong[OF assms(2),where Y=Z] qbs_bind_assoc[OF assms(3) _ assms(1)])
	+ also have "... = ?rhs"
	+ by(auto intro!: qbs_bind_assoc[OF assms(2) _ assms(1)] qbs_bind_morphism[where Y=Y])
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_bind_rotate:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q monadP_qbs Z"
	+ "p \<in> monadP_qbs_Px X"
	+ and "q \<in> monadP_qbs_Px Y"
	+ shows "q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. f (x,y))) = p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. f (x,y)))"
	+ using qbs_pair_bind_return1[OF assms(1) assms(2) assms(3)] qbs_bind_return_rotate[OF assms(2) assms(3)] qbs_pair_bind_return2[OF assms(1) assms(2) assms(3)]
	+ by simp
	+
	+
	+lemma(in pair_qbs_probs) qbs_bind_bind_return:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
	+ shows "qbs_prob Z (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ and "qbs_prob_space (X,\<alpha>,\<mu>) \<bind> (\<lambda>x. qbs_prob_space (Y,\<beta>,\<nu>) \<bind> (\<lambda>y. qbs_return Z (f (x,y)))) = qbs_prob_space (Z,f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g),distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ (is "?lhs = ?rhs")
	+proof -
	+ show "qbs_prob Z (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ using qbs_bind_return_qp(2) qbs_morphismE(3)[OF assms] by(simp add: qbs_prob_def in_Mx_def)
	+next
	+ have "?lhs = (qbs_prob_space (X,\<alpha>,\<mu>) \<bind> (\<lambda>x. qbs_prob_space (Y,\<beta>,\<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))) \<bind> qbs_return Z \<circ> f"
	+ using qbs_pair_bind_return2[OF qbs_morphism_comp[OF assms qbs_return_morphism] qp1.qbs_prob_space_in_Px qp2.qbs_prob_space_in_Px]
	+ by(simp add: comp_def)
	+ also have "... = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) \<bind> qbs_return Z \<circ> f"
	+ by(simp add: qbs_bind_return_pq(1))
	+ also have "... = ?rhs"
	+ by(rule monadP_qbs_Pf_computation[OF refl assms,simplified monadP_qbs_Pf_def])
	+ finally show "?lhs = ?rhs" .
	+qed
	+
	+subsubsection \<open> Properties of Return and Bind \<close>
	+lemma qbs_prob_measure_return:
	+ assumes "x \<in> qbs_space X"
	+ shows "qbs_prob_measure (qbs_return X x) = return (qbs_to_measure X) x"
	+proof -
	+ interpret qp: qbs_prob X "\<lambda>r. x" "return real_borel 0"
	+ by(auto intro!: qbs_probI simp: prob_space_return assms)
	+ show ?thesis
	+ by(simp add: qp.qbs_return_computation[OF assms] distr_return)
	+qed
	+
	+lemma qbs_prob_measure_bind:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ and "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ shows "qbs_prob_measure (s \<bind> f) = qbs_prob_measure s \<bind> qbs_prob_measure \<circ> f"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain \<alpha> \<mu> where hs:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by blast
	+ hence "f \<circ> \<alpha> \<in> monadP_qbs_MPx Y"
	+ using assms(2) by(auto simp: qbs_prob_def in_Mx_def)
	+ then obtain \<beta> g where hbg:
	+ "\<beta> \<in> qbs_Mx Y" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, g r))"
	+ using rep_monadP_qbs_MPx by blast
	+ note [measurable] = hbg(2)
	+ have [measurable]:"f \<in> qbs_to_measure X \<rightarrow>\<^sub>M qbs_to_measure (monadP_qbs Y)"
	+ using l_preserves_morphisms assms(2) by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> "\<mu> \<bind> g"
	+ by(simp add: pair_qbs_probs_def hs(1) qbs_prob.qbs_bind_computation[OF hs assms(2) hbg])
	+
	+ have "?lhs = distr (\<mu> \<bind> g) (qbs_to_measure Y) \<beta>"
	+ by(simp add: pqp.qp1.qbs_bind_computation[OF hs(2) assms(2) hbg])
	+ also have "... = \<mu> \<bind> (\<lambda>x. distr (g x) (qbs_to_measure Y) \<beta>)"
	+ by(auto intro!: distr_bind[where K=real_borel] measurable_prob_algebraD)
	+ also have "... = \<mu> \<bind> (\<lambda>x. qbs_prob_measure (qbs_prob_space (Y,\<beta>,g x)))"
	+ using measurable_space[OF hbg(2)]
	+ by(auto intro!: bind_cong qbs_prob.qbs_prob_measure_computation[symmetric] qbs_probI simp: space_prob_algebra)
	+ also have "... = \<mu> \<bind> (\<lambda>x. qbs_prob_measure ((f \<circ> \<alpha>) x))"
	+ by(simp add: hbg(3))
	+ also have "... = \<mu> \<bind> (\<lambda>x. (qbs_prob_measure \<circ> f) (\<alpha> x))" by simp
	+ also have "... = distr \<mu> (qbs_to_measure X) \<alpha> \<bind> qbs_prob_measure \<circ> f"
	+ by(intro bind_distr[symmetric,where K="qbs_to_measure Y"]) auto
	+ also have "... = ?rhs"
	+ by(simp add: hs(2))
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_of_return:
	+ assumes "x \<in> qbs_space X"
	+ shows "qbs_prob_space_qbs (qbs_return X x) = X"
	+ using real_distribution.qbs_return_computation[OF _ assms,of "return real_borel 0"]
	+ qbs_prob.qbs_prob_space_qbs_computation[of X "\<lambda>r. x" "return real_borel 0"] assms
	+ by(auto simp: qbs_prob_def in_Mx_def real_distribution_def real_distribution_axioms_def prob_space_return)
	+
	+lemma qbs_of_bind:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ and "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ shows "qbs_prob_space_qbs (s \<bind> f) = Y"
	+proof -
	+ obtain \<alpha> \<mu> where hs:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ hence "f \<circ> \<alpha> \<in> monadP_qbs_MPx Y"
	+ using assms(2) by(auto simp: qbs_prob_def in_Mx_def)
	+ then obtain \<beta> g where hbg:
	+ "\<beta> \<in> qbs_Mx Y" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, g r))"
	+ using rep_monadP_qbs_MPx by blast
	+ show ?thesis
	+ using qbs_prob.qbs_bind_computation[OF hs assms(2) hbg] qbs_prob.qbs_prob_space_qbs_computation
	+ by simp
	+qed
	+
	+subsubsection \<open> Properties of Integrals\<close>
	+lemma qbs_integrable_return:
	+ assumes "x \<in> qbs_space X"
	+ and "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ shows "qbs_integrable (qbs_return X x) f"
	+ using assms(2) nn_integral_return[of x "qbs_to_measure X" "\<lambda>x. \<bar>f x\<bar>",simplified,OF assms(1)]
	+ by(auto intro!: qbs_integrable_if_integrable integrableI_bounded
	+ simp: qbs_prob_measure_return[OF assms(1)] )
	+
	+lemma qbs_integrable_bind_return:
	+ assumes "s \<in> monadP_qbs_Px Y"
	+ "f \<in> Z \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q Z"
	+ shows "qbs_integrable (s \<bind> (\<lambda>y. qbs_return Z (g y))) f = qbs_integrable s (f \<circ> g)"
	+proof -
	+ obtain \<alpha> \<mu> where hs:
	+ "qbs_prob Y \<alpha> \<mu>" "s = qbs_prob_space (Y, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ then interpret qp: qbs_prob Y \<alpha> \<mu> by simp
	+ show ?thesis (is "?lhs = ?rhs")
	+ proof -
	+ have "qbs_return Z \<circ> (g \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Z, g \<circ> \<alpha>, return real_borel r))"
	+ by(rule qbs_return_comp) (use assms(3) qp.in_Mx in blast)
	+ hence hb:"qbs_prob Z (g \<circ> \<alpha>) \<mu>"
	+ "s \<bind> (\<lambda>y. qbs_return Z (g y)) = qbs_prob_space (Z, g \<circ> \<alpha>, \<mu>)"
	+ by(auto intro!: qbs_prob.qbs_bind_computation[OF hs qbs_morphism_comp[OF assms(3) qbs_return_morphism,simplified comp_def] qbs_morphismE(3)[OF assms(3) qp.in_Mx],of "return real_borel",simplified bind_return''[of \<mu> real_borel,simplified]])
	+ (simp_all add: comp_def)
	+ have "?lhs = integrable \<mu> (f \<circ> (g \<circ> \<alpha>))"
	+ using assms(2)
	+ by(auto intro!: qbs_prob.qbs_integrable_iff_integrable[OF hb(1),simplified comp_def] simp: hb(2) comp_def)
	+ also have "... = ?rhs"
	+ using qbs_morphism_comp[OF assms(3,2)]
	+ by(auto intro!: qbs_prob.qbs_integrable_iff_integrable[OF hs(1),symmetric] simp: hs(2) comp_def)
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+
	+lemma qbs_prob_ennintegral_morphism:
	+ assumes "L \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ and "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<lambda>x. qbs_prob_ennintegral (L x) (f x)) \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+proof(rule qbs_morphismI,simp_all)
	+ fix \<alpha>
	+ assume h0:"\<alpha> \<in> qbs_Mx X"
	+ then obtain \<beta> g where h:
	+ "\<beta> \<in> qbs_Mx Y" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(L \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, g r))"
	+ using rep_monadP_qbs_MPx[of "L \<circ> \<alpha>" Y] qbs_morphismE(3)[OF assms(1)] by auto
	+ note [measurable] = h(2)
	+ have [measurable]: "(\<lambda>(r, y). f (\<alpha> r) (\<beta> y)) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ proof -
	+ have "(\<lambda>(r, y). f (\<alpha> r) (\<beta> y)) = case_prod f \<circ> map_prod \<alpha> \<beta>"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ apply(rule qbs_morphism_comp[OF qbs_morphism_map_prod uncurry_preserves_morphisms[OF assms(2)]])
	+ using h0 h(1) by(auto simp: qbs_Mx_is_morphisms)
	+ finally show ?thesis
	+ by auto
	+ qed
	+ have "(\<lambda>x. qbs_prob_ennintegral (L x) (f x)) \<circ> \<alpha> = (\<lambda>r. qbs_prob_ennintegral ((L \<circ> \<alpha>) r) ((f \<circ> \<alpha>) r))"
	+ by auto
	+ also have "... = (\<lambda>r. (\<integral>\<^sup>+ x. (f \<circ> \<alpha>) r (\<beta> x) \<partial>(g r)))"
	+ apply standard
	+ using h0 by(auto intro!: qbs_prob.qbs_prob_ennintegral_def[OF qbs_prob_MPx[OF h(1,2)]] qbs_morphismE(2)[OF assms(2),simplified] simp: h(3))
	+ also have "... \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ using assms(2) h0 h(1)
	+ by(auto intro!: nn_integral_measurable_subprob_algebra2[where N=real_borel] simp: measurable_prob_algebraD)
	+ finally show "(\<lambda>x. qbs_prob_ennintegral (L x) (f x)) \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel " .
	+qed
	+
	+lemma qbs_morphism_ennintegral_fst:
	+ assumes "q \<in> monadP_qbs_Px Y"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<lambda>x. \<integral>\<^sup>+\<^sub>Q y. f (x, y) \<partial>q) \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ by(rule qbs_prob_ennintegral_morphism[OF qbs_morphism_const[of _ "monadP_qbs Y",simplified,OF assms(1)] curry_preserves_morphisms[OF assms(2)],simplified curry_def])
	+
	+lemma qbs_morphism_ennintegral_snd:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<lambda>y. \<integral>\<^sup>+\<^sub>Q x. f (x, y) \<partial>p) \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ using qbs_morphism_ennintegral_fst[OF assms(1) qbs_morphism_pair_swap[OF assms(2)]]
	+ by fastforce
	+
	+lemma qbs_prob_ennintegral_morphism':
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<lambda>s. qbs_prob_ennintegral s f) \<in> monadP_qbs X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ apply(rule qbs_prob_ennintegral_morphism[of _ _ X])
	+ using qbs_morphism_ident[of "monadP_qbs X"]
	+ apply (simp add: id_def)
	+ using assms qbs_morphism_const[of f "exp_qbs X \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"]
	+ by simp
	+
	+lemma qbs_prob_ennintegral_return:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ and "x \<in> qbs_space X"
	+ shows "qbs_prob_ennintegral (qbs_return X x) f = f x"
	+ using assms
	+ by(auto intro!: nn_integral_return
	+ simp: qbs_prob_ennintegral_def2[OF qbs_of_return[OF assms(2)] assms(1)] qbs_prob_measure_return[OF assms(2)])
	+
	+lemma qbs_prob_ennintegral_bind:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "qbs_prob_ennintegral (s \<bind> f) g = qbs_prob_ennintegral s (\<lambda>y. (qbs_prob_ennintegral (f y) g))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain \<alpha> \<mu> where hs:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ then interpret qp: qbs_prob X \<alpha> \<mu> by simp
	+ obtain \<beta> h where hb:
	+ "\<beta> \<in> qbs_Mx Y" "h \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, h r))"
	+ using rep_monadP_qbs_MPx[OF qbs_morphismE(3)[OF assms(2) qp.in_Mx,simplified]]
	+ by auto
	+ hence h:"qbs_prob Y \<beta> (\<mu> \<bind> h)"
	+ "s \<bind> f = qbs_prob_space (Y, \<beta>, \<mu> \<bind> h)"
	+ using qp.qbs_bind_computation[OF hs(2) assms(2) hb] by auto
	+ hence LHS:"?lhs = (\<integral>\<^sup>+ x. g (\<beta> x) \<partial>(\<mu> \<bind> h))"
	+ using qbs_prob.qbs_prob_ennintegral_def[OF h(1) assms(3)]
	+ by simp
	+ note [measurable] = hb(2)
	+
	+ have "\<And>r. qbs_prob_ennintegral (f (\<alpha> r)) g = (\<integral>\<^sup>+ y. g (\<beta> y) \<partial>(h r))"
	+ using qbs_prob.qbs_prob_ennintegral_def[OF qbs_prob_MPx[OF hb(1,2)] assms(3)] hb(3)[simplified comp_def]
	+ by metis
	+ hence "?rhs = (\<integral>\<^sup>+ r. (\<integral>\<^sup>+ y. (g \<circ> \<beta>) y \<partial>(h r)) \<partial>\<mu>)"
	+ by(auto intro!: nn_integral_cong
	+ simp: qbs_prob.qbs_prob_ennintegral_def[OF hs(1) qbs_prob_ennintegral_morphism[OF assms(2) qbs_morphism_const[of _ "exp_qbs Y \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 ",simplified,OF assms(3)]]] hs(2))
	+ also have "... = (integral\<^sup>N (\<mu> \<bind> h) (g \<circ> \<beta>))"
	+ apply(intro nn_integral_bind[symmetric,of _ real_borel])
	+ using assms(3) hb(1)
	+ by(auto intro!: measurable_prob_algebraD hb(2))
	+ finally show ?thesis
	+ using LHS by(simp add: comp_def)
	+qed
	+
	+lemma qbs_prob_ennintegral_bind_return:
	+ assumes "s \<in> monadP_qbs_Px Y"
	+ "f \<in> Z \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q Z"
	+ shows "qbs_prob_ennintegral (s \<bind> (\<lambda>y. qbs_return Z (g y))) f = qbs_prob_ennintegral s (f \<circ> g)"
	+ apply(simp add: qbs_prob_ennintegral_bind[OF assms(1) qbs_return_morphism'[OF assms(3)] assms(2)])
	+ using assms(1,3)
	+ by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return[OF assms(2)]
	+ simp: monadP_qbs_Px_def)
	+
	+lemma qbs_prob_integral_morphism':
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ shows "(\<lambda>s. qbs_prob_integral s f) \<in> monadP_qbs X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+proof(rule qbs_morphismI;simp)
	+ fix \<alpha>
	+ assume "\<alpha> \<in> monadP_qbs_MPx X"
	+ then obtain \<beta> g where h:
	+ "\<beta> \<in> qbs_Mx X" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "\<alpha> = (\<lambda>r. qbs_prob_space (X, \<beta>, g r))"
	+ using rep_monadP_qbs_MPx[of \<alpha> X] by auto
	+ note [measurable] = h(2)
	+ have [measurable]: "f \<circ> \<beta> \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ using assms h(1) by auto
	+ have "(\<lambda>s. qbs_prob_integral s f) \<circ> \<alpha> = (\<lambda>r. \<integral> x. f (\<beta> x) \<partial>g r)"
	+ apply standard
	+ using assms qbs_prob_MPx[OF h(1,2)] by(auto intro!: qbs_prob.qbs_prob_integral_def simp: h(3))
	+ also have "... = (\<lambda>M. integral\<^sup>L M (f \<circ> \<beta>)) \<circ> g"
	+ by (simp add: comp_def)
	+ also have "... \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ by(auto intro!: measurable_comp[where N="subprob_algebra real_borel"]
	+ simp: integral_measurable_subprob_algebra measurable_prob_algebraD)
	+ finally show "(\<lambda>s. qbs_prob_integral s f) \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M real_borel" .
	+qed
	+
	+lemma qbs_morphism_integral_fst:
	+ assumes "q \<in> monadP_qbs_Px Y"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ shows "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+proof(rule qbs_morphismI,simp_all)
	+ fix \<alpha>
	+ assume ha:"\<alpha> \<in> qbs_Mx X"
	+ obtain \<beta> \<nu> where hq:
	+ "qbs_prob Y \<beta> \<nu>" "q = qbs_prob_space (Y, \<beta>, \<nu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ then interpret qp: qbs_prob Y \<beta> \<nu> by simp
	+ have "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha> = (\<lambda>x. \<integral> y. f (\<alpha> x, \<beta> y) \<partial>\<nu>)"
	+ apply standard
	+ using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF ha] assms(2)]
	+ by(auto intro!: qp.qbs_prob_integral_def
	+ simp: hq(2))
	+ also have "... \<in> borel_measurable borel"
	+ using qbs_morphism_comp[OF qbs_morphism_map_prod assms(2),of \<alpha> "\<real>\<^sub>Q" \<beta> "\<real>\<^sub>Q",simplified comp_def map_prod_def split_beta'] ha qp.in_Mx
	+ by(auto intro!: qp.borel_measurable_lebesgue_integral
	+ simp: qbs_Mx_is_morphisms)
	+ finally show "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha> \<in> borel_measurable borel" .
	+qed
	+
	+lemma qbs_morphism_integral_snd:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ shows "(\<lambda>y. \<integral>\<^sub>Q x. f (x, y) \<partial>p) \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using qbs_morphism_integral_fst[OF assms(1) qbs_morphism_pair_swap[OF assms(2)]]
	+ by simp
	+
	+lemma qbs_prob_integral_morphism:
	+ assumes "L \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y \<real>\<^sub>Q"
	+ and "\<And>x. x \<in> qbs_space X \<Longrightarrow> qbs_integrable (L x) (f x)"
	+ shows "(\<lambda>x. qbs_prob_integral (L x) (f x)) \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+proof(rule qbs_morphismI;simp)
	+ fix \<alpha>
	+ assume h0:"\<alpha> \<in> qbs_Mx X"
	+ then obtain \<beta> g where h:
	+ "\<beta> \<in> qbs_Mx Y" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(L \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, g r))"
	+ using rep_monadP_qbs_MPx[of "L \<circ> \<alpha>" Y] qbs_morphismE(3)[OF assms(1)] by auto
	+ have "(\<lambda>x. qbs_prob_integral (L x) (f x)) \<circ> \<alpha> = (\<lambda>r. qbs_prob_integral ((L \<circ> \<alpha>) r) ((f \<circ> \<alpha>) r))"
	+ by auto
	+ also have "... = (\<lambda>r. enn2real (qbs_prob_ennintegral ((L \<circ> \<alpha>) r) (\<lambda>x. ennreal ((f \<circ> \<alpha>) r x)))
	+ - enn2real (qbs_prob_ennintegral ((L \<circ> \<alpha>) r) (\<lambda>x. ennreal (- (f \<circ> \<alpha>) r x))))"
	+ using h0 assms(3) by(auto intro!: real_qbs_prob_integral_def)
	+ also have "... \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ proof -
	+ have h2:"L \<circ> \<alpha> \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ using qbs_morphismE(3)[OF assms(1) h0] by(auto simp: qbs_Mx_is_morphisms)
	+ have [measurable]:"(\<lambda>x. f (fst x) (snd x)) \<in> qbs_to_measure (X \<Otimes>\<^sub>Q Y) \<rightarrow>\<^sub>M real_borel"
	+ using uncurry_preserves_morphisms[OF assms(2)] by(auto simp: split_beta')
	+ have h3:"(\<lambda>r x. ennreal ((f \<circ> \<alpha>) r x)) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs Y \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ proof(auto intro!: curry_preserves_morphisms[of "(\<lambda>(r,x). ennreal ((f \<circ> \<alpha>) r x))",simplified curry_def,simplified])
	+ have "(\<lambda>(r, y). ennreal (f (\<alpha> r) y)) = ennreal \<circ> case_prod f \<circ> map_prod \<alpha> id"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ apply(rule qbs_morphism_comp[where Y="X \<Otimes>\<^sub>Q Y"])
	+ using h0 qbs_morphism_map_prod[OF _ qbs_morphism_ident,of \<alpha> "\<real>\<^sub>Q" X Y]
	+ by(auto simp: qbs_Mx_is_morphisms)
	+ finally show "(\<lambda>(r, y). ennreal (f (\<alpha> r) y)) \<in> qbs_to_measure (\<real>\<^sub>Q \<Otimes>\<^sub>Q Y) \<rightarrow>\<^sub>M ennreal_borel"
	+ by auto
	+ qed
	+ have h4:"(\<lambda>r x. ennreal (- (f \<circ> \<alpha>) r x)) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs Y \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ proof(auto intro!: curry_preserves_morphisms[of "(\<lambda>(r,x). ennreal (- (f \<circ> \<alpha>) r x))",simplified curry_def,simplified])
	+ have "(\<lambda>(r, y). ennreal (- f (\<alpha> r) y)) = ennreal \<circ> (\<lambda>r. - r) \<circ> case_prod f \<circ> map_prod \<alpha> id"
	+ by auto
	+ also have "... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ apply(rule qbs_morphism_comp[where Y="X \<Otimes>\<^sub>Q Y"])
	+ using h0 qbs_morphism_map_prod[OF _ qbs_morphism_ident,of \<alpha> "\<real>\<^sub>Q" X Y]
	+ by(auto simp: qbs_Mx_is_morphisms)
	+ finally show "(\<lambda>(r, y). ennreal (- f (\<alpha> r) y)) \<in> qbs_to_measure (\<real>\<^sub>Q \<Otimes>\<^sub>Q Y) \<rightarrow>\<^sub>M ennreal_borel"
	+ by auto
	+ qed
	+ have "(\<lambda>r. qbs_prob_ennintegral ((L \<circ> \<alpha>) r) (\<lambda>x. ennreal ((f \<circ> \<alpha>) r x))) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ "(\<lambda>r. qbs_prob_ennintegral ((L \<circ> \<alpha>) r) (\<lambda>x. ennreal (- (f \<circ> \<alpha>) r x))) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ using qbs_prob_ennintegral_morphism[OF h2 h3] qbs_prob_ennintegral_morphism[OF h2 h4]
	+ by auto
	+ thus ?thesis by simp
	+ qed
	+ finally show "(\<lambda>x. qbs_prob_integral (L x) (f x)) \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M real_borel" .
	+qed
	+
	+lemma qbs_prob_integral_morphism'':
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "L \<in> Y \<rightarrow>\<^sub>Q monadP_qbs X"
	+ shows "(\<lambda>y. qbs_prob_integral (L y) f) \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using qbs_morphism_comp[OF assms(2) qbs_prob_integral_morphism'[OF assms(1)]]
	+ by(simp add: comp_def)
	+
	+lemma qbs_prob_integral_return:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "x \<in> qbs_space X"
	+ shows "qbs_prob_integral (qbs_return X x) f = f x"
	+ using assms
	+ by(auto intro!: integral_return
	+ simp add: qbs_prob_integral_def2 qbs_prob_measure_return[OF assms(2)])
	+
	+lemma qbs_prob_integral_bind:
	+ assumes "s \<in> monadP_qbs_Px X"
	+ "f \<in> X \<rightarrow>\<^sub>Q monadP_qbs Y"
	+ "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "\<exists>K. \<forall>y \<in> qbs_space Y.\<bar>g y\<bar> \<le> K"
	+ shows "qbs_prob_integral (s \<bind> f) g = qbs_prob_integral s (\<lambda>y. (qbs_prob_integral (f y) g))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain K where hK:
	+ "\<And>y. y \<in> qbs_space Y \<Longrightarrow> \<bar>g y\<bar> \<le> K"
	+ using assms(4) by auto
	+ obtain \<alpha> \<mu> where hs:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ then obtain \<beta> h where hb:
	+ "\<beta> \<in> qbs_Mx Y" "h \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
	+ "(f \<circ> \<alpha>) = (\<lambda>r. qbs_prob_space (Y, \<beta>, h r))"
	+ using rep_monadP_qbs_MPx[of "f \<circ> \<alpha>" Y] qbs_morphismE(3)[OF assms(2)]
	+ by(auto simp add: qbs_prob_def in_Mx_def)
	+ note [measurable] = hb(2)
	+ interpret rd: real_distribution \<mu> by(simp add: hs(1)[simplified qbs_prob_def])
	+ have h:"qbs_prob Y \<beta> (\<mu> \<bind> h)"
	+ "s \<bind> f = qbs_prob_space (Y, \<beta>, \<mu> \<bind> h)"
	+ using qbs_prob.qbs_bind_computation[OF hs assms(2) hb] by auto
	+
	+ hence "?lhs = (\<integral> x. g (\<beta> x) \<partial>(\<mu> \<bind> h))"
	+ by(simp add: qbs_prob.qbs_prob_integral_def[OF h(1) assms(3)])
	+ also have "... = (integral\<^sup>L (\<mu> \<bind> h) (g \<circ> \<beta>))" by(simp add: comp_def)
	+ also have "... = (\<integral> r. (\<integral> y. (g \<circ> \<beta>) y \<partial>(h r)) \<partial>\<mu>)"
	+ apply(rule integral_bind[of _ real_borel K _ _ 1])
	+ using assms(3) hb(1) hK measurable_space[OF hb(2)]
	+ by(auto intro!: measurable_prob_algebraD
	+ simp: space_prob_algebra prob_space.emeasure_le_1)
	+ also have "... = ?rhs"
	+ by(auto intro!: Bochner_Integration.integral_cong
	+ simp: qbs_prob.qbs_prob_integral_def[OF qbs_prob_MPx[OF hb(1,2)] assms(3)] fun_cong[OF hb(3),simplified comp_def] hs(2) qbs_prob.qbs_prob_integral_def[OF hs(1) qbs_prob_integral_morphism''[OF assms(3,2)]])
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_prob_integral_bind_return:
	+ assumes "s \<in> monadP_qbs_Px Y"
	+ "f \<in> Z \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q Z"
	+ shows "qbs_prob_integral (s \<bind> (\<lambda>y. qbs_return Z (g y))) f = qbs_prob_integral s (f \<circ> g)"
	+proof -
	+ obtain \<alpha> \<mu> where hs:
	+ "qbs_prob Y \<alpha> \<mu>" "s = qbs_prob_space (Y, \<alpha>, \<mu>)"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ then interpret qp: qbs_prob Y \<alpha> \<mu> by simp
	+ have hb:"qbs_prob Z (g \<circ> \<alpha>) \<mu>"
	+ "s \<bind> (\<lambda>y. qbs_return Z (g y)) = qbs_prob_space (Z, g \<circ> \<alpha>, \<mu>)"
	+ by(auto intro!: qp.qbs_bind_computation[OF hs(2) qbs_return_morphism'[OF assms(3)] qbs_morphismE(3)[OF assms(3) qp.in_Mx],of "return real_borel",simplified bind_return''[of \<mu> real_borel,simplified] comp_def]
	+ simp: comp_def qbs_return_comp[OF qbs_morphismE(3)[OF assms(3) qp.in_Mx],simplified comp_def])
	+ thus ?thesis
	+ by(simp add: hb(2) qbs_prob.qbs_prob_integral_def[OF hb(1) assms(2)] hs(2) qbs_prob.qbs_prob_integral_def[OF hs(1) qbs_morphism_comp[OF assms(3,2)]])
	+qed
	+
	+lemma qbs_prob_var_bind_return:
	+ assumes "s \<in> monadP_qbs_Px Y"
	+ "f \<in> Z \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q Z"
	+ shows "qbs_prob_var (s \<bind> (\<lambda>y. qbs_return Z (g y))) f = qbs_prob_var s (f \<circ> g)"
	+proof -
	+ have 1:"(\<lambda>x. (f x - qbs_prob_integral s (f \<circ> g))\<^sup>2) \<in> Z \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using assms(2,3) by auto
	+ thus ?thesis
	+ using qbs_prob_integral_bind_return[OF assms(1) 1 assms(3)] qbs_prob_integral_bind_return[OF assms]
	+ by(simp add: comp_def qbs_prob_var_def)
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Pair_QuasiBorel_Measure.thy b/thys/Quasi_Borel_Spaces/Pair_QuasiBorel_Measure.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Pair_QuasiBorel_Measure.thy
	@@ -0,0 +1,559 @@
	+(* Title: Pair_QuasiBorel_Measure.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsection \<open>Binary Product Measure\<close>
	+
	+theory Pair_QuasiBorel_Measure
	+ imports "Monad_QuasiBorel"
	+begin
	+
	+subsubsection \<open> Binary Product Measure\<close>
	+text \<open> Special case of \cite{Heunen_2017} Proposition 23 where $\Omega = \mathbb{R}\times \mathbb{R}$ and $X = X \times Y$.
	+ Let $[\alpha,\mu ] \in P(X)$ and $[\beta ,\nu] \in P(Y)$. $\alpha\times\beta$ is the $\alpha$ in Proposition 23. \<close>
	+definition qbs_prob_pair_measure_t :: "['a qbs_prob_t, 'b qbs_prob_t] \<Rightarrow> ('a \<times> 'b) qbs_prob_t" where
	+"qbs_prob_pair_measure_t p q \<equiv> (let (X,\<alpha>,\<mu>) = p;
	+ (Y,\<beta>,\<nu>) = q in
	+ (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f))"
	+
	+lift_definition qbs_prob_pair_measure :: "['a qbs_prob_space, 'b qbs_prob_space] \<Rightarrow> ('a \<times> 'b) qbs_prob_space" (infix "\<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s" 80)
	+is qbs_prob_pair_measure_t
	+ unfolding qbs_prob_pair_measure_t_def
	+proof auto
	+ fix X X' :: "'a quasi_borel"
	+ fix Y Y' :: "'b quasi_borel"
	+ fix \<alpha> \<alpha>' \<mu> \<mu>' \<beta> \<beta>' \<nu> \<nu>'
	+ assume h:"qbs_prob_eq (X,\<alpha>,\<mu>) (X',\<alpha>',\<mu>')"
	+ "qbs_prob_eq (Y,\<beta>,\<nu>) (Y',\<beta>',\<nu>')"
	+ then have 1: "X = X'" "Y = Y'"
	+ by(auto simp: qbs_prob_eq_def)
	+ interpret pqp1: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(1)[OF h(1)] qbs_prob_eq_dest(1)[OF h(2)])
	+ interpret pqp2: pair_qbs_probs X' \<alpha>' \<mu>' Y' \<beta>' \<nu>'
	+ by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(2)[OF h(1)] qbs_prob_eq_dest(2)[OF h(2)])
	+ interpret pqp: pair_qbs_prob "X \<Otimes>\<^sub>Q Y" "map_prod \<alpha> \<beta> \<circ> real_real.g" "distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f" "X' \<Otimes>\<^sub>Q Y'" "map_prod \<alpha>' \<beta>' \<circ> real_real.g" "distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f"
	+ by(auto intro!: qbs_probI pqp1.P.prob_space_distr pqp2.P.prob_space_distr simp: pair_qbs_prob_def)
	+
	+ show "qbs_prob_eq (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (X' \<Otimes>\<^sub>Q Y', map_prod \<alpha>' \<beta>' \<circ> real_real.g, distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f)"
	+ proof(rule pqp.qbs_prob_space_eq_inverse(1))
	+ show "qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)
	+ = qbs_prob_space (X' \<Otimes>\<^sub>Q Y', map_prod \<alpha>' \<beta>' \<circ> real_real.g, distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)))"
	+ by(simp add: pqp1.qbs_bind_return_pq)
	+ also have "... = qbs_prob_space (X', \<alpha>', \<mu>') \<bind> (\<lambda>x. qbs_prob_space (Y', \<beta>', \<nu>') \<bind> (\<lambda>y. qbs_return (X' \<Otimes>\<^sub>Q Y') (x, y)))"
	+ using h by(simp add: qbs_prob_space_eq 1)
	+ also have "... = ?rhs"
	+ by(simp add: pqp2.qbs_bind_return_pq)
	+ finally show ?thesis .
	+ qed
	+ qed
	+qed
	+
	+lemma(in pair_qbs_probs) qbs_prob_pair_measure_computation:
	+ "(qbs_prob_space (X,\<alpha>,\<mu>)) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s (qbs_prob_space (Y,\<beta>,\<nu>)) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g , distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ by(simp_all add: qbs_prob_pair_measure.abs_eq qbs_prob_pair_measure_t_def qbs_bind_return_pq)
	+
	+lemma qbs_prob_pair_measure_qbs:
	+ "qbs_prob_space_qbs (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) = qbs_prob_space_qbs p \<Otimes>\<^sub>Q qbs_prob_space_qbs q"
	+ by(transfer,simp add: qbs_prob_pair_measure_t_def Let_def prod.case_eq_if)
	+
	+lemma(in pair_qbs_probs) qbs_prob_pair_measure_measure:
	+ shows "qbs_prob_measure (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) = distr (\<mu> \<Otimes>\<^sub>M \<nu>) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (map_prod \<alpha> \<beta>)"
	+ by(simp add: qbs_prob_pair_measure_computation distr_distr comp_assoc)
	+
	+lemma qbs_prob_pair_measure_morphism:
	+ "case_prod qbs_prob_pair_measure \<in> monadP_qbs X \<Otimes>\<^sub>Q monadP_qbs Y \<rightarrow>\<^sub>Q monadP_qbs (X \<Otimes>\<^sub>Q Y)"
	+proof(rule pair_qbs_morphismI)
	+ fix \<beta>x \<beta>y
	+ assume h: "\<beta>x \<in> qbs_Mx (monadP_qbs X)" " \<beta>y \<in> qbs_Mx (monadP_qbs Y)"
	+ then obtain \<alpha>x \<alpha>y gx gy where ha:
	+ "\<alpha>x \<in> qbs_Mx X" "gx \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel" "\<beta>x = (\<lambda>r. qbs_prob_space (X, \<alpha>x, gx r))"
	+ "\<alpha>y \<in> qbs_Mx Y" "gy \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel" "\<beta>y = (\<lambda>r. qbs_prob_space (Y, \<alpha>y, gy r))"
	+ using rep_monadP_qbs_MPx[of \<beta>x X] rep_monadP_qbs_MPx[of \<beta>y Y] by auto
	+ note [measurable] = ha(2,5)
	+ have "(\<lambda>(x, y). x \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s y) \<circ> (\<lambda>r. (\<beta>x r, \<beta>y r)) = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha>x \<alpha>y \<circ> real_real.g, distr (gx r \<Otimes>\<^sub>M gy r) real_borel real_real.f))"
	+ apply standard
	+ using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.qbs_prob_pair_measure_computation[of X \<alpha>x _ Y \<alpha>y]
	+ by (auto simp: ha pair_qbs_probs_def)
	+ also have "... \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q Y))"
	+ using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.ab_g_in_Mx[of X \<alpha>x _ Y \<alpha>y]
	+ by(auto intro!: bexI[where x="map_prod \<alpha>x \<alpha>y \<circ> real_real.g"] bexI[where x="\<lambda>r. distr (gx r \<Otimes>\<^sub>M gy r) real_borel real_real.f"]
	+ simp: monadP_qbs_MPx_def in_MPx_def pair_qbs_probs_def)
	+ finally show "(\<lambda>(x, y). x \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s y) \<circ> (\<lambda>r. (\<beta>x r, \<beta>y r)) \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q Y))" .
	+qed
	+
	+lemma(in pair_qbs_probs) qbs_prob_pair_measure_nnintegral:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>))) = (\<integral>\<^sup>+ z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have "?lhs = (\<integral>\<^sup>+ x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) x \<partial>distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ by(simp add: qbs_prob_ennintegral_def[OF assms] qbs_prob_pair_measure_computation)
	+ also have "... = (\<integral>\<^sup>+ x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) (real_real.f x) \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
	+ using assms by(intro nn_integral_distr) auto
	+ also have "... = ?rhs" by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma(in pair_qbs_probs) qbs_prob_pair_measure_integral:
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ shows "(\<integral>\<^sub>Q z. f z \<partial>(qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>))) = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have "?lhs = (\<integral>x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) x \<partial>distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
	+ by(simp add: qbs_prob_integral_def[OF assms] qbs_prob_pair_measure_computation)
	+ also have "... = (\<integral> x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) (real_real.f x) \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
	+ using assms by(intro integral_distr) auto
	+ also have "... = ?rhs" by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_prob_pair_measure_eq_bind:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ and "q \<in> monadP_qbs_Px Y"
	+ shows "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q = p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))"
	+proof -
	+ obtain \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ obtain \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_monadP_qbs_Px[OF assms(2)] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: pair_qbs_probs_def hp hq)
	+ show ?thesis
	+ by(simp add: hp(1) hq(1) pqp.qbs_prob_pair_measure_computation(1) pqp.qbs_bind_return_pq(1))
	+qed
	+
	+subsubsection \<open>Fubini Theorem\<close>
	+lemma qbs_prob_ennintegral_Fubini_fst:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ "q \<in> monadP_qbs_Px Y"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. f (x,y) \<partial>q \<partial>p) = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs Y",simplified,OF assms(2)] curry_preserves_morphisms[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]],simplified curry_def,simplified]
	+ qbs_morphism_Pair1'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
	+ assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
	+ have "?rhs = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))))"
	+ by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)])
	+ also have "... = (\<integral>\<^sup>+\<^sub>Q x. qbs_prob_ennintegral (q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) f \<partial>p)"
	+ by(auto intro!: qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
	+ also have "... = (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. qbs_prob_ennintegral (qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)) f \<partial>q \<partial>p)"
	+ by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
	+ also have "... = ?lhs"
	+ using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
	+ finally show ?thesis by simp
	+qed
	+
	+lemma qbs_prob_ennintegral_Fubini_snd:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ "q \<in> monadP_qbs_Px Y"
	+ and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. f (x,y) \<partial>p \<partial>q) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs X",simplified,OF assms(1)] curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]],simplified curry_def,simplified]]
	+ qbs_morphism_Pair2'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
	+ assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
	+ have "?rhs = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))))"
	+ by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)] qbs_bind_return_rotate[OF assms(1,2)])
	+ also have "... = (\<integral>\<^sup>+\<^sub>Q y. qbs_prob_ennintegral (p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) f \<partial>q)"
	+ by(auto intro!: qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
	+ also have "... = (\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. qbs_prob_ennintegral (qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)) f \<partial>p \<partial>q)"
	+ by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
	+ also have "... = ?lhs"
	+ using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
	+ finally show ?thesis by simp
	+qed
	+
	+lemma qbs_prob_ennintegral_indep1:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ and "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<integral>\<^sup>+\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>p)"
	+ (is "?lhs = _")
	+proof -
	+ obtain Y \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_qbs_prob_space[of q] by auto
	+ have "?lhs = (\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. f x \<partial>p \<partial>q)"
	+ using qbs_prob_ennintegral_Fubini_snd[OF assms(1) qbs_prob.qbs_prob_space_in_Px[OF hq(2)] qbs_morphism_fst''[OF assms(2)]]
	+ by(simp add: hq(1))
	+ thus ?thesis
	+ by(simp add: qbs_prob_ennintegral_const)
	+qed
	+
	+lemma qbs_prob_ennintegral_indep2:
	+ assumes "q \<in> monadP_qbs_Px Y"
	+ and "f \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<integral>\<^sup>+\<^sub>Q z. f (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q y. f y \<partial>q)"
	+ (is "?lhs = _")
	+proof -
	+ obtain X \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of p] by auto
	+ have "?lhs = (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. f y \<partial>q \<partial>p)"
	+ using qbs_prob_ennintegral_Fubini_fst[OF qbs_prob.qbs_prob_space_in_Px[OF hp(2)] assms(1) qbs_morphism_snd''[OF assms(2)]]
	+ by(simp add: hp(1))
	+ thus ?thesis
	+ by(simp add: qbs_prob_ennintegral_const)
	+qed
	+
	+lemma qbs_ennintegral_indep_mult:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ "q \<in> monadP_qbs_Px Y"
	+ "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ and "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "(\<integral>\<^sup>+\<^sub>Q z. f (fst z) * g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>p) * (\<integral>\<^sup>+\<^sub>Q y. g y \<partial>q)"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have h:"(\<lambda>z. f (fst z) * g (snd z)) \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ using assms(4,3)
	+ by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)
	+
	+ have "?lhs = (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y .f x * g y \<partial>q \<partial>p)"
	+ using qbs_prob_ennintegral_Fubini_fst[OF assms(1,2) h] by simp
	+ also have "... = (\<integral>\<^sup>+\<^sub>Q x. f x * \<integral>\<^sup>+\<^sub>Q y . g y \<partial>q \<partial>p)"
	+ using qbs_prob_ennintegral_cmult[of q,OF _ assms(4)] assms(2)
	+ by(simp add: monadP_qbs_Px_def)
	+ also have "... = ?rhs"
	+ using qbs_prob_ennintegral_cmult[of p,OF _ assms(3)] assms(1)
	+ by(simp add: ab_semigroup_mult_class.mult.commute[where b="qbs_prob_ennintegral q g"] monadP_qbs_Px_def)
	+ finally show ?thesis .
	+qed
	+
	+
	+lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable:
	+ assumes "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) f"
	+ shows "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> (map_prod \<alpha> \<beta>))"
	+proof -
	+ show "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using qbs_integrable_morphism[OF qbs_prob_pair_measure_qbs assms]
	+ by simp
	+next
	+ have 1:"integrable (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g))"
	+ using assms[simplified qbs_prob_pair_measure_computation] qbs_integrable_def[of f]
	+ by simp
	+ have "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (\<lambda>x. (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (real_real.f x))"
	+ by(intro integrable_distr[OF _ 1]) simp
	+ thus "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
	+ by(simp add: comp_def)
	+qed
	+
	+lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable':
	+ assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ and "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> (map_prod \<alpha> \<beta>))"
	+ shows "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) f"
	+proof -
	+ have "integrable (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) = integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (\<lambda>x. (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (real_real.f x))"
	+ by(intro integrable_distr_eq) (use assms(1) in auto)
	+ thus ?thesis
	+ using assms qbs_integrable_def
	+ by(simp add: comp_def qbs_prob_pair_measure_computation)
	+qed
	+
	+lemma qbs_integrable_pair_swap:
	+ assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+ shows "qbs_integrable (q \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s p) (\<lambda>(x,y). f (y,x))"
	+proof -
	+ obtain X \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of p] by auto
	+ obtain Y \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_qbs_prob_space[of q] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: pair_qbs_probs_def hp hq)
	+ interpret pqp2: pair_qbs_probs Y \<beta> \<nu> X \<alpha> \<mu>
	+ by(simp add: pair_qbs_probs_def hp hq)
	+
	+ have "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
	+ by(auto simp: pqp.qbs_prob_pair_measure_integrable[OF assms[simplified hp(1) hq(1)]])
	+ from qbs_morphism_pair_swap[OF this(1)] pqp.integrable_product_swap[OF this(2)]
	+ have "(\<lambda>(x,y). f (y,x)) \<in> Y \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ "integrable (\<nu> \<Otimes>\<^sub>M \<mu>) ((\<lambda>(x,y). f (y,x)) \<circ> map_prod \<beta> \<alpha>)"
	+ by(simp_all add: map_prod_def comp_def split_beta')
	+ from pqp2.qbs_prob_pair_measure_integrable' [OF this]
	+ show ?thesis by(simp add: hp(1) hq(1))
	+qed
	+
	+lemma qbs_integrable_pair1:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ "q \<in> monadP_qbs_Px Y"
	+ "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f (x,y)\<bar> \<partial>q)"
	+ and "\<And>x. x \<in> qbs_space X \<Longrightarrow> qbs_integrable q (\<lambda>y. f (x,y))"
	+ shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+proof -
	+ obtain \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_monadP_qbs_Px[OF assms(1)] by auto
	+ obtain \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_monadP_qbs_Px[OF assms(2)] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: pair_qbs_probs_def hp hq)
	+
	+ have "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
	+ proof(rule pqp.Fubini_integrable)
	+ show "f \<circ> map_prod \<alpha> \<beta> \<in> borel_measurable (\<mu> \<Otimes>\<^sub>M \<nu>)"
	+ using assms(3) by auto
	+ next
	+ have "(\<lambda>x. LINT y\|\<nu>. norm ((f \<circ> map_prod \<alpha> \<beta>) (x, y))) = (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f (x,y)\<bar> \<partial>q) \<circ> \<alpha>"
	+ apply standard subgoal for x
	+ using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx,of x] assms(3)]
	+ by(auto intro!: pqp.qp2.qbs_prob_integral_def[symmetric] simp: hq(1))
	+ done
	+ moreover have "integrable \<mu> ..."
	+ using assms(4) pqp.qp1.qbs_integrable_def
	+ by (simp add: hp(1))
	+ ultimately show "integrable \<mu> (\<lambda>x. LINT y\|\<nu>. norm ((f \<circ> map_prod \<alpha> \<beta>) (x, y)))"
	+ by simp
	+ next
	+ have "\<And>x. integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
	+ proof-
	+ fix x
	+ have "(\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y)) = (\<lambda>y. f (\<alpha> x,y)) \<circ> \<beta>"
	+ by auto
	+ moreover have "qbs_integrable (qbs_prob_space (Y, \<beta>, \<nu>)) (\<lambda>y. f (\<alpha> x, y))"
	+ by(auto intro!: assms(5)[simplified hq(1)] simp: qbs_Mx_to_X)
	+ ultimately show "integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
	+ by(simp add: pqp.qp2.qbs_integrable_def)
	+ qed
	+ thus "AE x in \<mu>. integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
	+ by simp
	+ qed
	+ thus ?thesis
	+ using pqp.qbs_prob_pair_measure_integrable'[OF assms(3)]
	+ by(simp add: hp(1) hq(1))
	+qed
	+
	+lemma qbs_integrable_pair2:
	+ assumes "p \<in> monadP_qbs_Px X"
	+ "q \<in> monadP_qbs_Px Y"
	+ "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ "qbs_integrable q (\<lambda>y. \<integral>\<^sub>Q x. \<bar>f (x,y)\<bar> \<partial>p)"
	+ and "\<And>y. y \<in> qbs_space Y \<Longrightarrow> qbs_integrable p (\<lambda>x. f (x,y))"
	+ shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+ using qbs_integrable_pair_swap[OF qbs_integrable_pair1[OF assms(2,1) qbs_morphism_pair_swap[OF assms(3)],simplified,OF assms(4,5)]]
	+ by simp
	+
	+lemma qbs_integrable_fst:
	+ assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+ shows "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. f (x,y) \<partial>q)"
	+proof -
	+ obtain X \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of p] by auto
	+ obtain Y \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_qbs_prob_space[of q] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: hp hq pair_qbs_probs_def)
	+ have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
	+ by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))
	+
	+ show "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q)"
	+ proof(auto simp add: pqp.qp1.qbs_integrable_def hp(1))
	+ show "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<in> borel_measurable (qbs_to_measure X)"
	+ using qbs_morphism_integral_fst[OF h0(2,3)] by auto
	+ next
	+ have "integrable \<mu> (\<lambda>x. LINT y\|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
	+ by(intro pqp.integrable_fst') (rule pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]])
	+ moreover have "\<And>x. ((\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>) x = LINT y\|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y)"
	+ by(auto intro!: pqp.qp2.qbs_prob_integral_def qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)] simp: hq)
	+ ultimately show "integrable \<mu> ((\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>)"
	+ using integrable_cong[of \<mu> \<mu> "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>" " (\<lambda>x. LINT y\|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"]
	+ by simp
	+ qed
	+qed
	+
	+lemma qbs_integrable_snd:
	+ assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+ shows "qbs_integrable q (\<lambda>y. \<integral>\<^sub>Q x. f (x,y) \<partial>p)"
	+ using qbs_integrable_fst[OF qbs_integrable_pair_swap[OF assms]]
	+ by simp
	+
	+lemma qbs_integrable_indep_mult:
	+ assumes "qbs_integrable p f"
	+ and "qbs_integrable q g"
	+ shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. f (fst x) * g (snd x))"
	+proof -
	+ obtain X \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of p] by auto
	+ obtain Y \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_qbs_prob_space[of q] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: hp hq pair_qbs_probs_def)
	+ have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q" "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using qbs_integrable_morphism[OF _ assms(1)] qbs_integrable_morphism[OF _ assms(2)]
	+ by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))
	+
	+ show ?thesis
	+ proof(rule qbs_integrable_pair1[OF h0(1,2)],simp_all add: assms(2))
	+ show "(\<lambda>z. f (fst z) * g (snd z)) \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using h0(3,4) by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)
	+ next
	+ show "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f x * g y\<bar> \<partial>q)"
	+ by(auto intro!: qbs_integrable_mult[OF qbs_integrable_abs[OF assms(1)]]
	+ simp only: idom_abs_sgn_class.abs_mult qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="\<integral>\<^sub>Q y. \<bar>g y\<bar> \<partial>q"])
	+ qed
	+qed
	+
	+lemma qbs_integrable_indep1:
	+ assumes "qbs_integrable p f"
	+ shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. f (fst x))"
	+ using qbs_integrable_indep_mult[OF assms qbs_integrable_const[of q 1]]
	+ by simp
	+
	+lemma qbs_integrable_indep2:
	+ assumes "qbs_integrable q g"
	+ shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. g (snd x))"
	+ using qbs_integrable_pair_swap[OF qbs_integrable_indep1[OF assms],of p]
	+ by(simp add: split_beta')
	+
	+
	+lemma qbs_prob_integral_Fubini_fst:
	+ assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+ shows "(\<integral>\<^sub>Q x. \<integral>\<^sub>Q y. f (x,y) \<partial>q \<partial>p) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain X \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of p] by auto
	+ obtain Y \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_qbs_prob_space[of q] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: hp hq pair_qbs_probs_def)
	+ have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
	+ by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))
	+
	+ have "?lhs = (\<integral> x. \<integral>\<^sub>Q y. f (\<alpha> x, y) \<partial>q \<partial>\<mu>)"
	+ using qbs_morphism_integral_fst[OF h0(2) h0(3)]
	+ by(auto intro!: pqp.qp1.qbs_prob_integral_def simp: hp(1))
	+ also have "... = (\<integral>x. \<integral>y. f (\<alpha> x, \<beta> y) \<partial>\<nu> \<partial>\<mu>)"
	+ using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)]
	+ by(auto intro!: Bochner_Integration.integral_cong pqp.qp2.qbs_prob_integral_def
	+ simp: hq(1))
	+ also have "... = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
	+ using pqp.integral_fst'[OF pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]]
	+ by(simp add: map_prod_def comp_def)
	+ also have "... = ?rhs"
	+ by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_prob_integral_Fubini_snd:
	+ assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+ shows "(\<integral>\<^sub>Q y. \<integral>\<^sub>Q x. f (x,y) \<partial>p \<partial>q) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain X \<alpha> \<mu> where hp:
	+ "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of p] by auto
	+ obtain Y \<beta> \<nu> where hq:
	+ "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
	+ using rep_qbs_prob_space[of q] by auto
	+ interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(simp add: hp hq pair_qbs_probs_def)
	+ have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
	+ by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))
	+
	+ have "?lhs = (\<integral> y. \<integral>\<^sub>Q x. f (x,\<beta> y) \<partial>p \<partial>\<nu>)"
	+ using qbs_morphism_integral_snd[OF h0(1) h0(3)]
	+ by(auto intro!: pqp.qp2.qbs_prob_integral_def simp: hq(1))
	+ also have "... = (\<integral>y. \<integral>x. f (\<alpha> x, \<beta> y) \<partial>\<mu> \<partial>\<nu>)"
	+ using qbs_morphism_Pair2'[OF qbs_Mx_to_X(2)[OF pqp.qp2.in_Mx] h0(3)]
	+ by(auto intro!: Bochner_Integration.integral_cong pqp.qp1.qbs_prob_integral_def
	+ simp: hp(1))
	+ also have "... = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
	+ using pqp.integral_snd[of "curry (f \<circ> map_prod \<alpha> \<beta>)"] pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]
	+ by(simp add: map_prod_def comp_def split_beta')
	+ also have "... = ?rhs"
	+ by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_prob_integral_indep1:
	+ assumes "qbs_integrable p f"
	+ shows "(\<integral>\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q x. f x \<partial>p)"
	+ using qbs_prob_integral_Fubini_snd[OF qbs_integrable_indep1[OF assms],of q]
	+ by(simp add: qbs_prob_integral_const)
	+
	+lemma qbs_prob_integral_indep2:
	+ assumes "qbs_integrable q g"
	+ shows "(\<integral>\<^sub>Q z. g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q y. g y \<partial>q)"
	+ using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep2[OF assms],of p]
	+ by(simp add: qbs_prob_integral_const)
	+
	+lemma qbs_prob_integral_indep_mult:
	+ assumes "qbs_integrable p f"
	+ and "qbs_integrable q g"
	+ shows "(\<integral>\<^sub>Q z. f (fst z) * g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q x. f x \<partial>p) * (\<integral>\<^sub>Q y. g y \<partial>q)"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have "?lhs = (\<integral>\<^sub>Q x. \<integral>\<^sub>Q y. f x * g y \<partial>q \<partial>p)"
	+ using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep_mult[OF assms]]
	+ by simp
	+ also have "... = (\<integral>\<^sub>Q x. f x * (\<integral>\<^sub>Q y. g y \<partial>q) \<partial>p)"
	+ by(simp add: qbs_prob_integral_cmult)
	+ also have "... = ?rhs"
	+ by(simp add: qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="\<integral>\<^sub>Q y. g y \<partial>q"])
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_prob_var_indep_plus:
	+ assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
	+ "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (f z)\<^sup>2)"
	+ "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"
	+ "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (g z)\<^sup>2)"
	+ "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (f z) * (g z))"
	+ and "(\<integral>\<^sub>Q z. f z * g z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * (\<integral>\<^sub>Q z. g z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ shows "qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. f z + g z) = qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f + qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"
	+ unfolding qbs_prob_var_def
	+proof -
	+ show "(\<integral>\<^sub>Q z. (f z + g z - \<integral>\<^sub>Q w. f w + g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q z. (f z - qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f)\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) + (\<integral>\<^sub>Q z. (g z - qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g)\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = (\<integral>\<^sub>Q z. ((f z - (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))) + (g z - (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))))\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ by(simp add: qbs_prob_integral_add[OF assms(1,3)] add_diff_add)
	+ also have "... = (\<integral>\<^sub>Q z. (f z - (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))\<^sup>2 + (g z - (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))\<^sup>2 + (2 * f z * g z - 2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * g z - (2 * f z * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) - 2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
	+ by(simp add: comm_semiring_1_class.power2_sum comm_semiring_1_cancel_class.left_diff_distrib' ring_class.right_diff_distrib)
	+ also have "... = ?rhs"
	+ using qbs_prob_integral_add[OF qbs_integrable_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]] qbs_integrable_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]]]
	+ qbs_prob_integral_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]]
	+ qbs_prob_integral_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]]
	+ qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]]
	+ qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]
	+ qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" 2 "\<lambda>z. f z * g z",simplified assms(6) comm_semiring_1_class.semiring_normalization_rules(18)]
	+ qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))" g]
	+ qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))" f,simplified semigroup_mult_class.mult.assoc[of 2 "\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of 2 _ "\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"]]
	+ qbs_prob_integral_const[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]
	+ by simp
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+lemma qbs_prob_var_indep_plus':
	+ assumes "qbs_integrable p f"
	+ "qbs_integrable p (\<lambda>x. (f x)\<^sup>2)"
	+ "qbs_integrable q g"
	+ and "qbs_integrable q (\<lambda>x. (g x)\<^sup>2)"
	+ shows "qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. f (fst z) + g (snd z)) = qbs_prob_var p f + qbs_prob_var q g"
	+ using qbs_prob_var_indep_plus[OF qbs_integrable_indep1[OF assms(1)] qbs_integrable_indep1[OF assms(2)] qbs_integrable_indep2[OF assms(3)] qbs_integrable_indep2[OF assms(4)] qbs_integrable_indep_mult[OF assms(1) assms(3)] qbs_prob_integral_indep_mult[OF assms(1) assms(3),simplified qbs_prob_integral_indep1[OF assms(1),of q,symmetric] qbs_prob_integral_indep2[OF assms(3),of p,symmetric]]]
	+ qbs_prob_integral_indep1[OF qbs_integrable_sq[OF assms(1,2)],of q "\<integral>\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"] qbs_prob_integral_indep2[OF qbs_integrable_sq[OF assms(3,4)],of p "\<integral>\<^sub>Q z. g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"]
	+ by(simp add: qbs_prob_var_def qbs_prob_integral_indep1[OF assms(1)] qbs_prob_integral_indep2[OF assms(3)])
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Probability_Space_QuasiBorel.thy b/thys/Quasi_Borel_Spaces/Probability_Space_QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Probability_Space_QuasiBorel.thy
	@@ -0,0 +1,1125 @@
	+(* Title: Probability_Space_QuasiBorel.thy
	+ Author: Michikazu Hirata, Yasuhiko Minamide, Tokyo Institute of Technology
	+*)
	+
	+section \<open>Probability Spaces\<close>
	+
	+subsection \<open>Probability Measures \<close>
	+
	+theory Probability_Space_QuasiBorel
	+ imports Exponent_QuasiBorel
	+begin
	+
	+subsubsection \<open> Probability Measures \<close>
	+type_synonym 'a qbs_prob_t = "'a quasi_borel * (real \<Rightarrow> 'a) * real measure"
	+
	+locale in_Mx =
	+ fixes X :: "'a quasi_borel"
	+ and \<alpha> :: "real \<Rightarrow> 'a"
	+ assumes in_Mx[simp]:"\<alpha> \<in> qbs_Mx X"
	+
	+locale qbs_prob = in_Mx X \<alpha> + real_distribution \<mu>
	+ for X :: "'a quasi_borel" and \<alpha> and \<mu>
	+begin
	+declare prob_space_axioms[simp]
	+
	+lemma m_in_space_prob_algebra[simp]:
	+ "\<mu> \<in> space (prob_algebra real_borel)"
	+ using space_prob_algebra[of real_borel] by simp
	+end
	+
	+locale pair_qbs_probs = qp1:qbs_prob X \<alpha> \<mu> + qp2:qbs_prob Y \<beta> \<nu>
	+ for X :: "'a quasi_borel"and \<alpha> \<mu> and Y :: "'b quasi_borel" and \<beta> \<nu>
	+begin
	+
	+sublocale pair_prob_space \<mu> \<nu>
	+ by standard
	+
	+lemma ab_measurable[measurable]:
	+ "map_prod \<alpha> \<beta> \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M qbs_to_measure (X \<Otimes>\<^sub>Q Y)"
	+ using qbs_morphism_map_prod[of \<alpha> "\<real>\<^sub>Q" X \<beta> "\<real>\<^sub>Q" Y] qp1.in_Mx qp2.in_Mx l_preserves_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q" "X \<Otimes>\<^sub>Q Y"]
	+ by(auto simp: qbs_Mx_is_morphisms)
	+
	+lemma ab_g_in_Mx[simp]:
	+ "map_prod \<alpha> \<beta> \<circ> real_real.g \<in> pair_qbs_Mx X Y"
	+ using qbs_closed1_dest[OF qp1.in_Mx] qbs_closed1_dest[OF qp2.in_Mx]
	+ by(auto simp add: pair_qbs_Mx_def comp_def)
	+
	+sublocale qbs_prob "X \<Otimes>\<^sub>Q Y" "map_prod \<alpha> \<beta> \<circ> real_real.g" "distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f"
	+ by(auto simp: qbs_prob_def in_Mx_def)
	+
	+end
	+
	+locale pair_qbs_prob = qp1:qbs_prob X \<alpha> \<mu> + qp2:qbs_prob Y \<beta> \<nu>
	+ for X :: "'a quasi_borel"and \<alpha> \<mu> and Y :: "'a quasi_borel" and \<beta> \<nu>
	+begin
	+
	+sublocale pair_qbs_probs
	+ by standard
	+
	+lemma same_spaces[simp]:
	+ assumes "Y = X"
	+ shows "\<beta> \<in> qbs_Mx X"
	+ by(simp add: assms[symmetric])
	+
	+end
	+
	+lemma prob_algebra_real_prob_measure:
	+ "p \<in> space (prob_algebra (real_borel)) = real_distribution p"
	+proof
	+ assume "p \<in> space (prob_algebra real_borel)"
	+ then show "real_distribution p"
	+ unfolding real_distribution_def real_distribution_axioms_def
	+ by(simp add: space_prob_algebra sets_eq_imp_space_eq)
	+next
	+ assume "real_distribution p"
	+ then interpret rd: real_distribution p .
	+ show "p \<in> space (prob_algebra real_borel)"
	+ by (simp add: space_prob_algebra rd.prob_space_axioms)
	+qed
	+
	+lemma qbs_probI:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ and "sets \<mu> = sets borel"
	+ and "prob_space \<mu>"
	+ shows "qbs_prob X \<alpha> \<mu>"
	+ using assms
	+ by(auto intro!: qbs_prob.intro simp: in_Mx_def real_distribution_def real_distribution_axioms_def)
	+
	+lemma qbs_empty_not_qbs_prob :"\<not> qbs_prob (empty_quasi_borel) f M"
	+ by(simp add: qbs_prob_def in_Mx_def)
	+
	+definition qbs_prob_eq :: "['a qbs_prob_t, 'a qbs_prob_t] \<Rightarrow> bool" where
	+ "qbs_prob_eq p1 p2 \<equiv>
	+ (let (qbs1, a1, m1) = p1;
	+ (qbs2, a2, m2) = p2 in
	+ qbs_prob qbs1 a1 m1 \<and> qbs_prob qbs2 a2 m2 \<and> qbs1 = qbs2 \<and>
	+ distr m1 (qbs_to_measure qbs1) a1 = distr m2 (qbs_to_measure qbs2) a2)"
	+
	+definition qbs_prob_eq2 :: "['a qbs_prob_t, 'a qbs_prob_t] \<Rightarrow> bool" where
	+ "qbs_prob_eq2 p1 p2 \<equiv>
	+ (let (qbs1, a1, m1) = p1;
	+ (qbs2, a2, m2) = p2 in
	+ qbs_prob qbs1 a1 m1 \<and> qbs_prob qbs2 a2 m2 \<and> qbs1 = qbs2 \<and>
	+ (\<forall>f \<in> qbs1 \<rightarrow>\<^sub>Q real_quasi_borel.
	+ (\<integral>x. f (a1 x) \<partial> m1) = (\<integral>x. f (a2 x) \<partial> m2)))"
	+
	+definition qbs_prob_eq3 :: "['a qbs_prob_t, 'a qbs_prob_t] \<Rightarrow> bool" where
	+ "qbs_prob_eq3 p1 p2 \<equiv>
	+ (let (qbs1, a1, m1) = p1;
	+ (qbs2, a2, m2) = p2 in
	+ (qbs_prob qbs1 a1 m1 \<and> qbs_prob qbs2 a2 m2 \<and> qbs1 = qbs2 \<and>
	+ (\<forall>f \<in> qbs1 \<rightarrow>\<^sub>Q real_quasi_borel.
	+ (\<forall> k \<in> qbs_space qbs1. 0 \<le> f k) \<longrightarrow>
	+ (\<integral>x. f (a1 x) \<partial> m1) = (\<integral>x. f (a2 x) \<partial> m2))))"
	+
	+definition qbs_prob_eq4 :: "['a qbs_prob_t, 'a qbs_prob_t] \<Rightarrow> bool" where
	+ "qbs_prob_eq4 p1 p2 \<equiv>
	+ (let (qbs1, a1, m1) = p1;
	+ (qbs2, a2, m2) = p2 in
	+ (qbs_prob qbs1 a1 m1 \<and> qbs_prob qbs2 a2 m2 \<and> qbs1 = qbs2 \<and>
	+ (\<forall>f \<in> qbs1 \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0.
	+ (\<integral>\<^sup>+x. f (a1 x) \<partial> m1) = (\<integral>\<^sup>+x. f (a2 x) \<partial> m2))))"
	+
	+lemma(in qbs_prob) qbs_prob_eq_refl[simp]:
	+ "qbs_prob_eq (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ by(simp add: qbs_prob_eq_def qbs_prob_axioms)
	+
	+lemma(in qbs_prob) qbs_prob_eq2_refl[simp]:
	+ "qbs_prob_eq2 (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ by(simp add: qbs_prob_eq2_def qbs_prob_axioms)
	+
	+lemma(in qbs_prob) qbs_prob_eq3_refl[simp]:
	+ "qbs_prob_eq3 (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ by(simp add: qbs_prob_eq3_def qbs_prob_axioms)
	+
	+lemma(in qbs_prob) qbs_prob_eq4_refl[simp]:
	+ "qbs_prob_eq4 (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ by(simp add: qbs_prob_eq4_def qbs_prob_axioms)
	+
	+lemma(in pair_qbs_prob) qbs_prob_eq_intro:
	+ assumes "X = Y"
	+ and "distr \<mu> (qbs_to_measure X) \<alpha> = distr \<nu> (qbs_to_measure X) \<beta>"
	+ shows "qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms
	+ by(auto simp add: qbs_prob_eq_def)
	+
	+lemma(in pair_qbs_prob) qbs_prob_eq2_intro:
	+ assumes "X = Y"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel
	+ \<Longrightarrow> (\<integral>x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>x. f (\<beta> x) \<partial> \<nu>)"
	+ shows "qbs_prob_eq2 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms
	+ by(auto simp add: qbs_prob_eq2_def)
	+
	+lemma(in pair_qbs_prob) qbs_prob_eq3_intro:
	+ assumes "X = Y"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel \<Longrightarrow> (\<forall> k \<in> qbs_space X. 0 \<le> f k)
	+ \<Longrightarrow> (\<integral>x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>x. f (\<beta> x) \<partial> \<nu>)"
	+ shows "qbs_prob_eq3 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms
	+ by(auto simp add: qbs_prob_eq3_def)
	+
	+lemma(in pair_qbs_prob) qbs_prob_eq4_intro:
	+ assumes "X = Y"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel
	+ \<Longrightarrow> (\<integral>\<^sup>+x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>\<^sup>+x. f (\<beta> x) \<partial> \<nu>)"
	+ shows "qbs_prob_eq4 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms
	+ by(auto simp add: qbs_prob_eq4_def)
	+
	+
	+lemma qbs_prob_eq_dest:
	+ assumes "qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ shows "qbs_prob X \<alpha> \<mu>"
	+ "qbs_prob Y \<beta> \<nu>"
	+ "Y = X"
	+ and "distr \<mu> (qbs_to_measure X) \<alpha> = distr \<nu> (qbs_to_measure X) \<beta>"
	+ using assms by(auto simp: qbs_prob_eq_def)
	+
	+lemma qbs_prob_eq2_dest:
	+ assumes "qbs_prob_eq2 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ shows "qbs_prob X \<alpha> \<mu>"
	+ "qbs_prob Y \<beta> \<nu>"
	+ "Y = X"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel
	+ \<Longrightarrow> (\<integral>x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>x. f (\<beta> x) \<partial> \<nu>)"
	+ using assms by(auto simp: qbs_prob_eq2_def)
	+
	+lemma qbs_prob_eq3_dest:
	+ assumes "qbs_prob_eq3 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ shows "qbs_prob X \<alpha> \<mu>"
	+ "qbs_prob Y \<beta> \<nu>"
	+ "Y = X"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel \<Longrightarrow> (\<forall> k \<in> qbs_space X. 0 \<le> f k)
	+ \<Longrightarrow> (\<integral>x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>x. f (\<beta> x) \<partial> \<nu>)"
	+ using assms by(auto simp: qbs_prob_eq3_def)
	+
	+lemma qbs_prob_eq4_dest:
	+ assumes "qbs_prob_eq4 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ shows "qbs_prob X \<alpha> \<mu>"
	+ "qbs_prob Y \<beta> \<nu>"
	+ "Y = X"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel
	+ \<Longrightarrow> (\<integral>\<^sup>+x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>\<^sup>+x. f (\<beta> x) \<partial> \<nu>)"
	+ using assms by(auto simp: qbs_prob_eq4_def)
	+
	+definition qbs_prob_t_ennintegral :: "['a qbs_prob_t, 'a \<Rightarrow> ennreal] \<Rightarrow> ennreal" where
	+"qbs_prob_t_ennintegral p f \<equiv>
	+ (if f \<in> (fst p) \<rightarrow>\<^sub>Q ennreal_quasi_borel
	+ then (\<integral>\<^sup>+x. f (fst (snd p) x) \<partial> (snd (snd p))) else 0)"
	+
	+definition qbs_prob_t_integral :: "['a qbs_prob_t, 'a \<Rightarrow> real] \<Rightarrow> real" where
	+"qbs_prob_t_integral p f \<equiv>
	+ (if f \<in> (fst p) \<rightarrow>\<^sub>Q \<real>\<^sub>Q
	+ then (\<integral>x. f (fst (snd p) x) \<partial> (snd (snd p)))
	+ else 0)"
	+
	+definition qbs_prob_t_integrable :: "['a qbs_prob_t, 'a \<Rightarrow> real] \<Rightarrow> bool" where
	+"qbs_prob_t_integrable p f \<equiv> f \<in> fst p \<rightarrow>\<^sub>Q real_quasi_borel \<and> integrable (snd (snd p)) (f \<circ> (fst (snd p)))"
	+
	+definition qbs_prob_t_measure :: "'a qbs_prob_t \<Rightarrow> 'a measure" where
	+"qbs_prob_t_measure p \<equiv> distr (snd (snd p)) (qbs_to_measure (fst p)) (fst (snd p))"
	+
	+lemma qbs_prob_eq_symp:
	+ "symp qbs_prob_eq"
	+ by(simp add: symp_def qbs_prob_eq_def)
	+
	+lemma qbs_prob_eq_transp:
	+ "transp qbs_prob_eq"
	+ by(simp add: transp_def qbs_prob_eq_def)
	+
	+quotient_type 'a qbs_prob_space = "'a qbs_prob_t" / partial: qbs_prob_eq
	+ morphisms rep_qbs_prob_space qbs_prob_space
	+proof(rule part_equivpI)
	+ let ?U = "UNIV :: 'a set"
	+ let ?Uf = "UNIV :: (real \<Rightarrow> 'a) set"
	+ let ?f = "(\<lambda>_. undefined) :: real \<Rightarrow> 'a"
	+ have "qbs_prob (Abs_quasi_borel (?U,?Uf)) ?f (return borel 0)"
	+ proof(auto simp add: qbs_prob_def in_Mx_def)
	+ have "Rep_quasi_borel (Abs_quasi_borel (?U,?Uf)) = (?U, ?Uf)"
	+ using Abs_quasi_borel_inverse
	+ by (auto simp add: qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)
	+ thus "(\<lambda>_. undefined) \<in> qbs_Mx (Abs_quasi_borel (?U, ?Uf))"
	+ by(simp add: qbs_Mx_def)
	+ next
	+ show "real_distribution (return borel 0)"
	+ by (simp add: prob_space_return real_distribution_axioms_def real_distribution_def)
	+ qed
	+ thus "\<exists>x :: 'a qbs_prob_t . qbs_prob_eq x x"
	+ unfolding qbs_prob_eq_def
	+ by(auto intro!: exI[where x="(Abs_quasi_borel (?U,?Uf), ?f, return borel 0)"])
	+qed (simp_all add: qbs_prob_eq_symp qbs_prob_eq_transp)
	+
	+interpretation qbs_prob_space : quot_type "qbs_prob_eq" "Abs_qbs_prob_space" "Rep_qbs_prob_space"
	+ using Abs_qbs_prob_space_inverse Rep_qbs_prob_space
	+ by(simp add: quot_type_def equivp_implies_part_equivp qbs_prob_space_equivp Rep_qbs_prob_space_inverse Rep_qbs_prob_space_inject) blast
	+
	+lemma qbs_prob_space_induct:
	+ assumes "\<And>X \<alpha> \<mu>. qbs_prob X \<alpha> \<mu> \<Longrightarrow> P (qbs_prob_space (X,\<alpha>,\<mu>))"
	+ shows "P s"
	+ apply(rule qbs_prob_space.abs_induct)
	+ using assms by(auto simp: qbs_prob_eq_def)
	+
	+lemma qbs_prob_space_induct':
	+ assumes "\<And>X \<alpha> \<mu>. qbs_prob X \<alpha> \<mu> \<Longrightarrow> s = qbs_prob_space (X,\<alpha>,\<mu>)\<Longrightarrow> P (qbs_prob_space (X,\<alpha>,\<mu>))"
	+ shows "P s"
	+ by (metis (no_types, lifting) Rep_qbs_prob_space_inverse assms case_prodE qbs_prob_eq_def qbs_prob_space.abs_def qbs_prob_space.rep_prop qbs_prob_space_def)
	+
	+lemma rep_qbs_prob_space:
	+ "\<exists>X \<alpha> \<mu>. p = qbs_prob_space (X, \<alpha>, \<mu>) \<and> qbs_prob X \<alpha> \<mu>"
	+ by(rule qbs_prob_space.abs_induct,auto simp add: qbs_prob_eq_def)
	+
	+lemma(in qbs_prob) in_Rep:
	+ "(X, \<alpha>, \<mu>) \<in> Rep_qbs_prob_space (qbs_prob_space (X,\<alpha>,\<mu>))"
	+ by (metis mem_Collect_eq qbs_prob_eq_refl qbs_prob_space.abs_def qbs_prob_space.abs_inverse qbs_prob_space_def)
	+
	+lemma(in qbs_prob) if_in_Rep:
	+ assumes "(X',\<alpha>',\<mu>') \<in> Rep_qbs_prob_space (qbs_prob_space (X,\<alpha>,\<mu>))"
	+ shows "X' = X"
	+ "qbs_prob X' \<alpha>' \<mu>'"
	+ "qbs_prob_eq (X,\<alpha>,\<mu>) (X',\<alpha>',\<mu>')"
	+proof -
	+ have h:"X' = X"
	+ by (metis assms mem_Collect_eq qbs_prob_eq_dest(3) qbs_prob_eq_refl qbs_prob_space.abs_def qbs_prob_space.abs_inverse qbs_prob_space_def)
	+ have [simp]:"qbs_prob X' \<alpha>' \<mu>'"
	+ by (metis assms mem_Collect_eq prod_cases3 qbs_prob_eq_dest(2) qbs_prob_space.rep_prop)
	+ have [simp]:"qbs_prob_eq (X,\<alpha>,\<mu>) (X',\<alpha>',\<mu>')"
	+ by (metis assms mem_Collect_eq qbs_prob_eq_refl qbs_prob_space.abs_def qbs_prob_space.abs_inverse qbs_prob_space_def)
	+ show "X' = X"
	+ "qbs_prob X' \<alpha>' \<mu>'"
	+ "qbs_prob_eq (X,\<alpha>,\<mu>) (X',\<alpha>',\<mu>')"
	+ by simp_all (simp add: h)
	+qed
	+
	+lemma(in qbs_prob) in_Rep_induct:
	+ assumes "\<And>Y \<beta> \<nu>. (Y,\<beta>,\<nu>) \<in> Rep_qbs_prob_space (qbs_prob_space (X,\<alpha>,\<mu>)) \<Longrightarrow> P (Y,\<beta>,\<nu>)"
	+ shows "P (rep_qbs_prob_space (qbs_prob_space (X,\<alpha>,\<mu>)))"
	+ unfolding rep_qbs_prob_space_def qbs_prob_space.rep_def
	+ by(rule someI2[where a="(X,\<alpha>,\<mu>)"]) (use in_Rep assms in auto)
	+
	+(* qbs_prob_eq[1-4] are equivalent. *)
	+lemma qbs_prob_eq_2_implies_3 :
	+ assumes "qbs_prob_eq2 p1 p2"
	+ shows "qbs_prob_eq3 p1 p2"
	+ using assms by(auto simp: qbs_prob_eq2_def qbs_prob_eq3_def)
	+
	+lemma qbs_prob_eq_3_implies_1 :
	+ assumes "qbs_prob_eq3 (p1 :: 'a qbs_prob_t) p2"
	+ shows "qbs_prob_eq p1 p2"
	+proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
	+ fix X Y :: "'a quasi_borel"
	+ fix \<alpha> \<beta> \<mu> \<nu>
	+ assume "p1 = (X,\<alpha>,\<mu>)" "p2 = (Y,\<beta>,\<nu>)"
	+ then have h:"qbs_prob_eq3 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms by simp
	+ then interpret qp : pair_qbs_prob X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq3_def)
	+ note [simp] = qbs_prob_eq3_dest(3)[OF h]
	+
	+ show "qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ proof(rule qp.qbs_prob_eq_intro)
	+ show "distr \<mu> (qbs_to_measure X) \<alpha> = distr \<nu> (qbs_to_measure X) \<beta>"
	+ proof(rule measure_eqI)
	+ fix U
	+ assume hu:"U \<in> sets (distr \<mu> (qbs_to_measure X) \<alpha>)"
	+ have "measure (distr \<mu> (qbs_to_measure X) \<alpha>) U = measure (distr \<nu> (qbs_to_measure X) \<beta>) U"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = measure \<mu> (\<alpha> -` U \<inter> space \<mu>)"
	+ by(rule measure_distr) (use hu in simp_all)
	+ also have "... = integral\<^sup>L \<mu> (indicat_real (\<alpha> -` U))"
	+ by simp
	+ also have "... = (\<integral>x. indicat_real U (\<alpha> x) \<partial>\<mu>)"
	+ using indicator_vimage[of \<alpha> U] Bochner_Integration.integral_cong[of \<mu> _ "indicat_real (\<alpha> -` U)" "\<lambda>x. indicat_real U (\<alpha> x)"]
	+ by auto
	+ also have "... = (\<integral>x. indicat_real U (\<beta> x) \<partial>\<nu>)"
	+ using qbs_prob_eq3_dest(4)[OF h,of "indicat_real U"] hu
	+ by simp
	+ also have "... = integral\<^sup>L \<nu> (indicat_real (\<beta> -` U))"
	+ using indicator_vimage[of \<beta> U,symmetric] Bochner_Integration.integral_cong[of \<nu> _ "\<lambda>x. indicat_real U (\<beta> x)" "indicat_real (\<beta> -` U)"]
	+ by blast
	+ also have "... = measure \<nu> (\<beta> -` U \<inter> space \<nu>)"
	+ by simp
	+ also have "... = ?rhs"
	+ by(rule measure_distr[symmetric]) (use hu in simp_all)
	+ finally show ?thesis .
	+ qed
	+ thus "emeasure (distr \<mu> (qbs_to_measure X) \<alpha>) U = emeasure (distr \<nu> (qbs_to_measure X) \<beta>) U"
	+ using qp.qp2.finite_measure_distr[of \<beta>] qp.qp1.finite_measure_distr[of \<alpha>]
	+ by(simp add: finite_measure.emeasure_eq_measure)
	+ qed simp
	+ qed simp
	+qed
	+
	+lemma qbs_prob_eq_1_implies_2 :
	+ assumes "qbs_prob_eq p1 (p2 :: 'a qbs_prob_t)"
	+ shows "qbs_prob_eq2 p1 p2"
	+proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
	+ fix X Y :: "'a quasi_borel"
	+ fix \<alpha> \<beta> \<mu> \<nu>
	+ assume "p1 = (X,\<alpha>,\<mu>)" "p2 = (Y,\<beta>,\<nu>)"
	+ then have h:"qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms by simp
	+ then interpret qp : pair_qbs_prob X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq_def)
	+ note [simp] = qbs_prob_eq_dest(3)[OF h]
	+
	+ show "qbs_prob_eq2 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ proof(rule qp.qbs_prob_eq2_intro)
	+ fix f :: "'a \<Rightarrow> real"
	+ assume [measurable]:"f \<in> borel_measurable (qbs_to_measure X)"
	+ show "(\<integral>r. f (\<alpha> r) \<partial> \<mu>) = (\<integral>r. f (\<beta> r) \<partial> \<nu>)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = (\<integral>x. f x \<partial>(distr \<mu> (qbs_to_measure X) \<alpha>))"
	+ by(simp add: Bochner_Integration.integral_distr[symmetric])
	+ also have "... = (\<integral>x. f x \<partial>(distr \<nu> (qbs_to_measure X) \<beta>))"
	+ by(simp add: qbs_prob_eq_dest(4)[OF h])
	+ also have "... = ?rhs"
	+ by(simp add: Bochner_Integration.integral_distr)
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+qed
	+
	+lemma qbs_prob_eq_1_implies_4 :
	+ assumes "qbs_prob_eq p1 p2"
	+ shows "qbs_prob_eq4 p1 p2"
	+proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
	+ fix X Y :: "'a quasi_borel"
	+ fix \<alpha> \<beta> \<mu> \<nu>
	+ assume "p1 = (X,\<alpha>,\<mu>)" "p2 = (Y,\<beta>,\<nu>)"
	+ then have h:"qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms by simp
	+ then interpret qp : pair_qbs_prob X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq_def)
	+ note [simp] = qbs_prob_eq_dest(3)[OF h]
	+
	+ show "qbs_prob_eq4 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ proof(rule qp.qbs_prob_eq4_intro)
	+ fix f ::"'a \<Rightarrow> ennreal"
	+ assume [measurable]:"f \<in> borel_measurable (qbs_to_measure X)"
	+ show "(\<integral>\<^sup>+ x. f (\<alpha> x) \<partial>\<mu>) = (\<integral>\<^sup>+ x. f (\<beta> x) \<partial>\<nu>)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = integral\<^sup>N (distr \<mu> (qbs_to_measure X) \<alpha>) f"
	+ by(simp add: nn_integral_distr)
	+ also have "... = integral\<^sup>N (distr \<nu> (qbs_to_measure X) \<beta>) f"
	+ by(simp add: qbs_prob_eq_dest(4)[OF h])
	+ also have "... = ?rhs"
	+ by(simp add: nn_integral_distr)
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+qed
	+
	+lemma qbs_prob_eq_4_implies_3 :
	+ assumes "qbs_prob_eq4 p1 p2"
	+ shows "qbs_prob_eq3 p1 p2"
	+proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
	+ fix X Y :: "'a quasi_borel"
	+ fix \<alpha> \<beta> \<mu> \<nu>
	+ assume "p1 = (X,\<alpha>,\<mu>)" "p2 = (Y,\<beta>,\<nu>)"
	+ then have h:"qbs_prob_eq4 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using assms by simp
	+ then interpret qp : pair_qbs_prob X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq4_def)
	+ note [simp] = qbs_prob_eq4_dest(3)[OF h]
	+
	+ show "qbs_prob_eq3 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ proof(rule qp.qbs_prob_eq3_intro)
	+ fix f :: "'a \<Rightarrow> real"
	+ assume [measurable]:"f \<in> borel_measurable (qbs_to_measure X)"
	+ and h': "\<forall>k\<in>qbs_space X. 0 \<le> f k"
	+ show "(\<integral> x. f (\<alpha> x) \<partial>\<mu>) = (\<integral> x. f (\<beta> x) \<partial>\<nu>)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = enn2real (\<integral>\<^sup>+ x. ennreal (f (\<alpha> x)) \<partial>\<mu>)"
	+ using h' by(auto simp: integral_eq_nn_integral[where f="(\<lambda>x. f (\<alpha> x))"] qbs_Mx_to_X(2))
	+ also have "... = enn2real (\<integral>\<^sup>+ x. (ennreal \<circ> f) (\<alpha> x) \<partial>\<mu>)"
	+ by simp
	+ also have "... = enn2real (\<integral>\<^sup>+ x. (ennreal \<circ> f) (\<beta> x) \<partial>\<nu>)"
	+ using qbs_prob_eq4_dest(4)[OF h,of "ennreal \<circ> f"] by simp
	+ also have "... = enn2real (\<integral>\<^sup>+ x. ennreal (f (\<beta> x)) \<partial>\<nu>)"
	+ by simp
	+ also have "... = ?rhs"
	+ using h' by(auto simp: integral_eq_nn_integral[where f="(\<lambda>x. f (\<beta> x))"] qbs_Mx_to_X(2))
	+ finally show ?thesis .
	+ qed
	+ qed simp
	+qed
	+
	+lemma qbs_prob_eq_equiv12 :
	+ "qbs_prob_eq = qbs_prob_eq2"
	+ using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
	+ by blast
	+
	+lemma qbs_prob_eq_equiv13 :
	+ "qbs_prob_eq = qbs_prob_eq3"
	+ using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
	+ by blast
	+
	+lemma qbs_prob_eq_equiv14 :
	+ "qbs_prob_eq = qbs_prob_eq4"
	+ using qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1 qbs_prob_eq_1_implies_4 qbs_prob_eq_4_implies_3 qbs_prob_eq_1_implies_2
	+ by blast
	+
	+lemma qbs_prob_eq_equiv23 :
	+ "qbs_prob_eq2 = qbs_prob_eq3"
	+ using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
	+ by blast
	+
	+lemma qbs_prob_eq_equiv24 :
	+ "qbs_prob_eq2 = qbs_prob_eq4"
	+ using qbs_prob_eq_2_implies_3 qbs_prob_eq_4_implies_3 qbs_prob_eq_3_implies_1 qbs_prob_eq_1_implies_4 qbs_prob_eq_1_implies_2
	+ by blast
	+
	+lemma qbs_prob_eq_equiv34:
	+ "qbs_prob_eq3 = qbs_prob_eq4"
	+ using qbs_prob_eq_3_implies_1 qbs_prob_eq_1_implies_4 qbs_prob_eq_4_implies_3
	+ by blast
	+
	+lemma qbs_prob_eq_equiv31 :
	+ "qbs_prob_eq = qbs_prob_eq3"
	+ using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
	+ by blast
	+
	+lemma qbs_prob_space_eq:
	+ assumes "qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ shows "qbs_prob_space (X,\<alpha>,\<mu>) = qbs_prob_space (Y,\<beta>,\<nu>)"
	+ using Quotient3_rel[OF Quotient3_qbs_prob_space] assms
	+ by blast
	+
	+lemma(in pair_qbs_prob) qbs_prob_space_eq:
	+ assumes "Y = X"
	+ and "distr \<mu> (qbs_to_measure X) \<alpha> = distr \<nu> (qbs_to_measure X) \<beta>"
	+ shows "qbs_prob_space (X,\<alpha>,\<mu>) = qbs_prob_space (Y,\<beta>,\<nu>)"
	+ using assms qbs_prob_eq_intro qbs_prob_space_eq by auto
	+
	+lemma(in pair_qbs_prob) qbs_prob_space_eq2:
	+ assumes "Y = X"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel
	+ \<Longrightarrow> (\<integral>x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>x. f (\<beta> x) \<partial> \<nu>)"
	+ shows "qbs_prob_space (X,\<alpha>,\<mu>) = qbs_prob_space (Y,\<beta>,\<nu>)"
	+ using qbs_prob_space_eq assms qbs_prob_eq_2_implies_3[of "(X,\<alpha>,\<mu>)" "(Y,\<beta>,\<nu>)"] qbs_prob_eq_3_implies_1[of "(X,\<alpha>,\<mu>)" "(Y,\<beta>,\<nu>)"] qbs_prob_eq2_intro qbs_prob_eq_dest(4)
	+ by blast
	+
	+lemma(in pair_qbs_prob) qbs_prob_space_eq3:
	+ assumes "Y = X"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel \<Longrightarrow> (\<forall>k\<in> qbs_space X. 0 \<le> f k)
	+ \<Longrightarrow> (\<integral>x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>x. f (\<beta> x) \<partial> \<nu>)"
	+ shows "qbs_prob_space (X,\<alpha>,\<mu>) = qbs_prob_space (Y,\<beta>,\<nu>)"
	+ using assms qbs_prob_eq_3_implies_1[of "(X,\<alpha>,\<mu>)" "(Y,\<beta>,\<nu>)"] qbs_prob_eq3_intro qbs_prob_space_eq qbs_prob_eq_dest(4)
	+ by blast
	+
	+lemma(in pair_qbs_prob) qbs_prob_space_eq4:
	+ assumes "Y = X"
	+ and "\<And>f. f \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel
	+ \<Longrightarrow> (\<integral>\<^sup>+x. f (\<alpha> x) \<partial> \<mu>) = (\<integral>\<^sup>+x. f (\<beta> x) \<partial> \<nu>)"
	+ shows "qbs_prob_space (X,\<alpha>,\<mu>) = qbs_prob_space (Y,\<beta>,\<nu>)"
	+ using assms qbs_prob_eq_4_implies_3[of "(X,\<alpha>,\<mu>)" "(Y,\<beta>,\<nu>)"] qbs_prob_space_eq3[OF assms(1)] qbs_prob_eq3_dest(4) qbs_prob_eq4_intro
	+ by blast
	+
	+lemma(in pair_qbs_prob) qbs_prob_space_eq_inverse:
	+ assumes "qbs_prob_space (X,\<alpha>,\<mu>) = qbs_prob_space (Y,\<beta>,\<nu>)"
	+ shows "qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ and "qbs_prob_eq2 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ and "qbs_prob_eq3 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ and "qbs_prob_eq4 (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>)"
	+ using Quotient3_rel[OF Quotient3_qbs_prob_space,of "(X, \<alpha>, \<mu>)" "(Y,\<beta>,\<nu>)",simplified] assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms
	+ by(simp_all add: qbs_prob_eq_equiv13[symmetric] qbs_prob_eq_equiv12[symmetric] qbs_prob_eq_equiv14[symmetric])
	+
	+
	+lift_definition qbs_prob_space_qbs :: "'a qbs_prob_space \<Rightarrow> 'a quasi_borel"
	+is fst by(auto simp add: qbs_prob_eq_def)
	+
	+lemma(in qbs_prob) qbs_prob_space_qbs_computation[simp]:
	+ "qbs_prob_space_qbs (qbs_prob_space (X,\<alpha>,\<mu>)) = X"
	+ by(simp add: qbs_prob_space_qbs.abs_eq)
	+
	+lemma rep_qbs_prob_space':
	+ assumes "qbs_prob_space_qbs s = X"
	+ shows "\<exists>\<alpha> \<mu>. s = qbs_prob_space (X,\<alpha>,\<mu>) \<and> qbs_prob X \<alpha> \<mu>"
	+proof -
	+ obtain X' \<alpha> \<mu> where hs:
	+ "s = qbs_prob_space (X', \<alpha>, \<mu>)" "qbs_prob X' \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of s] by auto
	+ then interpret qp:qbs_prob X' \<alpha> \<mu>
	+ by simp
	+ show ?thesis
	+ using assms hs(2) by(auto simp add: hs(1))
	+qed
	+
	+lift_definition qbs_prob_ennintegral :: "['a qbs_prob_space, 'a \<Rightarrow> ennreal] \<Rightarrow> ennreal"
	+is qbs_prob_t_ennintegral
	+ by(auto simp add: qbs_prob_t_ennintegral_def qbs_prob_eq_equiv14 qbs_prob_eq4_def)
	+
	+lift_definition qbs_prob_integral :: "['a qbs_prob_space, 'a \<Rightarrow> real] \<Rightarrow> real"
	+is qbs_prob_t_integral
	+ by(auto simp add: qbs_prob_eq_equiv12 qbs_prob_t_integral_def qbs_prob_eq2_def)
	+
	+syntax
	+ "_qbs_prob_ennintegral" :: "pttrn \<Rightarrow> ennreal \<Rightarrow> 'a qbs_prob_space \<Rightarrow> ennreal" ("\<integral>\<^sup>+\<^sub>Q((2 _./ _)/ \<partial>_)" [60,61] 110)
	+
	+translations
	+ "\<integral>\<^sup>+\<^sub>Q x. f \<partial>p" \<rightleftharpoons> "CONST qbs_prob_ennintegral p (\<lambda>x. f)"
	+
	+syntax
	+ "_qbs_prob_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> 'a qbs_prob_space \<Rightarrow> real" ("\<integral>\<^sub>Q((2 _./ _)/ \<partial>_)" [60,61] 110)
	+
	+translations
	+ "\<integral>\<^sub>Q x. f \<partial>p" \<rightleftharpoons> "CONST qbs_prob_integral p (\<lambda>x. f)"
	+
	+
	+text \<open> We define the function \<open>l\<^sub>X \<in> L(P(X)) \<rightarrow>\<^sub>M G(X)\<close>. \<close>
	+lift_definition qbs_prob_measure :: "'a qbs_prob_space \<Rightarrow> 'a measure"
	+is qbs_prob_t_measure
	+ by(auto simp add: qbs_prob_eq_def qbs_prob_t_measure_def)
	+
	+declare [[coercion qbs_prob_measure]]
	+
	+lemma(in qbs_prob) qbs_prob_measure_computation[simp]:
	+ "qbs_prob_measure (qbs_prob_space (X,\<alpha>,\<mu>)) = distr \<mu> (qbs_to_measure X) \<alpha>"
	+ by (simp add: qbs_prob_measure.abs_eq qbs_prob_t_measure_def)
	+
	+
	+definition qbs_emeasure ::"'a qbs_prob_space \<Rightarrow> 'a set \<Rightarrow> ennreal" where
	+"qbs_emeasure s \<equiv> emeasure (qbs_prob_measure s)"
	+
	+lemma(in qbs_prob) qbs_emeasure_computation[simp]:
	+ assumes "U \<in> sets (qbs_to_measure X)"
	+ shows "qbs_emeasure (qbs_prob_space (X,\<alpha>,\<mu>)) U = emeasure \<mu> (\<alpha> -` U)"
	+ by(simp add: qbs_emeasure_def emeasure_distr[OF _ assms])
	+
	+
	+definition qbs_measure ::"'a qbs_prob_space \<Rightarrow> 'a set \<Rightarrow> real" where
	+"qbs_measure s \<equiv> measure (qbs_prob_measure s)"
	+
	+
	+interpretation qbs_prob_measure_prob_space : prob_space "qbs_prob_measure (s::'a qbs_prob_space)" for s
	+proof(transfer,auto)
	+ fix X :: "'a quasi_borel"
	+ fix \<alpha> \<mu>
	+ assume "qbs_prob_eq (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ then interpret qp: qbs_prob X \<alpha> \<mu>
	+ by(simp add: qbs_prob_eq_def)
	+ show "prob_space (qbs_prob_t_measure (X,\<alpha>,\<mu>))"
	+ by(simp add: qbs_prob_t_measure_def qp.prob_space_distr)
	+qed
	+
	+lemma qbs_prob_measure_space:
	+ "qbs_space (qbs_prob_space_qbs s) = space (qbs_prob_measure s)"
	+ by(transfer,simp add: qbs_prob_t_measure_def)
	+
	+lemma qbs_prob_measure_sets[measurable_cong]:
	+ "sets (qbs_to_measure (qbs_prob_space_qbs s)) = sets (qbs_prob_measure s)"
	+ by(transfer,simp add: qbs_prob_t_measure_def)
	+
	+lemma(in qbs_prob) qbs_prob_ennintegral_def:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "qbs_prob_ennintegral (qbs_prob_space (X,\<alpha>,\<mu>)) f = (\<integral>\<^sup>+x. f (\<alpha> x) \<partial> \<mu>)"
	+ by (simp add: assms qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def)
	+
	+lemma(in qbs_prob) qbs_prob_ennintegral_def2:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "qbs_prob_ennintegral (qbs_prob_space (X,\<alpha>,\<mu>)) f = integral\<^sup>N (distr \<mu> (qbs_to_measure X) \<alpha>) f"
	+ using assms by(auto simp add: qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def qbs_prob_t_measure_def nn_integral_distr)
	+
	+lemma (in qbs_prob) qbs_prob_ennintegral_not_morphism:
	+ assumes "f \<notin> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "qbs_prob_ennintegral (qbs_prob_space (X,\<alpha>,\<mu>)) f = 0"
	+ by(simp add: assms qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def)
	+
	+lemma qbs_prob_ennintegral_def2:
	+ assumes "qbs_prob_space_qbs s = (X :: 'a quasi_borel)"
	+ and "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "qbs_prob_ennintegral s f = integral\<^sup>N (qbs_prob_measure s) f"
	+ using assms
	+proof(transfer,auto)
	+ fix X :: "'a quasi_borel" and \<alpha> \<mu> f
	+ assume "qbs_prob_eq (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ and h:"f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ then interpret qp : qbs_prob X \<alpha> \<mu>
	+ by(simp add: qbs_prob_eq_def)
	+ show "qbs_prob_t_ennintegral (X, \<alpha>, \<mu>) f = integral\<^sup>N (qbs_prob_t_measure (X, \<alpha>, \<mu>)) f"
	+ using qp.qbs_prob_ennintegral_def2[OF h]
	+ by(simp add: qbs_prob_ennintegral.abs_eq qbs_prob_t_measure_def)
	+qed
	+
	+lemma(in qbs_prob) qbs_prob_integral_def:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q real_quasi_borel"
	+ shows "qbs_prob_integral (qbs_prob_space (X,\<alpha>,\<mu>)) f = (\<integral>x. f (\<alpha> x) \<partial> \<mu>)"
	+ by (simp add: assms qbs_prob_integral.abs_eq qbs_prob_t_integral_def)
	+
	+lemma(in qbs_prob) qbs_prob_integral_def2:
	+ "qbs_prob_integral (qbs_prob_space (X,\<alpha>,\<mu>)) f = integral\<^sup>L (distr \<mu> (qbs_to_measure X) \<alpha>) f"
	+proof -
	+ consider "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q" \| "f \<notin> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q" by auto
	+ thus ?thesis
	+ proof cases
	+ case h:2
	+ then have "\<not> integrable (qbs_prob_measure (qbs_prob_space (X,\<alpha>,\<mu>))) f"
	+ by auto
	+ thus ?thesis
	+ using h by(simp add: qbs_prob_integral.abs_eq qbs_prob_t_integral_def not_integrable_integral_eq)
	+ qed (auto simp add: qbs_prob_integral.abs_eq qbs_prob_t_integral_def integral_distr )
	+qed
	+
	+lemma qbs_prob_integral_def2:
	+ "qbs_prob_integral (s::'a qbs_prob_space) f = integral\<^sup>L (qbs_prob_measure s) f"
	+proof(transfer,auto)
	+ fix X :: "'a quasi_borel" and \<mu> \<alpha> f
	+ assume "qbs_prob_eq (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ then interpret qp : qbs_prob X \<alpha> \<mu>
	+ by(simp add: qbs_prob_eq_def)
	+ show "qbs_prob_t_integral (X,\<alpha>,\<mu>) f = integral\<^sup>L (qbs_prob_t_measure (X,\<alpha>,\<mu>)) f"
	+ using qp.qbs_prob_integral_def2
	+ by(simp add: qbs_prob_t_measure_def qbs_prob_integral.abs_eq)
	+qed
	+
	+definition qbs_prob_var :: "'a qbs_prob_space \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> real" where
	+"qbs_prob_var s f \<equiv> qbs_prob_integral s (\<lambda>x. (f x - qbs_prob_integral s f)\<^sup>2)"
	+
	+lemma(in qbs_prob) qbs_prob_var_computation:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q real_quasi_borel"
	+ shows "qbs_prob_var (qbs_prob_space (X,\<alpha>,\<mu>)) f = (\<integral>x. (f (\<alpha> x) - (\<integral>x. f (\<alpha> x) \<partial> \<mu>))\<^sup>2 \<partial> \<mu>)"
	+proof -
	+ have "(\<lambda>x. (f x - qbs_prob_integral (qbs_prob_space (X, \<alpha>, \<mu>)) f)\<^sup>2) \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using assms by auto
	+ thus ?thesis
	+ using assms qbs_prob_integral_def[of "\<lambda>x. (f x - qbs_prob_integral (qbs_prob_space (X,\<alpha>,\<mu>)) f)\<^sup>2"]
	+ by(simp add: qbs_prob_var_def qbs_prob_integral_def)
	+qed
	+
	+lift_definition qbs_integrable :: "['a qbs_prob_space, 'a \<Rightarrow> real] \<Rightarrow> bool"
	+is qbs_prob_t_integrable
	+proof auto
	+ have H:"\<And> (X::'a quasi_borel) Y \<alpha> \<beta> \<mu> \<nu> f.
	+ qbs_prob_eq (X,\<alpha>,\<mu>) (Y,\<beta>,\<nu>) \<Longrightarrow> qbs_prob_t_integrable (X,\<alpha>,\<mu>) f \<Longrightarrow> qbs_prob_t_integrable (Y,\<beta>,\<nu>) f"
	+ proof -
	+ fix X Y :: "'a quasi_borel"
	+ fix \<alpha> \<beta> \<mu> \<nu> f
	+ assume H0:"qbs_prob_eq (X, \<alpha>, \<mu>) (Y, \<beta>, \<nu>)"
	+ "qbs_prob_t_integrable (X, \<alpha>, \<mu>) f"
	+ then interpret qp: pair_qbs_prob X \<alpha> \<mu> Y \<beta> \<nu>
	+ by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq_def)
	+ have [measurable]: "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel"
	+ and h: "integrable \<mu> (f \<circ> \<alpha>)"
	+ using H0 by(auto simp: qbs_prob_t_integrable_def)
	+ note [simp] = qbs_prob_eq_dest(3)[OF H0(1)]
	+
	+ show "qbs_prob_t_integrable (Y, \<beta>, \<nu>) f"
	+ unfolding qbs_prob_t_integrable_def
	+ proof auto
	+ have "integrable (distr \<mu> (qbs_to_measure X) \<alpha>) f"
	+ using h by(simp add: comp_def integrable_distr_eq)
	+ hence "integrable (distr \<nu> (qbs_to_measure X) \<beta>) f"
	+ using qbs_prob_eq_dest(4)[OF H0(1)] by simp
	+ thus "integrable \<nu> (f \<circ> \<beta>)"
	+ by(simp add: comp_def integrable_distr_eq)
	+ qed
	+ qed
	+ fix X Y :: "'a quasi_borel"
	+ fix \<alpha> \<beta> \<mu> \<nu>
	+ assume H0:"qbs_prob_eq (X, \<alpha>, \<mu>) (Y, \<beta>, \<nu>)"
	+ then have H1:"qbs_prob_eq (Y, \<beta>, \<nu>) (X, \<alpha>, \<mu>)"
	+ by(auto simp add: qbs_prob_eq_def)
	+ show "qbs_prob_t_integrable (X, \<alpha>, \<mu>) = qbs_prob_t_integrable (Y, \<beta>, \<nu>)"
	+ using H[OF H0] H[OF H1] by auto
	+qed
	+
	+lemma(in qbs_prob) qbs_integrable_def:
	+ "qbs_integrable (qbs_prob_space (X, \<alpha>, \<mu>)) f = (f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q \<and> integrable \<mu> (f \<circ> \<alpha>))"
	+ by (simp add: qbs_integrable.abs_eq qbs_prob_t_integrable_def)
	+
	+lemma qbs_integrable_morphism:
	+ assumes "qbs_prob_space_qbs s = X"
	+ and "qbs_integrable s f"
	+ shows "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
	+ using assms by(transfer,auto simp: qbs_prob_t_integrable_def)
	+
	+lemma(in qbs_prob) qbs_integrable_measurable[simp,measurable]:
	+ assumes "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>)) f"
	+ shows "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel"
	+ using assms by(auto simp add: qbs_integrable_def)
	+
	+lemma qbs_integrable_iff_integrable:
	+ "(qbs_integrable (s::'a qbs_prob_space) f) = (integrable (qbs_prob_measure s) f)"
	+ apply transfer
	+ subgoal for s f
	+ proof(rule prod_cases3[where y=s],simp)
	+ fix X :: "'a quasi_borel"
	+ fix \<alpha> \<mu>
	+ assume "qbs_prob_eq (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ then interpret qp: qbs_prob X \<alpha> \<mu>
	+ by(simp add: qbs_prob_eq_def)
	+
	+ show "qbs_prob_t_integrable (X,\<alpha>,\<mu>) f = integrable (qbs_prob_t_measure (X,\<alpha>,\<mu>)) f"
	+ (is "?lhs = ?rhs")
	+ using integrable_distr_eq[of \<alpha> \<mu> "qbs_to_measure X" f]
	+ by(auto simp add: qbs_prob_t_integrable_def qbs_prob_t_measure_def comp_def)
	+ qed
	+ done
	+
	+lemma(in qbs_prob) qbs_integrable_iff_integrable_distr:
	+ "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>)) f = integrable (distr \<mu> (qbs_to_measure X) \<alpha>) f"
	+ by(simp add: qbs_integrable_iff_integrable)
	+
	+lemma(in qbs_prob) qbs_integrable_iff_integrable:
	+ assumes "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M real_borel"
	+ shows "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>)) f = integrable \<mu> (\<lambda>x. f (\<alpha> x))"
	+ by(auto intro!: integrable_distr_eq[of \<alpha> \<mu> "qbs_to_measure X" f] simp: assms qbs_integrable_iff_integrable_distr)
	+
	+lemma qbs_integrable_if_integrable:
	+ assumes "integrable (qbs_prob_measure s) f"
	+ shows "qbs_integrable (s::'a qbs_prob_space) f"
	+ using assms by(simp add: qbs_integrable_iff_integrable)
	+
	+lemma integrable_if_qbs_integrable:
	+ assumes "qbs_integrable (s::'a qbs_prob_space) f"
	+ shows "integrable (qbs_prob_measure s) f"
	+ using assms by(simp add: qbs_integrable_iff_integrable)
	+
	+lemma qbs_integrable_iff_bounded:
	+ assumes "qbs_prob_space_qbs s = X"
	+ shows "qbs_integrable s f \<longleftrightarrow> f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q \<and> qbs_prob_ennintegral s (\<lambda>x. ennreal \<bar>f x \<bar>) < \<infinity>"
	+ (is "?lhs = ?rhs")
	+proof -
	+ obtain \<alpha> \<mu> where hs:
	+ "qbs_prob X \<alpha> \<mu>" "s = qbs_prob_space (X,\<alpha>,\<mu>)"
	+ using rep_qbs_prob_space'[OF assms] by auto
	+ then interpret qp:qbs_prob X \<alpha> \<mu> by simp
	+ have "?lhs = integrable (distr \<mu> (qbs_to_measure X) \<alpha>) f"
	+ by (simp add: hs(2) qbs_integrable_iff_integrable)
	+ also have "... = (f \<in> borel_measurable (distr \<mu> (qbs_to_measure X) \<alpha>) \<and> ((\<integral>\<^sup>+ x. ennreal (norm (f x)) \<partial>(distr \<mu> (qbs_to_measure X) \<alpha>)) < \<infinity>))"
	+ by(rule integrable_iff_bounded)
	+ also have "... = ?rhs"
	+ proof -
	+ have [simp]:"f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q \<Longrightarrow>(\<lambda>x. ennreal \<bar>f x\<bar>) \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ by auto
	+ have "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q \<Longrightarrow> qbs_prob_ennintegral s (\<lambda>x. ennreal \<bar>f x\<bar>) = (\<integral>\<^sup>+ x. ennreal (norm (f x)) \<partial>qbs_prob_measure s)"
	+ using qp.qbs_prob_ennintegral_def2[of "\<lambda>x. ennreal \<bar>f x\<bar>"]
	+ by(auto simp: hs(2))
	+ thus ?thesis
	+ by(simp add: hs(2)) fastforce
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_integrable_cong:
	+ assumes "qbs_prob_space_qbs s = X"
	+ "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x = g x"
	+ and "qbs_integrable s f"
	+ shows "qbs_integrable s g"
	+ apply(rule qbs_integrable_if_integrable)
	+ using integrable_cong[OF refl, of "qbs_prob_measure s" f g,simplified qbs_prob_measure_space[symmetric] assms(1),OF assms(2)]
	+ qbs_integrable_iff_integrable[of s f] assms(3)
	+ by simp
	+
	+lemma qbs_integrable_const[simp]:
	+ "qbs_integrable s (\<lambda>x. c)"
	+ using qbs_integrable_iff_integrable[of s "\<lambda>x. c"] by simp
	+
	+lemma qbs_integrable_add[simp]:
	+ assumes "qbs_integrable s f"
	+ and "qbs_integrable s g"
	+ shows "qbs_integrable s (\<lambda>x. f x + g x)"
	+ by(rule qbs_integrable_if_integrable[OF Bochner_Integration.integrable_add[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]])
	+
	+lemma qbs_integrable_diff[simp]:
	+ assumes "qbs_integrable s f"
	+ and "qbs_integrable s g"
	+ shows "qbs_integrable s (\<lambda>x. f x - g x)"
	+ by(rule qbs_integrable_if_integrable[OF Bochner_Integration.integrable_diff[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]])
	+
	+lemma qbs_integrable_mult_iff[simp]:
	+ "(qbs_integrable s (\<lambda>x. c * f x)) = (c = 0 \<or> qbs_integrable s f)"
	+ using qbs_integrable_iff_integrable[of s "\<lambda>x. c * f x"] integrable_mult_left_iff[of "qbs_prob_measure s" c f] qbs_integrable_iff_integrable[of s f]
	+ by simp
	+
	+lemma qbs_integrable_mult[simp]:
	+ assumes "qbs_integrable s f"
	+ shows "qbs_integrable s (\<lambda>x. c * f x)"
	+ using assms qbs_integrable_mult_iff by auto
	+
	+lemma qbs_integrable_abs[simp]:
	+ assumes "qbs_integrable s f"
	+ shows "qbs_integrable s (\<lambda>x. \<bar>f x\<bar>)"
	+ by(rule qbs_integrable_if_integrable[OF integrable_abs[OF integrable_if_qbs_integrable[OF assms]]])
	+
	+lemma qbs_integrable_sq[simp]:
	+ assumes "qbs_integrable s f"
	+ and "qbs_integrable s (\<lambda>x. (f x)\<^sup>2)"
	+ shows "qbs_integrable s (\<lambda>x. (f x - c)\<^sup>2)"
	+ by(simp add: comm_ring_1_class.power2_diff,rule qbs_integrable_diff,rule qbs_integrable_add)
	+ (simp_all add: comm_semiring_1_class.semiring_normalization_rules(16)[of 2] assms)
	+
	+lemma qbs_ennintegral_eq_qbs_integral:
	+ assumes "qbs_prob_space_qbs s = X"
	+ "qbs_integrable s f"
	+ and "\<And>x. x \<in> qbs_space X \<Longrightarrow> 0 \<le> f x"
	+ shows "qbs_prob_ennintegral s (\<lambda>x. ennreal (f x)) = ennreal (qbs_prob_integral s f)"
	+ using nn_integral_eq_integral[OF integrable_if_qbs_integrable[OF assms(2)]] assms qbs_prob_ennintegral_def2[OF assms(1) qbs_morphism_comp[OF qbs_integrable_morphism[OF assms(1,2)],of ennreal "\<real>\<^sub>Q\<^sub>\<ge>\<^sub>0",simplified comp_def]] measurable_ennreal
	+ by (metis AE_I2 qbs_prob_integral_def2 qbs_prob_measure_space real.standard_borel_r_full_faithful)
	+
	+lemma qbs_prob_ennintegral_cong:
	+ assumes "qbs_prob_space_qbs s = X"
	+ and "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x = g x"
	+ shows "qbs_prob_ennintegral s f = qbs_prob_ennintegral s g"
	+proof -
	+ obtain \<alpha> \<mu> where hs:
	+ "s = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space'[OF assms(1)] by auto
	+ then interpret qp : qbs_prob X \<alpha> \<mu>
	+ by simp
	+ have H1:"f \<circ> \<alpha> = g \<circ> \<alpha>"
	+ using assms(2)
	+ unfolding comp_def apply standard
	+ using assms(2)[of "\<alpha> _"] by (simp add: qbs_Mx_to_X(2))
	+ consider "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" \| "f \<notin> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" by auto
	+ then have "qbs_prob_t_ennintegral (X,\<alpha>,\<mu>) f = qbs_prob_t_ennintegral (X,\<alpha>,\<mu>) g"
	+ proof cases
	+ case h:1
	+ then have "g \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ using qbs_morphism_cong[of X f g "\<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"] assms by simp
	+ then show ?thesis
	+ using h H1 by(simp add: qbs_prob_t_ennintegral_def comp_def)
	+ next
	+ case h:2
	+ then have "g \<notin> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ using assms qbs_morphism_cong[of X g f "\<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"] by auto
	+ then show ?thesis
	+ using h by(simp add: qbs_prob_t_ennintegral_def)
	+ qed
	+ thus ?thesis
	+ using hs(1) by (simp add: qbs_prob_ennintegral.abs_eq)
	+qed
	+
	+
	+lemma qbs_prob_ennintegral_const:
	+ "qbs_prob_ennintegral (s::'a qbs_prob_space) (\<lambda>x. c) = c"
	+ using qbs_prob_ennintegral_def2[OF _ qbs_morphism_const[of c "\<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" "qbs_prob_space_qbs s",simplified]]
	+ by (simp add: qbs_prob_measure_prob_space.emeasure_space_1)
	+
	+lemma qbs_prob_ennintegral_add:
	+ assumes "qbs_prob_space_qbs s = X"
	+ "f \<in> (X::'a quasi_borel) \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ and "g \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "qbs_prob_ennintegral s (\<lambda>x. f x + g x) = qbs_prob_ennintegral s f + qbs_prob_ennintegral s g"
	+ using qbs_prob_ennintegral_def2[of s X "\<lambda>x. f x + g x"] qbs_prob_ennintegral_def2[OF assms(1,2)] qbs_prob_ennintegral_def2[OF assms(1,3)] assms nn_integral_add[of f "qbs_prob_measure s" g]
	+ by fastforce
	+
	+lemma qbs_prob_ennintegral_cmult:
	+ assumes "qbs_prob_space_qbs s = X"
	+ and "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ shows "qbs_prob_ennintegral s (\<lambda>x. c * f x) = c * qbs_prob_ennintegral s f"
	+ using qbs_prob_ennintegral_def2[OF assms(1),of "\<lambda>x. c * f x"] qbs_prob_ennintegral_def2[OF assms(1,2)] nn_integral_cmult[of f "qbs_prob_measure s"] assms
	+ by fastforce
	+
	+lemma qbs_prob_ennintegral_cmult_noninfty:
	+ assumes "c \<noteq> \<infinity>"
	+ shows "qbs_prob_ennintegral s (\<lambda>x. c * f x) = c * qbs_prob_ennintegral s f"
	+proof -
	+ obtain X \<alpha> \<mu> where hs:
	+ "s = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
	+ using rep_qbs_prob_space[of s] by auto
	+ then interpret qp: qbs_prob X \<alpha> \<mu> by simp
	+ consider "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" \| "f \<notin> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" by auto
	+ then show ?thesis
	+ proof cases
	+ case 1
	+ then show ?thesis
	+ by(auto intro!: qbs_prob_ennintegral_cmult[where X=X] simp: hs(1))
	+ next
	+ case 2
	+ consider "c = 0" \| "c \<noteq> 0 \<and> c \<noteq> \<infinity>"
	+ using assms by auto
	+ then show ?thesis
	+ proof cases
	+ case 1
	+ then show ?thesis
	+ by(simp add: hs qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def)
	+ next
	+ case h:2
	+ have "(\<lambda>x. c * f x) \<notin> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ proof(rule ccontr)
	+ assume "\<not> (\<lambda>x. c * f x) \<notin> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
	+ hence 3:"(\<lambda>x. c * f x) \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel"
	+ by auto
	+ have "f = (\<lambda>x. (1/c) * (c * f x))"
	+ using h by(simp add: divide_eq_1_ennreal ennreal_divide_times mult.assoc mult.commute[of c] mult_divide_eq_ennreal)
	+ also have "... \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel"
	+ using 3 by simp
	+ finally show False
	+ using 2 by auto
	+ qed
	+ thus ?thesis
	+ using qp.qbs_prob_ennintegral_not_morphism 2
	+ by(simp add: hs(1))
	+ qed
	+ qed
	+qed
	+
	+lemma qbs_prob_integral_cong:
	+ assumes "qbs_prob_space_qbs s = X"
	+ and "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x = g x"
	+ shows "qbs_prob_integral s f = qbs_prob_integral s g"
	+ by(simp add: qbs_prob_integral_def2) (metis Bochner_Integration.integral_cong assms(1) assms(2) qbs_prob_measure_space)
	+
	+lemma qbs_prob_integral_nonneg:
	+ assumes "qbs_prob_space_qbs s = X"
	+ and "\<And>x. x \<in> qbs_space X \<Longrightarrow> 0 \<le> f x"
	+ shows "0 \<le> qbs_prob_integral s f"
	+ using qbs_prob_measure_space[of s] assms
	+ by(simp add: qbs_prob_integral_def2)
	+
	+lemma qbs_prob_integral_mono:
	+ assumes "qbs_prob_space_qbs s = X"
	+ "qbs_integrable (s :: 'a qbs_prob_space) f"
	+ "qbs_integrable s g"
	+ and "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x \<le> g x"
	+ shows "qbs_prob_integral s f \<le> qbs_prob_integral s g"
	+ using integral_mono[OF integrable_if_qbs_integrable[OF assms(2)] integrable_if_qbs_integrable[OF assms(3)] assms(4)[simplified qbs_prob_measure_space]]
	+ by(simp add: qbs_prob_integral_def2 assms(1) qbs_prob_measure_space[symmetric])
	+
	+lemma qbs_prob_integral_const:
	+ "qbs_prob_integral (s::'a qbs_prob_space) (\<lambda>x. c) = c"
	+ by(simp add: qbs_prob_integral_def2 qbs_prob_measure_prob_space.prob_space)
	+
	+lemma qbs_prob_integral_add:
	+ assumes "qbs_integrable (s::'a qbs_prob_space) f"
	+ and "qbs_integrable s g"
	+ shows "qbs_prob_integral s (\<lambda>x. f x + g x) = qbs_prob_integral s f + qbs_prob_integral s g"
	+ using Bochner_Integration.integral_add[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]
	+ by(simp add: qbs_prob_integral_def2)
	+
	+lemma qbs_prob_integral_diff:
	+ assumes "qbs_integrable (s::'a qbs_prob_space) f"
	+ and "qbs_integrable s g"
	+ shows "qbs_prob_integral s (\<lambda>x. f x - g x) = qbs_prob_integral s f - qbs_prob_integral s g"
	+ using Bochner_Integration.integral_diff[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]
	+ by(simp add: qbs_prob_integral_def2)
	+
	+lemma qbs_prob_integral_cmult:
	+ "qbs_prob_integral s (\<lambda>x. c * f x) = c * qbs_prob_integral s f"
	+ by(simp add: qbs_prob_integral_def2)
	+
	+lemma real_qbs_prob_integral_def:
	+ assumes "qbs_integrable (s::'a qbs_prob_space) f"
	+ shows "qbs_prob_integral s f = enn2real (qbs_prob_ennintegral s (\<lambda>x. ennreal (f x))) - enn2real (qbs_prob_ennintegral s (\<lambda>x. ennreal (- f x)))"
	+ using assms
	+proof(transfer,auto)
	+ fix X :: "'a quasi_borel"
	+ fix \<alpha> \<mu> f
	+ assume H:"qbs_prob_eq (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ "qbs_prob_t_integrable (X,\<alpha>,\<mu>) f"
	+ then interpret qp: qbs_prob X \<alpha> \<mu>
	+ by(simp add: qbs_prob_eq_def)
	+ show "qbs_prob_t_integral (X,\<alpha>,\<mu>) f = enn2real (qbs_prob_t_ennintegral (X,\<alpha>,\<mu>) (\<lambda>x. ennreal (f x))) - enn2real (qbs_prob_t_ennintegral (X,\<alpha>,\<mu>) (\<lambda>x. ennreal (- f x)))"
	+ using H(2) real_lebesgue_integral_def[of \<mu> "f \<circ> \<alpha>"]
	+ by(auto simp add: comp_def qbs_prob_t_integrable_def qbs_prob_t_integral_def qbs_prob_t_ennintegral_def)
	+qed
	+
	+lemma qbs_prob_var_eq:
	+ assumes "qbs_integrable (s::'a qbs_prob_space) f"
	+ and "qbs_integrable s (\<lambda>x. (f x)\<^sup>2)"
	+ shows "qbs_prob_var s f = qbs_prob_integral s (\<lambda>x. (f x)\<^sup>2) - (qbs_prob_integral s f)\<^sup>2"
	+ unfolding qbs_prob_var_def using assms
	+proof(transfer,auto)
	+ fix X :: "'a quasi_borel"
	+ fix \<alpha> \<mu> f
	+ assume H:"qbs_prob_eq (X,\<alpha>,\<mu>) (X,\<alpha>,\<mu>)"
	+ "qbs_prob_t_integrable (X,\<alpha>,\<mu>) f"
	+ "qbs_prob_t_integrable (X,\<alpha>,\<mu>) (\<lambda>x. (f x)\<^sup>2)"
	+ then interpret qp: qbs_prob X \<alpha> \<mu>
	+ by(simp add: qbs_prob_eq_def)
	+ show "qbs_prob_t_integral (X,\<alpha>,\<mu>) (\<lambda>x. (f x - qbs_prob_t_integral (X,\<alpha>,\<mu>) f)\<^sup>2) = qbs_prob_t_integral (X,\<alpha>,\<mu>) (\<lambda>x. (f x)\<^sup>2) - (qbs_prob_t_integral (X,\<alpha>,\<mu>) f)\<^sup>2"
	+ using H(2,3) prob_space.variance_eq[of \<mu> "f \<circ> \<alpha>"]
	+ by(auto simp add: qbs_prob_t_integral_def qbs_prob_def qbs_prob_t_integrable_def comp_def qbs_prob_eq_def)
	+qed
	+
	+lemma qbs_prob_var_affine:
	+ assumes "qbs_integrable s f"
	+ shows "qbs_prob_var s (\<lambda>x. a * f x + b) = a\<^sup>2 * qbs_prob_var s f"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have "?lhs = qbs_prob_integral s (\<lambda>x. (a * f x + b - (a * qbs_prob_integral s f + b))\<^sup>2)"
	+ using qbs_prob_integral_add[OF qbs_integrable_mult[OF assms,of a] qbs_integrable_const[of s b]]
	+ by (simp add: qbs_prob_integral_cmult qbs_prob_integral_const qbs_prob_var_def)
	+ also have "... = qbs_prob_integral s (\<lambda>x. (a * f x - a * qbs_prob_integral s f)\<^sup>2)"
	+ by simp
	+ also have "... = qbs_prob_integral s (\<lambda>x. a\<^sup>2 * (f x - qbs_prob_integral s f)\<^sup>2)"
	+ by (metis power_mult_distrib right_diff_distrib)
	+ also have "... = ?rhs"
	+ by(simp add: qbs_prob_var_def qbs_prob_integral_cmult[of s "a\<^sup>2"])
	+ finally show ?thesis .
	+qed
	+
	+lemma qbs_prob_integral_Markov_inequality:
	+ assumes "qbs_prob_space_qbs s = X"
	+ and "qbs_integrable s f"
	+ "\<And>x. x \<in> qbs_space X \<Longrightarrow> 0 \<le> f x"
	+ and "0 < c"
	+ shows "qbs_emeasure s {x \<in> qbs_space X. c \<le> f x} \<le> ennreal (1/c * qbs_prob_integral s f)"
	+ using integral_Markov_inequality[OF integrable_if_qbs_integrable[OF assms(2)] _ assms(4)] assms(3)
	+ by(force simp add: qbs_prob_integral_def2 qbs_prob_measure_space qbs_emeasure_def assms(1) qbs_prob_measure_space[symmetric])
	+
	+lemma qbs_prob_integral_Markov_inequality':
	+ assumes "qbs_prob_space_qbs s = X"
	+ "qbs_integrable s f"
	+ "\<And>x. x \<in> qbs_space (qbs_prob_space_qbs s) \<Longrightarrow> 0 \<le> f x"
	+ and "0 < c"
	+ shows "qbs_measure s {x \<in> qbs_space (qbs_prob_space_qbs s). c \<le> f x} \<le> (1/c * qbs_prob_integral s f)"
	+ using qbs_prob_integral_Markov_inequality[OF assms] ennreal_le_iff[of "1/c * qbs_prob_integral s f" "qbs_measure s {x \<in> qbs_space (qbs_prob_space_qbs s). c \<le> f x}"] qbs_prob_integral_nonneg[of s X f,OF assms(1,3)] assms(4)
	+ by(simp add: qbs_measure_def qbs_emeasure_def qbs_prob_measure_prob_space.emeasure_eq_measure assms(1))
	+
	+lemma qbs_prob_integral_Markov_inequality_abs:
	+ assumes "qbs_prob_space_qbs s = X"
	+ "qbs_integrable s f"
	+ and "0 < c"
	+ shows "qbs_emeasure s {x \<in> qbs_space X. c \<le> \<bar>f x\<bar>} \<le> ennreal (1/c * qbs_prob_integral s (\<lambda>x. \<bar>f x\<bar>))"
	+ using qbs_prob_integral_Markov_inequality[OF assms(1) qbs_integrable_abs[OF assms(2)] _ assms(3)]
	+ by(simp add: assms(1))
	+
	+lemma qbs_prob_integral_Markov_inequality_abs':
	+ assumes "qbs_prob_space_qbs s = X"
	+ "qbs_integrable s f"
	+ and "0 < c"
	+ shows "qbs_measure s {x \<in> qbs_space X. c \<le> \<bar>f x\<bar>} \<le> (1/c * qbs_prob_integral s (\<lambda>x. \<bar>f x\<bar>))"
	+ using qbs_prob_integral_Markov_inequality'[OF assms(1) qbs_integrable_abs[OF assms(2)] _ assms(3)]
	+ by(simp add: assms(1))
	+
	+lemma qbs_prob_integral_real_Markov_inequality:
	+ assumes "qbs_prob_space_qbs s = \<real>\<^sub>Q"
	+ "qbs_integrable s f"
	+ and "0 < c"
	+ shows "qbs_emeasure s {r. c \<le> \<bar>f r\<bar>} \<le> ennreal (1/c * qbs_prob_integral s (\<lambda>x. \<bar>f x\<bar>))"
	+ using qbs_prob_integral_Markov_inequality_abs[OF assms]
	+ by simp
	+
	+lemma qbs_prob_integral_real_Markov_inequality':
	+ assumes "qbs_prob_space_qbs s = \<real>\<^sub>Q"
	+ "qbs_integrable s f"
	+ and "0 < c"
	+ shows "qbs_measure s {r. c \<le> \<bar>f r\<bar>} \<le> 1/c * qbs_prob_integral s (\<lambda>x. \<bar>f x\<bar>)"
	+ using qbs_prob_integral_Markov_inequality_abs'[OF assms]
	+ by simp
	+
	+lemma qbs_prob_integral_Chebyshev_inequality:
	+ assumes "qbs_prob_space_qbs s = X"
	+ "qbs_integrable s f"
	+ "qbs_integrable s (\<lambda>x. (f x)\<^sup>2)"
	+ and "0 < b"
	+ shows "qbs_measure s {x \<in> qbs_space X. b \<le> \<bar>f x - qbs_prob_integral s f\<bar>} \<le> 1 / b\<^sup>2 * qbs_prob_var s f"
	+proof -
	+ have "qbs_integrable s (\<lambda>x. \<bar>f x - qbs_prob_integral s f\<bar>\<^sup>2)"
	+ by(simp, rule qbs_integrable_sq[OF assms(2,3)])
	+ moreover have "{x \<in> qbs_space X. b\<^sup>2 \<le> \<bar>f x - qbs_prob_integral s f\<bar>\<^sup>2} = {x \<in> qbs_space X. b \<le> \<bar>f x - qbs_prob_integral s f\<bar>}"
	+ by (metis (mono_tags, opaque_lifting) abs_le_square_iff abs_of_nonneg assms(4) less_imp_le power2_abs)
	+ ultimately show ?thesis
	+ using qbs_prob_integral_Markov_inequality'[OF assms(1),of "\<lambda>x. \<bar>f x - qbs_prob_integral s f\<bar>^2" "b^2"] assms(4)
	+ by(simp add: qbs_prob_var_def assms(1))
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/Product_QuasiBorel.thy b/thys/Quasi_Borel_Spaces/Product_QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/Product_QuasiBorel.thy
	@@ -0,0 +1,209 @@
	+(* Title: Product_QuasiBorel.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+subsubsection \<open> Product Spaces\<close>
	+theory Product_QuasiBorel
	+
	+imports "Binary_Product_QuasiBorel"
	+
	+begin
	+
	+definition prod_qbs_Mx :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a \<Rightarrow> 'b) set" where
	+"prod_qbs_Mx I M \<equiv> { \<alpha> \| \<alpha>. \<forall>i. (i \<in> I \<longrightarrow> (\<lambda>r. \<alpha> r i) \<in> qbs_Mx (M i)) \<and> (i \<notin> I \<longrightarrow> (\<lambda>r. \<alpha> r i) = (\<lambda>r. undefined))}"
	+
	+lemma prod_qbs_MxI:
	+ assumes "\<And>i. i \<in> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) \<in> qbs_Mx (M i)"
	+ and "\<And>i. i \<notin> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) = (\<lambda>r. undefined)"
	+ shows "\<alpha> \<in> prod_qbs_Mx I M"
	+ using assms by(auto simp: prod_qbs_Mx_def)
	+
	+lemma prod_qbs_MxE:
	+ assumes "\<alpha> \<in> prod_qbs_Mx I M"
	+ shows "\<And>i. i \<in> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) \<in> qbs_Mx (M i)"
	+ and "\<And>i. i \<notin> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) = (\<lambda>r. undefined)"
	+ and "\<And>i r. i \<notin> I \<Longrightarrow> \<alpha> r i = undefined"
	+ using assms by(auto simp: prod_qbs_Mx_def dest: fun_cong[where g="(\<lambda>r. undefined)"])
	+
	+definition PiQ :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b quasi_borel) \<Rightarrow> ('a \<Rightarrow> 'b) quasi_borel" where
	+"PiQ I M \<equiv> Abs_quasi_borel (\<Pi>\<^sub>E i\<in>I. qbs_space (M i), prod_qbs_Mx I M)"
	+
	+syntax
	+ "_PiQ" :: "pttrn \<Rightarrow> 'i set \<Rightarrow> 'a quasi_borel \<Rightarrow> ('i => 'a) quasi_borel" ("(3\<Pi>\<^sub>Q _\<in>_./ _)" 10)
	+translations
	+ "\<Pi>\<^sub>Q x\<in>I. M" == "CONST PiQ I (\<lambda>x. M)"
	+
	+
	+lemma PiQ_f: "prod_qbs_Mx I M \<subseteq> UNIV \<rightarrow> (\<Pi>\<^sub>E i\<in>I. qbs_space (M i))"
	+ using prod_qbs_MxE by fastforce
	+
	+lemma PiQ_closed1: "qbs_closed1 (prod_qbs_Mx I M)"
	+proof(rule qbs_closed1I)
	+ fix \<alpha> f
	+ assume h:"\<alpha> \<in> prod_qbs_Mx I M "
	+ "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ show "\<alpha> \<circ> f \<in> prod_qbs_Mx I M"
	+ proof(rule prod_qbs_MxI)
	+ fix i
	+ assume "i \<in> I"
	+ from prod_qbs_MxE(1)[OF h(1) this]
	+ have "(\<lambda>r. \<alpha> r i) \<circ> f \<in> qbs_Mx (M i)"
	+ using h(2) by auto
	+ thus "(\<lambda>r. (\<alpha> \<circ> f) r i) \<in> qbs_Mx (M i)"
	+ by(simp add: comp_def)
	+ next
	+ fix i
	+ assume "i \<notin> I"
	+ from prod_qbs_MxE(3)[OF h(1) this]
	+ show "(\<lambda>r. (\<alpha> \<circ> f) r i) = (\<lambda>r. undefined)"
	+ by simp
	+ qed
	+qed
	+
	+lemma PiQ_closed2: "qbs_closed2 (\<Pi>\<^sub>E i\<in>I. qbs_space (M i)) (prod_qbs_Mx I M)"
	+proof(rule qbs_closed2I)
	+ fix x
	+ assume h:"x \<in> (\<Pi>\<^sub>E i\<in>I. qbs_space (M i))"
	+ show "(\<lambda>r. x) \<in> prod_qbs_Mx I M"
	+ proof(rule prod_qbs_MxI)
	+ fix i
	+ assume hi:"i \<in> I"
	+ then have "x i \<in> qbs_space (M i)"
	+ using h by auto
	+ thus "(\<lambda>r. x i) \<in> qbs_Mx (M i)"
	+ by auto
	+ next
	+ show "\<And>i. i \<notin> I \<Longrightarrow> (\<lambda>r. x i) = (\<lambda>r. undefined)"
	+ using h by auto
	+ qed
	+qed
	+
	+lemma PiQ_closed3: "qbs_closed3 (prod_qbs_Mx I M)"
	+proof(rule qbs_closed3I)
	+ fix P Fi
	+ assume h:"\<And>i::nat. P -` {i} \<in> sets real_borel"
	+ "\<And>i::nat. Fi i \<in> prod_qbs_Mx I M"
	+ show "(\<lambda>r. Fi (P r) r) \<in> prod_qbs_Mx I M"
	+ proof(rule prod_qbs_MxI)
	+ fix i
	+ assume hi:"i \<in> I"
	+ show "(\<lambda>r. Fi (P r) r i) \<in> qbs_Mx (M i)"
	+ using prod_qbs_MxE(1)[OF h(2) hi] qbs_closed3_dest[OF h(1),of "\<lambda>j r. Fi j r i"]
	+ by auto
	+ next
	+ show "\<And>i. i \<notin> I \<Longrightarrow>
	+ (\<lambda>r. Fi (P r) r i) = (\<lambda>r. undefined)"
	+ using prod_qbs_MxE[OF h(2)] by auto
	+ qed
	+qed
	+
	+lemma PiQ_correct: "Rep_quasi_borel (PiQ I M) = (\<Pi>\<^sub>E i\<in>I. qbs_space (M i), prod_qbs_Mx I M)"
	+ by(auto intro!: Abs_quasi_borel_inverse PiQ_f is_quasi_borel_intro simp: PiQ_def PiQ_closed1 PiQ_closed2 PiQ_closed3)
	+
	+lemma PiQ_space[simp]: "qbs_space (PiQ I M) = (\<Pi>\<^sub>E i\<in>I. qbs_space (M i))"
	+ by(simp add: qbs_space_def PiQ_correct)
	+
	+lemma PiQ_Mx[simp]: "qbs_Mx (PiQ I M) = prod_qbs_Mx I M"
	+ by(simp add: qbs_Mx_def PiQ_correct)
	+
	+
	+lemma qbs_morphism_component_singleton:
	+ assumes "i \<in> I"
	+ shows "(\<lambda>x. x i) \<in> (\<Pi>\<^sub>Q i\<in>I. (M i)) \<rightarrow>\<^sub>Q M i"
	+ by(auto intro!: qbs_morphismI simp: prod_qbs_Mx_def comp_def assms)
	+
	+lemma product_qbs_canonical1:
	+ assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> Y \<rightarrow>\<^sub>Q X i"
	+ and "\<And>i. i \<notin> I \<Longrightarrow> f i = (\<lambda>y. undefined)"
	+ shows "(\<lambda>y i. f i y) \<in> Y \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>I. X i)"
	+ using qbs_morphismE(3)[simplified comp_def,OF assms(1)] assms(2)
	+ by(auto intro!: qbs_morphismI prod_qbs_MxI)
	+
	+lemma product_qbs_canonical2:
	+ assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> Y \<rightarrow>\<^sub>Q X i"
	+ "\<And>i. i \<notin> I \<Longrightarrow> f i = (\<lambda>y. undefined)"
	+ "g \<in> Y \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>I. X i)"
	+ "\<And>i. i \<in> I \<Longrightarrow> f i = (\<lambda>x. x i) \<circ> g"
	+ and "y \<in> qbs_space Y"
	+ shows "g y = (\<lambda>i. f i y)"
	+proof(rule ext)+
	+ fix i
	+ show "g y i = f i y"
	+ proof(cases "i \<in> I")
	+ case True
	+ then show ?thesis
	+ using assms(4)[of i] by simp
	+ next
	+ case False
	+ moreover have "(\<lambda>r. y) \<in> qbs_Mx Y"
	+ using assms(5) by simp
	+ ultimately show ?thesis
	+ using assms(2,3) qbs_morphismE(3)[OF assms(3) _]
	+ by(fastforce simp: prod_qbs_Mx_def)
	+ qed
	+qed
	+
	+lemma merge_qbs_morphism:
	+ "merge I J \<in> (\<Pi>\<^sub>Q i\<in>I. (M i)) \<Otimes>\<^sub>Q (\<Pi>\<^sub>Q j\<in>J. (M j)) \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>I\<union>J. (M i))"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume h:"\<alpha> \<in> qbs_Mx ((\<Pi>\<^sub>Q i\<in>I. (M i)) \<Otimes>\<^sub>Q (\<Pi>\<^sub>Q j\<in>J. (M j)))"
	+ show "merge I J \<circ> \<alpha> \<in> qbs_Mx (\<Pi>\<^sub>Q i\<in>I\<union>J. (M i))"
	+ proof(simp, rule prod_qbs_MxI)
	+ fix i
	+ assume "i \<in> I \<union> J"
	+ then consider "i \<in> I" \| "i \<in> I \<and> i \<in> J" \| "i \<notin> I \<and> i \<in> J"
	+ by auto
	+ then show "(\<lambda>r. (merge I J \<circ> \<alpha>) r i) \<in> qbs_Mx (M i)"
	+ apply cases
	+ using h
	+ by(auto simp: merge_def pair_qbs_Mx_def split_beta' dest: prod_qbs_MxE)
	+ next
	+ fix i
	+ assume "i \<notin> I \<union> J"
	+ then show "(\<lambda>r. (merge I J \<circ> \<alpha>) r i) = (\<lambda>r. undefined)"
	+ using h
	+ by(auto simp: merge_def pair_qbs_Mx_def split_beta' dest: prod_qbs_MxE )
	+ qed
	+qed
	+
	+text \<open> The following lemma corresponds to \cite{Heunen_2017} Proposition 19(1). \<close>
	+lemma r_preserves_product':
	+ "measure_to_qbs (\<Pi>\<^sub>M i\<in>I. M i) = (\<Pi>\<^sub>Q i\<in>I. measure_to_qbs (M i))"
	+proof(rule qbs_eqI)
	+ show "qbs_Mx (measure_to_qbs (Pi\<^sub>M I M)) = qbs_Mx (\<Pi>\<^sub>Q i\<in>I. measure_to_qbs (M i))"
	+ proof auto
	+ fix f
	+ assume h:"f \<in> real_borel \<rightarrow>\<^sub>M Pi\<^sub>M I M"
	+ show "f \<in> prod_qbs_Mx I (\<lambda>i. measure_to_qbs (M i))"
	+ proof(rule prod_qbs_MxI)
	+ fix i
	+ assume 1:"i \<in> I"
	+ show "(\<lambda>r. f r i) \<in> qbs_Mx (measure_to_qbs (M i))"
	+ using measurable_comp[OF h measurable_component_singleton[OF 1,of M]]
	+ by (simp add: comp_def)
	+ next
	+ fix i
	+ assume 1:"i \<notin> I"
	+ then show "(\<lambda>r. f r i) = (\<lambda>r. undefined)"
	+ using measurable_space[OF h] 1
	+ by(auto simp: space_PiM PiE_def extensional_def)
	+ qed
	+ next
	+ fix f
	+ assume h:"f \<in> prod_qbs_Mx I (\<lambda>i. measure_to_qbs (M i))"
	+ show "f \<in> real_borel \<rightarrow>\<^sub>M Pi\<^sub>M I M"
	+ apply(rule measurable_PiM_single')
	+ using prod_qbs_MxE(1)[OF h] apply auto[1]
	+ using PiQ_f[of I M] h by auto
	+ qed
	+qed
	+
	+text \<open> $\prod_{i = 0,1} X_i \cong X_1 \times X_2$. \<close>
	+lemma product_binary_product:
	+ "\<exists>f g. f \<in> (\<Pi>\<^sub>Q i\<in>UNIV. if i then X else Y) \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y \<and> g \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>UNIV. if i then X else Y) \<and>
	+ g \<circ> f = id \<and> f \<circ> g = id"
	+ by(auto intro!: exI[where x="\<lambda>f. (f True, f False)"] exI[where x="\<lambda>xy b. if b then fst xy else snd xy"] qbs_morphismI
	+ simp: prod_qbs_Mx_def pair_qbs_Mx_def comp_def all_bool_eq ext)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/QuasiBorel.thy b/thys/Quasi_Borel_Spaces/QuasiBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/QuasiBorel.thy
	@@ -0,0 +1,590 @@
	+(* Title: QuasiBorel.thy
	+ Author: Yasuhiko Minamide, Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+section \<open>Quasi-Borel Spaces\<close>
	+theory QuasiBorel
	+imports "StandardBorel"
	+begin
	+
	+subsection \<open> Definitions \<close>
	+
	+text \<open> We formalize quasi-Borel spaces introduced by Heunen et al.~\cite{Heunen_2017}.\<close>
	+
	+subsubsection \<open> Quasi-Borel Spaces\<close>
	+definition qbs_closed1 :: "(real \<Rightarrow> 'a) set \<Rightarrow> bool"
	+ where "qbs_closed1 Mx \<equiv> (\<forall>a \<in> Mx. \<forall>f \<in> real_borel \<rightarrow>\<^sub>M real_borel. a \<circ> f \<in> Mx)"
	+
	+definition qbs_closed2 :: "['a set, (real \<Rightarrow> 'a) set] \<Rightarrow> bool"
	+ where "qbs_closed2 X Mx \<equiv> (\<forall>x \<in> X. (\<lambda>r. x) \<in> Mx)"
	+
	+definition qbs_closed3 :: "(real \<Rightarrow> 'a) set \<Rightarrow> bool"
	+ where "qbs_closed3 Mx \<equiv> (\<forall>P::real \<Rightarrow> nat. \<forall>Fi::nat \<Rightarrow> real \<Rightarrow> 'a.
	+ (\<forall>i. P -` {i} \<in> sets real_borel)
	+ \<longrightarrow> (\<forall>i. Fi i \<in> Mx)
	+ \<longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx)"
	+
	+lemma separate_measurable:
	+ fixes P :: "real \<Rightarrow> nat"
	+ assumes "\<And>i. P -` {i} \<in> sets real_borel"
	+ shows "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
	+proof -
	+ have "P \<in> real_borel \<rightarrow>\<^sub>M count_space UNIV"
	+ by (auto simp add: assms measurable_count_space_eq_countable)
	+ thus ?thesis
	+ using measurable_cong_sets sets_borel_eq_count_space by blast
	+qed
	+
	+lemma measurable_separate:
	+ fixes P :: "real \<Rightarrow> nat"
	+ assumes "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
	+ shows "P -` {i} \<in> sets real_borel"
	+ by(rule measurable_sets_borel[OF assms borel_singleton[OF sets.empty_sets,of i]])
	+
	+definition "is_quasi_borel X Mx \<longleftrightarrow> Mx \<subseteq> UNIV \<rightarrow> X \<and> qbs_closed1 Mx \<and> qbs_closed2 X Mx \<and> qbs_closed3 Mx"
	+
	+lemma is_quasi_borel_intro[simp]:
	+ assumes "Mx \<subseteq> UNIV \<rightarrow> X"
	+ and "qbs_closed1 Mx" "qbs_closed2 X Mx" "qbs_closed3 Mx"
	+ shows "is_quasi_borel X Mx"
	+ using assms by(simp add: is_quasi_borel_def)
	+
	+typedef 'a quasi_borel = "{(X::'a set, Mx). is_quasi_borel X Mx}"
	+proof
	+ show "(UNIV, UNIV) \<in> {(X::'a set, Mx). is_quasi_borel X Mx}"
	+ by (simp add: is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)
	+qed
	+
	+definition qbs_space :: "'a quasi_borel \<Rightarrow> 'a set" where
	+ "qbs_space X \<equiv> fst (Rep_quasi_borel X)"
	+
	+definition qbs_Mx :: "'a quasi_borel \<Rightarrow> (real \<Rightarrow> 'a) set" where
	+ "qbs_Mx X \<equiv> snd (Rep_quasi_borel X)"
	+
	+lemma qbs_decomp :
	+"(qbs_space X,qbs_Mx X) \<in> {(X::'a set, Mx). is_quasi_borel X Mx}"
	+ by (simp add: qbs_space_def qbs_Mx_def Rep_quasi_borel[simplified])
	+
	+lemma qbs_Mx_to_X[dest]:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ shows "\<alpha> \<in> UNIV \<rightarrow> qbs_space X"
	+ "\<alpha> r \<in> qbs_space X"
	+ using qbs_decomp assms by(auto simp: is_quasi_borel_def)
	+
	+
	+lemma qbs_closed1I:
	+ assumes "\<And>\<alpha> f. \<alpha> \<in> Mx \<Longrightarrow> f \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Longrightarrow> \<alpha> \<circ> f \<in> Mx"
	+ shows "qbs_closed1 Mx"
	+ using assms by(simp add: qbs_closed1_def)
	+
	+lemma qbs_closed1_dest[simp]:
	+ assumes "\<alpha> \<in> qbs_Mx X"
	+ and "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ shows "\<alpha> \<circ> f \<in> qbs_Mx X"
	+ using assms qbs_decomp by (auto simp add: is_quasi_borel_def qbs_closed1_def)
	+
	+lemma qbs_closed2I:
	+ assumes "\<And>x. x \<in> X \<Longrightarrow> (\<lambda>r. x) \<in> Mx"
	+ shows "qbs_closed2 X Mx"
	+ using assms by(simp add: qbs_closed2_def)
	+
	+lemma qbs_closed2_dest[simp]:
	+ assumes "x \<in> qbs_space X"
	+ shows "(\<lambda>r. x) \<in> qbs_Mx X"
	+ using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed2_def)
	+
	+lemma qbs_closed3I:
	+ assumes "\<And>(P :: real \<Rightarrow> nat) Fi. (\<And>i. P -` {i} \<in> sets real_borel) \<Longrightarrow> (\<And>i. Fi i \<in> Mx)
	+ \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx"
	+ shows "qbs_closed3 Mx"
	+ using assms by(auto simp: qbs_closed3_def)
	+
	+lemma qbs_closed3I':
	+ assumes "\<And>(P :: real \<Rightarrow> nat) Fi. P \<in> real_borel \<rightarrow>\<^sub>M nat_borel \<Longrightarrow> (\<And>i. Fi i \<in> Mx)
	+ \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx"
	+ shows "qbs_closed3 Mx"
	+ using assms by(auto intro!: qbs_closed3I simp: separate_measurable)
	+
	+lemma qbs_closed3_dest[simp]:
	+ fixes P::"real \<Rightarrow> nat" and Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
	+ assumes "\<And>i. P -` {i} \<in> sets real_borel"
	+ and "\<And>i. Fi i \<in> qbs_Mx X"
	+ shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
	+ using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed3_def)
	+
	+lemma qbs_closed3_dest':
	+ fixes P::"real \<Rightarrow> nat" and Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
	+ assumes "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
	+ and "\<And>i. Fi i \<in> qbs_Mx X"
	+ shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
	+ using qbs_closed3_dest[OF measurable_separate[OF assms(1)] assms(2)] .
	+
	+lemma qbs_closed3_dest2:
	+ assumes "countable I"
	+ and [measurable]: "P \<in> real_borel \<rightarrow>\<^sub>M count_space I"
	+ and "\<And>i. i \<in> I \<Longrightarrow> Fi i \<in> qbs_Mx X"
	+ shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
	+proof -
	+ have 0:"I \<noteq> {}"
	+ using measurable_empty_iff[of "count_space I" P real_borel] assms(2)
	+ by fastforce
	+ define P' where "P' \<equiv> to_nat_on I \<circ> P"
	+ define Fi' where "Fi' \<equiv> Fi \<circ> (from_nat_into I)"
	+ have 1:"P' \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
	+ by(simp add: P'_def)
	+ have 2:"\<And>i. Fi' i \<in> qbs_Mx X"
	+ using assms(3) from_nat_into[OF 0] by(simp add: Fi'_def)
	+ have "(\<lambda>r. Fi' (P' r) r) \<in> qbs_Mx X"
	+ using 1 2 measurable_separate by auto
	+ thus ?thesis
	+ using from_nat_into_to_nat_on[OF assms(1)] measurable_space[OF assms(2)]
	+ by(auto simp: Fi'_def P'_def)
	+qed
	+
	+lemma qbs_closed3_dest2':
	+ assumes "countable I"
	+ and [measurable]: "P \<in> real_borel \<rightarrow>\<^sub>M count_space I"
	+ and "\<And>i. i \<in> range P \<Longrightarrow> Fi i \<in> qbs_Mx X"
	+ shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
	+proof -
	+ have 0:"range P \<inter> I = range P"
	+ using measurable_space[OF assms(2)] by auto
	+ have 1:"P \<in> real_borel \<rightarrow>\<^sub>M count_space (range P)"
	+ using restrict_count_space[of I "range P"] measurable_restrict_space2[OF _ assms(2),of "range P"]
	+ by(simp add: 0)
	+ have 2:"countable (range P)"
	+ using countable_Int2[OF assms(1),of "range P"]
	+ by(simp add: 0)
	+ show ?thesis
	+ by(auto intro!: qbs_closed3_dest2[OF 2 1 assms(3)])
	+qed
	+
	+lemma qbs_space_Mx:
	+ "qbs_space X = {\<alpha> x \|x \<alpha>. \<alpha> \<in> qbs_Mx X}"
	+proof auto
	+ fix x
	+ assume 1:"x \<in> qbs_space X"
	+ show "\<exists>xa \<alpha>. x = \<alpha> xa \<and> \<alpha> \<in> qbs_Mx X"
	+ by(auto intro!: exI[where x=0] exI[where x="(\<lambda>r. x)"] simp: 1)
	+qed
	+
	+lemma qbs_space_eq_Mx:
	+ assumes "qbs_Mx X = qbs_Mx Y"
	+ shows "qbs_space X = qbs_space Y"
	+ by(simp add: qbs_space_Mx assms)
	+
	+lemma qbs_eqI:
	+ assumes "qbs_Mx X = qbs_Mx Y"
	+ shows "X = Y"
	+ by (metis Rep_quasi_borel_inverse prod.exhaust_sel qbs_Mx_def qbs_space_def assms qbs_space_eq_Mx[OF assms])
	+
	+
	+subsubsection \<open> Morphism of Quasi-Borel Spaces \<close>
	+definition qbs_morphism :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a \<Rightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>Q" 60) where
	+ "X \<rightarrow>\<^sub>Q Y \<equiv> {f \<in> qbs_space X \<rightarrow> qbs_space Y. \<forall>\<alpha> \<in> qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx Y}"
	+
	+lemma qbs_morphismI:
	+ assumes "\<And>\<alpha>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> f \<circ> \<alpha> \<in> qbs_Mx Y"
	+ shows "f \<in> X \<rightarrow>\<^sub>Q Y"
	+proof -
	+ have "f \<in> qbs_space X \<rightarrow> qbs_space Y"
	+ proof
	+ fix x
	+ assume "x \<in> qbs_space X "
	+ then have "(\<lambda>r. x) \<in> qbs_Mx X"
	+ by simp
	+ hence "f \<circ> (\<lambda>r. x) \<in> qbs_Mx Y"
	+ using assms by blast
	+ thus "f x \<in> qbs_space Y"
	+ by auto
	+ qed
	+ thus ?thesis
	+ using assms by(simp add: qbs_morphism_def)
	+qed
	+
	+lemma qbs_morphismE[dest]:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ shows "f \<in> qbs_space X \<rightarrow> qbs_space Y"
	+ "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x \<in> qbs_space Y"
	+ "\<And>\<alpha>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> f \<circ> \<alpha> \<in> qbs_Mx Y"
	+ using assms by(auto simp add: qbs_morphism_def)
	+
	+lemma qbs_morphism_ident[simp]:
	+ "id \<in> X \<rightarrow>\<^sub>Q X"
	+ by(auto intro: qbs_morphismI)
	+
	+lemma qbs_morphism_ident'[simp]:
	+ "(\<lambda>x. x) \<in> X \<rightarrow>\<^sub>Q X"
	+ using qbs_morphism_ident by(simp add: id_def)
	+
	+
	+lemma qbs_morphism_comp:
	+ assumes "f \<in> X \<rightarrow>\<^sub>Q Y" "g \<in> Y \<rightarrow>\<^sub>Q Z"
	+ shows "g \<circ> f \<in> X \<rightarrow>\<^sub>Q Z"
	+ using assms by (simp add: comp_assoc Pi_def qbs_morphism_def)
	+
	+lemma qbs_morphism_cong:
	+ assumes "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x = g x"
	+ and "f \<in> X \<rightarrow>\<^sub>Q Y"
	+ shows "g \<in> X \<rightarrow>\<^sub>Q Y"
	+proof(rule qbs_morphismI)
	+ fix \<alpha>
	+ assume 1:"\<alpha> \<in> qbs_Mx X"
	+ have "g \<circ> \<alpha> = f \<circ> \<alpha>"
	+ proof
	+ fix x
	+ have "\<alpha> x \<in> qbs_space X"
	+ using 1 qbs_decomp[of X] by auto
	+ thus "(g \<circ> \<alpha>) x = (f \<circ> \<alpha>) x"
	+ using assms(1) by simp
	+ qed
	+ thus "g \<circ> \<alpha> \<in> qbs_Mx Y"
	+ using 1 assms(2) by(simp add: qbs_morphism_def)
	+qed
	+
	+lemma qbs_morphism_const:
	+ assumes "y \<in> qbs_space Y"
	+ shows "(\<lambda>_. y) \<in> X \<rightarrow>\<^sub>Q Y"
	+ using assms by (auto intro: qbs_morphismI)
	+
	+
	+subsubsection \<open> Empty Space \<close>
	+definition empty_quasi_borel :: "'a quasi_borel" where
	+"empty_quasi_borel \<equiv> Abs_quasi_borel ({},{})"
	+
	+lemma eqb_correct: "Rep_quasi_borel empty_quasi_borel = ({}, {})"
	+ using Abs_quasi_borel_inverse
	+ by(auto simp add: Abs_quasi_borel_inverse empty_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)
	+
	+lemma eqb_space[simp]: "qbs_space empty_quasi_borel = {}"
	+ by(simp add: qbs_space_def eqb_correct)
	+
	+lemma eqb_Mx[simp]: "qbs_Mx empty_quasi_borel = {}"
	+ by(simp add: qbs_Mx_def eqb_correct)
	+
	+lemma qbs_empty_equiv :"qbs_space X = {} \<longleftrightarrow> qbs_Mx X = {}"
	+proof(auto)
	+ fix x
	+ assume "qbs_Mx X = {}"
	+ and h:"x \<in> qbs_space X"
	+ have "(\<lambda>r. x) \<in> qbs_Mx X"
	+ using h by simp
	+ thus "False" using \<open>qbs_Mx X = {}\<close> by simp
	+qed
	+
	+lemma empty_quasi_borel_iff:
	+ "qbs_space X = {} \<longleftrightarrow> X = empty_quasi_borel"
	+ by(auto intro!: qbs_eqI)
	+
	+subsubsection \<open> Unit Space \<close>
	+definition unit_quasi_borel :: "unit quasi_borel" ("1\<^sub>Q") where
	+"unit_quasi_borel \<equiv> Abs_quasi_borel (UNIV,UNIV)"
	+
	+lemma uqb_correct: "Rep_quasi_borel unit_quasi_borel = (UNIV,UNIV)"
	+ using Abs_quasi_borel_inverse
	+ by(auto simp add: unit_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)
	+
	+lemma uqb_space[simp]: "qbs_space unit_quasi_borel = {()}"
	+ by(simp add: qbs_space_def UNIV_unit uqb_correct)
	+
	+lemma uqb_Mx[simp]: "qbs_Mx unit_quasi_borel = {\<lambda>r. ()}"
	+ by(auto simp add: qbs_Mx_def uqb_correct)
	+
	+lemma unit_quasi_borel_terminal:
	+ "\<exists>! f. f \<in> X \<rightarrow>\<^sub>Q unit_quasi_borel"
	+ by(fastforce simp: qbs_morphism_def)
	+
	+definition to_unit_quasi_borel :: "'a \<Rightarrow> unit" ("!\<^sub>Q") where
	+"to_unit_quasi_borel \<equiv> (\<lambda>_.())"
	+
	+lemma to_unit_quasi_borel_morphism :
	+ "!\<^sub>Q \<in> X \<rightarrow>\<^sub>Q unit_quasi_borel"
	+ by(auto simp add: to_unit_quasi_borel_def qbs_morphism_def)
	+
	+subsubsection \<open> Subspaces \<close>
	+definition sub_qbs :: "['a quasi_borel, 'a set] \<Rightarrow> 'a quasi_borel" where
	+"sub_qbs X U \<equiv> Abs_quasi_borel (qbs_space X \<inter> U,{f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X})"
	+
	+lemma sub_qbs_closed:
	+ "qbs_closed1 {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
	+ "qbs_closed2 (qbs_space X \<inter> U) {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
	+ "qbs_closed3 {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
	+ unfolding qbs_closed1_def qbs_closed2_def qbs_closed3_def by auto
	+
	+lemma sub_qbs_correct[simp]: "Rep_quasi_borel (sub_qbs X U) = (qbs_space X \<inter> U,{f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X})"
	+ by(simp add: Abs_quasi_borel_inverse sub_qbs_def sub_qbs_closed)
	+
	+lemma sub_qbs_space[simp]: "qbs_space (sub_qbs X U) = qbs_space X \<inter> U"
	+ by(simp add: qbs_space_def)
	+
	+lemma sub_qbs_Mx[simp]: "qbs_Mx (sub_qbs X U) = {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
	+ by(simp add: qbs_Mx_def)
	+
	+lemma sub_qbs:
	+ assumes "U \<subseteq> qbs_space X"
	+ shows "(qbs_space (sub_qbs X U), qbs_Mx (sub_qbs X U)) = (U, {f \<in> UNIV \<rightarrow> U. f \<in> qbs_Mx X})"
	+ using assms by auto
	+
	+
	+subsubsection \<open> Image Spaces \<close>
	+definition map_qbs :: "['a \<Rightarrow> 'b] \<Rightarrow> 'a quasi_borel \<Rightarrow> 'b quasi_borel" where
	+"map_qbs f X = Abs_quasi_borel (f ` (qbs_space X),{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>})"
	+
	+lemma map_qbs_f:
	+ "{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>} \<subseteq> UNIV \<rightarrow> f ` (qbs_space X)"
	+ by fastforce
	+
	+lemma map_qbs_closed1:
	+ "qbs_closed1 {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
	+ unfolding qbs_closed1_def
	+ using qbs_closed1_dest by(fastforce simp: comp_def)
	+
	+lemma map_qbs_closed2:
	+ "qbs_closed2 (f ` (qbs_space X)) {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
	+ unfolding qbs_closed2_def by fastforce
	+
	+lemma map_qbs_closed3:
	+ "qbs_closed3 {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
	+proof(auto simp add: qbs_closed3_def)
	+ fix P Fi
	+ assume h:"\<forall>i::nat. P -` {i} \<in> sets real_borel"
	+ "\<forall>i::nat. \<exists>\<alpha>\<in>qbs_Mx X. Fi i = f \<circ> \<alpha>"
	+ then obtain \<alpha>i
	+ where ha: "\<forall>i::nat. \<alpha>i i \<in> qbs_Mx X \<and> Fi i = f \<circ> (\<alpha>i i)"
	+ by metis
	+ hence 1:"(\<lambda>r. \<alpha>i (P r) r) \<in> qbs_Mx X"
	+ using h(1) by fastforce
	+ show "\<exists>\<alpha>\<in>qbs_Mx X. (\<lambda>r. Fi (P r) r) = f \<circ> \<alpha>"
	+ by(auto intro!: bexI[where x="(\<lambda>r. \<alpha>i (P r) r)"] simp add: 1 ha comp_def)
	+qed
	+
	+lemma map_qbs_correct[simp]:
	+ "Rep_quasi_borel (map_qbs f X) = (f ` (qbs_space X),{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>})"
	+ unfolding map_qbs_def
	+ by(simp add: Abs_quasi_borel_inverse map_qbs_f map_qbs_closed1 map_qbs_closed2 map_qbs_closed3)
	+
	+lemma map_qbs_space[simp]:
	+ "qbs_space (map_qbs f X) = f ` (qbs_space X)"
	+ by(simp add: qbs_space_def)
	+
	+lemma map_qbs_Mx[simp]:
	+ "qbs_Mx (map_qbs f X) = {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
	+ by(simp add: qbs_Mx_def)
	+
	+
	+inductive_set generating_Mx :: "'a set \<Rightarrow> (real \<Rightarrow> 'a) set \<Rightarrow> (real \<Rightarrow> 'a) set"
	+ for X :: "'a set" and Mx :: "(real \<Rightarrow> 'a) set"
	+ where
	+ Basic: "\<alpha> \<in> Mx \<Longrightarrow> \<alpha> \<in> generating_Mx X Mx"
	+ \| Const: "x \<in> X \<Longrightarrow> (\<lambda>r. x) \<in> generating_Mx X Mx"
	+ \| Comp : "f \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Longrightarrow> \<alpha> \<in> generating_Mx X Mx \<Longrightarrow> \<alpha> \<circ> f \<in> generating_Mx X Mx"
	+ \| Part : "(\<And>i. Fi i \<in> generating_Mx X Mx) \<Longrightarrow> P \<in> real_borel \<rightarrow>\<^sub>M nat_borel \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> generating_Mx X Mx"
	+
	+lemma generating_Mx_to_space:
	+ assumes "Mx \<subseteq> UNIV \<rightarrow> X"
	+ shows "generating_Mx X Mx \<subseteq> UNIV \<rightarrow> X"
	+proof
	+ fix \<alpha>
	+ assume "\<alpha> \<in> generating_Mx X Mx"
	+ then show "\<alpha> \<in> UNIV \<rightarrow> X"
	+ by(induct rule: generating_Mx.induct) (use assms in auto)
	+qed
	+
	+lemma generating_Mx_closed1:
	+ "qbs_closed1 (generating_Mx X Mx)"
	+ by (simp add: generating_Mx.Comp qbs_closed1I)
	+
	+lemma generating_Mx_closed2:
	+ "qbs_closed2 X (generating_Mx X Mx)"
	+ by (simp add: generating_Mx.Const qbs_closed2I)
	+
	+lemma generating_Mx_closed3:
	+ "qbs_closed3 (generating_Mx X Mx)"
	+ by(simp add: qbs_closed3I' generating_Mx.Part)
	+
	+lemma generating_Mx_Mx:
	+ "generating_Mx (qbs_space X) (qbs_Mx X) = qbs_Mx X"
	+proof auto
	+ fix \<alpha>
	+ assume "\<alpha> \<in> generating_Mx (qbs_space X) (qbs_Mx X)"
	+ then show "\<alpha> \<in> qbs_Mx X"
	+ by(rule generating_Mx.induct) (auto intro!: qbs_closed1_dest[simplified comp_def] simp: qbs_closed3_dest')
	+next
	+ fix \<alpha>
	+ assume "\<alpha> \<in> qbs_Mx X"
	+ then show "\<alpha> \<in> generating_Mx (qbs_space X) (qbs_Mx X)" ..
	+qed
	+
	+
	+subsubsection \<open> Ordering of Quasi-Borel Spaces \<close>
	+
	+instantiation quasi_borel :: (type) order_bot
	+begin
	+
	+inductive less_eq_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> bool" where
	+ "qbs_space X \<subset> qbs_space Y \<Longrightarrow> less_eq_quasi_borel X Y"
	+\| "qbs_space X = qbs_space Y \<Longrightarrow> qbs_Mx Y \<subseteq> qbs_Mx X \<Longrightarrow> less_eq_quasi_borel X Y"
	+
	+lemma le_quasi_borel_iff:
	+ "X \<le> Y \<longleftrightarrow> (if qbs_space X = qbs_space Y then qbs_Mx Y \<subseteq> qbs_Mx X else qbs_space X \<subset> qbs_space Y)"
	+ by(auto elim: less_eq_quasi_borel.cases intro: less_eq_quasi_borel.intros)
	+
	+definition less_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> bool" where
	+ "less_quasi_borel X Y \<longleftrightarrow> (X \<le> Y \<and> \<not> Y \<le> X)"
	+
	+definition bot_quasi_borel :: "'a quasi_borel" where
	+ "bot_quasi_borel = empty_quasi_borel"
	+
	+instance
	+proof
	+ show "bot \<le> a" for a :: "'a quasi_borel"
	+ using qbs_empty_equiv
	+ by(auto simp add: le_quasi_borel_iff bot_quasi_borel_def)
	+qed (auto simp: le_quasi_borel_iff less_quasi_borel_def split: if_split_asm intro: qbs_eqI)
	+end
	+
	+definition inf_quasi_borel :: "['a quasi_borel, 'a quasi_borel] \<Rightarrow> 'a quasi_borel" where
	+"inf_quasi_borel X X' = Abs_quasi_borel (qbs_space X \<inter> qbs_space X', qbs_Mx X \<inter> qbs_Mx X')"
	+
	+lemma inf_quasi_borel_correct: "Rep_quasi_borel (inf_quasi_borel X X') = (qbs_space X \<inter> qbs_space X', qbs_Mx X \<inter> qbs_Mx X')"
	+ by(fastforce intro!: Abs_quasi_borel_inverse
	+ simp: inf_quasi_borel_def is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)
	+
	+lemma inf_qbs_space[simp]: "qbs_space (inf_quasi_borel X X') = qbs_space X \<inter> qbs_space X'"
	+ by (simp add: qbs_space_def inf_quasi_borel_correct)
	+
	+lemma inf_qbs_Mx[simp]: "qbs_Mx (inf_quasi_borel X X') = qbs_Mx X \<inter> qbs_Mx X'"
	+ by(simp add: qbs_Mx_def inf_quasi_borel_correct)
	+
	+definition max_quasi_borel :: "'a set \<Rightarrow> 'a quasi_borel" where
	+"max_quasi_borel X = Abs_quasi_borel (X, UNIV \<rightarrow> X)"
	+
	+lemma max_quasi_borel_correct: "Rep_quasi_borel (max_quasi_borel X) = (X, UNIV \<rightarrow> X)"
	+ by(fastforce intro!: Abs_quasi_borel_inverse
	+ simp: max_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)
	+
	+lemma max_qbs_space[simp]: "qbs_space (max_quasi_borel X) = X"
	+ by(simp add: qbs_space_def max_quasi_borel_correct)
	+
	+lemma max_qbs_Mx[simp]: "qbs_Mx (max_quasi_borel X) = UNIV \<rightarrow> X"
	+ by(simp add: qbs_Mx_def max_quasi_borel_correct)
	+
	+instantiation quasi_borel :: (type) semilattice_sup
	+begin
	+
	+definition sup_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> 'a quasi_borel" where
	+"sup_quasi_borel X Y \<equiv> (if qbs_space X = qbs_space Y then inf_quasi_borel X Y
	+ else if qbs_space X \<subset> qbs_space Y then Y
	+ else if qbs_space Y \<subset> qbs_space X then X
	+ else max_quasi_borel (qbs_space X \<union> qbs_space Y))"
	+
	+
	+instance
	+proof
	+ fix X Y :: "'a quasi_borel"
	+ let ?X = "qbs_space X"
	+ let ?Y = "qbs_space Y"
	+ consider "?X = ?Y" \| "?X \<subset> ?Y" \| "?Y \<subset> ?X" \| "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
	+ by auto
	+ then show "X \<le> X \<squnion> Y"
	+ proof(cases)
	+ case 1
	+ show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by(rule less_eq_quasi_borel.intros(2),simp_all add: 1)
	+ next
	+ case 2
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by (simp add: less_eq_quasi_borel.intros(1))
	+ next
	+ case 3
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by auto
	+ next
	+ case 4
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by(auto simp: less_eq_quasi_borel.intros(1))
	+ qed
	+next
	+ fix X Y :: "'a quasi_borel"
	+ let ?X = "qbs_space X"
	+ let ?Y = "qbs_space Y"
	+ consider "?X = ?Y" \| "?X \<subset> ?Y" \| "?Y \<subset> ?X" \| "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
	+ by auto
	+ then show "Y \<le> X \<squnion> Y"
	+ proof(cases)
	+ case 1
	+ show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by(rule less_eq_quasi_borel.intros(2)) (simp_all add: 1)
	+ next
	+ case 2
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by auto
	+ next
	+ case 3
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by (auto simp add: less_eq_quasi_borel.intros(1))
	+ next
	+ case 4
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ by(auto simp: less_eq_quasi_borel.intros(1))
	+ qed
	+next
	+ fix X Y Z :: "'a quasi_borel"
	+ assume h:"X \<le> Z" "Y \<le> Z"
	+ let ?X = "qbs_space X"
	+ let ?Y = "qbs_space Y"
	+ let ?Z = "qbs_space Z"
	+ consider "?X = ?Y" \| "?X \<subset> ?Y" \| "?Y \<subset> ?X" \| "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
	+ by auto
	+ then show "sup X Y \<le> Z"
	+ proof cases
	+ case 1
	+ show ?thesis
	+ unfolding sup_quasi_borel_def
	+ apply(simp add: 1,rule less_eq_quasi_borel.cases[OF h(1)])
	+ apply(rule less_eq_quasi_borel.intros(1))
	+ apply auto[1]
	+ apply auto
	+ apply(rule less_eq_quasi_borel.intros(2))
	+ apply(simp add: 1)
	+ by(rule less_eq_quasi_borel.cases[OF h(2)]) (auto simp: 1)
	+ next
	+ case 2
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ using h(2) by auto
	+ next
	+ case 3
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ using h(1) by auto
	+ next
	+ case 4
	+ then have [simp]:"?X \<noteq> ?Y" "~ (?X \<subset> ?Y)" "~ (?Y \<subset> ?X)"
	+ by auto
	+ have [simp]:"?X \<subseteq> ?Z" "?Y \<subseteq> ?Z"
	+ by (metis h(1) dual_order.order_iff_strict less_eq_quasi_borel.cases)
	+ (metis h(2) dual_order.order_iff_strict less_eq_quasi_borel.cases)
	+ then consider "?X \<union> ?Y = ?Z" \| "?X \<union> ?Y \<subset> ?Z"
	+ by blast
	+ then show ?thesis
	+ unfolding sup_quasi_borel_def
	+ apply cases
	+ apply simp
	+ apply(rule less_eq_quasi_borel.intros(2))
	+ apply simp
	+ apply auto[1]
	+ by(simp add: less_eq_quasi_borel.intros(1))
	+ qed
	+qed
	+end
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/ROOT b/thys/Quasi_Borel_Spaces/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/ROOT
	@@ -0,0 +1,9 @@
	+chapter AFP
	+
	+session Quasi_Borel_Spaces (AFP) = "HOL-Probability" +
	+ options [timeout = 600]
	+ theories
	+ Bayesian_Linear_Regression
	+ document_files
	+ "root.bib"
	+ "root.tex"
	diff --git a/thys/Quasi_Borel_Spaces/StandardBorel.thy b/thys/Quasi_Borel_Spaces/StandardBorel.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/StandardBorel.thy
	@@ -0,0 +1,1939 @@
	+(* Title: StandardBorel.thy
	+ Author: Michikazu Hirata, Tokyo Institute of Technology
	+*)
	+
	+section \<open>Standard Borel Spaces\<close>
	+theory StandardBorel
	+ imports "HOL-Probability.Probability"
	+begin
	+
	+text \<open>A standard Borel space is the Borel space associated with a Polish space.
	+ Here, we define standard Borel spaces in another, but equivallent, way.
	+ See @{cite "Heunen_2017"} Proposition 5. \<close>
	+abbreviation "real_borel \<equiv> borel :: real measure"
	+abbreviation "nat_borel \<equiv> borel :: nat measure"
	+abbreviation "ennreal_borel \<equiv> borel :: ennreal measure"
	+abbreviation "bool_borel \<equiv> borel :: bool measure"
	+
	+
	+subsection \<open> Definition \<close>
	+locale standard_borel =
	+ fixes M :: "'a measure"
	+ assumes exist_fg: "\<exists>f \<in> M \<rightarrow>\<^sub>M real_borel. \<exists>g \<in> real_borel \<rightarrow>\<^sub>M M.
	+ \<forall>x \<in> space M. (g \<circ> f) x = x"
	+begin
	+
	+abbreviation "fg \<equiv> (SOME k. (fst k) \<in> M \<rightarrow>\<^sub>M real_borel \<and>
	+ (snd k) \<in> real_borel \<rightarrow>\<^sub>M M \<and>
	+ (\<forall>x \<in> space M. ((snd k) \<circ> (fst k)) x = x))"
	+
	+definition "f \<equiv> (fst fg)"
	+definition "g \<equiv> (snd fg)"
	+
	+lemma
	+ shows f_meas[simp,measurable] : "f \<in> M \<rightarrow>\<^sub>M real_borel"
	+ and g_meas[simp,measurable] : "g \<in> real_borel \<rightarrow>\<^sub>M M"
	+ and gf_comp_id[simp]: "\<And>x. x \<in> space M \<Longrightarrow> (g \<circ> f) x = x"
	+ "\<And>x. x \<in> space M \<Longrightarrow> g (f x) = x"
	+proof -
	+ obtain f' g' where h:
	+ "f' \<in> M \<rightarrow>\<^sub>M real_borel" "g' \<in> real_borel \<rightarrow>\<^sub>M M" "\<forall>x \<in> space M. (g' \<circ> f') x = x"
	+ using exist_fg by blast
	+ have "f \<in> borel_measurable M \<and> g \<in> real_borel \<rightarrow>\<^sub>M M \<and> (\<forall>x\<in>space M. (g \<circ> f) x = x)"
	+ unfolding f_def g_def
	+ by(rule someI2[where a="(f',g')"]) (use h in auto)
	+ thus "f \<in> borel_measurable M" "g \<in> real_borel \<rightarrow>\<^sub>M M"
	+ "\<And>x. x \<in> space M \<Longrightarrow> (g \<circ> f) x = x" "\<And>x. x \<in> space M \<Longrightarrow> g (f x) = x"
	+ by auto
	+qed
	+
	+lemma standard_borel_sets[simp]:
	+ assumes "sets M = sets Y"
	+ shows "standard_borel Y"
	+ unfolding standard_borel_def
	+ using measurable_cong_sets[OF assms refl,of real_borel] measurable_cong_sets[OF refl assms,of real_borel] sets_eq_imp_space_eq[OF assms] exist_fg
	+ by simp
	+
	+lemma f_inj:
	+ "inj_on f (space M)"
	+ by standard (use gf_comp_id(2) in fastforce)
	+
	+lemma singleton_sets:
	+ assumes "x \<in> space M"
	+ shows "{x} \<in> sets M"
	+proof -
	+ let ?y = "f x"
	+ let ?U = "f -` {?y}"
	+ have "?U \<inter> space M \<in> sets M"
	+ using borel_measurable_vimage f_meas by blast
	+ moreover have "?U \<inter> space M = {x}"
	+ using assms f_inj by(auto simp:inj_on_def)
	+ ultimately show ?thesis
	+ by simp
	+qed
	+
	+lemma countable_space_discrete:
	+ assumes "countable (space M)"
	+ shows "sets M = sets (count_space (space M))"
	+proof
	+ show "sets (count_space (space M)) \<subseteq> sets M"
	+ proof auto
	+ fix U
	+ assume 1:"U \<subseteq> space M"
	+ then have 2:"countable U"
	+ using assms countable_subset by auto
	+ have 3:"U = (\<Union>x\<in>U. {x})" by auto
	+ moreover have "... \<in> sets M"
	+ by(rule sets.countable_UN''[of U "\<lambda>x. {x}"]) (use 1 2 singleton_sets in auto)
	+ ultimately show "U \<in> sets M"
	+ by simp
	+ qed
	+qed (simp add: sets.sets_into_space subsetI)
	+
	+end
	+
	+lemma standard_borelI:
	+ assumes "f \<in> Y \<rightarrow>\<^sub>M real_borel"
	+ "g \<in> real_borel \<rightarrow>\<^sub>M Y"
	+ and "\<And>y. y \<in> space Y \<Longrightarrow> (g \<circ> f) y = y"
	+ shows "standard_borel Y"
	+ unfolding standard_borel_def
	+ by (intro bexI[OF _ assms(1)] bexI[OF _ assms(2)]) (auto dest: assms(3))
	+
	+
	+locale standard_borel_space_UNIV = standard_borel +
	+ assumes space_UNIV:"space M = UNIV"
	+begin
	+
	+lemma gf_comp_id'[simp]:
	+ "g \<circ> f = id" "g (f x) = x"
	+ using space_UNIV gf_comp_id
	+ by(simp_all add: id_def comp_def)
	+
	+lemma f_inj':
	+ "inj f"
	+ using f_inj by(simp add: space_UNIV)
	+
	+lemma g_surj':
	+ "surj g"
	+ using gf_comp_id'(2) surjI by blast
	+
	+end
	+
	+lemma standard_borel_space_UNIVI:
	+ assumes "f \<in> Y \<rightarrow>\<^sub>M real_borel"
	+ "g \<in> real_borel \<rightarrow>\<^sub>M Y"
	+ "(g \<circ> f) = id"
	+ and "space Y = UNIV"
	+ shows "standard_borel_space_UNIV Y"
	+ using assms
	+ by(auto intro!: standard_borelI simp: standard_borel_space_UNIV_def standard_borel_space_UNIV_axioms_def)
	+
	+lemma standard_borel_space_UNIVI':
	+ assumes "standard_borel Y"
	+ and "space Y = UNIV"
	+ shows "standard_borel_space_UNIV Y"
	+ using assms by(simp add: standard_borel_space_UNIV_def standard_borel_space_UNIV_axioms_def)
	+
	+subsection \<open> $\mathbb{R}$, $\mathbb{N}$, Boolean, $[0,\infty]$ \<close>
	+text \<open> $\mathbb{R}$ is a standard Borel space. \<close>
	+interpretation real : standard_borel_space_UNIV "real_borel"
	+ by(auto intro!: standard_borel_space_UNIVI)
	+
	+text\<open> A non-empty Borel subspace of $\mathbb{R}$ is also a standard Borel space. \<close>
	+lemma real_standard_borel_subset:
	+ assumes "U \<in> sets real_borel"
	+ and "U \<noteq> {}"
	+ shows "standard_borel (restrict_space real_borel U)"
	+proof -
	+ have std1: "id \<in> (restrict_space real_borel U) \<rightarrow>\<^sub>M real_borel"
	+ by (simp add: measurable_restrict_space1)
	+ obtain x where hx : "x \<in> U"
	+ using assms(2) by auto
	+ define g :: "real \<Rightarrow> real"
	+ where "g \<equiv> (\<lambda>r. if r \<in> U then r else x)"
	+ have "g \<in> real_borel \<rightarrow>\<^sub>M real_borel"
	+ unfolding g_def by(rule borel_measurable_continuous_on_if) (simp_all add: assms(1))
	+ hence std2: "g \<in> real_borel \<rightarrow>\<^sub>M (restrict_space real_borel U)"
	+ by(auto intro!: measurable_restrict_space2 simp: g_def hx)
	+ have std3: "\<forall>y\<in> space (restrict_space real_borel U). (g \<circ> id) y = y"
	+ by(simp add: g_def space_restrict_space)
	+ show ?thesis
	+ using std1 std2 std3 standard_borel_def by blast
	+qed
	+
	+text \<open> A non-empty measurable subset of a standard Borel space is also a standard Borel space.\<close>
	+lemma(in standard_borel) standard_borel_subset:
	+ assumes "U \<in> sets M"
	+ "U \<noteq> {}"
	+ shows "standard_borel (restrict_space M U)"
	+proof -
	+ let ?ginvU = "g -` U"
	+ have hgu1:"?ginvU \<in> sets real_borel"
	+ using assms(1) g_meas measurable_sets_borel by blast
	+ have hgu2:"f ` U \<subseteq> ?ginvU"
	+ using gf_comp_id sets.sets_into_space[OF assms(1)] by fastforce
	+ hence hgu3:"?ginvU \<noteq> {}"
	+ using assms(2) by blast
	+ interpret r_borel_set: standard_borel "restrict_space real_borel ?ginvU"
	+ by(rule real_standard_borel_subset[OF hgu1 hgu3])
	+
	+ have std1: "r_borel_set.f \<circ> f \<in> (restrict_space M U) \<rightarrow>\<^sub>M real_borel"
	+ using sets.sets_into_space[OF assms(1)]
	+ by(auto intro!: measurable_comp[where N="restrict_space real_borel ?ginvU"] measurable_restrict_space3)
	+ have std2: "g \<circ> r_borel_set.g \<in> real_borel \<rightarrow>\<^sub>M (restrict_space M U)"
	+ by(auto intro!: measurable_comp[where N="restrict_space real_borel ?ginvU"] measurable_restrict_space3[OF g_meas])
	+ have std3: "\<forall>x\<in> space (restrict_space M U). ((g \<circ> r_borel_set.g) \<circ> (r_borel_set.f \<circ> f)) x = x"
	+ by (simp add: space_restrict_space)
	+ show ?thesis
	+ using std1 std2 std3 standard_borel_def by blast
	+qed
	+
	+text \<open> $\mathbb{N}$ is a standard Borel space. \<close>
	+interpretation nat : standard_borel_space_UNIV nat_borel
	+proof -
	+ define n_to_r :: "nat \<Rightarrow> real"
	+ where "n_to_r \<equiv> (\<lambda>n. of_real n)"
	+ define r_to_n :: "real \<Rightarrow> nat"
	+ where "r_to_n \<equiv> (\<lambda>r. nat \<lfloor>r\<rfloor>)"
	+
	+ have n_to_r_measurable: "n_to_r \<in> nat_borel \<rightarrow>\<^sub>M real_borel"
	+ using borel_measurable_count_space measurable_cong_sets sets_borel_eq_count_space
	+ by blast
	+ have r_to_n_measurable: "r_to_n \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
	+ by(simp add: r_to_n_def)
	+ have n_to_r_to_n_id: "r_to_n \<circ> n_to_r = id"
	+ by(simp add: n_to_r_def r_to_n_def comp_def id_def)
	+ show "standard_borel_space_UNIV nat_borel"
	+ using standard_borel_space_UNIVI[OF n_to_r_measurable r_to_n_measurable n_to_r_to_n_id]
	+ by simp
	+qed
	+
	+text \<open> For a countable space $X$, $X$ is a standard Borel space iff $X$ is a discrete space. \<close>
	+lemma countable_standard_iff:
	+ assumes "space X \<noteq> {}"
	+ and "countable (space X)"
	+ shows "standard_borel X \<longleftrightarrow> sets X = sets (count_space (space X))"
	+proof
	+ show "standard_borel X \<Longrightarrow> sets X = sets (count_space (space X))"
	+ using standard_borel.countable_space_discrete assms by simp
	+next
	+ assume h[measurable_cong]: "sets X = sets (count_space (space X))"
	+ show "standard_borel X"
	+ proof(rule standard_borelI[where f="nat.f \<circ> to_nat_on (space X)" and g="from_nat_into (space X) \<circ> nat.g"])
	+ show "nat.f \<circ> to_nat_on (space X) \<in> borel_measurable X"
	+ by simp
	+ next
	+ have [simp]: "from_nat_into (space X) \<in> UNIV \<rightarrow> (space X)"
	+ using from_nat_into[OF assms(1)] by simp
	+ hence [measurable]: "from_nat_into (space X) \<in> nat_borel \<rightarrow>\<^sub>M X"
	+ using measurable_count_space_eq1[of _ _ X] measurable_cong_sets[OF sets_borel_eq_count_space]
	+ by blast
	+ show "from_nat_into (space X) \<circ> nat.g \<in> real_borel \<rightarrow>\<^sub>M X"
	+ by simp
	+ next
	+ fix x
	+ assume "x \<in> space X"
	+ then show "(from_nat_into (space X) \<circ> nat.g \<circ> (nat.f \<circ> to_nat_on (space X))) x = x"
	+ using from_nat_into_to_nat_on[OF assms(2)] by simp
	+ qed
	+qed
	+
	+text \<open> $\mathbb{B}$ is a standard Borel space. \<close>
	+lemma to_bool_measurable:
	+ assumes "f -` {True} \<inter> space M \<in> sets M"
	+ shows "f \<in> M \<rightarrow>\<^sub>M bool_borel"
	+proof(rule measurableI)
	+ fix A
	+ assume h:"A \<in> sets bool_borel"
	+ have h2: "f -` {False} \<inter> space M \<in> sets M"
	+ proof -
	+ have "- {False} = {True}"
	+ by auto
	+ thus ?thesis
	+ by(simp add: vimage_sets_compl_iff[where A="{False}"] assms)
	+ qed
	+ have "A \<subseteq> {True,False}"
	+ by auto
	+ then consider "A = {}" \| "A = {True}" \| "A = {False}" \| "A = {True,False}"
	+ by auto
	+ thus "f -` A \<inter> space M \<in> sets M"
	+ proof cases
	+ case 1
	+ then show ?thesis
	+ by simp
	+ next
	+ case 2
	+ then show ?thesis
	+ by(simp add: assms)
	+ next
	+ case 3
	+ then show ?thesis
	+ by(simp add: h2)
	+ next
	+ case 4
	+ then have "f -` A = f -` {True} \<union> f -` {False}"
	+ by auto
	+ thus ?thesis
	+ using assms h2
	+ by (metis Int_Un_distrib2 sets.Un)
	+ qed
	+qed simp
	+
	+interpretation bool : standard_borel_space_UNIV bool_borel
	+ using countable_standard_iff[of bool_borel]
	+ by(auto intro!: standard_borel_space_UNIVI' simp: sets_borel_eq_count_space)
	+
	+
	+text \<open> $[0,\infty]$ (the set of extended non-negative real numbers) is a standard Borel space. \<close>
	+interpretation ennreal : standard_borel_space_UNIV ennreal_borel
	+proof -
	+ define preal_to_real :: "ennreal \<Rightarrow> real"
	+ where "preal_to_real \<equiv> (\<lambda>r. if r = \<infinity> then -1
	+ else enn2real r)"
	+ define real_to_preal :: "real \<Rightarrow> ennreal"
	+ where "real_to_preal \<equiv> (\<lambda>r. if r = -1 then \<infinity>
	+ else ennreal r)"
	+ have preal_to_real_measurable: "preal_to_real \<in> ennreal_borel \<rightarrow>\<^sub>M real_borel"
	+ unfolding preal_to_real_def by simp
	+ have real_to_preal_measurable: "real_to_preal \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
	+ unfolding real_to_preal_def by simp
	+ have preal_real_preal_id: "real_to_preal \<circ> preal_to_real = id"
	+ proof
	+ fix r :: ennreal
	+ show "(real_to_preal \<circ> preal_to_real) r = id r"
	+ using ennreal_enn2real_if[of r] ennreal_neg
	+ by(auto simp add: real_to_preal_def preal_to_real_def)
	+ qed
	+ show "standard_borel_space_UNIV ennreal_borel"
	+ using standard_borel_space_UNIVI[OF preal_to_real_measurable real_to_preal_measurable preal_real_preal_id]
	+ by simp
	+qed
	+
	+subsection \<open> $\mathbb{R}\times\mathbb{R}$ \<close>
	+definition real_to_01open :: "real \<Rightarrow> real" where
	+"real_to_01open r \<equiv> arctan r / pi + 1 / 2"
	+
	+definition real_to_01open_inverse :: "real \<Rightarrow> real" where
	+"real_to_01open_inverse r \<equiv> tan (pi * r - (pi / 2))"
	+
	+lemma real_to_01open_inverse_correct:
	+ "real_to_01open_inverse \<circ> real_to_01open = id"
	+ by(auto simp add: real_to_01open_def real_to_01open_inverse_def distrib_left tan_arctan)
	+
	+lemma real_to_01open_inverse_correct':
	+ assumes "0 < r" "r < 1"
	+ shows "real_to_01open (real_to_01open_inverse r) = r"
	+ unfolding real_to_01open_def real_to_01open_inverse_def
	+proof -
	+ have "arctan (tan (pi * r - pi / 2)) = pi * r - pi / 2"
	+ using arctan_unique[of "pi * r - pi / 2"] assms
	+ by simp
	+ hence "arctan (tan (pi * r - pi / 2)) / pi + 1 / 2 = ((pi * r) - pi / 2)/ pi + 1/2"
	+ by simp
	+ also have "... = r - 1/2 + 1/2"
	+ by (metis (no_types, opaque_lifting) divide_inverse mult.left_neutral nonzero_mult_div_cancel_left pi_neq_zero right_diff_distrib)
	+ finally show "arctan (tan (pi * r - pi / 2)) / pi + 1 / 2 = r"
	+ by simp
	+qed
	+
	+lemma real_to_01open_01 :
	+ "0 < real_to_01open r \<and> real_to_01open r < 1"
	+proof
	+ have "- pi / 2 < arctan r" by(simp add: arctan_lbound)
	+ hence "0 < arctan r + pi / 2" by simp
	+ hence "0 < (1 / pi) * (arctan r + pi / 2)" by simp
	+ thus "0 < real_to_01open r"
	+ by (simp add: add_divide_distrib real_to_01open_def)
	+next
	+ have "arctan r < pi / 2" using arctan_ubound by simp
	+ hence "arctan r + pi / 2 < pi" by simp
	+ hence "(1 / pi) * (arctan r + pi / 2) < 1" by simp
	+ thus "real_to_01open r < 1"
	+ by(simp add: real_to_01open_def add_divide_distrib)
	+qed
	+
	+lemma real_to_01open_continuous:
	+ "continuous_on UNIV real_to_01open"
	+proof -
	+ have "continuous_on UNIV ((\<lambda>x. x / pi + 1 / 2) \<circ> arctan)"
	+ proof (rule continuous_on_compose)
	+ show "continuous_on UNIV arctan"
	+ by (simp add: continuous_on_arctan)
	+ next
	+ show "continuous_on (range arctan) (\<lambda>x. x / pi + 1 / 2)"
	+ by(auto intro!: continuous_on_add continuous_on_divide)
	+ qed
	+ thus ?thesis
	+ by(simp add: real_to_01open_def)
	+qed
	+
	+lemma real_to_01open_inverse_continuous:
	+ "continuous_on {0<..<1} real_to_01open_inverse"
	+ unfolding real_to_01open_inverse_def
	+proof(rule Transcendental.continuous_on_tan)
	+ have [simp]: "(\<lambda>x. pi * x - pi / 2) = (\<lambda>x. x - pi/2) \<circ> (\<lambda>x. pi * x)"
	+ by auto
	+ have "continuous_on {0<..<1} ..."
	+ proof(rule continuous_on_compose)
	+ show "continuous_on {0<..<1} ((*) pi)"
	+ by simp
	+ next
	+ show "continuous_on ((*) pi ` {0<..<1}) (\<lambda>x. x - pi / 2)"
	+ using continuous_on_diff[of "(*) pi ` {0<..<1}" "\<lambda>x. x"]
	+ by simp
	+ qed
	+ thus "continuous_on {0<..<1} (\<lambda>x. pi * x - pi / 2)" by simp
	+next
	+ have "\<forall>r\<in>{0<..<1::real}. -(pi/2) < pi * r - pi / 2 \<and> pi * r - pi / 2 < pi/2"
	+ by simp
	+ thus "\<forall>r\<in>{0<..<1::real}. cos (pi * r - pi / 2) \<noteq> 0"
	+ using cos_gt_zero_pi by fastforce
	+qed
	+
	+lemma real_to_01open_inverse_measurable:
	+ "real_to_01open_inverse \<in> restrict_space real_borel {0<..<1} \<rightarrow>\<^sub>M real_borel"
	+ using borel_measurable_continuous_on_restrict real_to_01open_inverse_continuous
	+ by simp
	+
	+fun r01_binary_expansion'' :: "real \<Rightarrow> nat \<Rightarrow> nat \<times> real \<times> real" where
	+"r01_binary_expansion'' r 0 = (if 1/2 \<le> r then (1,1 ,1/2)
	+ else (0,1/2, 0))" \|
	+"r01_binary_expansion'' r (Suc n) = (let (_,ur,lr) = r01_binary_expansion'' r n;
	+ k = (ur + lr)/2 in
	+ (if k \<le> r then (1,ur,k)
	+ else (0,k,lr)))"
	+
	+
	+text \<open> $a_n$ where $r = 0.a_0 a_1 a_2 ....$ for $0 < r < 1$.\<close>
	+definition r01_binary_expansion' :: "real \<Rightarrow> nat \<Rightarrow> nat" where
	+"r01_binary_expansion' r n \<equiv> fst (r01_binary_expansion'' r n)"
	+
	+text \<open>$a_n = 0$ or $1$.\<close>
	+lemma real01_binary_expansion'_0or1:
	+ "r01_binary_expansion' r n \<in> {0,1}"
	+ by (cases n) (simp_all add: r01_binary_expansion'_def split_beta' Let_def)
	+
	+(* S_n = a_0 + ... + a_n *)
	+definition r01_binary_sum :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> real" where
	+"r01_binary_sum a n \<equiv> (\<Sum>i=0..n. real (a i) * ((1/2)^(Suc i)))"
	+
	+definition r01_binary_sum_lim :: "(nat \<Rightarrow> nat) \<Rightarrow> real" where
	+"r01_binary_sum_lim \<equiv> lim \<circ> r01_binary_sum"
	+
	+
	+definition r01_binary_expression :: "real \<Rightarrow> nat \<Rightarrow> real" where
	+"r01_binary_expression \<equiv> r01_binary_sum \<circ> r01_binary_expansion'"
	+
	+lemma r01_binary_expansion_lr_r_ur:
	+ assumes "0 < r" "r < 1"
	+ shows "(snd (snd (r01_binary_expansion'' r n))) \<le> r \<and>
	+ r < (fst (snd (r01_binary_expansion'' r n)))"
	+ using assms by (induction n) (simp_all add:split_beta' Let_def)
	+
	+text \<open>\<open>0 \<le> lr \<and> lr < ur \<and> ur \<le> 1\<close>.\<close>
	+lemma r01_binary_expansion_lr_ur_nn:
	+ shows "0 \<le> snd (snd (r01_binary_expansion'' r n)) \<and>
	+ snd (snd (r01_binary_expansion'' r n)) < fst (snd (r01_binary_expansion'' r n)) \<and>
	+ fst (snd (r01_binary_expansion'' r n)) \<le> 1"
	+ by (induction n) (simp_all add:split_beta' Let_def)
	+
	+lemma r01_binary_expansion_diff:
	+ shows "(fst (snd (r01_binary_expansion'' r n))) - (snd (snd (r01_binary_expansion'' r n))) = (1/2)^(Suc n)"
	+proof(induction n)
	+ case (Suc n')
	+ then show ?case
	+ proof(cases "r01_binary_expansion'' r n'")
	+ case 1:(fields a ur lr)
	+ assume "fst (snd (r01_binary_expansion'' r n')) - snd (snd (r01_binary_expansion'' r n')) = (1 / 2) ^ (Suc n')"
	+ then have 2:"ur - lr = (1/2)^(Suc n')" by (simp add: 1)
	+ show ?thesis
	+ proof -
	+ have [simp]:"ur * 4 - (ur * 4 + lr * 4) / 2 = (ur - lr) * 2"
	+ by(simp add: division_ring_class.add_divide_distrib)
	+ have "ur * 4 - (ur * 4 + lr * 4) / 2 = (1 / 2) ^ n'"
	+ by(simp add: 2)
	+ moreover have "(ur * 4 + lr * 4) / 2 - lr * 4 = (1 / 2) ^ n'"
	+ by(simp add: division_ring_class.add_divide_distrib ring_class.right_diff_distrib[symmetric] 2)
	+ ultimately show ?thesis
	+ by(simp add: 1 Let_def)
	+ qed
	+ qed
	+qed simp
	+
	+text \<open>\<open>lrn = Sn\<close>.\<close>
	+lemma r01_binary_expression_eq_lr:
	+ "snd (snd (r01_binary_expansion'' r n)) = r01_binary_expression r n"
	+proof(induction n)
	+ case 0
	+ then show ?case
	+ by(simp add: r01_binary_expression_def r01_binary_sum_def r01_binary_expansion'_def)
	+next
	+ case 1:(Suc n')
	+ show ?case
	+ proof (cases "r01_binary_expansion'' r n'")
	+ case 2:(fields a ur lr)
	+ then have ih:"lr = (\<Sum>i = 0..n'. real (fst (r01_binary_expansion'' r i)) * (1 / 2) ^ i / 2)"
	+ using 1 by(simp add: r01_binary_expression_def r01_binary_sum_def r01_binary_expansion'_def)
	+ have 3:"(ur + lr) / 2 = lr + (1/2)^(Suc (Suc n'))"
	+ using r01_binary_expansion_diff[of r n'] 2 by simp
	+ show ?thesis
	+ by(simp add: r01_binary_expression_def r01_binary_sum_def r01_binary_expansion'_def 2 Let_def 3) fact
	+ qed
	+qed
	+
	+lemma r01_binary_expression'_sum_range:
	+ "\<exists>k::nat. (snd (snd (r01_binary_expansion'' r n))) = real k/2^(Suc n) \<and>
	+ k < 2^(Suc n) \<and>
	+ ((r01_binary_expansion' r n) = 0 \<longrightarrow> even k) \<and>
	+ ((r01_binary_expansion' r n) = 1 \<longrightarrow> odd k)"
	+proof -
	+ have [simp]:"(snd (snd (r01_binary_expansion'' r n))) = (\<Sum>i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i)))"
	+ using r01_binary_expression_eq_lr[of r n] by(simp add: r01_binary_expression_def r01_binary_sum_def)
	+ have "\<exists>k::nat. (\<Sum>i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) = real k/2^(Suc n) \<and>
	+ k < 2^(Suc n) \<and>
	+ ((r01_binary_expansion' r n) = 0 \<longrightarrow> even k) \<and>
	+ ((r01_binary_expansion' r n) = 1 \<longrightarrow> odd k)"
	+ proof(induction n)
	+ case 0
	+ consider "r01_binary_expansion' r 0 = 0" \| "r01_binary_expansion' r 0 = 1"
	+ using real01_binary_expansion'_0or1[of r 0] by auto
	+ then show ?case
	+ by cases auto
	+ next
	+ case (Suc n')
	+ then obtain k :: nat where ih:
	+ "(\<Sum>i = 0..n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) = real k / 2^(Suc n') \<and> k < 2^(Suc n')"
	+ by auto
	+ have "(\<Sum>i = 0..Suc n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) = (\<Sum>i = 0..n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) + real (r01_binary_expansion' r (Suc n')) * (1 / 2) ^ Suc (Suc n')"
	+ by simp
	+ also have "... = real k / 2^(Suc n') + (real (r01_binary_expansion' r (Suc n')))/ 2^ Suc (Suc n')"
	+ proof -
	+ have "\<And>r ra n. (r::real) * (1 / ra) ^ n = r / ra ^ n"
	+ by (simp add: power_one_over)
	+ then show ?thesis
	+ using ih by presburger
	+ qed
	+ also have "... = (2*real k) / 2^(Suc (Suc n')) + (real (r01_binary_expansion' r (Suc n')))/ 2^ Suc (Suc n')"
	+ by simp
	+ also have "... = (2*(real k) + real (r01_binary_expansion' r (Suc n')))/2 ^ Suc (Suc n')"
	+ by (simp add: add_divide_distrib)
	+ also have "... = (real (2*k + r01_binary_expansion' r (Suc n')))/2 ^ Suc (Suc n')"
	+ by simp
	+ finally have "(\<Sum>i = 0..Suc n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) = real (2 * k + r01_binary_expansion' r (Suc n')) / 2 ^ Suc (Suc n')" .
	+ moreover have "2 * k + r01_binary_expansion' r (Suc n') < 2^Suc (Suc n')"
	+ proof -
	+ have "k + 1 \<le> 2^Suc n'"
	+ using ih by simp
	+ hence "2*k + 2 \<le> 2^Suc (Suc n')"
	+ by simp
	+ thus ?thesis
	+ using real01_binary_expansion'_0or1[of r "Suc n'"]
	+ by auto
	+ qed
	+ moreover have "r01_binary_expansion' r (Suc n') = 0 \<longrightarrow> even (2 * k + r01_binary_expansion' r (Suc n'))"
	+ by simp
	+ moreover have "r01_binary_expansion' r (Suc n') = 1 \<longrightarrow> odd (2 * k + r01_binary_expansion' r (Suc n'))"
	+ by simp
	+ ultimately show ?case by fastforce
	+ qed
	+ thus ?thesis
	+ by simp
	+qed
	+
	+text \<open>\<open>an = bn \<leftrightarrow> Sn = S'n\<close>.\<close>
	+lemma r01_binary_expansion'_expression_eq:
	+ "r01_binary_expansion' r1 = r01_binary_expansion' r2 \<longleftrightarrow>
	+ r01_binary_expression r1 = r01_binary_expression r2"
	+proof
	+ assume "r01_binary_expansion' r1 = r01_binary_expansion' r2"
	+ then show "r01_binary_expression r1 = r01_binary_expression r2"
	+ by(simp add: r01_binary_expression_def)
	+next
	+ assume "r01_binary_expression r1 = r01_binary_expression r2"
	+ then have 1:"\<And>n. r01_binary_sum (r01_binary_expansion' r1) n = r01_binary_sum (r01_binary_expansion' r2) n"
	+ by(simp add: r01_binary_expression_def)
	+ show "r01_binary_expansion' r1 = r01_binary_expansion' r2"
	+ proof
	+ fix n
	+ show " r01_binary_expansion' r1 n = r01_binary_expansion' r2 n"
	+ proof(cases n)
	+ case 0
	+ then show ?thesis
	+ using 1[of 0] by(simp add: r01_binary_sum_def)
	+ next
	+ fix n'
	+ case (Suc n')
	+ have "r01_binary_sum (r01_binary_expansion' r1) n - r01_binary_sum (r01_binary_expansion' r1) n' = r01_binary_sum (r01_binary_expansion' r2) n - r01_binary_sum (r01_binary_expansion' r2) n'"
	+ by(simp add: 1)
	+ thus ?thesis
	+ using \<open>n = Suc n'\<close> by(simp add: r01_binary_sum_def)
	+ qed
	+ qed
	+qed
	+
	+lemma power2_e:
	+ "\<And>e::real. 0 < e \<Longrightarrow> \<exists>n::nat. real_of_rat (1/2)^n < e"
	+ by (simp add: real_arch_pow_inv)
	+
	+lemma r01_binary_expression_converges_to_r:
	+ assumes "0 < r"
	+ and "r < 1"
	+ shows "LIMSEQ (r01_binary_expression r) r"
	+proof
	+ fix e :: real
	+ assume "0 < e"
	+ then obtain k :: nat where hk:"real_of_rat (1/2)^k < e"
	+ using power2_e by auto
	+ show "\<forall>\<^sub>F x in sequentially. dist (r01_binary_expression r x) r < e"
	+ proof(rule eventually_sequentiallyI[of k])
	+ fix m
	+ assume "k \<le> m"
	+ have "\<bar> r - r01_binary_expression r m \<bar> < e"
	+ proof (cases "r01_binary_expansion'' r m")
	+ case 1:(fields a ur lr)
	+ then have "\<bar>r - r01_binary_expression r m\<bar> = \<bar>r - lr\<bar>"
	+ by (metis r01_binary_expression_eq_lr snd_conv)
	+ also have "... = r - lr"
	+ using r01_binary_expansion_lr_r_ur[OF assms] 1
	+ by (metis abs_of_nonneg diff_ge_0_iff_ge snd_conv)
	+ also have "... < e"
	+ proof -
	+ have "r - lr \<le> ur - lr"
	+ using r01_binary_expansion_lr_r_ur[of r] assms 1
	+ by (metis diff_right_mono fst_conv less_imp_le snd_conv)
	+ also have "... = (1/2)^(Suc m)"
	+ using r01_binary_expansion_diff[of r m]
	+ by(simp add: 1)
	+ also have "... \<le> (1/2)^(Suc k)"
	+ using \<open>k \<le> m\<close> by simp
	+ also have "... < (1/2)^k" by simp
	+ finally show ?thesis
	+ using hk by (simp add: of_rat_divide)
	+ qed
	+ finally show ?thesis .
	+ qed
	+ then show "dist (r01_binary_expression r m) r < e"
	+ by (simp add: dist_real_def)
	+ qed
	+qed
	+
	+lemma r01_binary_expression_correct:
	+ assumes "0 < r"
	+ and "r < 1"
	+ shows "r = (\<Sum>n. real (r01_binary_expansion' r n) * (1/2)^(Suc n))"
	+proof -
	+ have "(\<lambda>n. (\<lambda>n. \<Sum>i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) (Suc n)) = r01_binary_expression r"
	+ proof -
	+ have "\<And>n. {..<Suc n} = {0..n}" by auto
	+ thus ?thesis
	+ by(auto simp add: r01_binary_expression_def r01_binary_sum_def)
	+ qed
	+ hence "LIMSEQ (\<lambda>n. \<Sum>i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) r"
	+ using r01_binary_expression_converges_to_r[OF assms] LIMSEQ_imp_Suc[of "\<lambda>n. \<Sum>i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i" r]
	+ by simp
	+ thus ?thesis
	+ using suminf_eq_lim[of "\<lambda>n. real (r01_binary_expansion' r n) * (1/2)^(Suc n)"] assms limI[of "(\<lambda>n. \<Sum>i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i)" r]
	+ by simp
	+qed
	+
	+
	+text \<open>\<open>S0 \<le> S1 \<le> S2 \<le> ...\<close>.\<close>
	+lemma binary_sum_incseq:
	+ "incseq (r01_binary_sum a)"
	+ by(simp add: incseq_Suc_iff r01_binary_sum_def)
	+
	+lemma r01_eq_iff:
	+ assumes "0 < r1" "r1 < 1"
	+ "0 < r2" "r2 < 1"
	+ shows "r1 = r2 \<longleftrightarrow> r01_binary_expansion' r1 = r01_binary_expansion' r2"
	+proof auto
	+ assume "r01_binary_expansion' r1 = r01_binary_expansion' r2"
	+ then have 1:"r01_binary_expression r1 = r01_binary_expression r2"
	+ using r01_binary_expansion'_expression_eq[of r1 r2] by simp
	+ have "r1 = lim (r01_binary_expression r1)"
	+ using limI[of _ r1] r01_binary_expression_converges_to_r[of r1] assms(1,2)
	+ by simp
	+ also have "... = lim (r01_binary_expression r2)"
	+ by (simp add: 1)
	+ also have "... = r2"
	+ using limI[of _ r2] r01_binary_expression_converges_to_r[of r2] assms(3,4)
	+ by simp
	+ finally show "r1 = r2" .
	+qed
	+
	+lemma power_half_summable:
	+ "summable (\<lambda>n. ((1::real) / 2) ^ Suc n)"
	+ using power_half_series summable_def by blast
	+
	+
	+lemma binary_expression_summable:
	+ assumes "\<And>n. a n \<in> {0,1 :: nat}"
	+ shows "summable (\<lambda>n. real (a n) * (1/2)^(Suc n))"
	+proof -
	+ have "summable (\<lambda>n::nat. \<bar>real (a n) * ((1::real) / (2::real)) ^ Suc n\<bar>)"
	+ proof(rule summable_rabs_comparison_test[of "\<lambda>n. real (a n) * (1/2)^(Suc n)" "\<lambda>n. (1/2)^(Suc n)"])
	+ have "\<And>n. \<bar>real (a n) * (1 / 2) ^ Suc n\<bar> \<le> (1 / 2)^(Suc n)"
	+ proof -
	+ fix n
	+ have "\<bar>real (a n) * (1 / 2) ^ Suc n\<bar> = real (a n) * (1 / 2) ^ Suc n"
	+ using assms by simp
	+ also have "... \<le> (1 / 2) ^ Suc n"
	+ proof -
	+ consider "a n = 0" \| "a n = 1"
	+ using assms by (meson insertE singleton_iff)
	+ then show ?thesis
	+ by(cases,auto)
	+ qed
	+ finally show "\<bar>real (a n) * (1 / 2) ^ Suc n\<bar> \<le> (1 / 2)^(Suc n)" .
	+ qed
	+ thus "\<exists>N. \<forall>n\<ge>N. \<bar>real (a n) * (1 / 2) ^ Suc n\<bar> \<le> (1 / 2) ^ Suc n"
	+ by simp
	+ next
	+ show "summable (\<lambda>n. ((1::real) / 2) ^ Suc n)"
	+ using power_half_summable by simp
	+ qed
	+ thus ?thesis by simp
	+qed
	+
	+lemma binary_expression_gteq0:
	+ assumes "\<And>n. a n \<in> {0,1 :: nat}"
	+ shows "0 \<le> (\<Sum>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
	+proof -
	+ have "(\<Sum>n. 0) \<le> (\<Sum>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
	+ using binary_expression_summable[of a] summable_iff_shift[of "\<lambda>n. real (a n) * (1 / 2) ^ Suc n" k] suminf_le[of "\<lambda>n. 0" "\<lambda>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k)"] assms
	+ by simp
	+ thus ?thesis by simp
	+qed
	+
	+lemma binary_expression_leeq1:
	+ assumes "\<And>n. a n \<in> {0,1 :: nat}"
	+ shows "(\<Sum>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k)) \<le> 1"
	+proof -
	+ have "(\<Sum>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k)) \<le> (\<Sum>n. (1/2)^(Suc n))"
	+ proof(rule suminf_le)
	+ fix n
	+ have 1:"real (a (n + k)) * (1 / 2) ^ Suc (n + k) \<le> (1 / 2) ^ Suc (n + k)"
	+ using assms[of "n+k"] by auto
	+ have 2:"((1::real) / 2) ^ Suc (n + k) \<le> (1 / 2) ^ Suc n"
	+ by simp
	+ show "real (a (n + k)) * (1 / 2) ^ Suc (n + k) \<le> (1 / 2) ^ Suc n"
	+ by(rule order.trans[OF 1 2])
	+ next
	+ show "summable (\<lambda>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
	+ using binary_expression_summable[of a] summable_iff_shift[of "\<lambda>n. real (a n) * (1 / 2) ^ Suc n" k] assms
	+ by simp
	+ next
	+ show "summable (\<lambda>n. ((1::real) / 2) ^ Suc n)"
	+ using power_half_summable by simp
	+ qed
	+ thus ?thesis
	+ using power_half_series sums_unique by fastforce
	+qed
	+
	+lemma binary_expression_less_than:
	+ assumes "\<And>n. a n \<in> {0,1 :: nat}"
	+ shows "(\<Sum>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k)) \<le> (\<Sum>n. (1 / 2) ^ Suc (n + k))"
	+proof(rule suminf_le)
	+ fix n
	+ show "real (a (n + k)) * (1 / 2) ^ Suc (n + k) \<le> (1 / 2) ^ Suc (n + k)"
	+ using assms[of "n + k"] by auto
	+next
	+ show "summable (\<lambda>n. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
	+ using summable_iff_shift[of "\<lambda>n. real (a n) * (1 / 2) ^ Suc n" k] binary_expression_summable[of a] assms
	+ by simp
	+next
	+ show "summable (\<lambda>n. ((1::real) / 2) ^ Suc (n + k))"
	+ using power_half_summable summable_iff_shift[of "\<lambda>n. ((1::real) / 2) ^ Suc n" k]
	+ by simp
	+qed
	+
	+lemma lim_sum_ai:
	+ assumes "\<And>n. a n \<in> {0,1 :: nat}"
	+ shows "lim (\<lambda>n. (\<Sum>i=0..n. real (a i) * (1/2)^(Suc i))) = (\<Sum>n::nat. real (a n) * (1/2)^(Suc n))"
	+proof -
	+ have "\<And>n::nat. {0..n} = {..n}" by auto
	+ hence "LIMSEQ (\<lambda>n. \<Sum>i=0..n. real (a i) * (1 / 2) ^ Suc i) (\<Sum>n. real (a n) * (1 / 2) ^ Suc n)"
	+ using summable_LIMSEQ'[of "\<lambda>n. real (a n) * (1/2)^(Suc n)"] binary_expression_summable[of a] assms
	+ by simp
	+ thus "lim (\<lambda>n. (\<Sum>i=0..n. real (a i) * (1/2)^(Suc i))) = (\<Sum>n. real (a n) * (1 / 2) ^ Suc n)"
	+ using limI by simp
	+qed
	+
	+lemma half_1_minus_sum:
	+ "1 - (\<Sum>i<k. ((1::real) / 2) ^ Suc i) = (1/2)^k"
	+ by(induction k) auto
	+
	+lemma half_sum:
	+ "(\<Sum>n. ((1::real) / 2) ^ (Suc (n + k))) = (1/2)^k"
	+ using suminf_split_initial_segment[of "\<lambda>n. ((1::real) / 2) ^ (Suc n)" k] half_1_minus_sum[of k] power_half_series sums_unique[of "\<lambda>n. (1 / 2) ^ Suc n" 1] power_half_summable
	+ by fastforce
	+
	+lemma ai_exists0_less_than_sum:
	+ assumes "\<And>n. a n \<in> {0,1}"
	+ "i \<ge> m"
	+ and "a i = 0"
	+ shows "(\<Sum>n::nat. real (a (n + m)) * (1/2)^(Suc (n + m))) < (1 / 2) ^ m"
	+proof -
	+ have "(\<Sum>n::nat. real (a (n + m)) * (1/2)^(Suc (n + m))) = (\<Sum>n<i-m. real (a (n + m)) * (1/2)^(Suc (n + m))) + (\<Sum>n::nat. real (a (n + i)) * (1/2)^(Suc (n + i)))"
	+ using suminf_split_initial_segment[of "\<lambda>n. real (a (n + m)) * (1/2)^(Suc (n + m))" "i-m"] assms(1) binary_expression_summable[of a] summable_iff_shift[of "\<lambda>n. real (a n) * (1 / 2) ^ Suc n" m] assms(2)
	+ by simp
	+ also have "... < (1 / 2) ^ m"
	+ proof -
	+ have "(\<Sum>n. real (a (n + i)) * (1 / 2) ^ Suc (n + i)) \<le> (1 / 2) ^ Suc i"
	+ proof -
	+ have "(\<Sum>n::nat. real (a (n + i)) * (1/2)^(Suc (n + i))) = (\<Sum>n::nat. real (a (Suc n + i)) * (1/2)^(Suc (Suc n + i)))"
	+ using suminf_split_head[of "\<lambda>n. real (a (n + i)) * (1/2)^(Suc (n + i))"] assms(1,3) binary_expression_summable[of a] summable_iff_shift[of "\<lambda>n. real (a n) * (1 / 2) ^ Suc n" i]
	+ by simp
	+ also have "... = (\<Sum>n::nat. real (a (n + Suc i)) * (1/2)^(Suc n + Suc i))"
	+ by simp
	+ also have "... \<le> (\<Sum>n::nat. (1/2)^(Suc n + Suc i))"
	+ using binary_expression_less_than[of a "Suc i"] assms(1)
	+ by simp
	+ also have "... = (1/2)^(Suc i)"
	+ using half_sum[of "Suc i"] by simp
	+ finally show ?thesis .
	+ qed
	+ moreover have "(\<Sum>n<i - m. real (a (n + m)) * (1 / 2) ^ Suc (n + m)) \<le> (1/2)^m - (1/2)^i"
	+ proof -
	+ have "(\<Sum>n<i - m. real (a (n + m)) * (1 / 2) ^ Suc (n + m)) \<le> (\<Sum>n<i - m. (1 / 2) ^ Suc (n + m))"
	+ proof -
	+ have "real (a i) * (1 / 2) ^ Suc i \<le> (1 / 2) ^ Suc i" for i
	+ using assms(1)[of i] by auto
	+ thus ?thesis
	+ by (simp add: sum_mono)
	+ qed
	+ also have "... = (\<Sum>n. (1 / 2) ^ Suc (n + m)) - (\<Sum>n. (1 / 2) ^ Suc (n + (i - m) + m))"
	+ using suminf_split_initial_segment[of "\<lambda>n. (1 / 2) ^ Suc (n + m)" "i-m"] power_half_summable summable_iff_shift[of "\<lambda>n. ((1::real) / 2) ^ Suc n" m]
	+ by fastforce
	+ also have "... = (\<Sum>n. (1 / 2) ^ Suc (n + m)) - (\<Sum>n. (1 / 2) ^ Suc (n + i))"
	+ using assms(2) by simp
	+ also have "... = (1/2)^m - (1/2)^i"
	+ using half_sum by fastforce
	+ finally show ?thesis .
	+ qed
	+ ultimately have "(\<Sum>n<i - m. real (a (n + m)) * (1 / 2) ^ Suc (n + m)) + (\<Sum>n. real (a (n + i)) * (1 / 2) ^ Suc (n + i)) \<le> (1 / 2) ^ Suc i + (1 / 2) ^ m - (1 / 2) ^ i"
	+ by linarith
	+ also have "... < (1 / 2) ^ m "
	+ by simp
	+ finally show ?thesis .
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+lemma ai_exists0_less_than1:
	+ assumes "\<And>n. a n \<in> {0,1}"
	+ and "\<exists>i. a i = 0"
	+ shows "(\<Sum>n::nat. real (a n) * (1/2)^(Suc n)) < 1"
	+ using ai_exists0_less_than_sum[of a 0] assms
	+ by auto
	+
	+lemma ai_1_gt:
	+ assumes "\<And>n. a n \<in> {0,1}"
	+ and "a i = 1"
	+ shows "(1/2)^(Suc i) \<le> (\<Sum>n::nat. real (a (n+i)) * (1/2)^(Suc (n+i)))"
	+proof -
	+ have 1:"(\<Sum>n::nat. real (a (n+i)) * (1/2)^(Suc (n+i))) = (1 / 2) ^ Suc (0 + i) + (\<Sum>n. real (a (Suc n + i)) * (1 / 2) ^ Suc (Suc n + i))"
	+ using suminf_split_head[of "\<lambda>n. real (a (n+i)) * (1/2)^(Suc (n+i))"] binary_expression_summable[of a] summable_iff_shift[of "\<lambda>n. real (a n) * (1 / 2) ^ Suc n" i] assms
	+ by simp
	+ show ?thesis
	+ using 1 binary_expression_gteq0[of a "Suc i"] assms(1)
	+ by simp
	+qed
	+
	+lemma ai_exists1_gt0:
	+ assumes "\<And>n. a n \<in> {0,1}"
	+ and "\<exists>i. a i = 1"
	+ shows "0 < (\<Sum>n::nat. real (a n) * (1/2)^(Suc n))"
	+proof -
	+ obtain k where h1: "a k = 1"
	+ using assms(2) by auto
	+ have "(1/2)^(Suc k) = (\<Sum>n::nat. (if n = k then (1/2)^(Suc k) else (0::real)))"
	+ proof -
	+ have "(\<lambda>n. if n \<in> {k} then (1 / 2) ^ Suc k else (0::real)) = (\<lambda>n. if n = k then (1/2)^(Suc k) else 0)"
	+ by simp
	+ moreover have "(\<lambda>n. if n \<in> {k} then (1 / 2) ^ Suc k else (0::real)) sums (\<Sum>r\<in>{k}. (1 / 2) ^ Suc k)"
	+ using sums_If_finite_set[of "{k}" "\<lambda>n. ((1::real)/2)^(Suc k)"] by simp
	+ ultimately have "(\<lambda>n. if n = k then (1 / 2) ^ Suc k else (0::real)) sums (1/2)^(Suc k)"
	+ by simp
	+ thus ?thesis
	+ using sums_unique[of "\<lambda>n. if n = k then (1 / 2) ^ Suc k else (0::real)" "(1/2)^(Suc k)"]
	+ by simp
	+ qed
	+ also have "(\<Sum>n::nat. (if n = k then (1/2)^(Suc k) else 0)) \<le> (\<Sum>n::nat. real (a n) * (1/2)^(Suc n))"
	+ proof(rule suminf_le)
	+ show "\<And>n. (if n = k then (1 / 2) ^ Suc k else 0) \<le> real (a n) * (1 / 2) ^ Suc n"
	+ proof -
	+ fix n
	+ show "(if n = k then (1 / 2) ^ Suc k else 0) \<le> real (a n) * (1 / 2) ^ Suc n"
	+ by(cases "n = k"; simp add: h1)
	+ qed
	+ next
	+ show "summable (\<lambda>n. if n = k then (1 / 2) ^ Suc k else (0::real))"
	+ using summable_single[of k "\<lambda>n. ((1::real) / 2) ^ Suc k"]
	+ by simp
	+ next
	+ show "summable (\<lambda>n. real (a n) * (1 / 2) ^ Suc n)"
	+ using binary_expression_summable[of a] assms(1)
	+ by simp
	+ qed
	+ finally have "(1 / 2) ^ Suc k \<le> (\<Sum>n. real (a n) * (1 / 2) ^ Suc n)" .
	+ moreover have "0 < ((1::real) / 2) ^ Suc k" by simp
	+ ultimately show ?thesis by linarith
	+qed
	+
	+
	+lemma r01_binary_expression_ex0:
	+ assumes "0 < r" "r < 1"
	+ shows "\<exists>i. r01_binary_expansion' r i = 0"
	+proof (rule ccontr)
	+ assume "\<not> (\<exists> i. r01_binary_expansion' r i = 0)"
	+ then have "\<And>i. r01_binary_expansion' r i = 1"
	+ using real01_binary_expansion'_0or1[of r] by blast
	+ hence 1:"r01_binary_expression r = (\<lambda>n. \<Sum>i=0..n. ((1/2)^(Suc i)))"
	+ by(auto simp: r01_binary_expression_def r01_binary_sum_def)
	+ have "LIMSEQ (r01_binary_expression r) 1"
	+ proof -
	+ have "LIMSEQ (\<lambda>n. \<Sum>i=0..n. (((1::real)/2)^(Suc i))) 1"
	+ using power_half_series sums_def'[of "\<lambda>n. ((1::real)/2)^(Suc n)" 1]
	+ by simp
	+ thus ?thesis
	+ using 1 by simp
	+ qed
	+ moreover have "LIMSEQ (r01_binary_expression r) r"
	+ using r01_binary_expression_converges_to_r[of r] assms
	+ by simp
	+ ultimately have "r = 1"
	+ using LIMSEQ_unique by auto
	+ thus False
	+ using assms by simp
	+qed
	+
	+lemma r01_binary_expression_ex1:
	+ assumes "0 < r" "r < 1"
	+ shows "\<exists>i. r01_binary_expansion' r i = 1"
	+proof (rule ccontr)
	+ assume "\<not> (\<exists>i. r01_binary_expansion' r i = 1)"
	+ then have "\<And>i. r01_binary_expansion' r i = 0"
	+ using real01_binary_expansion'_0or1[of r] by blast
	+ hence 1:"r01_binary_expression r = (\<lambda>n. \<Sum>i=0..n. 0)"
	+ by(auto simp add: r01_binary_expression_def r01_binary_sum_def)
	+ hence "LIMSEQ (r01_binary_expression r) 0"
	+ by simp
	+ moreover have "LIMSEQ (r01_binary_expression r) r"
	+ using r01_binary_expression_converges_to_r[of r] assms
	+ by simp
	+ ultimately have "r = 0"
	+ using LIMSEQ_unique by auto
	+ thus False
	+ using assms by simp
	+qed
	+
	+lemma r01_binary_expansion'_gt1:
	+ "1 \<le> r \<longleftrightarrow> (\<forall>n. r01_binary_expansion' r n = 1)"
	+proof auto
	+ fix n
	+ assume h:"1 \<le> r"
	+ show "r01_binary_expansion' r n = Suc 0"
	+ unfolding r01_binary_expansion'_def
	+ proof(cases n)
	+ case 0
	+ then show "fst (r01_binary_expansion'' r n) = Suc 0"
	+ using h by simp
	+ next
	+ case 2:(Suc n')
	+ show "fst (r01_binary_expansion'' r n) = Suc 0"
	+ proof(cases "r01_binary_expansion'' r n'")
	+ case 3:(fields a ur lr)
	+ then have "(ur + lr) / 2 \<le> 1"
	+ using r01_binary_expansion_lr_ur_nn[of r "Suc n'"]
	+ by (cases "((ur + lr) / 2) \<le> r") (auto simp: Let_def)
	+ thus "fst (r01_binary_expansion'' r n) = Suc 0"
	+ using h by(simp add: 2 3 Let_def)
	+ qed
	+ qed
	+next
	+ assume h:"\<forall>n. r01_binary_expansion' r n = Suc 0"
	+ show "1 \<le> r"
	+ proof(rule ccontr)
	+ assume "\<not> 1 \<le> r"
	+ then consider "r \<le> 0" \| "0 < r \<and> r < 1"
	+ by linarith
	+ then show "False"
	+ proof cases
	+ case 1
	+ then have "r01_binary_expansion' r 0 = 0"
	+ by(simp add: r01_binary_expansion'_def)
	+ then show ?thesis
	+ using h by simp
	+ next
	+ case 2
	+ then have "\<exists>i. r01_binary_expansion' r i = 0"
	+ using r01_binary_expression_ex0[of r] by simp
	+ then show ?thesis
	+ using h by simp
	+ qed
	+ qed
	+qed
	+
	+lemma r01_binary_expansion'_lt0:
	+ "r \<le> 0 \<longleftrightarrow> (\<forall>n. r01_binary_expansion' r n = 0)"
	+proof auto
	+ fix n
	+ assume h:"r \<le> 0"
	+ show "r01_binary_expansion' r n = 0"
	+ proof(cases n)
	+ case 0
	+ then show ?thesis
	+ using h by(simp add: r01_binary_expansion'_def)
	+ next
	+ case hn:(Suc n')
	+ then show ?thesis
	+ unfolding r01_binary_expansion'_def
	+ proof(cases "r01_binary_expansion'' r n'")
	+ case 1:(fields a ur lr)
	+ then have "0 < ((ur + lr) / 2)"
	+ using r01_binary_expansion_lr_ur_nn[of r n']
	+ by simp
	+ hence "r < ..."
	+ using h by linarith
	+ then show "fst (r01_binary_expansion'' r n) = 0 "
	+ by(simp add: 1 hn Let_def)
	+ qed
	+ qed
	+next
	+ assume h:"\<forall>n. r01_binary_expansion' r n = 0"
	+ show "r \<le> 0"
	+ proof(rule ccontr)
	+ assume "\<not> r \<le> 0"
	+ then consider "0 < r \<and> r < 1" \| "1 \<le> r" by linarith
	+ thus False
	+ proof cases
	+ case 1
	+ then have "\<exists>i. r01_binary_expansion' r i = 1"
	+ using r01_binary_expression_ex1[of r] by simp
	+ then show ?thesis
	+ using h by simp
	+ next
	+ case 2
	+ then show ?thesis
	+ using r01_binary_expansion'_gt1[of r] h by simp
	+ qed
	+ qed
	+qed
	+
	+
	+text \<open>The sequence $111111\dots$ does not appear in $r = 0.a_1 a_2\dots$. \<close>
	+lemma r01_binary_expression_ex0_strong:
	+ assumes "0 < r" "r < 1"
	+ shows "\<exists>i\<ge>n. r01_binary_expansion' r i = 0"
	+proof(cases "r01_binary_expansion'' r n")
	+ case 1:(fields a ur lr)
	+ show ?thesis
	+ proof(rule ccontr)
	+ assume "\<not> (\<exists>i\<ge>n. r01_binary_expansion' r i = 0)"
	+ then have h:"\<forall>i\<ge>n. r01_binary_expansion' r i = 1"
	+ using real01_binary_expansion'_0or1[of r] by blast
	+
	+ have "r = (\<Sum>i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (\<Sum>i::nat. real (r01_binary_expansion' r (i + (Suc n))) * ((1/2)^(Suc (i + (Suc n)))))"
	+ proof -
	+ have "r = (\<Sum>l. real (r01_binary_expansion' r l) * (1 / 2) ^ Suc l)"
	+ using r01_binary_expression_correct[of r] assms by simp
	+ also have "... = (\<Sum>l. real (r01_binary_expansion' r (l + Suc n)) * (1 / 2) ^ Suc (l + Suc n)) + (\<Sum>i<Suc n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i)"
	+ apply(rule suminf_split_initial_segment)
	+ apply(rule binary_expression_summable)
	+ using real01_binary_expansion'_0or1[of r] by simp
	+ also have "... = (\<Sum>i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (\<Sum>i::nat. real (r01_binary_expansion' r (i + (Suc n))) * ((1/2)^(Suc (i + (Suc n)))))"
	+ proof -
	+ have "\<And>n. {..<Suc n} = {0..n}" by auto
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis .
	+ qed
	+ also have "... = (\<Sum>i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (\<Sum>i::nat. ((1/2)^(Suc (i + (Suc n)))))"
	+ using h by simp
	+ also have "... = (\<Sum>i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (1/2)^(Suc n)"
	+ using half_sum[of "Suc n"] by simp
	+ also have "... = lr + (1/2)^(Suc n)"
	+ using 1 r01_binary_expression_eq_lr[of r n]
	+ by(simp add: r01_binary_expression_def r01_binary_sum_def)
	+ also have "... = ur"
	+ using r01_binary_expansion_diff[of r n]
	+ by(simp add: 1)
	+ finally have "r = ur" .
	+ moreover have "r < ur"
	+ using r01_binary_expansion_lr_r_ur[of r n] assms 1
	+ by simp
	+ ultimately show False
	+ by simp
	+ qed
	+qed
	+
	+text \<open> A binary expression is well-formed when $111\dots$ does not appear in the tail of the sequence \<close>
	+definition biexp01_well_formed :: "(nat \<Rightarrow> nat) \<Rightarrow> bool" where
	+"biexp01_well_formed a \<equiv> (\<forall>n. a n \<in> {0,1}) \<and> (\<forall>n. \<exists>m\<ge>n. a m = 0)"
	+
	+lemma biexp01_well_formedE:
	+ assumes "biexp01_well_formed a"
	+ shows "(\<forall>n. a n \<in> {0,1}) \<and> (\<forall>n. \<exists>m\<ge>n. a m = 0)"
	+ using assms by(simp add: biexp01_well_formed_def)
	+
	+lemma biexp01_well_formedI:
	+ assumes "\<And>n. a n \<in> {0,1}"
	+ and "\<And>n. \<exists>m\<ge>n. a m = 0"
	+ shows "biexp01_well_formed a"
	+ using assms by(simp add: biexp01_well_formed_def)
	+
	+lemma r01_binary_expansion_well_formed:
	+ assumes "0 < r" "r < 1"
	+ shows "biexp01_well_formed (r01_binary_expansion' r)"
	+ using r01_binary_expression_ex0_strong[of r] assms real01_binary_expansion'_0or1[of r]
	+ by(simp add: biexp01_well_formed_def)
	+
	+lemma biexp01_well_formed_comb:
	+ assumes "biexp01_well_formed a"
	+ and "biexp01_well_formed b"
	+ shows "biexp01_well_formed (\<lambda>n. if even n then a (n div 2)
	+ else b ((n-1) div 2))"
	+proof(rule biexp01_well_formedI)
	+ show "\<And>n. (if even n then a (n div 2) else b ((n - 1) div 2)) \<in> {0, 1}"
	+ using assms biexp01_well_formedE by simp
	+next
	+ fix n
	+ obtain m where 1:"m\<ge>n \<and> a m = 0"
	+ using assms biexp01_well_formedE by blast
	+ then have "a ((2*m) div 2) = 0" by simp
	+ hence "(if even (2m) then a (2m div 2) else b ((2*m - 1) div 2)) = 0"
	+ by simp
	+ moreover have "2*m \<ge> n" using 1 by simp
	+ ultimately show "\<exists>m\<ge>n. (if even m then a (m div 2) else b ((m - 1) div 2)) = 0"
	+ by auto
	+qed
	+
	+
	+
	+lemma nat_complete_induction:
	+ assumes "P (0 :: nat)"
	+ and "\<And>n. (\<And>m. m \<le> n \<Longrightarrow> P m) \<Longrightarrow> P (Suc n)"
	+ shows "P n"
	+proof(cases n)
	+ case 0
	+ then show ?thesis
	+ using assms(1) by simp
	+next
	+ case h:(Suc n')
	+ have "P (Suc n')"
	+ proof(rule assms(2))
	+ show "\<And>m. m \<le> n' \<Longrightarrow> P m"
	+ proof(induction n')
	+ case 0
	+ then show ?case
	+ using assms(1) by simp
	+ next
	+ case (Suc n'')
	+ then show ?case
	+ by (metis assms(2) le_SucE)
	+ qed
	+ qed
	+ thus ?thesis
	+ using h by simp
	+qed
	+
	+text \<open> \<open>(\<Sum>m. real (a m) * (1 / 2) ^ Suc m) n = a n\<close>.\<close>
	+lemma biexp01_well_formed_an:
	+ assumes "biexp01_well_formed a"
	+ shows "r01_binary_expansion' (\<Sum>m. real (a m) * (1 / 2) ^ Suc m) n = a n"
	+proof(rule nat_complete_induction[of _ n])
	+ show "r01_binary_expansion' (\<Sum>m. real (a m) * (1 / 2) ^ Suc m) 0 = a 0"
	+ proof (auto simp add: r01_binary_expansion'_def)
	+ assume h:"1 \<le> (\<Sum>m. real (a m) * (1 / 2) ^ m / 2) * 2"
	+ show "Suc 0 = a 0"
	+ proof(rule ccontr)
	+ assume "Suc 0 \<noteq> a 0"
	+ then have "a 0 = 0"
	+ using assms(1) biexp01_well_formedE[of a] by auto
	+ hence "(\<Sum>m. real (a m) * (1 / 2) ^ (Suc m)) = (\<Sum>m. real (a (Suc m)) * (1 / 2) ^ (Suc (Suc m)))"
	+ using suminf_split_head[of "\<lambda>m. real (a m) * (1 / 2) ^ (Suc m)"] binary_expression_summable[of a] assms biexp01_well_formedE
	+ by simp
	+ also have "... < 1/2"
	+ using ai_exists0_less_than_sum[of a 1] assms biexp01_well_formedE[of a]
	+ by auto
	+ finally have "(\<Sum>m. real (a m) * (1 / 2) ^ m / 2) < 1/2"
	+ by simp
	+ thus False
	+ using h by simp
	+ qed
	+ next
	+ assume h:"\<not> 1 \<le> (\<Sum>m. real (a m) * (1 / 2) ^ m / 2) * 2"
	+ show "a 0 = 0"
	+ proof(rule ccontr)
	+ assume "a 0 \<noteq> 0"
	+ then have "a 0 = 1"
	+ using assms(1) biexp01_well_formedE[of a]
	+ by (meson insertE singletonD)
	+ hence "1/2 \<le> (\<Sum>m. real (a m) * (1 / 2) ^ (Suc m))"
	+ using ai_1_gt[of a 0] assms(1) biexp01_well_formedE[of a]
	+ by auto
	+ thus False
	+ using h by simp
	+ qed
	+ qed
	+next
	+ fix n :: nat
	+ assume ih:"(\<And>m. m \<le> n \<Longrightarrow> r01_binary_expansion' (\<Sum>m. real (a m) * (1 / 2) ^ Suc m) m = a m)"
	+ show "r01_binary_expansion' (\<Sum>m. real (a m) * (1 / 2) ^ Suc m) (Suc n) = a (Suc n)"
	+ proof(cases "r01_binary_expansion'' (\<Sum>m. real (a m) * (1 / 2) ^ Suc m) n")
	+ case h:(fields bn ur lr)
	+ then have hlr:"lr = (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k)"
	+ using r01_binary_expression_eq_lr[of "\<Sum>m. real (a m) * (1 / 2) ^ Suc m" n] ih
	+ by(simp add: r01_binary_expression_def r01_binary_sum_def)
	+ have hlr2:"(ur + lr) / 2 = lr + (1/2)^(Suc (Suc n))"
	+ proof -
	+ have "(ur + lr) / 2 = lr + (1/2)^(Suc (Suc n))"
	+ using r01_binary_expansion_diff[of "\<Sum>m. real (a m) * (1 / 2) ^ Suc m" n] h by simp
	+ show ?thesis
	+ by (simp add: \<open>(ur + lr) / 2 = lr + (1 / 2) ^ Suc (Suc n)\<close> of_rat_add of_rat_divide of_rat_power)
	+ qed
	+ show ?thesis
	+ using h
	+ proof(auto simp add: r01_binary_expansion'_def Let_def)
	+ assume h1: "(ur + lr) \<le> (\<Sum>m. real (a m) * (1 / 2) ^ m / 2) * 2"
	+ show "Suc 0 = a (Suc n)"
	+ proof(rule ccontr)
	+ assume "Suc 0 \<noteq> a (Suc n)"
	+ then have "a (Suc n) = 0"
	+ using assms(1) biexp01_well_formedE[of a] by auto
	+ have "(\<Sum>m. real (a m) * (1 / 2) ^ m / 2) < (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1/2)^(Suc (Suc n))"
	+ proof -
	+ have "(\<Sum>m. real (a m) * (1 / 2) ^ (Suc m)) = (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (\<Sum>m. real (a (m+Suc n)) * (1 / 2) ^ Suc (m + Suc n))"
	+ proof -
	+ have "{0..n} = {..<Suc n}" by auto
	+ thus ?thesis
	+ using suminf_split_initial_segment[of "\<lambda>m. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a]
	+ by simp
	+ qed
	+ also have "... = (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (\<Sum>m. real (a (Suc m + Suc n)) * (1 / 2) ^ Suc (Suc m + Suc n))"
	+ using suminf_split_head[of "\<lambda>m. real (a (m + Suc n)) * (1 / 2) ^ (Suc (m + Suc n))"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a] Series.summable_iff_shift[of "\<lambda>m. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] \<open>a (Suc n) = 0\<close>
	+ by simp
	+ also have "... = (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (\<Sum>m. real (a (m + Suc (Suc n))) * (1 / 2) ^ Suc (m + Suc (Suc n)))"
	+ by simp
	+ also have "... < (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1/2)^Suc (Suc n)"
	+ using ai_exists0_less_than_sum[of a "Suc (Suc n)"] assms(1) biexp01_well_formedE[of a]
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ thus False
	+ using h1 hlr2 hlr by simp
	+ qed
	+ next
	+ assume h2:"\<not> ur + lr \<le> (\<Sum>m. real (a m) * (1 / 2) ^ m / 2) * 2"
	+ show "a (Suc n) = 0"
	+ proof(rule ccontr)
	+ assume "a (Suc n) \<noteq> 0"
	+ then have "a (Suc n) = 1"
	+ using biexp01_well_formedE[OF assms(1)]
	+ by (meson insertE singletonD)
	+ have "(\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1/2)^(Suc (Suc n)) \<le> (\<Sum>m. real (a m) * (1 / 2) ^ m / 2)"
	+ proof -
	+ have "(\<Sum>m. real (a m) * (1 / 2) ^ (Suc m)) = (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (\<Sum>m. real (a (m+Suc n)) * (1 / 2) ^ Suc (m + Suc n))"
	+ proof -
	+ have "{0..n} = {..<Suc n}" by auto
	+ thus ?thesis
	+ using suminf_split_initial_segment[of "\<lambda>m. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a]
	+ by simp
	+ qed
	+ also have "... = (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (\<Sum>m. real (a (Suc m + Suc n)) * (1 / 2) ^ Suc (Suc m + Suc n)) + (1 / 2) ^ Suc (Suc n)"
	+ using suminf_split_head[of "\<lambda>m. real (a (m + Suc n)) * (1 / 2) ^ (Suc (m + Suc n))"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a] Series.summable_iff_shift[of "\<lambda>m. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] \<open>a (Suc n) = 1\<close>
	+ by simp
	+ also have "... = (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (\<Sum>m. real (a (m + Suc (Suc n))) * (1 / 2) ^ Suc (m + (Suc (Suc n)))) + (1 / 2) ^ Suc (Suc n)"
	+ by simp
	+ also have "... \<ge> (\<Sum>k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1 / 2) ^ Suc (Suc n)"
	+ using binary_expression_gteq0[of a "Suc (Suc n)"] assms(1) biexp01_well_formedE[of a] by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus False
	+ using h2 hlr2 hlr by simp
	+ qed
	+ qed
	+ qed
	+qed
	+
	+
	+lemma f01_borel_measurable:
	+ assumes "f -` {0::real} \<in> sets real_borel"
	+ "f -` {1} \<in> sets borel"
	+ and "\<And>r::real. f r \<in> {0,1}"
	+ shows "f \<in> borel_measurable real_borel"
	+proof(rule measurableI)
	+ fix U :: "real set"
	+ assume "U \<in> sets borel"
	+ consider "1 \<in> U \<and> 0 \<in> U" \| "1 \<in> U \<and> 0 \<notin> U" \| "1 \<notin> U \<and> 0 \<in> U" \| "1 \<notin> U \<and> 0 \<notin> U"
	+ by auto
	+ then show "f -` U \<inter> space real_borel \<in> sets borel"
	+ proof cases
	+ case 1
	+ then have "f -` U = UNIV"
	+ using assms(3) by auto
	+ then show ?thesis by simp
	+ next
	+ case 2
	+ then have "f -` U = f -` {1}"
	+ using assms(3) by fastforce
	+ then show ?thesis
	+ using assms(2) by simp
	+ next
	+ case 3
	+ then have "f -` U = f -` {0}"
	+ using assms(3) by fastforce
	+ then show ?thesis
	+ using assms(1) by simp
	+ next
	+ case 4
	+ then have "f -` U = {}"
	+ using assms(3) by (metis all_not_in_conv insert_iff vimage_eq)
	+ then show ?thesis by simp
	+ qed
	+qed simp
	+
	+
	+lemma r01_binary_expansion'_measurable:
	+ "(\<lambda>r. real (r01_binary_expansion' r n)) \<in> borel_measurable (borel :: real measure)"
	+proof -
	+ have "(\<lambda>r. real (r01_binary_expansion' r n)) -`{0} \<in> sets borel \<and> (\<lambda>r. real (r01_binary_expansion' r n)) -`{1} \<in> sets borel"
	+ proof -
	+ let ?A = "{..0::real} \<union> (\<Union>i\<in>{l::nat. l < 2^(Suc n) \<and> even l} . {i/2^(Suc n)..<(Suc i)/2^(Suc n)})"
	+ let ?B = "{1::real..} \<union> (\<Union>i\<in>{l::nat. l < 2^(Suc n) \<and> odd l} . {i/2^(Suc n)..<(Suc i)/2^(Suc n)})"
	+ have "?A \<in> sets borel" by simp
	+ have "?B \<in> sets borel" by simp
	+ have hE:"?A \<inter> ?B = {}"
	+ proof auto
	+ fix r :: real
	+ fix l :: nat
	+ assume h: "r \<le> 0"
	+ "odd l"
	+ "real l / (2 * 2 ^ n) \<le> r"
	+ then have "0 < l" by(cases l; auto)
	+ hence "0 < real l / (2 * 2 ^ n)" by simp
	+ thus False
	+ using h by simp
	+ next
	+ fix r :: real
	+ fix l :: nat
	+ assume h: "l < 2 * 2 ^ n"
	+ "even l"
	+ "1 \<le> r"
	+ "r < (1 + real l) / (2 * 2 ^ n)"
	+ then have "1 + real l \<le> 2 * 2 ^ n"
	+ by (simp add: nat_less_real_le)
	+ moreover have "1 + real l \<noteq> 2 * 2 ^ n"
	+ using h by auto
	+ ultimately have "1 + real l < 2 * 2 ^ n" by simp
	+ hence "(1 + real l) / (2 * 2 ^ n) < 1" by simp
	+ thus False using h by linarith
	+ next
	+ fix r :: real
	+ fix l1 l2 :: nat
	+ assume h: "even l1" "odd l2"
	+ "real l1 / (2 * 2 ^ n) \<le> r" "r < (1 + real l1) / (2 * 2 ^ n)"
	+ "real l2 / (2 * 2 ^ n) \<le> r" "r < (1 + real l2) / (2 * 2 ^ n)"
	+ then consider "l1 < l2" \| "l2 < l1" by fastforce
	+ thus False
	+ proof cases
	+ case 1
	+ then have "(1 + real l1) / (2 * 2 ^ n) \<le> real l2 / (2 * 2 ^ n)"
	+ by (simp add: frac_le)
	+ then show ?thesis
	+ using h by simp
	+ next
	+ case 2
	+ then have "(1 + real l2) / (2 * 2 ^ n) \<le> real l1 / (2 * 2 ^ n)"
	+ by (simp add: frac_le)
	+ then show ?thesis
	+ using h by simp
	+ qed
	+ qed
	+ have hU:"?A \<union> ?B = UNIV"
	+ proof
	+ show "?A \<union> ?B \<subseteq> UNIV" by simp
	+ next
	+ show "UNIV \<subseteq> ?A \<union> ?B"
	+ proof
	+ fix r :: real
	+ consider "r \<le> 0" \| "0 < r \<and> r < 1" \| "1 \<le> r" by linarith
	+ then show "r \<in> ?A \<union> ?B"
	+ proof cases
	+ case 1
	+ then show ?thesis by simp
	+ next
	+ case 2
	+ show ?thesis
	+ proof(cases "r01_binary_expansion'' r n")
	+ case hc:(fields a ur lr)
	+ then have hlu:"lr \<le> r \<and> r < ur"
	+ using 2 r01_binary_expansion_lr_r_ur[of r n] by simp
	+ obtain k :: nat where hk:
	+ "lr = real k / 2 ^ Suc n \<and> k < 2 ^ Suc n"
	+ using r01_binary_expression'_sum_range[of r n] hc
	+ by auto
	+ hence "ur = real (Suc k) / 2^Suc n"
	+ using r01_binary_expansion_diff[of r n] hc
	+ by (simp add: add_divide_distrib power_one_over)
	+ thus ?thesis
	+ using hlu hk by auto
	+ qed
	+ next
	+ case 3
	+ then show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ have hi1:"- ?A = ?B"
	+ proof -
	+ have "?B \<subseteq> - ?A"
	+ using hE by blast
	+ moreover have "-?A \<subseteq> ?B"
	+ proof -
	+ have "-(?A \<union> ?B) = {}"
	+ using hU by simp
	+ hence "(-?A) \<inter> (-?B) = {}" by simp
	+ thus ?thesis
	+ by blast
	+ qed
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+ have hi2: "?A = -?B"
	+ using hi1 by blast
	+
	+ let ?U0 = "(\<lambda>r. real (r01_binary_expansion' r n)) -`{0}"
	+ let ?U1 = "(\<lambda>r. real (r01_binary_expansion' r n)) -`{1}"
	+
	+ have hU':"?U0 \<union> ?U1 = UNIV"
	+ proof -
	+ have "?U0 \<union> ?U1 = (\<lambda>r. real (r01_binary_expansion' r n)) -`{0,1}"
	+ by auto
	+ thus ?thesis
	+ using real01_binary_expansion'_0or1[of _ n] by auto
	+ qed
	+ have hE':"?U0 \<inter> ?U1 = {}"
	+ by auto
	+
	+ have hiu1:"- ?U0 = ?U1"
	+ using hE' hU' by fastforce
	+
	+ have hiu2:"- ?U1 = ?U0"
	+ using hE' hU' by fastforce
	+
	+ have "?U0 \<subseteq> ?A"
	+ proof
	+ fix r
	+ assume "r \<in> ?U0"
	+ then have h1:"r01_binary_expansion' r n = 0"
	+ by simp
	+ then consider "r \<le> 0" \| "0 < r \<and> r < 1"
	+ using r01_binary_expansion'_gt1[of r] by fastforce
	+ thus "r \<in> ?A"
	+ proof cases
	+ case 1
	+ then show ?thesis by simp
	+ next
	+ case 2
	+ then have 3:"(snd (snd (r01_binary_expansion'' r n))) \<le> r \<and>
	+ r < (fst (snd (r01_binary_expansion'' r n)))"
	+ using r01_binary_expansion_lr_r_ur[of r n] by simp
	+ obtain k where 4:
	+ "(snd (snd (r01_binary_expansion'' r n))) =
	+ real k / 2 ^ Suc n \<and>
	+ k < 2 ^ Suc n \<and> even k"
	+ using r01_binary_expression'_sum_range[of r n] h1
	+ by auto
	+ have "(fst (snd (r01_binary_expansion'' r n))) = real (Suc k) / 2 ^ Suc n"
	+ proof -
	+ have "(fst (snd (r01_binary_expansion'' r n))) = (snd (snd (r01_binary_expansion'' r n))) + (1/2)^Suc n"
	+ using r01_binary_expansion_diff[of r n] by linarith
	+ thus ?thesis
	+ using 4
	+ by (simp add: add_divide_distrib power_one_over)
	+ qed
	+ thus ?thesis
	+ using 3 4 by auto
	+ qed
	+ qed
	+
	+ have "?U1 \<subseteq> ?B"
	+ proof
	+ fix r
	+ assume "r \<in> ?U1"
	+ then have h1:"r01_binary_expansion' r n = 1"
	+ by simp
	+ then consider "1 \<le> r" \| "0 < r \<and> r < 1"
	+ using r01_binary_expansion'_lt0[of r] by fastforce
	+ thus "r \<in> ?B"
	+ proof cases
	+ case 1
	+ then show ?thesis by simp
	+ next
	+ case 2
	+ then have 3:"(snd (snd (r01_binary_expansion'' r n))) \<le> r \<and>
	+ r < (fst (snd (r01_binary_expansion'' r n)))"
	+ using r01_binary_expansion_lr_r_ur[of r n] by simp
	+ obtain k where 4:
	+ "(snd (snd (r01_binary_expansion'' r n))) =
	+ real k / 2 ^ Suc n \<and>
	+ k < 2 ^ Suc n \<and> odd k"
	+ using StandardBorel.r01_binary_expression'_sum_range[of r n] h1
	+ by auto
	+ have "(fst (snd (r01_binary_expansion'' r n))) = real (Suc k) / 2 ^ Suc n"
	+ proof -
	+ have "(fst (snd (r01_binary_expansion'' r n))) = (snd (snd (r01_binary_expansion'' r n))) + (1/2)^Suc n"
	+ using r01_binary_expansion_diff[of r n] by simp
	+ thus ?thesis
	+ using 4
	+ by (simp add: add_divide_distrib power_one_over)
	+ qed
	+ thus ?thesis
	+ using 3 4 by auto
	+ qed
	+ qed
	+
	+ have "?U0 = ?A"
	+ proof
	+ show "?U0 \<subseteq> ?A" by fact
	+ next
	+ show "?A \<subseteq> ?U0"
	+ using \<open>?U1 \<subseteq> ?B\<close> Compl_subset_Compl_iff[of ?U0 ?A] hi1 hiu1
	+ by blast
	+ qed
	+
	+ have "?U1 = ?B"
	+ using \<open>?U0 = ?A\<close> hi1 hiu1 by auto
	+ show ?thesis
	+ using \<open>?U0 = ?A\<close> \<open>?U1 = ?B\<close> \<open>?A \<in> sets borel\<close> \<open>?B \<in> sets borel\<close>
	+ by simp
	+ qed
	+ thus ?thesis
	+ using f01_borel_measurable[of "(\<lambda>r. real (r01_binary_expansion' r n))"] real01_binary_expansion'_0or1[of _ n]
	+ by simp
	+qed
	+
	+
	+
	+(* (0,1) \<Rightarrow> [0,1]\<times>[0,1]. *)
	+definition r01_to_r01_r01_fst' :: "real \<Rightarrow> nat \<Rightarrow> nat" where
	+"r01_to_r01_r01_fst' r n \<equiv> r01_binary_expansion' r (2*n)"
	+
	+lemma r01_to_r01_r01_fst'in01:
	+ "\<And>n. r01_to_r01_r01_fst' r n \<in> {0,1}"
	+ using real01_binary_expansion'_0or1 by (simp add: r01_to_r01_r01_fst'_def)
	+
	+definition r01_to_r01_r01_fst_sum :: "real \<Rightarrow> nat \<Rightarrow> real" where
	+"r01_to_r01_r01_fst_sum \<equiv> r01_binary_sum \<circ> r01_to_r01_r01_fst'"
	+
	+definition r01_to_r01_r01_fst :: "real \<Rightarrow> real" where
	+"r01_to_r01_r01_fst = lim \<circ> r01_to_r01_r01_fst_sum"
	+
	+lemma r01_to_r01_r01_fst_def':
	+ "r01_to_r01_r01_fst r = (\<Sum>n. real (r01_binary_expansion' r (2n)) (1/2)^(n+1))"
	+proof -
	+ have "r01_to_r01_r01_fst_sum r = (\<lambda>n. \<Sum>i=0..n. real (r01_binary_expansion' r (2i)) (1/2)^(i+1))"
	+ by(auto simp add: r01_to_r01_r01_fst_sum_def r01_binary_sum_def r01_to_r01_r01_fst'_def)
	+ thus ?thesis
	+ using lim_sum_ai real01_binary_expansion'_0or1
	+ by(simp add: r01_to_r01_r01_fst_def)
	+qed
	+
	+lemma r01_to_r01_r01_fst_measurable:
	+ "r01_to_r01_r01_fst \<in> borel_measurable borel"
	+ unfolding r01_to_r01_r01_fst_def'
	+ using r01_binary_expansion'_measurable by auto
	+
	+
	+definition r01_to_r01_r01_snd' :: "real \<Rightarrow> nat \<Rightarrow> nat" where
	+"r01_to_r01_r01_snd' r n = r01_binary_expansion' r (2*n + 1)"
	+
	+lemma r01_to_r01_r01_snd'in01:
	+ "\<And>n. r01_to_r01_r01_snd' r n \<in> {0,1}"
	+ using real01_binary_expansion'_0or1 by (simp add: r01_to_r01_r01_snd'_def)
	+
	+
	+definition r01_to_r01_r01_snd_sum :: "real \<Rightarrow> nat \<Rightarrow> real" where
	+"r01_to_r01_r01_snd_sum \<equiv> r01_binary_sum \<circ> r01_to_r01_r01_snd'"
	+
	+definition r01_to_r01_r01_snd :: "real \<Rightarrow> real" where
	+"r01_to_r01_r01_snd = lim \<circ> r01_to_r01_r01_snd_sum"
	+
	+lemma r01_to_r01_r01_snd_def':
	+ "r01_to_r01_r01_snd r = (\<Sum>n. real (r01_binary_expansion' r (2n + 1)) (1/2)^(n+1))"
	+proof -
	+ have "r01_to_r01_r01_snd_sum r = (\<lambda>n. \<Sum>i=0..n. real (r01_binary_expansion' r (2i + 1)) (1/2)^(i+1))"
	+ by(auto simp add: r01_to_r01_r01_snd_sum_def r01_binary_sum_def r01_to_r01_r01_snd'_def)
	+ thus ?thesis
	+ using lim_sum_ai real01_binary_expansion'_0or1
	+ by(simp add: r01_to_r01_r01_snd_def)
	+qed
	+
	+lemma r01_to_r01_r01_snd_measurable:
	+ "r01_to_r01_r01_snd \<in> borel_measurable borel"
	+ unfolding r01_to_r01_r01_snd_def'
	+ using r01_binary_expansion'_measurable by auto
	+
	+
	+definition r01_to_r01_r01 :: "real \<Rightarrow> real \<times> real" where
	+"r01_to_r01_r01 r = (r01_to_r01_r01_fst r,r01_to_r01_r01_snd r)"
	+
	+lemma r01_to_r01_r01_image:
	+ "r01_to_r01_r01 r \<in> {0..1}\<times>{0..1}"
	+ using r01_to_r01_r01_fst_def'[of r] r01_to_r01_r01_snd_def'[of r] real01_binary_expansion'_0or1
	+ binary_expression_gteq0[of "\<lambda>n. r01_binary_expansion' r (2n)" 0] binary_expression_leeq1[of "\<lambda>n. r01_binary_expansion' r (2n)" 0] binary_expression_gteq0[of "\<lambda>n. r01_binary_expansion' r (2n+1)" 0] binary_expression_leeq1[of "\<lambda>n. r01_binary_expansion' r (2n+1)" 0]
	+ by(simp add: r01_to_r01_r01_def)
	+
	+lemma r01_to_r01_r01_measurable:
	+ "r01_to_r01_r01 \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Otimes>\<^sub>M real_borel"
	+ unfolding r01_to_r01_r01_def
	+ using borel_measurable_Pair[of r01_to_r01_r01_fst borel r01_to_r01_r01_snd] r01_to_r01_r01_fst_measurable r01_to_r01_r01_snd_measurable
	+ by(simp add: borel_prod)
	+
	+lemma r01_to_r01_r01_3over4:
	+ "r01_to_r01_r01 (3/4) = (1/2,1/2)"
	+proof -
	+ have h0:"r01_binary_expansion' (3/4) 0 = 1"
	+ by (simp add: r01_binary_expansion'_def)
	+ have h1:"r01_binary_expansion' (3/4) 1 = 1"
	+ by (simp add: r01_binary_expansion'_def Let_def of_rat_divide)
	+ have hn:"\<And>n. n>1\<Longrightarrow> r01_binary_expansion' (3/4) n = 0"
	+ proof -
	+ fix n :: nat
	+ assume h:"1 < n"
	+ show "r01_binary_expansion' (3 / 4) n = 0"
	+ proof(rule ccontr)
	+ assume "r01_binary_expansion' (3 / 4) n \<noteq> 0"
	+ have "3/4 < (\<Sum>i=0..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
	+ proof -
	+ have "(\<Sum>i=0..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) = real (r01_binary_expansion' (3/4) 0) * (1/2)^(Suc 0) + (\<Sum>i=(Suc 0)..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
	+ by(rule sum.atLeast_Suc_atMost) (simp add: h)
	+ also have "... = real (r01_binary_expansion' (3/4) 0) * (1/2)^(Suc 0) + (real (r01_binary_expansion' (3/4) 1) * (1/2)^(Suc 1) + (\<Sum>i=(Suc (Suc 0))..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)))"
	+ using sum.atLeast_Suc_atMost[OF order.strict_implies_order[OF h],of "\<lambda>i. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)"]
	+ by simp
	+ also have "... = 3/4 + (\<Sum>i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
	+ using h0 h1 by(simp add: numeral_2_eq_2)
	+ also have "... > 3/4"
	+ proof -
	+ have "(\<Sum>i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) = (\<Sum>i=2..n-1. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) + real (r01_binary_expansion' (3/4) n) * (1/2)^Suc n"
	+ by (metis (no_types, lifting) h One_nat_def Suc_pred less_2_cases_iff less_imp_add_positive order_less_irrefl plus_1_eq_Suc sum.cl_ivl_Suc zero_less_Suc)
	+ hence "real (r01_binary_expansion' (3/4) n) * (1/2)^Suc n \<le> (\<Sum>i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
	+ using ordered_comm_monoid_add_class.sum_nonneg[of "{2..n-1}" "\<lambda>i. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)"]
	+ by simp
	+ moreover have "0 < real (r01_binary_expansion' (3/4) n) * (1/2)^Suc n"
	+ using \<open>r01_binary_expansion' (3 / 4) n \<noteq> 0\<close> by simp
	+ ultimately have "0 < (\<Sum>i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ finally show "3 / 4 < (\<Sum>i = 0..n. real (r01_binary_expansion' (3 / 4) i) * (1 / 2) ^ Suc i)" .
	+ qed
	+ moreover have "(\<Sum>i=0..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) \<le> 3/4"
	+ using r01_binary_expansion_lr_r_ur[of "3/4" n] r01_binary_expression_eq_lr[of "3/4" n]
	+ by(simp add: r01_binary_expression_def r01_binary_sum_def)
	+ ultimately show False by simp
	+ qed
	+ qed
	+ show ?thesis
	+ proof
	+ have "fst (r01_to_r01_r01 (3 / 4)) = (\<Sum>n. real (r01_binary_expansion' (3 / 4) (2 * n)) * (1 / 2) ^ Suc n)"
	+ by(simp add: r01_to_r01_r01_def r01_to_r01_r01_fst_def')
	+ also have "... = 1/2 + (\<Sum>n. real (r01_binary_expansion' (3 / 4) (2 * Suc n)) * (1 / 2) ^ Suc (Suc n))"
	+ using suminf_split_head[of "\<lambda>n. real (r01_binary_expansion' (3 / 4) (2 * n)) * (1 / 2) ^ Suc n"] binary_expression_summable[of "\<lambda>n. r01_binary_expansion' (3/4) (2*n)"] real01_binary_expansion'_0or1[of "3/4"] h0
	+ by simp
	+ also have "... = 1/2"
	+ proof -
	+ have "\<forall>n. real (r01_binary_expansion' (3 / 4) (2 * Suc n)) * (1 / 2) ^ Suc (Suc n) = 0"
	+ using hn by simp
	+ hence "(\<Sum>n. real (r01_binary_expansion' (3 / 4) (2 * Suc n)) * (1 / 2) ^ Suc (Suc n)) = 0"
	+ by simp
	+ thus ?thesis
	+ by simp
	+ qed
	+ finally show "fst (r01_to_r01_r01 (3 / 4)) = fst (1 / 2, 1 / 2)"
	+ by simp
	+ next
	+ have "snd (r01_to_r01_r01 (3 / 4)) = (\<Sum>n. real (r01_binary_expansion' (3 / 4) (2 * n + 1)) * (1 / 2) ^ Suc n)"
	+ by(simp add: r01_to_r01_r01_def r01_to_r01_r01_snd_def')
	+ also have "... = 1/2 + (\<Sum>n. real (r01_binary_expansion' (3 / 4) (2 * Suc n + 1)) * (1 / 2) ^ Suc (Suc n))"
	+ using suminf_split_head[of "\<lambda>n. real (r01_binary_expansion' (3 / 4) (2 * n + 1)) * (1 / 2) ^ Suc n"] binary_expression_summable[of "\<lambda>n. r01_binary_expansion' (3/4) (2*n + 1)"] real01_binary_expansion'_0or1[of "3/4"] h1
	+ by simp
	+ also have "... = 1/2"
	+ proof -
	+ have "\<forall>n. real (r01_binary_expansion' (3 / 4) (2 * Suc n + 1)) * (1 / 2) ^ Suc (Suc n) = 0"
	+ using hn by simp
	+ hence "(\<Sum>n. real (r01_binary_expansion' (3 / 4) (2 * Suc n + 1)) * (1 / 2) ^ Suc (Suc n)) = 0"
	+ by simp
	+ thus ?thesis
	+ by simp
	+ qed
	+ finally show "snd (r01_to_r01_r01 (3 / 4)) = snd (1 / 2, 1 / 2)"
	+ by simp
	+ qed
	+qed
	+
	+
	+(* (0,1)\<times>(0,1) \<Rightarrow> (0,1). *)
	+definition r01_r01_to_r01' :: "real \<times> real \<Rightarrow> nat \<Rightarrow> nat" where
	+"r01_r01_to_r01' rs \<equiv> (\<lambda>n. if even n then r01_binary_expansion' (fst rs) (n div 2)
	+ else r01_binary_expansion' (snd rs) ((n-1) div 2))"
	+
	+lemma r01_r01_to_r01'in01:
	+ "\<And>n. r01_r01_to_r01' rs n \<in> {0,1}"
	+ using real01_binary_expansion'_0or1 by (simp add: r01_r01_to_r01'_def)
	+
	+lemma r01_r01_to_r01'_well_formed:
	+ assumes "0 < r1" "r1 < 1"
	+ and "0 < r2" "r2 < 1"
	+ shows "biexp01_well_formed (r01_r01_to_r01' (r1,r2))"
	+ using biexp01_well_formed_comb[of "r01_binary_expansion' (fst (r1,r2))" "r01_binary_expansion' (snd (r1,r2))"] r01_binary_expansion_well_formed[of r1] r01_binary_expansion_well_formed[of r2] assms
	+ by (auto simp add: r01_r01_to_r01'_def)
	+
	+definition r01_r01_to_r01_sum :: "real \<times> real \<Rightarrow> nat \<Rightarrow> real" where
	+"r01_r01_to_r01_sum \<equiv> r01_binary_sum \<circ> r01_r01_to_r01'"
	+
	+definition r01_r01_to_r01 :: "real \<times> real \<Rightarrow> real" where
	+"r01_r01_to_r01 \<equiv> lim \<circ> r01_r01_to_r01_sum"
	+
	+lemma r01_r01_to_r01_def':
	+ "r01_r01_to_r01 (r1,r2) = (\<Sum>n. real (r01_r01_to_r01' (r1,r2) n) * (1/2)^(n+1))"
	+proof -
	+ have "r01_r01_to_r01_sum (r1,r2) = (\<lambda>n. (\<Sum>i = 0..n. real (r01_r01_to_r01' (r1,r2) i) * (1 / 2) ^ Suc i))"
	+ by(auto simp add: r01_r01_to_r01_sum_def r01_binary_sum_def)
	+ thus ?thesis
	+ using lim_sum_ai[of "\<lambda>n. r01_r01_to_r01' (r1,r2) n"] r01_r01_to_r01'in01
	+ by(simp add: r01_r01_to_r01_def)
	+qed
	+
	+lemma r01_r01_to_r01_measurable:
	+ "r01_r01_to_r01 \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M real_borel"
	+proof -
	+ have "r01_r01_to_r01 = (\<lambda>x. \<Sum>n. real (r01_r01_to_r01' x n) * (1/2)^(n+1))"
	+ using r01_r01_to_r01_def' by auto
	+ also have "... \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M real_borel"
	+ proof(rule borel_measurable_suminf)
	+ fix n :: nat
	+ have "(\<lambda>x. real (r01_r01_to_r01' x n) * (1 / 2) ^ (n + 1)) = (\<lambda>r. r * (1/2)^(n+1)) \<circ> (\<lambda>x. real (r01_r01_to_r01' x n))"
	+ by auto
	+ also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
	+ proof(rule measurable_comp[of _ _ borel])
	+ have "(\<lambda>x. real (r01_r01_to_r01' x n))
	+ = (\<lambda>x. if even n then real (r01_binary_expansion' (fst x) (n div 2)) else real (r01_binary_expansion' (snd x) ((n - 1) div 2)))"
	+ by (auto simp add: r01_r01_to_r01'_def)
	+ also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
	+ using r01_binary_expansion'_measurable by simp
	+ finally show "(\<lambda>x. real (r01_r01_to_r01' x n)) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
	+ next
	+ show "(\<lambda>r::real. r * (1 / 2) ^ (n + 1)) \<in> borel_measurable borel"
	+ by simp
	+ qed
	+ finally show "(\<lambda>x. real (r01_r01_to_r01' x n) * (1 / 2) ^ (n + 1)) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+lemma r01_r01_to_r01_image:
	+ assumes "0 < r1" "r1 < 1"
	+ shows "r01_r01_to_r01 (r1,r2) \<in> {0<..<1}"
	+proof -
	+ obtain i where "r01_binary_expansion' r1 i = 1"
	+ using r01_binary_expression_ex1[of r1] assms(1,2)
	+ by auto
	+ hence hi:"r01_r01_to_r01' (r1,r2) (2*i) = 1"
	+ by(simp add: r01_r01_to_r01'_def)
	+ obtain j where "r01_binary_expansion' r1 j = 0"
	+ using r01_binary_expression_ex0[of r1] assms(1,2)
	+ by auto
	+ hence hj:"r01_r01_to_r01' (r1,r2) (2*j) = 0"
	+ by(simp add: r01_r01_to_r01'_def)
	+ show ?thesis
	+ using ai_exists1_gt0[of "r01_r01_to_r01' (r1,r2)"] ai_exists0_less_than1[of "r01_r01_to_r01' (r1,r2)"] r01_r01_to_r01'in01[of "(r1,r2)"] r01_r01_to_r01_def'[of r1 r2] hi hj
	+ by auto
	+qed
	+
	+lemma r01_r01_to_r01_image':
	+ assumes "0 < r2" "r2 < 1"
	+ shows "r01_r01_to_r01 (r1,r2) \<in> {0<..<1}"
	+proof -
	+ obtain i where "r01_binary_expansion' r2 i = 1"
	+ using r01_binary_expression_ex1[of r2] assms(1,2)
	+ by auto
	+ hence hi:"r01_r01_to_r01' (r1,r2) (2*i + 1) = 1"
	+ by(simp add: r01_r01_to_r01'_def)
	+ obtain j where "r01_binary_expansion' r2 j = 0"
	+ using r01_binary_expression_ex0[of r2] assms(1,2)
	+ by auto
	+ hence hj:"r01_r01_to_r01' (r1,r2) (2*j + 1) = 0"
	+ by(simp add: r01_r01_to_r01'_def)
	+ show ?thesis
	+ using ai_exists1_gt0[of "r01_r01_to_r01' (r1,r2)"] ai_exists0_less_than1[of "r01_r01_to_r01' (r1,r2)"] r01_r01_to_r01'in01[of "(r1,r2)"] r01_r01_to_r01_def'[of r1 r2] hi hj
	+ by auto
	+qed
	+
	+
	+lemma r01_r01_to_r01_binary_nth:
	+ assumes "0 < r1" "r1 < 1"
	+ and "0 < r2" "r2 < 1"
	+ shows "r01_binary_expansion' r1 n = r01_binary_expansion' (r01_r01_to_r01 (r1,r2)) (2*n) \<and>
	+ r01_binary_expansion' r2 n = r01_binary_expansion' (r01_r01_to_r01 (r1,r2)) (2*n + 1)"
	+proof -
	+ have "\<And>n. r01_binary_expansion' (r01_r01_to_r01 (r1,r2)) n = r01_r01_to_r01' (r1,r2) n"
	+ using r01_r01_to_r01_def'[of r1 r2] biexp01_well_formed_an[of "r01_r01_to_r01' (r1,r2)"] r01_r01_to_r01'_well_formed[of r1 r2] assms
	+ by simp
	+ thus ?thesis
	+ by(simp add: r01_r01_to_r01'_def)
	+qed
	+
	+lemma r01_r01__r01__r01_r01_id:
	+ assumes "0 < r1" "r1 < 1"
	+ "0 < r2" "r2 < 1"
	+ shows "(r01_to_r01_r01 \<circ> r01_r01_to_r01) (r1,r2) = (r1,r2)"
	+proof
	+ show "fst ((r01_to_r01_r01 \<circ> r01_r01_to_r01) (r1, r2)) = fst (r1, r2)"
	+ proof -
	+ have "fst ((r01_to_r01_r01 \<circ> r01_r01_to_r01) (r1, r2)) = r01_to_r01_r01_fst (r01_r01_to_r01 (r1,r2))"
	+ by(simp add: r01_to_r01_r01_def)
	+ also have "... = (\<Sum>n. real (r01_binary_expansion' (r01_r01_to_r01 (r1, r2)) (2 * n)) * (1 / 2) ^ (n + 1))"
	+ using r01_to_r01_r01_fst_def'[of "r01_r01_to_r01 (r1,r2)"] by simp
	+ also have "... = (\<Sum>n. real (r01_binary_expansion' r1 n) * (1 / 2) ^ (n + 1))"
	+ using r01_r01_to_r01_binary_nth[of r1 r2] assms by simp
	+ also have "... = r1"
	+ using r01_binary_expression_correct[of r1] assms(1,2)
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+next
	+ show "snd ((r01_to_r01_r01 \<circ> r01_r01_to_r01) (r1, r2)) = snd (r1, r2)"
	+ proof -
	+ have "snd ((r01_to_r01_r01 \<circ> r01_r01_to_r01) (r1, r2)) = r01_to_r01_r01_snd (r01_r01_to_r01 (r1,r2))"
	+ by(simp add: r01_to_r01_r01_def)
	+ also have "... = (\<Sum>n. real (r01_binary_expansion' (r01_r01_to_r01 (r1, r2)) (2 * n + 1)) * (1 / 2) ^ (n + 1))"
	+ using r01_to_r01_r01_snd_def'[of "r01_r01_to_r01 (r1,r2)"] by simp
	+ also have "... = (\<Sum>n. real (r01_binary_expansion' r2 n) * (1 / 2) ^ (n + 1))"
	+ using r01_r01_to_r01_binary_nth[of r1 r2] assms by simp
	+ also have "... = r2"
	+ using r01_binary_expression_correct[of r2] assms(3,4)
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+qed
	+
	+text \<open> We first show that \<open>M \<Otimes>\<^sub>M N\<close> is a standard Borel space for standard Borel spaces \<open>M\<close> and \<open>N\<close>.\<close>
	+lemma pair_measurable[measurable]:
	+ assumes "f \<in> X \<rightarrow>\<^sub>M Y"
	+ and "g \<in> X' \<rightarrow>\<^sub>M Y'"
	+ shows "map_prod f g \<in> X \<Otimes>\<^sub>M X' \<rightarrow>\<^sub>M Y \<Otimes>\<^sub>M Y'"
	+ using assms by(auto simp add: measurable_pair_iff)
	+
	+lemma pair_standard_borel_standard:
	+ assumes "standard_borel M"
	+ and "standard_borel N"
	+ shows "standard_borel (M \<Otimes>\<^sub>M N)"
	+proof -
	+ \<comment> \<open> First, define the measurable function $\mathbb{R} \times \mathbb{R} \rightarrow \mathbb{R}$.\<close>
	+ define rr_to_r :: "real \<times> real \<Rightarrow> real"
	+ where "rr_to_r \<equiv> real_to_01open_inverse \<circ> r01_r01_to_r01 \<circ> (\<lambda>(x,y). (real_to_01open x, real_to_01open y))"
	+ \<comment> \<open> $\mathbb{R}\times\mathbb{R} \rightarrow (0,1)\times(0,1) \rightarrow (0,1) \rightarrow \mathbb{R}$.\<close>
	+ have 1[measurable]: "rr_to_r \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M real_borel"
	+ proof -
	+ have "(\<lambda>(x,y). (real_to_01open x, real_to_01open y)) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M real_borel \<Otimes>\<^sub>M real_borel"
	+ using borel_measurable_continuous_onI[OF real_to_01open_continuous]
	+ by simp
	+ from measurable_restrict_space2[OF _ this,of "{0<..<1}\<times>{0<..<1}"]
	+ have [measurable]:"(\<lambda>(x,y). (real_to_01open x, real_to_01open y)) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M restrict_space (real_borel \<Otimes>\<^sub>M real_borel) ({0<..<1}\<times>{0<..<1})"
	+ by(simp add: split_beta' real_to_01open_01)
	+ have [measurable]: "r01_r01_to_r01 \<in> restrict_space (real_borel \<Otimes>\<^sub>M real_borel) ({0<..<1}\<times>{0<..<1}) \<rightarrow>\<^sub>M restrict_space real_borel {0<..<1}"
	+ using r01_r01_to_r01_image' by(auto intro!: measurable_restrict_space3[OF r01_r01_to_r01_measurable])
	+ thus ?thesis
	+ using borel_measurable_continuous_on_restrict[OF real_to_01open_inverse_continuous]
	+ by(simp add: rr_to_r_def)
	+ qed
	+ \<comment> \<open> Next, define the measurable function $\mathbb{R}\rightarrow \mathbb{R}\times\mathbb{R}$.\<close>
	+ define r_to_01 :: "real \<Rightarrow> real"
	+ where "r_to_01 \<equiv> (\<lambda>r. if r \<in> real_to_01open -` (r01_to_r01_r01 -` ({0<..<1}\<times>{0<..<1})) then real_to_01open r else 3/4)"
	+ define r01_to_r01_r01' :: "real \<Rightarrow> real \<times> real"
	+ where "r01_to_r01_r01' \<equiv> (\<lambda>r. if r \<in> r01_to_r01_r01 -` ({0<..<1}\<times>{0<..<1}) then r01_to_r01_r01 r else (1/2,1/2))"
	+ define r_to_rr :: "real \<Rightarrow> real \<times> real"
	+ where "r_to_rr \<equiv> (\<lambda>(x,y). (real_to_01open_inverse x, real_to_01open_inverse y)) \<circ> r01_to_r01_r01' \<circ> r_to_01"
	+ \<comment> \<open> $\mathbb{R} \rightarrow (0,1) \rightarrow (0,1)\times(0,1) \rightarrow \mathbb{R}\times\mathbb{R}$.\<close>
	+ have 2[measurable]: "r_to_rr \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Otimes>\<^sub>M real_borel"
	+ proof -
	+ have 1: "{0<..<1}\<times>{0<..<1} \<in> sets (restrict_space (real_borel \<Otimes>\<^sub>M real_borel) ({0..1}\<times>{0..1}))"
	+ by(auto simp: sets_restrict_space_iff)
	+ have 2[measurable]: "real_to_01open \<in> real_borel \<rightarrow>\<^sub>M restrict_space real_borel {0<..<1}"
	+ using measurable_restrict_space2[OF _ borel_measurable_continuous_onI[OF real_to_01open_continuous] ,of "{0<..<1}"]
	+ by(simp add: real_to_01open_01)
	+ have 3: "real_to_01open -` space (restrict_space real_borel {0<..<1}) = UNIV"
	+ using real_to_01open_01 by auto
	+ have "r01_to_r01_r01 \<in> restrict_space real_borel {0<..<1} \<rightarrow>\<^sub>M restrict_space (real_borel \<Otimes>\<^sub>M real_borel) ({0..1}\<times>{0..1})"
	+ using r01_to_r01_r01_image measurable_restrict_space3[OF r01_to_r01_r01_measurable] by simp
	+ note 4 = measurable_sets[OF this 1]
	+ note 5 = measurable_sets[OF 2 4,simplified vimage_Int 3,simplified]
	+ have [measurable]:"r_to_01 \<in> real_borel \<rightarrow>\<^sub>M restrict_space real_borel {0<..<1}"
	+ unfolding r_to_01_def
	+ by(rule measurable_If_set) (auto intro!: measurable_restrict_space2 simp: 5)
	+ have [measurable]: "r01_to_r01_r01' \<in> restrict_space real_borel {0<..<1} \<rightarrow>\<^sub>M restrict_space (real_borel \<Otimes>\<^sub>M real_borel) ({0<..<1}\<times>{0<..<1})"
	+ using 4 r01_to_r01_r01_measurable
	+ by(auto intro!: measurable_restrict_space3 simp: r01_to_r01_r01'_def)
	+ have [measurable]: "(\<lambda>(x,y). (real_to_01open_inverse x, real_to_01open_inverse y)) \<in> restrict_space (real_borel \<Otimes>\<^sub>M real_borel) ({0<..<1}\<times>{0<..<1}) \<rightarrow>\<^sub>M real_borel \<Otimes>\<^sub>M real_borel"
	+ using borel_measurable_continuous_on_restrict[OF continuous_on_Pair[OF continuous_on_compose[of "{0<..<1::real}\<times>{0<..<1::real}",OF continuous_on_fst[OF continuous_on_id'],simplified,OF real_to_01open_inverse_continuous] continuous_on_compose[of "{0<..<1::real}\<times>{0<..<1::real}",OF continuous_on_snd[OF continuous_on_id'],simplified,OF real_to_01open_inverse_continuous]]]
	+ by(simp add: split_beta' borel_prod)
	+ show ?thesis
	+ by(simp add: r_to_rr_def)
	+ qed
	+ have 3: "\<And>x. r_to_rr (rr_to_r x) = x"
	+ using r01_to_r01_r01_image r01_r01_to_r01_image r01_r01__r01__r01_r01_id real_to_01open_01 real_to_01open_inverse_correct' fun_cong[OF real_to_01open_inverse_correct]
	+ by(auto simp add: r01_to_r01_r01'_def r_to_01_def comp_def split_beta' r_to_rr_def rr_to_r_def)
	+
	+ interpret s1: standard_borel M by fact
	+ interpret s2: standard_borel N by fact
	+ show ?thesis
	+ by(auto intro!: standard_borelI[where f="rr_to_r \<circ> map_prod s1.f s2.f" and g="map_prod s1.g s2.g \<circ> r_to_rr"] simp: 3 space_pair_measure)
	+qed
	+
	+lemma pair_standard_borel_spaceUNIV:
	+ assumes "standard_borel_space_UNIV M"
	+ and "standard_borel_space_UNIV N"
	+ shows "standard_borel_space_UNIV (M \<Otimes>\<^sub>M N)"
	+ apply(rule standard_borel_space_UNIVI')
	+ using assms pair_standard_borel_standard[of M N]
	+ by(auto simp add: standard_borel_space_UNIV_def standard_borel_space_UNIV_axioms_def space_pair_measure)
	+
	+
	+locale pair_standard_borel = s1: standard_borel M + s2: standard_borel N
	+ for M :: "'a measure" and N :: "'b measure"
	+begin
	+
	+sublocale standard_borel "M \<Otimes>\<^sub>M N"
	+ by(auto intro!: pair_standard_borel_standard)
	+
	+end
	+
	+locale pair_standard_borel_space_UNIV = s1: standard_borel_space_UNIV M + s2: standard_borel_space_UNIV N
	+ for M :: "'a measure" and N :: "'b measure"
	+begin
	+
	+sublocale pair_standard_borel M N
	+ by standard
	+
	+sublocale standard_borel_space_UNIV "M \<Otimes>\<^sub>M N"
	+ by(auto intro!: pair_standard_borel_spaceUNIV
	+ simp: s1.standard_borel_space_UNIV_axioms s2.standard_borel_space_UNIV_axioms)
	+
	+end
	+
	+
	+text \<open>$\mathbb{R}\times\mathbb{R}$ is a standard Borel space.\<close>
	+interpretation real_real : pair_standard_borel_space_UNIV real_borel real_borel
	+ by(auto intro!: pair_standard_borel_spaceUNIV simp: real.standard_borel_space_UNIV_axioms pair_standard_borel_space_UNIV_def)
	+
	+subsection \<open> $\mathbb{N}\times\mathbb{R}$ \<close>
	+text \<open> $\mathbb{N}\times\mathbb{R}$ is a standard Borel space. \<close>
	+interpretation nat_real: pair_standard_borel_space_UNIV nat_borel real_borel
	+ by(auto intro!: pair_standard_borel_spaceUNIV
	+ simp: real.standard_borel_space_UNIV_axioms nat.standard_borel_space_UNIV_axioms pair_standard_borel_space_UNIV_def)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/document/root.bib b/thys/Quasi_Borel_Spaces/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/document/root.bib
	@@ -0,0 +1,14 @@
	+@inproceedings{
	+ Heunen_2017,
	+ author = {Heunen, Chris and Kammar, Ohad and Staton, Sam and Yang, Hongseok},
	+ title = {A Convenient Category for Higher-Order Probability Theory},
	+ year = {2017},
	+ isbn = {9781509030187},
	+ publisher = {IEEE Press},
	+ abstract = {Higher-order probabilistic programming languages allow programmers to write sophisticated models in machine learning and statistics in a succinct and structured way, but step outside the standard measure-theoretic formalization of probability theory. Programs may use both higher-order functions and continuous distributions, or even define a probability distribution on functions. But standard probability theory does not handle higher-order functions well: the category of measurable spaces is not cartesian closed.Here we introduce quasi-Borel spaces. We show that these spaces: form a new formalization of probability theory replacing measurable spaces; form a cartesian closed category and so support higher-order functions; form a well-pointed category and so support good proof principles for equational reasoning; and support continuous probability distributions. We demonstrate the use of quasi-Borel spaces for higher-order functions and probability by: showing that a well-known construction of probability theory involving random functions gains a cleaner expression; and generalizing de Finetti's theorem, that is a crucial theorem in probability theory, to quasi-Borel spaces.},
	+ booktitle = {Proceedings of the 32nd Annual ACM/IEEE Symposium on Logic in Computer Science},
	+ articleno = {77},
	+ numpages = {12},
	+ location = {Reykjav\'{\i}k, Iceland},
	+ series = {LICS '17}
	+}
	\ No newline at end of file
	diff --git a/thys/Quasi_Borel_Spaces/document/root.tex b/thys/Quasi_Borel_Spaces/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Quasi_Borel_Spaces/document/root.tex
	@@ -0,0 +1,75 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+
	+% further packages required for unusual symbols (see also
	+% isabellesym.sty), use only when needed
	+
	+\usepackage{amssymb}
	+ %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
	+ %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
	+ %\<triangleq>, \<yen>, \<lozenge>
	+
	+%\usepackage{eurosym}
	+ %for \<euro>
	+
	+%\usepackage[only,bigsqcap]{stmaryrd}
	+ %for \<Sqinter>
	+
	+%\usepackage{eufrak}
	+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
	+
	+%\usepackage{textcomp}
	+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
	+ %\<currency>
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+% for uniform font size
	+%\renewcommand{\isastyle}{\isastyleminor}
	+
	+
	+\begin{document}
	+
	+\title{Quasi-Borel Spaces}
	+\author{Michikazu Hirata, Yasuhiko Minamide, Tetsuya Sato}
	+\maketitle
	+
	+\begin{abstract}
	+ The notion of quasi-Borel spaces was introduced by Heunen et al.~\cite{Heunen_2017}.
	+ The theory provides a suitable denotational model
	+ for higher-order probabilistic programming languages with continuous distributions.
	+
	+ This entry is a formalization of the theory of quasi-Borel spaces, including
	+ construction of quasi-Borel spaces (product, coproduct, function spaces),
	+ the adjunction between the category of measurable spaces and the category of quasi-Borel spaces,
	+ and the probability monad on quasi-Borel spaces.
	+ This entry also contains the formalization of the Bayesian regression presented in the work of Heunen et al.
	+
	+ This work is a part of the work by same authors,
	+ \textit{Program Logic for Higher-Order Probabilistic Programs in Isabelle/HOL},
	+ which will be published in proceedings of the 16th International Symposium on Functional and Logic Programming (FLOPS 2022).
	+\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/ROOTS b/thys/ROOTS
	--- a/thys/ROOTS
	+++ b/thys/ROOTS
	@@ -1,652 +1,666 @@
	ADS_Functor
	AI_Planning_Languages_Semantics
	AODV
	AVL-Trees
	AWN
	Abortable_Linearizable_Modules
	Abs_Int_ITP2012
	Abstract-Hoare-Logics
	Abstract-Rewriting
	Abstract_Completeness
	Abstract_Soundness
	+Actuarial_Mathematics
	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
	BD_Security_Compositional
	BNF_CC
	BNF_Operations
	BTree
	Banach_Steinhaus
	Belief_Revision
	Bell_Numbers_Spivey
	BenOr_Kozen_Reif
	Berlekamp_Zassenhaus
	Bernoulli
	Bertrands_Postulate
	Bicategory
	BinarySearchTree
	Binding_Syntax_Theory
	Binomial-Heaps
	Binomial-Queues
	BirdKMP
	Blue_Eyes
	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
	CSP_RefTK
	CYK
	CZH_Elementary_Categories
	CZH_Foundations
	CZH_Universal_Constructions
	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
	CoCon
	CoSMeDis
	CoSMed
	CofGroups
	Coinductive
	Coinductive_Languages
	Collections
	Combinatorics_Words
	Combinatorics_Words_Graph_Lemma
	Combinatorics_Words_Lyndon
	Comparison_Sort_Lower_Bound
	Compiling-Exceptions-Correctly
	Complete_Non_Orders
	Completeness
	Complex_Bounded_Operators
	Complex_Geometry
	Complx
	ComponentDependencies
	ConcurrentGC
	ConcurrentIMP
	Concurrent_Ref_Alg
	Concurrent_Revisions
	Conditional_Simplification
	Conditional_Transfer_Rule
	Consensus_Refined
	Constructive_Cryptography
	Constructive_Cryptography_CM
	Constructor_Funs
	Containers
	CoreC++
	Core_DOM
	Core_SC_DOM
	Correctness_Algebras
	Count_Complex_Roots
	CryptHOL
	CryptoBasedCompositionalProperties
	Cubic_Quartic_Equations
	DFS_Framework
	DOM_Components
	DPT-SAT-Solver
	DataRefinementIBP
	Datatype_Order_Generator
	Decl_Sem_Fun_PL
	Decreasing-Diagrams
	Decreasing-Diagrams-II
	Deep_Learning
	Delta_System_Lemma
	Density_Compiler
	Dependent_SIFUM_Refinement
	Dependent_SIFUM_Type_Systems
	Depth-First-Search
	Derangements
	Deriving
	Descartes_Sign_Rule
	Design_Theory
	Dict_Construction
	Differential_Dynamic_Logic
	Differential_Game_Logic
	Dijkstra_Shortest_Path
	Diophantine_Eqns_Lin_Hom
	Dirichlet_L
	Dirichlet_Series
	DiscretePricing
	Discrete_Summation
	DiskPaxos
	Dominance_CHK
	DynamicArchitectures
	Dynamic_Tables
	E_Transcendental
	Echelon_Form
	EdmondsKarp_Maxflow
	Efficient-Mergesort
	Elliptic_Curves_Group_Law
	Encodability_Process_Calculi
	Epistemic_Logic
	+Equivalence_Relation_Enumeration
	Ergodic_Theory
	Error_Function
	Euler_MacLaurin
	Euler_Partition
	+Eval_FO
	Example-Submission
	Extended_Finite_State_Machine_Inference
	Extended_Finite_State_Machines
	FFT
	FLP
	FOL-Fitting
	FOL_Axiomatic
	FOL_Harrison
	FOL_Seq_Calc1
	+FOL_Seq_Calc2
	Factor_Algebraic_Polynomial
	Factored_Transition_System_Bounding
	Falling_Factorial_Sum
	Farkas
	FeatherweightJava
	Featherweight_OCL
	Fermat3_4
	FileRefinement
	FinFun
	Finger-Trees
	Finite-Map-Extras
	Finite_Automata_HF
	Finitely_Generated_Abelian_Groups
	First_Order_Terms
	First_Welfare_Theorem
	Fishburn_Impossibility
	Fisher_Yates
	Flow_Networks
	Floyd_Warshall
	Flyspeck-Tame
	FocusStreamsCaseStudies
	Forcing
	Formal_Puiseux_Series
	Formal_SSA
	Formula_Derivatives
	Foundation_of_geometry
	Fourier
	+FO_Theory_Rewriting
	Free-Boolean-Algebra
	Free-Groups
	Fresh_Identifiers
	FunWithFunctions
	FunWithTilings
	Functional-Automata
	Functional_Ordered_Resolution_Prover
	Furstenberg_Topology
	GPU_Kernel_PL
	Gabow_SCC
	GaleStewart_Games
	Gale_Shapley
	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
	Goedel_HFSet_Semantic
	Goedel_HFSet_Semanticless
	Goedel_Incompleteness
	Goodstein_Lambda
	GraphMarkingIBP
	Graph_Saturation
	Graph_Theory
	Green
	Groebner_Bases
	Groebner_Macaulay
	Gromov_Hyperbolicity
	Grothendieck_Schemes
	Group-Ring-Module
	HOL-CSP
	HOLCF-Prelude
	HRB-Slicing
	Hahn_Jordan_Decomposition
	Heard_Of
	Hello_World
	HereditarilyFinite
	Hermite
	Hermite_Lindemann
	Hidden_Markov_Models
	Higher_Order_Terms
	Hoare_Time
	Hood_Melville_Queue
	HotelKeyCards
	Huffman
	Hybrid_Logic
	Hybrid_Multi_Lane_Spatial_Logic
	Hybrid_Systems_VCs
	HyperCTL
	Hyperdual
	IEEE_Floating_Point
	IFC_Tracking
	IMAP-CRDT
	IMO2019
	IMP2
	IMP2_Binary_Heap
	IMP_Compiler
	IP_Addresses
	Imperative_Insertion_Sort
	Impossible_Geometry
	Incompleteness
	Incredible_Proof_Machine
	Inductive_Confidentiality
	Inductive_Inference
	InfPathElimination
	InformationFlowSlicing
	InformationFlowSlicing_Inter
	Integration
	+Interpolation_Polynomials_HOL_Algebra
	Interpreter_Optimizations
	Interval_Arithmetic_Word32
	Intro_Dest_Elim
	Iptables_Semantics
	Irrational_Series_Erdos_Straus
	Irrationality_J_Hancl
	+Irrationals_From_THEBOOK
	IsaGeoCoq
	Isabelle_C
	Isabelle_Marries_Dirac
	Isabelle_Meta_Model
	Jacobson_Basic_Algebra
	Jinja
	JinjaDCI
	JinjaThreads
	JiveDataStoreModel
	Jordan_Hoelder
	Jordan_Normal_Form
	KAD
	KAT_and_DRA
	KBPs
	KD_Tree
	Key_Agreement_Strong_Adversaries
	Kleene_Algebra
	Knights_Tour
	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
	Lam-ml-Normalization
	LambdaAuth
	LambdaMu
	Lambda_Free_EPO
	Lambda_Free_KBOs
	Lambda_Free_RPOs
	Lambert_W
	Landau_Symbols
	Laplace_Transform
	Latin_Square
	LatticeProperties
	Launchbury
	Laws_of_Large_Numbers
	Lazy-Lists-II
	Lazy_Case
	Lehmer
	Lifting_Definition_Option
	Lifting_the_Exponent
	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
	Logging_Independent_Anonymity
	Lowe_Ontological_Argument
	Lower_Semicontinuous
	Lp
	+LP_Duality
	Lucas_Theorem
	MDP-Algorithms
	MDP-Rewards
	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_Method
	Median_Of_Medians_Selection
	Menger
	Mereology
	Mersenne_Primes
	Metalogic_ProofChecker
	MiniML
	MiniSail
	Minimal_SSA
	Minkowskis_Theorem
	Minsky_Machines
	Modal_Logics_for_NTS
	Modular_Assembly_Kit_Security
	Modular_arithmetic_LLL_and_HNF_algorithms
	Monad_Memo_DP
	Monad_Normalisation
	MonoBoolTranAlgebra
	MonoidalCategory
	Monomorphic_Monad
	MuchAdoAboutTwo
	Multi_Party_Computation
	Multirelations
	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
	Optics
	Optimal_BST
	Orbit_Stabiliser
	Order_Lattice_Props
	Ordered_Resolution_Prover
	Ordinal
	Ordinal_Partitions
	Ordinals_and_Cardinals
	Ordinary_Differential_Equations
	PAC_Checker
	PAL
	PCF
	PLM
	POPLmark-deBruijn
	PSemigroupsConvolution
	Padic_Ints
	Pairing_Heap
	Paraconsistency
	Parity_Game
	Partial_Function_MR
	Partial_Order_Reduction
	Password_Authentication_Protocol
	Pell
	Perfect-Number-Thm
	Perron_Frobenius
	Physical_Quantities
	Pi_Calculus
	Pi_Transcendental
	Planarity_Certificates
	Poincare_Bendixson
	Poincare_Disc
	Polynomial_Factorization
	Polynomial_Interpolation
	Polynomials
	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
	Progress_Tracking
	Projective_Geometry
	Projective_Measurements
	Promela
	Proof_Strategy_Language
	PropResPI
	Propositional_Proof_Systems
	Prpu_Maxflow
	PseudoHoops
	Psi_Calculi
	Ptolemys_Theorem
	Public_Announcement_Logic
	QHLProver
	QR_Decomposition
	Quantales
	+Quasi_Borel_Spaces
	Quaternions
	Quick_Sort_Cost
	RIPEMD-160-SPARK
	ROBDD
	RSAPSS
	Ramsey-Infinite
	Random_BSTs
	Random_Graph_Subgraph_Threshold
	Randomised_BSTs
	Randomised_Social_Choice
	Rank_Nullity_Theorem
	Real_Impl
	Real_Power
	Recursion-Addition
	Recursion-Theory-I
	Refine_Imperative_HOL
	Refine_Monadic
	RefinementReactive
	Regex_Equivalence
	Registers
	Regression_Test_Selection
	Regular-Sets
	Regular_Algebras
	Regular_Tree_Relations
	Relation_Algebra
	Relational-Incorrectness-Logic
	Relational_Disjoint_Set_Forests
	Relational_Forests
	Relational_Method
	Relational_Minimum_Spanning_Trees
	Relational_Paths
	Rep_Fin_Groups
	Residuated_Lattices
	Resolution_FOL
	Rewriting_Z
	Ribbon_Proofs
	Robbins-Conjecture
	Robinson_Arithmetic
	Root_Balanced_Tree
	Roth_Arithmetic_Progressions
	Routing
	Roy_Floyd_Warshall
	SATSolverVerification
	SC_DOM_Components
	SDS_Impossibility
	SIFPL
	SIFUM_Type_Systems
	SPARCv8
	Safe_Distance
	Safe_OCL
	Saturation_Framework
	Saturation_Framework_Extensions
	Schutz_Spacetime
	Secondary_Sylow
	Security_Protocol_Refinement
	Selection_Heap_Sort
	SenSocialChoice
	Separata
	Separation_Algebra
	Separation_Logic_Imperative_HOL
	SequentInvertibility
	Shadow_DOM
	Shadow_SC_DOM
	Shivers-CFA
	ShortestPath
	Show
	Sigma_Commit_Crypto
	Signature_Groebner
	Simpl
	Simple_Firewall
	Simplex
	Simplicial_complexes_and_boolean_functions
	SimplifiedOntologicalArgument
	Skew_Heap
	Skip_Lists
	Slicing
	Sliding_Window_Algorithm
	Smith_Normal_Form
	Smooth_Manifolds
	Sort_Encodings
	Source_Coding_Theorem
	SpecCheck
	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
	Sunflowers
	SuperCalc
	Surprise_Paradox
	Symmetric_Polynomials
	Syntax_Independent_Logic
	Szemeredi_Regularity
	Szpilrajn
	TESL_Language
	TLA
	Tail_Recursive_Functions
	Tarskis_Geometry
	Taylor_Models
	Three_Circles
	Timed_Automata
	Topological_Semantics
	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
	Types_To_Sets_Extension
	UPF
	UPF_Firewall
	UTP
	+Universal_Hash_Families
	Universal_Turing_Machine
	UpDown_Scheme
	Valuation
	Van_Emde_Boas_Trees
	Van_der_Waerden
	VectorSpace
	VeriComp
	Verified-Prover
	Verified_SAT_Based_AI_Planning
	VerifyThis2018
	VerifyThis2019
	Vickrey_Clarke_Groves
	Virtual_Substitution
	VolpanoSmith
	+VYDRA_MDL
	WHATandWHERE_Security
	WOOT_Strong_Eventual_Consistency
	WebAssembly
	Weight_Balanced_Trees
	Weighted_Path_Order
	Well_Quasi_Orders
	+Wetzels_Problem
	Winding_Number_Eval
	Word_Lib
	WorkerWrapper
	X86_Semantics
	XML
	+Youngs_Inequality
	ZFC_in_HOL
	Zeta_3_Irrational
	Zeta_Function
	pGCL
	diff --git a/thys/Registers/document/root.tex b/thys/Registers/document/root.tex
	--- a/thys/Registers/document/root.tex
	+++ b/thys/Registers/document/root.tex
	@@ -1,57 +1,57 @@
	\documentclass{article}
	\usepackage[a4paper, margin=1in]{geometry}
	\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{Quantum and Classical Registers}
	+\title{Quantum and Classical Registers\thanks{Supported by the ERC consolidator grant CerQuS (819317), the PRG team grant “Secure Quantum Technology” (PRG946) from the Estonian Research Council, and the Estonian Centre of Exellence in IT (EXCITE) funded by ERDF.}}
	\author{Dominique Unruh}
	\maketitle

	\begin{abstract}
	A formalization of the theory of quantum and classical registers as
	developed by Unruh \cite{unruh21registers}. In a nutshell, a
	register refers to a part of a larger memory or system that can be
	accessed independently. Registers can be constructed from other
	registers and several (compatible) registers can be composed. For
	more details, see \cite{unruh21registers}. This formalization
	develops both the generic theory of registers as well as specific
	instantiations for classical and quantum registers.
	\end{abstract}

	\bigskip
	\bigskip

	\begin{quote}
	\textbf{Note:} This document assumes familiarity with the theoretical background developed in \cite{unruh21registers}.
	\cite{unruh21registers} also describes this formalization and mentions some of the design choices and challenges.

	Some of the theories are autogenerated (\textit{Laws\_Classical}, \textit{Laws\_Quantum}, \textit{Laws\_Complement\_Quantum}).
	Use the Python script \textit{instantiate\_laws.py} to recreate them after changing any of the theories starting with \textit{Laws} or \textit{Axioms}.
	See \cite{unruh21registers} for an explanation of this mechanism and the reasons for it.
	\end{quote}

	\tableofcontents

	% sane default for proof documents
	\parindent 0pt\parskip 0.5ex

	% generated text of all theories
	\input{session}

	\bibliographystyle{alpha}
	\bibliography{root}

	\end{document}

	%%% Local Variables:
	%%% mode: latex
	%%% TeX-master: t
	%%% End:
	diff --git a/thys/Roth_Arithmetic_Progressions/Roth_Arithmetic_Progressions.thy b/thys/Roth_Arithmetic_Progressions/Roth_Arithmetic_Progressions.thy
	--- a/thys/Roth_Arithmetic_Progressions/Roth_Arithmetic_Progressions.thy
	+++ b/thys/Roth_Arithmetic_Progressions/Roth_Arithmetic_Progressions.thy
	@@ -1,1862 +1,1668 @@
	section\<open>Roth's Theorem on Arithmetic Progressions\<close>

	theory Roth_Arithmetic_Progressions
	imports Szemeredi_Regularity.Szemeredi
	"Random_Graph_Subgraph_Threshold.Subgraph_Threshold"
	"Ergodic_Theory.Asymptotic_Density"
	"HOL-Library.Ramsey" "HOL-Library.Nat_Bijection"

	begin

	-
	-subsection \<open>For the Library\<close>
	-
	-declare prod_encode_eq [simp]
	-declare prod_decode_eq [simp]
	-
	-lemma mult_mod_cancel_right:
	- fixes m :: "'a::{euclidean_ring_cancel,semiring_gcd}"
	- assumes eq: "(a * n) mod m = (b * n) mod m" and "coprime m n"
	- shows "a mod m = b mod m"
	-proof -
	- have "m dvd (an - bn)"
	- using eq mod_eq_dvd_iff by blast
	- then have "m dvd a-b"
	- by (metis \<open>coprime m n\<close> coprime_dvd_mult_left_iff left_diff_distrib')
	- then show ?thesis
	- using mod_eq_dvd_iff by blast
	-qed
	-
	-lemma mult_mod_cancel_left:
	- fixes m :: "'a::{euclidean_ring_cancel,semiring_gcd}"
	- assumes "(n * a) mod m = (n * b) mod m" and "coprime m n"
	- shows "a mod m = b mod m"
	- by (metis assms mult.commute mult_mod_cancel_right)
	-
	-(Stronger than the one in Szemeredi [now installed in AFP_devel] )
	-lemma edge_density_le1: "edge_density X Y G \<le> 1"
	-proof (cases "finite X \<and> finite Y")
	- case True
	- then show ?thesis
	- using of_nat_mono [OF max_all_edges_between, of X Y]
	- by (fastforce simp add: edge_density_def divide_simps)
	-qed (auto simp: edge_density_def)
	-
	-lemma card_3_iff: "card S = 3 \<longleftrightarrow> (\<exists>x y z. S = {x,y,z} \<and> x \<noteq> y \<and> y \<noteq> z \<and> x \<noteq> z)"
	- by (fastforce simp: card_Suc_eq numeral_eq_Suc)
	-
	subsection \<open>Miscellaneous Preliminaries\<close>

	lemma sum_prod_le_prod_sum:
	fixes a :: "'a \<Rightarrow> 'b::linordered_idom"
	assumes "\<And>i. i \<in> I \<Longrightarrow> a i \<ge> 0 \<and> b i \<ge> 0"
	shows "(\<Sum>i\<in>I. \<Sum>j\<in>I. a i * b j) \<le> (\<Sum>i\<in>I. a i) * (\<Sum>i\<in>I. b i)"
	using assms
	by (induction I rule: infinite_finite_induct) (auto simp add: algebra_simps sum.distrib sum_distrib_left)

	lemma real_mult_gt_cube: "A \<ge> (X ::real) \<Longrightarrow> B \<ge> X \<Longrightarrow> C \<ge> X \<Longrightarrow> X \<ge> 0 \<Longrightarrow> A * B * C \<ge> X^3"
	by (simp add: mult_mono' power3_eq_cube)

	-lemma min_card_fin_X_elem: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> card X \<ge> 1"
	- using card.remove by fastforce
	-
	-lemma card_or_filter_max:
	- assumes "finite A"
	- shows "card {a \<in> A . P a \<or> Q a} \<le> card {a \<in> A . P a} + card {a \<in> A . Q a}"
	-proof -
	- have fin: "finite {a \<in> A . P a}" "finite {a \<in> A . Q a}"
	- by(simp_all add: assms)
	- have equiv: "{a \<in> A . P a \<or> Q a} = {a \<in> A . P a} \<union> {a \<in> A . Q a}" by auto
	- then have "card {a \<in> A . P a} + card {a \<in> A . Q a} = card ({a \<in> A . P a} \<union> {a \<in> A . Q a}) + card ({a \<in> A . P a} \<inter> {a \<in> A . Q a})"
	- using card_Un_Int fin by auto
	- thus ?thesis using equiv
	- by presburger
	-qed
	-
	lemma triple_sigma_rewrite_card:
	assumes "finite X" "finite Y" "finite Z"
	shows "card {(x, y, z) . x \<in> X \<and> (y, z) \<in> Y \<times> Z \<and> P x y z} = (\<Sum>x\<in> X . card {(y,z) \<in> Y \<times> Z. P x y z})"
	proof -
	define W where "W \<equiv> \<lambda>x. {(y,z) \<in> Y \<times> Z. P x y z}"
	have "W x \<subseteq> Y \<times> Z" for x
	by (auto simp: W_def)
	then have [simp]: "finite (W x)" for x
	by (meson assms finite_SigmaI infinite_super)
	have eq: "{(x, y, z) . x \<in> X \<and> (y, z) \<in> Y \<times> Z \<and> P x y z} = (\<Union>x\<in>X. \<Union>(y, z)\<in>W x. {(x,y,z)})"
	by (auto simp: W_def)
	show ?thesis
	unfolding eq by (simp add: disjoint_iff assms card_UN_disjoint) (simp add: W_def)
	qed

	-lemma all_edges_between_Union1:
	- "all_edges_between (Union \<X>) Y G = (\<Union>X\<in>\<X>. all_edges_between X Y G)"
	- by (auto simp: all_edges_between_def)
	-
	-lemma all_edges_between_Union2:
	- "all_edges_between X (Union \<Y>) G = (\<Union>Y\<in>\<Y>. all_edges_between X Y G)"
	- by (auto simp: all_edges_between_def)
	-
	-lemma all_edges_between_disjoint1:
	- assumes "disjoint R"
	- shows "disjoint ((\<lambda>X. all_edges_between X Y G) ` R)"
	- using assms by (auto simp: all_edges_between_def disjoint_def)
	-
	-lemma all_edges_between_disjoint2:
	- assumes "disjoint R"
	- shows "disjoint ((\<lambda>Y. all_edges_between X Y G) ` R)"
	- using assms by (auto simp: all_edges_between_def disjoint_def)
	-
	-lemma all_edges_between_disjoint_family_on1:
	- assumes "disjoint R"
	- shows "disjoint_family_on (\<lambda>X. all_edges_between X Y G) R"
	- by (metis (no_types, lifting) all_edges_between_disjnt1 assms disjnt_def disjoint_family_on_def pairwiseD)
	-
	-lemma all_edges_between_disjoint_family_on2:
	- assumes "disjoint R"
	- shows "disjoint_family_on (\<lambda>Y. all_edges_between X Y G) R"
	- by (metis (no_types, lifting) all_edges_between_disjnt2 assms disjnt_def disjoint_family_on_def pairwiseD)
	-
	lemma all_edges_between_mono1:
	"Y \<subseteq> Z \<Longrightarrow> all_edges_between Y X G \<subseteq> all_edges_between Z X G"
	by (auto simp: all_edges_between_def)

	lemma all_edges_between_mono2:
	"Y \<subseteq> Z \<Longrightarrow> all_edges_between X Y G \<subseteq> all_edges_between X Z G"
	by (auto simp: all_edges_between_def)

	-lemma inj_on_mk_uedge: "X \<inter> Y = {} \<Longrightarrow> inj_on mk_uedge (all_edges_between X Y G)"
	- by (auto simp: inj_on_def doubleton_eq_iff all_edges_between_def)
	-
	-lemma uwellformed_alt:
	- assumes "uwellformed G" "{x, y} \<in> uedges G"
	- shows "{x, y} \<subseteq> uverts G"
	- using uwellformed_def assms by auto
	-
	lemma uwellformed_alt_fst:
	assumes "uwellformed G" "{x, y} \<in> uedges G"
	shows "x \<in> uverts G"
	- using uwellformed_alt assms by simp
	+ using uwellformed_def assms by simp

	lemma uwellformed_alt_snd:
	assumes "uwellformed G" "{x, y} \<in> uedges G"
	shows "y \<in> uverts G"
	- using uwellformed_alt assms by simp
	+ using uwellformed_def assms by simp

	lemma all_edges_between_subset_times: "all_edges_between X Y G \<subseteq> (X \<inter> \<Union>(uedges G)) \<times> (Y \<inter> \<Union>(uedges G))"
	by (auto simp: all_edges_between_def)

	lemma finite_all_edges_between':
	assumes "finite (uverts G)" "uwellformed G"
	shows "finite (all_edges_between X Y G)"
	proof -
	have "finite (\<Union>(uedges G))"
	by (meson Pow_iff all_edges_subset_Pow assms finite_Sup subsetD wellformed_all_edges)
	with all_edges_between_subset_times show ?thesis
	by (metis finite_Int finite_SigmaI finite_subset)
	qed

	-lemma card_all_edges_between:
	- assumes "finite Y" "finite (uverts G)" "uwellformed G"
	- shows "card (all_edges_between X Y G) = (\<Sum>y\<in>Y. card (all_edges_between X {y} G))"
	-proof -
	- have "all_edges_between X Y G = (\<Union>y\<in>Y. all_edges_between X {y} G)"
	- by (auto simp: all_edges_between_def)
	- moreover have "disjoint_family_on (\<lambda>y. all_edges_between X {y} G) Y"
	- unfolding disjoint_family_on_def
	- by (auto simp: disjoint_family_on_def all_edges_between_def)
	- ultimately show ?thesis
	- by (simp add: card_UN_disjoint' assms finite_all_edges_between')
	-qed
	-
	lemma max_edges_graph:
	assumes "uwellformed G" "finite (uverts G)"
	shows "card (uedges G) \<le> (card (uverts G))^2"
	proof -
	have "card (uedges G) \<le> card (uverts G) choose 2"
	by (metis all_edges_finite assms card_all_edges card_mono wellformed_all_edges)
	thus ?thesis
	by (metis binomial_le_pow le0 neq0_conv order.trans zero_less_binomial_iff)
	qed

	lemma all_edges_between_ss_uedges: "mk_uedge ` (all_edges_between X Y G) \<subseteq> uedges G"
	by (auto simp: all_edges_between_def)

	-lemma all_edges_betw_D1: "(x, y) \<in> all_edges_between X Y G \<Longrightarrow> x \<in> X"
	- by (simp add: all_edges_between_def)
	-
	-lemma all_edges_betw_D2: "(x, y) \<in> all_edges_between X Y G \<Longrightarrow> y \<in> Y"
	- by (simp add: all_edges_between_def)
	-
	lemma all_edges_betw_D3: "(x, y) \<in> all_edges_between X Y G \<Longrightarrow> {x, y} \<in> uedges G"
	by (simp add: all_edges_between_def)

	lemma all_edges_betw_I: "x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> {x, y} \<in> uedges G \<Longrightarrow> (x, y) \<in> all_edges_between X Y G"
	by (simp add: all_edges_between_def)

	lemma all_edges_between_E_diff:
	"all_edges_between X Y (V,E-E') = all_edges_between X Y (V,E) - all_edges_between X Y (V,E')"
	by (auto simp: all_edges_between_def)

	lemma all_edges_between_E_Un:
	"all_edges_between X Y (V,E\<union>E') = all_edges_between X Y (V,E) \<union> all_edges_between X Y (V,E')"
	by (auto simp: all_edges_between_def)

	lemma all_edges_between_E_UN:
	"all_edges_between X Y (V, \<Union>i\<in>I. E i) = (\<Union>i\<in>I. all_edges_between X Y (V,E i))"
	by (auto simp: all_edges_between_def)

	-lemma all_edges_betw_prod_def: "all_edges_between X Y G = {(x, y) \<in> X \<times> Y . {x, y} \<in> uedges G}"
	- by (simp add: all_edges_between_def)
	-
	-thm in_mk_uedge_img
	-lemma in_mk_uedge_img_iff: "{a,b} \<in> mk_uedge ` A \<longleftrightarrow> (a,b) \<in> A \<or> (b,a) \<in> A"
	- by (auto simp: doubleton_eq_iff intro: rev_image_eqI)
	-
	lemma all_edges_preserved: "\<lbrakk>all_edges_between A B G' = all_edges_between A B G; X \<subseteq> A; Y \<subseteq> B\<rbrakk>
	\<Longrightarrow> all_edges_between X Y G' = all_edges_between X Y G"
	by (auto simp: all_edges_between_def)

	lemma subgraph_edge_wf:
	assumes "uwellformed G" "uverts H = uverts G" "uedges H \<subseteq> uedges G"
	shows "uwellformed H"
	by (metis assms subsetD uwellformed_def)


	subsection \<open>Preliminaries on Neighbors in Graphs\<close>

	-
	definition neighbor_in_graph:: " uvert \<Rightarrow> uvert \<Rightarrow> ugraph \<Rightarrow> bool"
	where "neighbor_in_graph x y G \<equiv> (x \<in> (uverts G) \<and> y \<in> (uverts G) \<and> {x,y} \<in> (uedges G))"

	definition neighbors :: "uvert \<Rightarrow> ugraph \<Rightarrow> uvert set" where
	"neighbors x G \<equiv> {y \<in> uverts G . neighbor_in_graph x y G}"

	definition neighbors_ss:: "uvert \<Rightarrow> uvert set \<Rightarrow> ugraph \<Rightarrow> uvert set" where
	"neighbors_ss x Y G \<equiv> {y \<in> Y . neighbor_in_graph x y G}"

	-
	-lemma all_edges_betw_prod_def_neighbors: "uwellformed G \<Longrightarrow>
	- all_edges_between X Y G = {(x, y) \<in> X \<times> Y . neighbor_in_graph x y G}"
	- by (auto simp: neighbor_in_graph_def uwellformed_alt_fst uwellformed_alt_snd all_edges_between_def)
	-
	lemma all_edges_betw_sigma_neighbor:
	"uwellformed G \<Longrightarrow> all_edges_between X Y G = (SIGMA x:X. neighbors_ss x Y G)"
	by (auto simp add: all_edges_between_def neighbors_ss_def neighbor_in_graph_def
	uwellformed_alt_fst uwellformed_alt_snd)

	lemma card_all_edges_betw_neighbor:
	assumes "finite X" "finite Y" "uwellformed G"
	shows "card (all_edges_between X Y G) = (\<Sum>x\<in>X. card (neighbors_ss x Y G))"
	using all_edges_betw_sigma_neighbor assms by (simp add: neighbors_ss_def)


	-
	subsection \<open>Preliminaries on Triangles in Graphs\<close>

	-
	definition triangle_in_graph:: "uvert \<Rightarrow> uvert \<Rightarrow> uvert \<Rightarrow> ugraph \<Rightarrow> bool"
	where "triangle_in_graph x y z G
	\<equiv> ({x,y} \<in> uedges G) \<and> ({y,z} \<in> uedges G) \<and> ({x,z} \<in> uedges G)"

	definition triangle_triples
	where "triangle_triples X Y Z G \<equiv> {(x,y,z) \<in> X \<times> Y \<times> Z. triangle_in_graph x y z G}"

	-lemma card_triangle_triples_rotate: "card (triangle_triples X Y Z G) = card (triangle_triples Y Z X G)"
	-proof -
	- have "triangle_triples Y Z X G = (\<lambda>(x,y,z). (y,z,x)) ` triangle_triples X Y Z G"
	- by (auto simp: triangle_triples_def case_prod_unfold image_iff insert_commute triangle_in_graph_def)
	- moreover have "inj_on (\<lambda>(x, y, z). (y, z, x)) (triangle_triples X Y Z G)"
	- by (auto simp: inj_on_def)
	- ultimately show ?thesis
	- by (simp add: card_image)
	-qed
	-
	lemma triangle_commu1:
	assumes "triangle_in_graph x y z G"
	shows "triangle_in_graph y x z G"
	using assms triangle_in_graph_def by (auto simp add: insert_commute)

	lemma triangle_vertices_distinct1:
	assumes wf: "uwellformed G"
	assumes tri: "triangle_in_graph x y z G"
	shows "x \<noteq> y"
	proof (rule ccontr)
	assume a: "\<not> x \<noteq> y"
	have "card {x, y} = 2" using tri wf triangle_in_graph_def
	using uwellformed_def by blast
	thus False using a by simp
	qed

	lemma triangle_vertices_distinct2:
	assumes "uwellformed G" "triangle_in_graph x y z G"
	shows "y \<noteq> z"
	by (metis assms triangle_vertices_distinct1 triangle_in_graph_def)

	-lemma triangle_vertices_distinct3:
	- assumes "uwellformed G" "triangle_in_graph x y z G"
	- shows "z \<noteq> x"
	- by (metis assms triangle_vertices_distinct1 triangle_in_graph_def)
	-
	lemma triangle_in_graph_edge_point:
	assumes "uwellformed G"
	shows "triangle_in_graph x y z G \<longleftrightarrow> {y, z} \<in> uedges G \<and> neighbor_in_graph x y G \<and> neighbor_in_graph x z G"
	by (auto simp add: triangle_in_graph_def neighbor_in_graph_def assms uwellformed_alt_fst uwellformed_alt_snd)

	definition
	"unique_triangles G
	\<equiv> \<forall>e \<in> uedges G. \<exists>!T. \<exists>x y z. T = {x,y,z} \<and> triangle_in_graph x y z G \<and> e \<subseteq> T"

	definition triangle_free_graph:: "ugraph \<Rightarrow> bool"
	where "triangle_free_graph G \<equiv> \<not>(\<exists> x y z. triangle_in_graph x y z G )"

	lemma triangle_free_graph_empty: "uedges G = {} \<Longrightarrow> triangle_free_graph G"
	by (simp add: triangle_free_graph_def triangle_in_graph_def)

	lemma edge_vertices_not_equal:
	assumes "uwellformed G" "{x,y} \<in> uedges G"
	shows "x \<noteq> y"
	using assms triangle_in_graph_def triangle_vertices_distinct1 by blast

	-lemma edge_btw_vertices_not_equal:
	- assumes "uwellformed G" "(x, y) \<in> all_edges_between X Y G"
	- shows "x \<noteq> y"
	- using edge_vertices_not_equal all_edges_between_def
	- by (metis all_edges_betw_D3 assms)
	-
	-lemma mk_triangle_from_ss_edges:
	-assumes "(x, y) \<in> all_edges_between X Y G" and "(x, z) \<in> all_edges_between X Z G" and "(y, z) \<in> all_edges_between Y Z G"
	-shows "(triangle_in_graph x y z G)"
	- by (meson all_edges_betw_D3 assms triangle_in_graph_def)
	-
	lemma triangle_in_graph_verts:
	- assumes "uwellformed G"
	- assumes "triangle_in_graph x y z G"
	+ assumes "uwellformed G" "triangle_in_graph x y z G"
	shows "x \<in> uverts G" "y \<in> uverts G" "z\<in> uverts G"
	proof -
	have 1: "{x, y} \<in> uedges G" using triangle_in_graph_def
	using assms(2) by auto
	then show "x \<in> uverts G" using uwellformed_alt_fst assms by blast
	then show "y \<in> uverts G" using 1 uwellformed_alt_snd assms by blast
	have "{x, z} \<in> uedges G" using triangle_in_graph_def assms(2) by auto
	then show "z \<in> uverts G" using uwellformed_alt_snd assms by blast
	qed


	definition triangle_set :: "ugraph \<Rightarrow> uvert set set"
	where "triangle_set G \<equiv> { {x,y,z} \| x y z. triangle_in_graph x y z G}"

	-
	fun mk_triangle_set :: "(uvert \<times> uvert \<times> uvert) \<Rightarrow> uvert set"
	where "mk_triangle_set (x, y, z) = {x,y,z}"

	-lemma convert_triangle_rep_ss:
	- fixes G :: "ugraph"
	- assumes "X \<subseteq> uverts G" and "Y \<subseteq> uverts G" and "Z \<subseteq> uverts G"
	- shows "mk_triangle_set ` {(x, y, z) \<in> X \<times> Y \<times> Z . (triangle_in_graph x y z G)} \<subseteq> triangle_set G"
	- by (auto simp add: subsetI triangle_set_def) (auto)
	-
	-lemma finite_triangle_set:
	- fixes G :: "ugraph"
	+lemma finite_triangle_set:
	assumes fin: "finite (uverts G)" and wf: "uwellformed G"
	shows "finite (triangle_set G)"
	proof -
	have "triangle_set G \<subseteq> Pow (uverts G)"
	using insert_iff local.wf triangle_in_graph_def triangle_set_def uwellformed_def by auto
	then show ?thesis
	by (meson fin finite_Pow_iff infinite_super)
	qed

	lemma card_triangle_3:
	- fixes G :: "ugraph"
	assumes "t \<in> triangle_set G" "uwellformed G"
	shows "card t = 3"
	using assms by (auto simp: triangle_set_def edge_vertices_not_equal triangle_in_graph_def)

	lemma triangle_set_power_set_ss: "uwellformed G \<Longrightarrow> triangle_set G \<subseteq> Pow (uverts G)"
	by (auto simp add: triangle_set_def triangle_in_graph_def uwellformed_alt_fst uwellformed_alt_snd)

	-lemma triangle_set_finite:
	- assumes "finite (uverts G)"
	- assumes "uwellformed G"
	- shows "finite (triangle_set G)"
	- using triangle_set_power_set_ss assms
	- by (meson finite_Pow_iff rev_finite_subset)
	-
	lemma triangle_in_graph_ss:
	fixes G :: "ugraph" and Gnew :: "ugraph"
	assumes "uedges Gnew \<subseteq> uedges G"
	assumes "triangle_in_graph x y z Gnew"
	shows "triangle_in_graph x y z G"
	proof -
	have "{x, y} \<in> uedges G" using assms triangle_in_graph_def by auto
	have "{y, z} \<in> uedges G" using assms triangle_in_graph_def by auto
	have "{x, z} \<in> uedges G" using assms triangle_in_graph_def by auto
	thus ?thesis
	by (simp add: \<open>{x, y} \<in> uedges G\<close> \<open>{y, z} \<in> uedges G\<close> triangle_in_graph_def)
	qed

	lemma triangle_set_graph_edge_ss:
	fixes G :: "ugraph" and Gnew :: "ugraph"
	assumes "uwellformed G"
	assumes "uedges Gnew \<subseteq> uedges G"
	assumes "uverts Gnew = uverts G"
	shows "(triangle_set Gnew) \<subseteq> (triangle_set G)"
	proof (intro subsetI)
	fix t assume "t \<in> triangle_set Gnew"
	then obtain x y z where "t = {x,y,z}" and "triangle_in_graph x y z Gnew"
	using triangle_set_def assms mem_Collect_eq by auto
	then have "triangle_in_graph x y z G" using assms triangle_in_graph_ss by simp
	thus "t \<in> triangle_set G" using triangle_set_def assms
	using \<open>t = {x,y,z}\<close> by auto
	qed

	lemma triangle_set_graph_edge_ss_bound:
	fixes G :: "ugraph" and Gnew :: "ugraph"
	- assumes "uwellformed G"
	- assumes "finite (uverts G)"
	- assumes "uedges Gnew \<subseteq> uedges G"
	- assumes "uverts Gnew = uverts G"
	+ assumes "uwellformed G" "finite (uverts G)" "uedges Gnew \<subseteq> uedges G" "uverts Gnew = uverts G"
	shows "card (triangle_set G) \<ge> card (triangle_set Gnew)"
	- using triangle_set_graph_edge_ss triangle_set_finite
	- by (simp add: assms card_mono)
	+ by (simp add: assms card_mono finite_triangle_set triangle_set_graph_edge_ss)


	subsection \<open>The Triangle Counting Lemma and the Triangle Removal Lemma\<close>

	text\<open>We begin with some more auxiliary material to be used in the main lemmas.\<close>

	lemma regular_pairI:
	fixes \<epsilon> :: real and G :: "ugraph" and X :: "uvert set" and Y ::"uvert set"
	assumes "\<epsilon> > 0" and "regular_pair X Y G \<epsilon>" and xss: "X' \<subseteq> X" and yss: "Y' \<subseteq> Y" and "card X' \<ge> \<epsilon> * card X" and "(card Y' \<ge> \<epsilon> * card Y)"
	shows "\<bar> edge_density X' Y' G - edge_density X Y G \<bar> \<le> \<epsilon>"
	using regular_pair_def assms by meson

	-lemma edge_density_zero: "Y = {} \<Longrightarrow> edge_density X Y G = 0"
	- by (simp add: edge_density_def)
	-
	lemma regular_pair_neighbor_bound:
	fixes \<epsilon>::real
	assumes finG: "finite (uverts G)"
	assumes xss: "X \<subseteq> uverts G" and yss: "Y \<subseteq> uverts G" and "card X > 0"
	and wf: "uwellformed G"
	and eg0: "\<epsilon> > 0" and "regular_pair X Y G \<epsilon>" and ed: "edge_density X Y G \<ge> 2*\<epsilon>"
	shows "card{x \<in> X. card (neighbors_ss x Y G) < (edge_density X Y G - \<epsilon>)* card (Y)} < \<epsilon> * card X"
	(is "card (?X') < \<epsilon> * _")
	proof (cases "?X' = {}")
	case True
	then show ?thesis
	by (simp add: True \<open>card X > 0\<close> eg0)
	next
	case False
	show ?thesis
	proof (rule ccontr)
	assume "\<not> (card (?X') < \<epsilon> * card X) "
	then have a: "(card(?X') \<ge> \<epsilon> * card X) " by simp
	have fin: "finite X" "finite Y" using assms finite_subset by auto
	have ebound: "\<epsilon> \<le> 1/2"
	by (metis ed edge_density_le1 le_divide_eq_numeral1(1) mult.commute order_trans)
	have finx: "finite ?X'" using fin by simp
	have "\<And> x. x \<in> ?X'\<Longrightarrow> (card (neighbors_ss x Y G)) < (edge_density X Y G - \<epsilon>) * (card Y)"
	by blast
	then have "(\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) < (\<Sum>x\<in>?X'. ((edge_density X Y G - \<epsilon>)* (card Y)))"
	using False sum_strict_mono
	by (smt (verit, del_insts) finx of_nat_sum)
	then have upper: "(\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) < (card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y))"
	by (simp add: sum_bounded_above)
	have sumge0: "(\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) \<ge> 0"
	by blast
	have xge0: "card X > 0"
	using fin(1) False by fastforce
	have yge0: "card Y > 0"
	using False by fastforce
	then have xyge0: "card X * card Y > 0" using xge0 by simp
	then have xyne0: "card X * card Y \<noteq> 0" by simp
	have fracg0:"(1/(card ?X' * card Y)) > 0"
	using card_0_eq finx False yge0 by fastforce
	then have upper2: "(1/(card ?X' * card Y)) * (\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) < (1/(card ?X' * card Y)) * (card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y))"
	using upper mult_less_cancel_left_pos[of "(1/(card ?X' * card Y))" "(\<Sum>x\<in>?X'. card (neighbors_ss x Y G))" "(card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y))"]
	by linarith
	have minuse: "(1/(card ?X' * card Y)) * (card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y)) = (edge_density X Y G - \<epsilon>)"
	proof -
	have "(1/(card ?X' * card Y)) * (card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y)) = (1/(card ?X' * card Y)) * ((card ?X')* (card Y))*(edge_density X Y G - \<epsilon>)"
	by (smt (z3) divide_divide_eq_right of_nat_mult times_divide_eq_left)
	also have "\<dots> = ((card ?X'* card Y)/(card ?X' * card Y)) * (edge_density X Y G - \<epsilon>)" by simp
	also have "\<dots> = 1 * (edge_density X Y G - \<epsilon>)"
	using divide_eq_1_iff[of "(card ?X'* card Y)" "(card ?X'* card Y)"] xyne0
	using finx False by force
	finally have "(1/(card ?X' * card Y)) * (card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y)) = (edge_density X Y G - \<epsilon>)" by simp
	thus ?thesis by simp
	qed
	then have edlt1: "(1/(card ?X' * card Y)) * (card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y)) < edge_density X Y G"
	using eg0
	by linarith
	then have edlt2: "(1/(card ?X' * card Y))* (\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) < edge_density X Y G"
	using upper2 by linarith
	then have "\<bar>edge_density X Y G - (1/(card ?X' * card Y))* (\<Sum>x\<in>?X'. card (neighbors_ss x Y G))\<bar> = edge_density X Y G - (1/(card ?X' * card Y))* (\<Sum>x\<in>?X'. card (neighbors_ss x Y G))"
	by linarith
	have "(edge_density X Y G - (1/(card ?X' * card Y))* (\<Sum>x\<in>?X'. card (neighbors_ss x Y G))) > (edge_density X Y G - (1/(card ?X' * card Y)) * (card ?X')* ((edge_density X Y G - \<epsilon>)* (card Y)))"
	using edlt1 edlt2 upper2
	by linarith
	then have "edge_density X Y G - (1/(card ?X' * card Y)) * (\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) > edge_density X Y G - (edge_density X Y G - \<epsilon>)"
	using minuse by linarith
	then have con: "edge_density X Y G - (1/(card ?X' * card Y)) * (\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) > \<epsilon>" by simp
	have ye: "card Y \<ge> \<epsilon> * (card Y)" using ebound by (simp add: yge0)
	have xe': "card ?X' \<ge> \<epsilon> * (card X)" using a by fastforce
	have "?X' \<subseteq> X" by simp
	then have "\<bar> edge_density ?X' Y G - edge_density X Y G \<bar> \<le> \<epsilon>"
	using regular_pairI[of "\<epsilon>" "X" "Y" "G" "?X'" "Y"] assms ye xe' by simp
	then have "\<bar> (card (all_edges_between ?X' Y G))/ (card ?X' * card Y) - edge_density X Y G \<bar> \<le> \<epsilon>"
	by (simp add: edge_density_def)
	then have "\<bar> (1/(card ?X' * card Y)) * (card (all_edges_between ?X' Y G)) - edge_density X Y G \<bar> \<le> \<epsilon>"
	by simp
	then have "\<bar>(1/(card ?X' * card Y)) * (\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) - edge_density X Y G \<bar> \<le> \<epsilon>"
	using card_all_edges_betw_neighbor fin wf by simp
	then have lt: "\<bar>edge_density X Y G - (1/(card ?X' * card Y)) * (\<Sum>x\<in>?X'. card (neighbors_ss x Y G)) \<bar> \<le> \<epsilon>"
	by simp
	thus False using lt con by linarith
	qed (* Following Gowers's proof - more in depth with reasoning on contradiction *)
	qed

	lemma neighbor_set_meets_e_reg_cond:
	fixes \<epsilon>::real
	assumes "X \<subseteq> uverts G" and "Y \<subseteq> uverts G" and enot0: "\<epsilon> > 0"
	and fin: "finite X" "finite Y" and "uwellformed G"
	and rp1: "regular_pair X Y G \<epsilon>"
	and ed1: "edge_density X Y G \<ge> 2*\<epsilon>"
	and "card (neighbors_ss x Y G) \<ge> (edge_density X Y G - \<epsilon>) * card Y"
	shows "card (neighbors_ss x Y G) \<ge> \<epsilon> * card (Y)"
	proof -
	have "card (neighbors_ss x Y G) \<ge> (edge_density X Y G - \<epsilon>) * card Y" using assms by simp
	thus ?thesis
	by (smt (verit, ccfv_SIG) mult_right_mono of_nat_less_0_iff ed1 enot0)
	qed

	-
	lemma all_edges_btwn_neighbour_sets_lower_bound:
	fixes \<epsilon>::real
	assumes "X \<subseteq> uverts G" and "Y \<subseteq> uverts G" and "Z \<subseteq> uverts G" and "\<epsilon> > 0"
	and finG: "finite (uverts G)"
	and wf: "uwellformed G" and fin: "finite X" "finite Y" "finite Z"
	and rp1: "regular_pair X Y G \<epsilon> " and rp2: "regular_pair Y Z G \<epsilon>" and rp3: "regular_pair X Z G \<epsilon>"
	and ed1: "edge_density X Y G \<ge> 2\<epsilon>" and ed2: "edge_density X Z G \<ge> 2\<epsilon>" and ed3: "edge_density Y Z G \<ge> 2*\<epsilon>"
	and cond1: "card (neighbors_ss x Y G) \<ge> (edge_density X Y G - \<epsilon>) * card Y"
	and cond2: "card (neighbors_ss x Z G) \<ge> (edge_density X Z G - \<epsilon>) * card Z"
	and "x \<in> X"
	shows "card (all_edges_between (neighbors_ss x Y G) (neighbors_ss x Z G) G)
	\<ge> (edge_density Y Z G - \<epsilon>) * card (neighbors_ss x Y G) * card (neighbors_ss x Z G)"
	(is "card (all_edges_between ?Y' ?Z' G) \<ge> (edge_density Y Z G - \<epsilon>) * card ?Y' * card ?Z'")
	proof -
	have yss': "?Y' \<subseteq> Y" using neighbors_ss_def by simp
	have zss': "?Z' \<subseteq> Z" using neighbors_ss_def by simp
	have min_sizeY: "card ?Y' \<ge> \<epsilon> * card Y" using neighbor_set_meets_e_reg_cond cond1 assms fin by meson
	have min_sizeZ: "card ?Z' \<ge> \<epsilon> * card Z" using neighbor_set_meets_e_reg_cond cond2 assms fin by meson
	then have "\<bar> edge_density ?Y' ?Z' G - edge_density Y Z G \<bar> \<le> \<epsilon>"
	using min_sizeY regular_pairI[of "\<epsilon>" "Y" "Z" "G" "?Y'" "?Z'"] yss' zss' assms by simp
	then have "-\<epsilon> \<le> ( edge_density ?Y' ?Z' G - edge_density Y Z G)"
	by linarith
	then have "edge_density Y Z G - \<epsilon> \<le> edge_density ?Y' ?Z' G" by linarith
	then have "edge_density Y Z G - \<epsilon> \<le> (card (all_edges_between ?Y' ?Z' G)/(card ?Y' * card ?Z'))" using edge_density_def by simp
	then have "(card ?Y' * card ?Z') * (edge_density Y Z G - \<epsilon>) \<le> (card (all_edges_between ?Y' ?Z' G))"
	by (metis abs_of_nat division_ring_divide_zero le_divide_eq mult_of_nat_commute of_nat_0_le_iff times_divide_eq_right zero_less_abs_iff)
	then show ?thesis
	by (metis (no_types, lifting) ab_semigroup_mult_class.mult_ac(1) mult_of_nat_commute of_nat_mult)
	qed


	-lemma edge_density_implies_edge_exists:
	- fixes \<epsilon>::real
	- assumes "X \<subseteq> uverts G" and "Y \<subseteq> uverts G" and "\<epsilon> > 0" and "uwellformed G"
	- assumes "edge_density X Y G \<ge> \<epsilon>"
	- obtains e where "e \<in> all_edges_between X Y G"
	-proof -
	- have "edge_density X Y G = card (all_edges_between X Y G) / (card X * card Y)" by (simp add: edge_density_def)
	- then have "card (all_edges_between X Y G) \<noteq> 0"
	- using assms divide_eq_0_iff by fastforce
	- thus ?thesis
	- by (metis card.empty empty_subsetI subsetI subset_antisym that)
	-qed
	-
	text\<open>We are now ready to show the Triangle Counting Lemma (Theorem 3.13 in Zhao's notes):\<close>

	theorem triangle_counting_lemma:
	fixes \<epsilon>::real
	assumes xss: "X \<subseteq> uverts G" and yss: "Y \<subseteq> uverts G" and zss: "Z \<subseteq> uverts G" and en0: "\<epsilon> > 0"
	and finG: "finite (uverts G)" and wf: "uwellformed G"
	and rp1: "regular_pair X Y G \<epsilon> " and rp2: "regular_pair Y Z G \<epsilon>" and rp3: "regular_pair X Z G \<epsilon>"
	and ed1: "edge_density X Y G \<ge> 2\<epsilon>" and ed2: "edge_density X Z G \<ge> 2\<epsilon>" and ed3: "edge_density Y Z G \<ge> 2*\<epsilon>"
	shows "card (triangle_triples X Y Z G)
	\<ge> (1-2\<epsilon>)((edge_density X Y G) - \<epsilon>)((edge_density X Z G) - \<epsilon>) ((edge_density Y Z G) - \<epsilon>)*
	(card X)(card Y) (card Z)"
	proof -
	let ?T_all = "{(x,y,z) \<in> X \<times> Y \<times> Z. (triangle_in_graph x y z G)}"
	define XF where "XF \<equiv> \<lambda>Y. {x \<in> X. card(neighbors_ss x Y G) < ((edge_density X Y G) - \<epsilon>) * card Y}"
	have fin: "finite X" "finite Y" "finite Z" using finG rev_finite_subset xss yss zss by auto
	have "card X > 0"
	using card_0_eq ed1 edge_density_def en0 fin(1) by fastforce
	have ebound: "\<epsilon> \<le> 1/2"
	using ed1 edge_density_le1 fin
	by (metis le_divide_eq_numeral1(1) mult.commute order_trans)
	then have ebound2: "1 - 2*\<epsilon> \<ge> 0"
	by linarith

	text\<open> Obtain a subset of @{term X} where all elements meet minimum numbers for neighborhood size
	in @{term Y} and @{term Z}.\<close>

	define X2 where "X2 \<equiv> X - (XF Y \<union> XF Z)"
	have xss: "X2 \<subseteq> X"
	by (simp add: X2_def)
	have finx2: "finite X2"
	by (simp add: X2_def fin)

	text \<open>Reasoning on the minimum size of @{term X2}:\<close>

	have part1: "(XF Y \<union> XF Z) \<union> X2 = X"
	by (auto simp: XF_def X2_def)
	have card_XFY: "card (XF Y) < \<epsilon> * card X"
	using regular_pair_neighbor_bound assms \<open>card X > 0\<close> by (simp add: XF_def)

	text\<open> We now repeat the same argument as above to the regular pair @{term X} @{term Z} in @{term G}.\<close>

	have card_XFZ: "card (XF Z) < \<epsilon> * card X"
	using regular_pair_neighbor_bound assms \<open>card X > 0\<close> by (simp add: XF_def)
	have "card (XF Y \<union> XF Z) \<le> 2 * \<epsilon> * (card X)"
	by (smt (verit) card_XFY card_XFZ card_Un_le comm_semiring_class.distrib of_nat_add of_nat_mono)
	then have minx2help: "card X2 \<ge> card X - 2 * \<epsilon> * card X" using part1
	by (smt (verit, del_insts) card_Un_le of_nat_add of_nat_mono)
	then have minx2: "card X2 \<ge> (1 - 2 * \<epsilon>) * card X"
	by (metis mult.commute mult_cancel_left2 right_diff_distrib)
	have edmultbound: "((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (edge_density X Z G - \<epsilon>)* (card Z) \<ge> 0"
	- using ed3 ed1 ed2 assms(4) by auto
	+ using ed3 ed1 ed2 \<open>\<epsilon> > 0\<close> by auto

	text \<open>Reasoning on the minimum number of edges between neighborhoods of @{term X} in @{term Y}
	and @{term Z}.\<close>

	have edyzgt0: "((edge_density Y Z G) - \<epsilon>) > 0"
	and edxygt0: "((edge_density X Y G) - \<epsilon>) > 0" using ed1 ed3 \<open>\<epsilon> > 0\<close> by linarith+
	have cardnzgt0: "card (neighbors_ss x Z G) \<ge> 0" and cardnygt0: "card (neighbors_ss x Y G) \<ge> 0"
	if "x \<in> X2" for x
	by auto
	have card_y_bound: "\<And>x. x \<in> X2 \<Longrightarrow> (card (neighbors_ss x Y G)) \<ge> (edge_density X Y G - \<epsilon>) * (card Y)"
	by (auto simp: XF_def X2_def)
	have card_z_bound: "\<And>x. x \<in> X2 \<Longrightarrow> (card (neighbors_ss x Z G)) \<ge> (edge_density X Z G - \<epsilon>) * (card Z)"
	by (auto simp: XF_def X2_def)
	have card_y_bound':
	"(\<Sum>x\<in> X2. ((edge_density Y Z G) - \<epsilon>) * (card (neighbors_ss x Y G)) * (card (neighbors_ss x Z G))) \<ge>
	(\<Sum>x\<in> X2 . ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (card (neighbors_ss x Z G)))"
	by (rule sum_mono) (smt (verit, best) Groups.mult_ac(3) card_y_bound edyzgt0 mult.commute mult_right_mono of_nat_0_le_iff)
	have x2_card: "\<And>x. x \<in> X2 \<Longrightarrow> ((edge_density Y Z G) - \<epsilon>) * (card (neighbors_ss x Y G)) * (card (neighbors_ss x Z G))
	\<le> card (all_edges_between (neighbors_ss x Y G) (neighbors_ss x Z G) G)"
	by (meson all_edges_btwn_neighbour_sets_lower_bound assms(1) card_y_bound card_z_bound ed1 ed2 ed3 en0 fin finG local.wf rp1 rp2 rp3 subsetD xss yss zss)
	have card_z_bound':
	"(\<Sum>x\<in> X2. ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (card (neighbors_ss x Z G))) \<ge>
	(\<Sum>x\<in> X2. ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (edge_density X Z G - \<epsilon>)* (card Z))"
	using card_z_bound mult_left_mono edxygt0 edyzgt0 by (fastforce intro!: sum_mono)
	have eq_set: "\<And> x. x \<in> X \<Longrightarrow> card {(y, z) . y \<in> Y \<and> z \<in> Z \<and> {y, z} \<in> uedges G \<and> neighbor_in_graph x y G \<and> neighbor_in_graph x z G } =
	card {(y, z) . y \<in> (neighbors_ss x Y G) \<and> z \<in> (neighbors_ss x Z G) \<and> {y, z} \<in> uedges G }"
	by (metis (no_types, lifting) mem_Collect_eq neighbors_ss_def)
	have "card ?T_all = (\<Sum>x\<in> X . card {(y,z) \<in> Y \<times> Z. triangle_in_graph x y z G})"
	using triple_sigma_rewrite_card fin by force
	also have "\<dots> = (\<Sum>x\<in> X . card {(y,z) \<in> Y \<times> Z. {y,z} \<in> uedges G \<and> neighbor_in_graph x y G \<and> neighbor_in_graph x z G })"
	using triangle_in_graph_edge_point assms by auto
	also have "\<dots> = (\<Sum>x\<in> X . card {(y, z). y \<in> Y \<and> z \<in> Z \<and> {y, z} \<in> uedges G \<and> neighbor_in_graph x y G \<and> neighbor_in_graph x z G })"
	by simp
	finally have "card ?T_all = (\<Sum>x\<in> X . card (all_edges_between (neighbors_ss x Y G) (neighbors_ss x Z G) G))"
	using eq_set by (auto simp: all_edges_between_def)
	then have l: "card ?T_all \<ge> (\<Sum>x\<in> X2 . card (all_edges_between (neighbors_ss x Y G) (neighbors_ss x Z G) G))"
	by (simp add: fin xss sum_mono2)
	have "(\<Sum>x\<in> X2 . ((edge_density Y Z G) - \<epsilon>) * (card (neighbors_ss x Y G)) * (card (neighbors_ss x Z G))) \<le>
	(\<Sum>x\<in> X2. real (card (all_edges_between (neighbors_ss x Y G) (neighbors_ss x Z G) G)))"
	by (meson x2_card finx2 sum_mono)
	then have "card ?T_all \<ge> (\<Sum>x\<in> X2 . ((edge_density Y Z G) - \<epsilon>) * (card (neighbors_ss x Y G)) * (card (neighbors_ss x Z G)))"
	using l of_nat_le_iff [symmetric, where 'a=real] by force
	then have "card ?T_all \<ge> (\<Sum>x\<in> X2 . ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (card (neighbors_ss x Z G)))"
	using card_y_bound' by simp
	then have tall_gt: "card ?T_all \<ge> (\<Sum>x\<in> X2 . ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (edge_density X Z G - \<epsilon>)* (card Z))"
	using card_z_bound' by simp
	have "(\<Sum>x\<in> X2 . ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (edge_density X Z G - \<epsilon>)* (card Z)) =
	card X2 * ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)* (card Y) * (edge_density X Z G - \<epsilon>)* (card Z)"
	by simp
	then have "of_real (card ?T_all) \<ge> card X2 * ((edge_density Y Z G) - \<epsilon>) * (edge_density X Y G - \<epsilon>)*
	(card Y) * (edge_density X Z G - \<epsilon>)* (card Z)"
	using tall_gt
	by force
	then have "of_real (card ?T_all) \<ge> ((1 - 2 * \<epsilon>) * card X) * ((edge_density Y Z G) - \<epsilon>) *
	(edge_density X Y G - \<epsilon>)* (card Y) * (edge_density X Z G - \<epsilon>)* (card Z)"
	- using minx2 edmultbound dual_order.trans mult.commute ordered_comm_semiring_class.comm_mult_left_mono
	- by (smt (verit, ccfv_SIG) assms(4) ed1 ed2 mult_cancel_right mult_less_cancel_right
	-mult_pos_neg2 of_nat_0_eq_iff of_nat_le_0_iff)
	+ by (smt (verit, best) ed2 edxygt0 edyzgt0 en0 minx2 mult_right_less_imp_less of_nat_less_0_iff)
	then show ?thesis by (simp add: triangle_triples_def mult.commute mult.left_commute)
	qed

	definition regular_graph :: "uvert set set \<Rightarrow> ugraph \<Rightarrow> real \<Rightarrow> bool"
	where "regular_graph P G \<epsilon> \<equiv> \<forall>R S. R\<in>P \<longrightarrow> S\<in>P \<longrightarrow> regular_pair R S G \<epsilon>" for \<epsilon>::real

	text \<open>A minimum density, but empty edge sets are excluded.\<close>

	definition edge_dense :: "nat set \<Rightarrow> nat set \<Rightarrow> ugraph \<Rightarrow> real \<Rightarrow> bool"
	where "edge_dense X Y G \<epsilon> \<equiv> all_edges_between X Y G = {} \<or> edge_density X Y G \<ge> \<epsilon>"

	definition dense_graph :: "uvert set set \<Rightarrow> ugraph \<Rightarrow> real \<Rightarrow> bool"
	where "dense_graph P G \<epsilon> \<equiv> \<forall>R S. R\<in>P \<longrightarrow> S\<in>P \<longrightarrow> edge_dense R S G \<epsilon>" for \<epsilon>::real

	definition decent :: "nat set \<Rightarrow> nat set \<Rightarrow> ugraph \<Rightarrow> real \<Rightarrow> bool"
	where "decent X Y G \<eta> \<equiv> all_edges_between X Y G = {} \<or> (real (card X) \<ge> \<eta> \<and> real (card Y) \<ge> \<eta>)"

	definition decent_graph :: "uvert set set \<Rightarrow> ugraph \<Rightarrow> real \<Rightarrow> bool"
	where "decent_graph P G \<eta> \<equiv> \<forall>R S. R\<in>P \<longrightarrow> S\<in>P \<longrightarrow> decent R S G \<eta>" for \<epsilon>::real

	text \<open>The proof of the triangle counting lemma requires ordered triples. For each unordered triple
	there are six permutations, hence the factor of $1/6$ here. This is mentioned briefly on pg 57 of
	Zhao's notes towards the end of the proof.\<close>

	lemma card_convert_triangle_rep:
	fixes G :: "ugraph"
	assumes "X \<subseteq> uverts G" and "Y \<subseteq> uverts G" and "Z \<subseteq> uverts G" and fin: "finite (uverts G)"
	and wf: "uwellformed G"
	shows "card (triangle_set G) \<ge> 1/6 * card {(x, y, z) \<in> X \<times> Y \<times> Z . (triangle_in_graph x y z G)}"
	(is "_ \<ge> 1/6 * card ?TT")
	proof -
	define tofl where "tofl \<equiv> \<lambda>l::nat list. (hd l, hd(tl l), hd(tl(tl l)))"
	have in_tofl: "(x, y, z) \<in> tofl ` permutations_of_set {x,y,z}" if "x\<noteq>y" "y\<noteq>z" "x\<noteq>z" for x y z
	proof -
	have "distinct[x,y,z]"
	using that by simp
	then show ?thesis
	unfolding tofl_def image_iff
	by (smt (verit, best) list.sel(1) list.sel(3) list.simps(15) permutations_of_setI set_empty)
	qed
	have "?TT \<subseteq> {(x, y, z). (triangle_in_graph x y z G)}"
	by auto
	also have "\<dots> \<subseteq> (\<Union>t \<in> triangle_set G. tofl ` permutations_of_set t)"
	proof (clarsimp simp: triangle_set_def)
	fix u v w
	assume t: "triangle_in_graph u v w G"
	then have "(u, v, w) \<in> tofl ` permutations_of_set {u,v,w}"
	by (metis in_tofl local.wf triangle_commu1 triangle_vertices_distinct1 triangle_vertices_distinct2)
	with t show "\<exists>t. (\<exists>x y z. t = {x, y, z} \<and> triangle_in_graph x y z G) \<and> (u, v, w) \<in> tofl ` permutations_of_set t"
	by blast
	qed
	finally have "?TT \<subseteq> (\<Union>t \<in> triangle_set G. tofl ` permutations_of_set t)" .
	then have "card ?TT \<le> card(\<Union>t \<in> triangle_set G. tofl ` permutations_of_set t)"
	by (intro card_mono finite_UN_I finite_triangle_set) (auto simp: assms)
	also have "\<dots> \<le> (\<Sum>t \<in> triangle_set G. card (tofl ` permutations_of_set t))"
	using card_UN_le fin finite_triangle_set local.wf by blast
	also have "\<dots> \<le> (\<Sum>t \<in> triangle_set G. card (permutations_of_set t))"
	by (meson card_image_le finite_permutations_of_set sum_mono)
	also have "\<dots> \<le> (\<Sum>t \<in> triangle_set G. fact 3)"
	apply (rule sum_mono)
	by (metis card.infinite card_permutations_of_set card_triangle_3 eq_refl local.wf nat.simps(3) numeral_3_eq_3)
	also have "\<dots> = 6 * card (triangle_set G)"
	by (simp add: eval_nat_numeral)
	finally have "card ?TT \<le> 6 * card (triangle_set G)" .
	then show ?thesis
	by (simp add: divide_simps)
	qed

	lemma card_convert_triangle_rep_bound:
	fixes G :: "ugraph" and t :: real
	assumes "card {(x, y, z) \<in> X \<times> Y \<times> Z . (triangle_in_graph x y z G)} \<ge> t"
	assumes "X \<subseteq> uverts G" and "Y \<subseteq> uverts G" and "Z \<subseteq> uverts G" and fin: "finite (uverts G)"
	and wf: "uwellformed G"
	shows "card (triangle_set G) \<ge> 1/6 *t"
	proof -
	define t' where "t' \<equiv> card {(x, y, z) \<in> X \<times> Y \<times> Z . (triangle_in_graph x y z G)}"
	have "t' \<ge> t" using assms t'_def by simp
	then have tgt: "1/6 * t' \<ge> 1/6 * t" by simp
	have "card (triangle_set G) \<ge> 1/6 *t'" using t'_def card_convert_triangle_rep assms by simp
	thus ?thesis using tgt by linarith
	qed

	lemma edge_density_eq0:
	assumes "all_edges_between A B G = {}" and "X \<subseteq> A" "Y \<subseteq> B"
	shows "edge_density X Y G = 0"
	proof -
	have "all_edges_between X Y G = {}"
	by (metis all_edges_between_mono1 all_edges_between_mono2 assms subset_empty)
	then show ?thesis
	by (auto simp: edge_density_def)
	qed

	text\<open>The following is the Triangle Removal Lemma (Theorem 3.15 in Zhao's notes).\<close>

	theorem triangle_removal_lemma:
	fixes \<epsilon> :: real
	assumes egt: "\<epsilon> > 0"
	shows "\<exists>\<delta>::real > 0. \<forall>G. card(uverts G) > 0 \<longrightarrow> uwellformed G \<longrightarrow>
	card (triangle_set G) \<le> \<delta> * card(uverts G) ^ 3 \<longrightarrow>
	(\<exists>Gnew. triangle_free_graph Gnew \<and> uverts Gnew = uverts G \<and> (uedges Gnew \<subseteq> uedges G) \<and>
	card (uedges G - uedges Gnew) \<le> \<epsilon> * (card (uverts G))\<^sup>2)"
	(is "\<exists>\<delta>::real > 0. \<forall>G. _ \<longrightarrow> _ \<longrightarrow> _ \<longrightarrow> (\<exists>Gnew. ?\<Phi> G Gnew)")
	proof (cases "\<epsilon> < 1")
	case False
	define Gnew where "Gnew \<equiv> \<lambda>G. ((uverts G), {}::uedge set)"
	show ?thesis
	proof (intro exI conjI strip)
	fix G
	assume G: "uwellformed G" "card(uverts G) > 0"
	then show "triangle_free_graph (Gnew G)" "uverts (Gnew G) = uverts G" "uedges (Gnew G) \<subseteq> uedges G"
	by (auto simp: Gnew_def triangle_free_graph_empty)
	have "real (card (uedges G)) \<le> (card (uverts G))\<^sup>2"
	by (meson G card_gt_0_iff max_edges_graph of_nat_le_iff)
	also have "\<dots> \<le> \<epsilon> * (card (uverts G))\<^sup>2"
	using False mult_le_cancel_right1 by fastforce
	finally show "real (card (uedges G - uedges (Gnew G))) \<le> \<epsilon> * real ((card (uverts G))\<^sup>2)"
	by (simp add: Gnew_def)
	qed (rule zero_less_one)
	next
	case True
	have e4gt: "\<epsilon>/4 > 0" using \<open>\<epsilon> > 0\<close> by auto
	then obtain M0 where
	M0: "\<And>G. card (uverts G) > 0 \<Longrightarrow> \<exists>P. regular_partition (\<epsilon>/4) G P \<and> card P \<le> M0"
	and "M0>0"
	by (metis Szemeredi_Regularity_Lemma le0 neq0_conv not_le not_numeral_le_zero)
	define D0 where "D0 \<equiv> 1/6 (1-(\<epsilon>/2))((\<epsilon>/4)^3)((\<epsilon> /(4M0))^3)"
	have "D0 > 0"
	using \<open>0 < \<epsilon>\<close> \<open>\<epsilon> < 1\<close> \<open>M0 > 0\<close> by (simp add: D0_def zero_less_mult_iff)
	then obtain \<delta>:: "real" where \<delta>: "0 < \<delta>" "\<delta> < D0"
	by (meson dense)
	show ?thesis
	proof (rule exI, intro conjI strip)
	fix G
	assume "card(uverts G) > 0" and wf: "uwellformed G"
	then have fin: "finite (uverts G)"
	by (simp add: card_gt_0_iff)

	text\<open>Assume that, for a yet to be determined $\delta$, we have:\<close>
	assume ineq: "real (card (triangle_set G)) \<le> \<delta> * card (uverts G) ^ 3"

	text\<open>Step 1: Partition: Using Szemer\'{e}di's Regularity Lemma, we get an $\epsilon/4$ partition. \<close>

	let ?n = "card (uverts G)"
	have vne: "uverts G \<noteq> {}"
	using \<open>0 < card (uverts G)\<close> by force
	then have ngt0: "?n > 0"
	by (simp add: fin card_gt_0_iff)
	with M0 obtain P where M: "regular_partition (\<epsilon>/4) G P" and "card P \<le> M0"
	by blast
	define M where "M \<equiv> card P"
	have "finite P"
	by (meson M fin finite_elements regular_partition_def)
	with M0 have "M > 0"
	unfolding M_def
	by (metis M card_gt_0_iff partition_onD1 partition_on_empty regular_partition_def vne)
	let ?e4M = "\<epsilon> / (4 * real M)"
	define D where "D \<equiv> 1/6 (1-(\<epsilon>/2)) ((\<epsilon>/4)^3) * ?e4M^3"
	have "D > 0"
	using \<open>0 < \<epsilon>\<close> \<open>\<epsilon> < 1\<close> \<open>M > 0\<close> by (simp add: D_def zero_less_mult_iff)
	have "D0 \<le> D"
	unfolding D0_def D_def using \<open>0 < \<epsilon>\<close> \<open>\<epsilon> < 1\<close> \<open>card P \<le> M0\<close> \<open>M > 0\<close>
	by (intro mult_mono) (auto simp: frac_le M_def)
	(* a reminder: as it is implied we have: *)
	have fin_part: "finite_graph_partition (uverts G) P M"
	using M unfolding regular_partition_def finite_graph_partition_def
	by (metis M_def \<open>0 < M\<close> card_gt_0_iff)
	then have fin_P: "finite R" and card_P_gt0: "card R > 0" if "R\<in>P" for R
	using fin finite_graph_partition_finite finite_graph_partition_gt0 that by auto
	have card_P_le: "card R \<le> ?n" if "R\<in>P" for R
	- using fin fin_part finite_graph_partition_le that by meson
	+ by (meson card_mono fin fin_part finite_graph_partition_subset that)
	have P_disjnt: "\<And>R S. \<lbrakk>R \<noteq> S; R \<in> P; S \<in> P\<rbrakk> \<Longrightarrow> R \<inter> S = {}"
	using fin_part
	by (metis disjnt_def finite_graph_partition_def insert_absorb pairwise_insert partition_on_def)
	have sum_card_P: "(\<Sum>R\<in>P. card R) = ?n"
	using card_finite_graph_partition fin fin_part by meson

	text\<open>Step 2. Cleaning. For each ordered pair of parts $(P_i,P_j)$, remove all edges between
	$P_i$ and $P_j$ if (a) it is an irregular pair, (b) its edge density ${} < \epsilon/2$,
	(c) either $P_i$ or $P_j$ is small (${}\le(\epsilon/4M)n$)
	Process (a) removes at most $(\epsilon/4)n^2$ edges.
	Process (b) removes at most $(\epsilon/2)n^2$ edges.
	Process (c) removes at most $(\epsilon/4)n^2$ edges.
	The remaining graph is triangle-free for some choice of $\delta$.
	We call the graph obtained after this process @{term Gnew}. \<close>

	define edge where "edge \<equiv> \<lambda>R S. mk_uedge ` (all_edges_between R S G)"
	have edge_commute: "edge R S = edge S R" for R S
	by (force simp add: edge_def all_edges_between_swap [of S] split: prod.split)
	have card_edge_le_card: "card (edge R S) \<le> card (all_edges_between R S G)" for R S
	by (simp add: card_image_le edge_def fin finite_all_edges_between' local.wf)
	have card_edge_le: "card (edge R S) \<le> card R * card S" if "R\<in>P" "S\<in>P" for R S
	by (meson card_edge_le_card fin_P le_trans max_all_edges_between that)

	text \<open>Obtain the set of edges meeting condition (a).\<close>

	- define irreg_pairs where "irreg_pairs \<equiv> {(R,S). R \<in> P \<and> S \<in> P \<and> irregular_pair R S G (\<epsilon>/4)}"
	+ define irreg_pairs where "irreg_pairs \<equiv> {(R,S). R \<in> P \<and> S \<in> P \<and> \<not> regular_pair R S G (\<epsilon>/4)}"
	define Ea where "Ea \<equiv> (\<Union>(R,S) \<in> irreg_pairs. edge R S)"

	text \<open>Obtain the set of edges meeting condition (b).\<close>

	define low_density_pairs
	where "low_density_pairs \<equiv> {(R,S). R \<in> P \<and> S \<in> P \<and> \<not> edge_dense R S G (\<epsilon>/2)}"
	define Eb where "Eb \<equiv> (\<Union>(i,j) \<in> low_density_pairs. edge i j)"

	text \<open>Obtain the set of edges meeting condition (c).\<close>

	define small where "small \<equiv> \<lambda>R. R \<in> P \<and> card R \<le> ?e4M * ?n"
	let ?SMALL = "Collect small"
	define small_pairs where "small_pairs \<equiv> {(R,S). R \<in> P \<and> S \<in> P \<and> (small R \<or> small S)}"
	define Ec where "Ec \<equiv> (\<Union>R \<in> ?SMALL. \<Union>S \<in> P. edge R S)"
	have Ec_def': "Ec = (\<Union>(i,j) \<in> small_pairs. edge i j)"
	by (force simp: edge_commute small_pairs_def small_def Ec_def)
	have eabound: "card Ea \<le> (\<epsilon>/4) * ?n^2" \<comment>\<open>Count the edge bound for @{term Ea}\<close>
	proof -
	have \<section>: "\<And>R S. \<lbrakk>R \<in> P; S \<in> P\<rbrakk> \<Longrightarrow> card (edge R S) \<le> card R * card S"
	unfolding edge_def
	by (meson card_image_le fin_P finite_all_edges_between max_all_edges_between order_trans)
	have "irreg_pairs \<subseteq> P \<times> P"
	by (auto simp: irreg_pairs_def)
	then have "finite irreg_pairs"
	by (meson \<open>finite P\<close> finite_SigmaI finite_subset)
	have "card Ea \<le> (\<Sum>(R,S)\<in>irreg_pairs. card (edge R S))"
	by (simp add: Ea_def card_UN_le [OF \<open>finite irreg_pairs\<close>] case_prod_unfold)
	- also have "\<dots> \<le> (\<Sum>(R,S) \<in> {(R,S). R\<in>P \<and> S\<in>P \<and> irregular_pair R S G (\<epsilon>/4)}. card R * card S)"
	+ also have "\<dots> \<le> (\<Sum>(R,S) \<in> {(R,S). R\<in>P \<and> S\<in>P \<and> \<not> regular_pair R S G (\<epsilon>/4)}. card R * card S)"
	unfolding irreg_pairs_def using \<section> by (force intro: sum_mono)
	also have "\<dots> = (\<Sum>(R,S) \<in> irregular_set (\<epsilon>/4) G P. card R * card S)"
	by (simp add: irregular_set_def)
	finally have "card Ea \<le> (\<Sum>(R,S) \<in> irregular_set (\<epsilon>/4) G P. card R * card S)" .
	with M show ?thesis
	unfolding regular_partition_def by linarith
	qed
	have ebbound: "card Eb \<le> (\<epsilon>/2) * (?n^2)" \<comment>\<open>Count the edge bound for @{term Eb}.\<close>
	proof -
	have subs: "low_density_pairs \<subseteq> P \<times> P"
	by (auto simp: low_density_pairs_def)
	then have "finite low_density_pairs"
	by (metis \<open>finite P\<close> finite_SigmaI finite_subset)
	have "real (card Eb) \<le> (\<Sum>(i,j)\<in>low_density_pairs. real (card (edge i j)))"
	unfolding Eb_def
	by (smt (verit, ccfv_SIG) \<open>finite low_density_pairs\<close> card_UN_le of_nat_mono of_nat_sum
	case_prod_unfold sum_mono)
	also have "\<dots> \<le> (\<Sum>(R,S)\<in>low_density_pairs. \<epsilon>/2 * card R * card S)"
	apply (rule sum_mono)
	apply(auto simp add: divide_simps card_P_gt0 low_density_pairs_def edge_density_def
	edge_dense_def)
	by (smt (verit, best) card_edge_le_card of_nat_le_iff mult.assoc)
	also have "\<dots> \<le> (\<Sum>(R,S)\<in>P \<times> P. \<epsilon>/2 * card R * card S)"
	using subs \<open>\<epsilon> > 0\<close> by (intro sum_mono2) (auto simp: \<open>finite P\<close>)
	also have "\<dots> = \<epsilon>/2 * (\<Sum>(R,S)\<in>P \<times> P. card R * card S)"
	by (simp add: sum_distrib_left case_prod_unfold mult_ac)
	also have "\<dots> \<le> (\<epsilon>/2) * (?n^2)"
	using \<open>\<epsilon>>0\<close> sum_prod_le_prod_sum
	by (simp add: power2_eq_square sum_product flip: sum.cartesian_product sum_card_P)
	finally show ?thesis .
	qed
	have ecbound: "card Ec \<le> (\<epsilon>/4) * (?n^2)" \<comment>\<open>Count the edge bound for @{term Ec}.\<close>
	proof -
	have edge_bound: "(card (edge R S)) \<le> ?e4M * ?n^2"
	if "S \<in> P" "small R" for R S
	proof -
	have "real (card R) \<le> \<epsilon> * ?n / (4 * real M)"
	using that by (simp add: small_def)
	with card_P_le [OF \<open>S\<in>P\<close>]
	have : "real (card R) real (card S) \<le> \<epsilon> * card (uverts G) / (4 * real M) * ?n"
	by (meson mult_mono of_nat_0_le_iff of_nat_mono order.trans)
	also have "\<dots> = ?e4M * ?n^2"
	by (simp add: power2_eq_square)
	finally show ?thesis
	by (smt (verit) card_edge_le of_nat_mono of_nat_mult small_def that)
	qed
	have subs: "?SMALL \<subseteq> P"
	by (auto simp: small_def)
	then obtain card_sp: "card (?SMALL) \<le> M" and "finite ?SMALL"
	using M_def \<open>finite P\<close> card_mono by (metis finite_subset)
	have "real (card Ec) \<le> (\<Sum>R \<in> ?SMALL. real (card (\<Union>S \<in> P. edge R S)))"
	unfolding Ec_def
	by (smt (verit, ccfv_SIG) \<open>finite ?SMALL\<close> card_UN_le of_nat_mono of_nat_sum case_prod_unfold sum_mono)
	also have "\<dots> \<le> (\<Sum>R \<in> ?SMALL. ?e4M * ?n^2)"
	proof (intro sum_mono)
	fix R assume i: "R \<in> Collect small"
	then have "R\<in>P" and card_Pi: "card R \<le> ?e4M * ?n"
	by (auto simp: small_def)
	let ?UE = "\<Union>(edge R ` (P))"
	have : "real (card ?UE) \<le> real (card R ?n)"
	proof -
	have "?UE \<subseteq> mk_uedge ` (all_edges_between R (uverts G) G)"
	apply (simp add: edge_def UN_subset_iff Ball_def)
	by (meson all_edges_between_mono2 fin_part finite_graph_partition_subset image_mono)
	then have "card ?UE \<le> card (all_edges_between R (uverts G) G)"
	by (meson card_image_le card_mono fin finite_all_edges_between' finite_imageI wf le_trans)
	then show ?thesis
	by (meson of_nat_mono fin fin_P max_all_edges_between order.trans \<open>R\<in>P\<close>)
	qed
	also have "\<dots> \<le> ?e4M * real (?n\<^sup>2)"
	using card_Pi \<open>M > 0\<close> \<open>?n > 0\<close> by (force simp add: divide_simps power2_eq_square)
	finally show "real (card ?UE) \<le> ?e4M * real (?n\<^sup>2)" .
	qed
	also have "\<dots> \<le> card ?SMALL * (?e4M * ?n^2)"
	by simp
	also have "\<dots> \<le> M * (?e4M * ?n^2)"
	using egt by (intro mult_right_mono) (auto simp add: card_sp)
	also have "\<dots> \<le> (\<epsilon>/4) * (?n^2)"
	using \<open>M > 0\<close> by simp
	finally show ?thesis .
	qed
	\<comment>\<open>total count\<close>
	have prev1: "card (Ea \<union> Eb \<union> Ec) \<le> card (Ea \<union> Eb) + card Ec" by (simp add: card_Un_le)
	also have "\<dots> \<le> card Ea + card Eb + card Ec" by (simp add: card_Un_le)
	also have prev: "\<dots> \<le> (\<epsilon>/4)(?n^2) + (\<epsilon>/2)(?n^2) + (\<epsilon>/4)*(?n^2)"
	using eabound ebbound ecbound by linarith
	finally have cutedgesbound: "card (Ea \<union> Eb \<union> Ec) \<le> \<epsilon> * (?n^2)" by simp

	define Gnew where "Gnew \<equiv> (uverts G, uedges G - (Ea \<union> Eb \<union> Ec))"
	show "\<exists>Gnew. ?\<Phi> G Gnew"
	proof (intro exI conjI)
	show verts: "uverts Gnew = uverts G" by (simp add: Gnew_def)
	have allij: "\<And>R S. edge R S \<subseteq> uedges G"
	using all_edges_between_ss_uedges edge_def by presburger
	then have eae: "Ea \<subseteq> uedges G" by (auto simp: Ea_def)
	have eab: "Eb \<subseteq> uedges G" using allij by (auto simp: Eb_def)
	have "Ec \<subseteq> uedges G" using allij by (auto simp: Ec_def)
	then have diffedges: "(Ea \<union> Eb \<union> Ec) \<subseteq> uedges G"
	using eae eab by auto
	then show edges: "uedges Gnew \<subseteq> uedges G"
	by (simp add: Gnew_def)
	then have "uedges G - (uedges Gnew) = uedges G \<inter> (Ea \<union> Eb \<union> Ec) "
	by (simp add: Gnew_def Diff_Diff_Int)
	then have "uedges G - (uedges Gnew) = (Ea \<union> Eb \<union> Ec)" using diffedges
	by (simp add: Int_absorb1)
	then have cardbound: "card (uedges G - uedges Gnew) \<le> \<epsilon> * (?n^2)"
	using cutedgesbound by simp
	have graph_partition_new: "finite_graph_partition (uverts Gnew) P M" using verts
	by (simp add: fin_part)
	have new_wf: "uwellformed Gnew" using subgraph_edge_wf verts edges wf by simp
	have new_fin: "finite (uverts Gnew)" using verts fin by simp

	text\<open> The notes by Bell and Grodzicki are quite useful for understanding the lines below.
	See pg 4 in the middle after the summary of the min edge counts.\<close>

	have irreg_pairs_swap: "(R,S) \<in> irreg_pairs \<longleftrightarrow> (S, R) \<in> irreg_pairs" for R S
	by (auto simp: irreg_pairs_def regular_pair_commute)
	have low_density_pairs_swap: "(R,S) \<in> low_density_pairs \<longleftrightarrow> (S,R) \<in> low_density_pairs" for R S
	by (simp add: low_density_pairs_def edge_density_commute edge_dense_def)
	(use all_edges_between_swap in blast)
	have small_pairs_swap: "(R,S) \<in> small_pairs \<longleftrightarrow> (S,R) \<in> small_pairs" for R S
	by (auto simp: small_pairs_def)

	have all_edges_if:
	"all_edges_between R S Gnew
	= (if (R,S) \<in> irreg_pairs \<union> low_density_pairs \<union> small_pairs then {}
	else all_edges_between R S G)"
	(is "?lhs = ?rhs")
	if ij: "R \<in> P" "S \<in> P" for R S
	proof
	show "?lhs \<subseteq> ?rhs"
	using that fin_part unfolding Gnew_def Ea_def Eb_def Ec_def'
	apply (simp add: all_edges_between_E_diff all_edges_between_E_Un all_edges_between_E_UN)
	apply (auto simp: edge_def in_mk_uedge_img_iff all_edges_between_def)
	done
	next
	have Ea: "all_edges_between R S (V, Ea) = {}"
	if "(R,S) \<notin> irreg_pairs" for V
	using ij that P_disjnt
	by (auto simp: Ea_def doubleton_eq_iff edge_def all_edges_between_def irreg_pairs_def;
	metis regular_pair_commute disjoint_iff_not_equal)
	have Eb: "all_edges_between R S (V, Eb) = {}"
	if "(R,S) \<notin> low_density_pairs" for V
	using ij that
	apply (auto simp: Eb_def edge_def all_edges_between_def low_density_pairs_def edge_dense_def)
	apply metis
	by (metis IntI P_disjnt doubleton_eq_iff edge_density_commute equals0D)
	have Ec: "all_edges_between R S (V, Ec) = {}"
	if "(R,S) \<notin> small_pairs" for V
	using ij that
	by (auto simp: Ec_def' doubleton_eq_iff edge_def all_edges_between_def small_pairs_def;
	metis P_disjnt disjoint_iff)
	show "?rhs \<subseteq> ?lhs"
	by (auto simp add: Gnew_def Ea Eb Ec all_edges_between_E_diff all_edges_between_E_Un)
	qed

	have rp: "regular_pair R S Gnew (\<epsilon>/4)" if ij: "R \<in> P" "S \<in> P" for R S
	proof (cases "(R,S) \<in> irreg_pairs")
	case False
	have ed: "edge_density X Y Gnew =
	(if (R,S) \<in> irreg_pairs \<union> low_density_pairs \<union> small_pairs then 0
	else edge_density X Y G)"
	if "X \<subseteq> R" "Y \<subseteq> S" for X Y
	using all_edges_if that ij False by (smt (verit) all_edges_preserved edge_density_eq0
	edge_density_def)
	show ?thesis
	using that False \<open>\<epsilon> > 0\<close>
	by (auto simp add: irreg_pairs_def regular_pair_def less_le ed)
	next
	case True
	then have ed: "edge_density X Y Gnew = 0" if "X \<subseteq> R" "Y \<subseteq> S" for X Y
	by (meson edge_density_eq0 all_edges_if that \<open>R \<in> P\<close> \<open>S \<in> P\<close> UnCI)
	with egt that show ?thesis
	by (auto simp: regular_pair_def ed)
	qed
	then have reg_pairs: "regular_graph P Gnew (\<epsilon>/4)"
	by (meson regular_graph_def)

	have "edge_dense R S Gnew (\<epsilon>/2)"
	if "R \<in> P" "S \<in> P" for R S
	proof (cases "(R,S) \<in> low_density_pairs")
	case False
	have ed: "edge_density R S Gnew =
	(if (R,S) \<in> irreg_pairs \<union> low_density_pairs \<union> small_pairs then 0
	else edge_density R S G)"
	using all_edges_if that that by (simp add: edge_density_def)
	with that \<open>\<epsilon> > 0\<close> False show ?thesis
	by (auto simp: low_density_pairs_def edge_dense_def all_edges_if)
	next
	case True
	then have "edge_density R S Gnew = 0"
	by (simp add: all_edges_if edge_density_def that)
	with \<open>\<epsilon> > 0\<close> that show ?thesis
	by (simp add: True all_edges_if edge_dense_def)
	qed
	then have density_bound: "dense_graph P Gnew (\<epsilon>/2)"
	by (meson dense_graph_def)

	have min_subset_size: "decent_graph P Gnew (?e4M * ?n)"
	using \<open>\<epsilon> > 0\<close>
	by (auto simp: decent_graph_def small_pairs_def small_def decent_def all_edges_if)
	show "triangle_free_graph Gnew"
	proof (rule ccontr)
	assume non: "\<not>?thesis"
	then obtain x y z where trig_ex: "triangle_in_graph x y z Gnew"
	using triangle_free_graph_def non by auto
	then have xin: "x \<in> (uverts Gnew)" and yin: "y \<in> (uverts Gnew)" and zin: "z \<in> (uverts Gnew)"
	using triangle_in_graph_verts new_wf by auto
	- then obtain R where xinp: "x \<in> R" and ilt: "R\<in>P"
	- using graph_partition_new finite_graph_partition_obtain xin by metis
	- then obtain S where yinp: "y \<in> S" and jlt: "S\<in>P"
	- using graph_partition_new finite_graph_partition_obtain yin by metis
	- then obtain T where zinp: "z \<in> T" and klt: "T\<in>P"
	- using graph_partition_new finite_graph_partition_obtain zin by metis
	- have finitesubsets: "finite R" "finite S" "finite T"
	- using ilt jlt klt new_fin fin_part finite_graph_partition_finite fin by auto
	+ then obtain R S T where xinp: "x \<in> R" and ilt: "R\<in>P" and yinp: "y \<in> S" and jlt: "S\<in>P"
	+ and zinp: "z \<in> T" and klt: "T\<in>P"
	+ by (metis graph_partition_new xin Union_iff finite_graph_partition_equals)
	+ then have finitesubsets: "finite R" "finite S" "finite T"
	+ using new_fin fin_part finite_graph_partition_finite fin by auto
	have subsets: "R \<subseteq> uverts Gnew" "S \<subseteq> uverts Gnew" "T \<subseteq> uverts Gnew"
	using finite_graph_partition_subset ilt jlt klt graph_partition_new by auto
	have min_sizes: "card R \<ge> ?e4M?n" "card S \<ge> ?e4M?n" "card T \<ge> ?e4M*?n"
	using trig_ex min_subset_size xinp yinp zinp ilt jlt klt
	by (auto simp: triangle_in_graph_def decent_graph_def decent_def all_edges_between_def)
	have min_dens: "edge_density R S Gnew \<ge> \<epsilon>/2" "edge_density R T Gnew \<ge> \<epsilon>/2"
	"edge_density S T Gnew \<ge> \<epsilon>/2"
	using density_bound subsets ilt jlt klt xinp yinp zinp unfolding dense_graph_def edge_dense_def
	by (metis all_edges_betw_I equals0D triangle_in_graph_def trig_ex)+
	then have min_dens_diff:
	"edge_density R S Gnew - \<epsilon>/4 \<ge> \<epsilon>/4" "edge_density R T Gnew - \<epsilon>/4 \<ge> \<epsilon>/4"
	"edge_density S T Gnew - \<epsilon>/4 \<ge> \<epsilon>/4"
	by auto
	have mincard0: "(card R)(card S) (card T) \<ge> 0" by simp
	have gtcube: "((edge_density R S Gnew) - \<epsilon>/4)((edge_density R T Gnew) - \<epsilon>/4) ((edge_density S T Gnew) - \<epsilon>/4) \<ge> (\<epsilon>/4)^3"
	using min_dens_diff e4gt real_mult_gt_cube by auto
	then have c1: "((edge_density R S Gnew) - \<epsilon>/4)((edge_density R T Gnew) - \<epsilon>/4) ((edge_density S T Gnew) - \<epsilon>/4) \<ge> 0"
	by (smt (verit) e4gt zero_less_power)
	have "?e4M * ?n \<ge> 0"
	using egt by force
	then have "card R * card S * card T \<ge> (?e4M * ?n)(?e4M ?n) * (?e4M * ?n)"
	by (metis (no_types) of_nat_0_le_iff of_nat_mult min_sizes mult_mono)
	then have "(card R)(card S) (card T) \<ge> (?e4M* ?n)^3"
	by (simp add: power3_eq_cube)
	then have cardgtbound:"card R * card S * card T \<ge> ?e4M^ 3 * ?n^3"
	by (metis of_nat_power power_mult_distrib)

	have "(1-\<epsilon>/2) * (\<epsilon>/4)^3 * (\<epsilon>/(4M))^3 ?n^3 \<le> (1-\<epsilon>/2) * (\<epsilon>/4)^3 * card R * card S * card T"
	using cardgtbound ordered_comm_semiring_class.comm_mult_left_mono True e4gt by fastforce
	also have "... \<le> (1-2(\<epsilon>/4)) (edge_density R S Gnew - \<epsilon>/4)(edge_density R T Gnew - \<epsilon>/4) (edge_density S T Gnew - \<epsilon>/4) * card R * card S * card T"
	using gtcube c1 \<open>\<epsilon> < 1\<close> mincard0 by (simp add: mult.commute mult.left_commute mult_left_mono)
	also have "... \<le> card (triangle_triples R S T Gnew)"
	by (smt (verit, best) e4gt ilt jlt klt min_dens_diff new_fin new_wf rp
	subsets triangle_counting_lemma)
	finally have "card (triangle_set Gnew) \<ge> D * ?n^3"
	using card_convert_triangle_rep_bound new_wf new_fin subsets
	by (auto simp: triangle_triples_def D_def)
	then have g_tset_bound: "card (triangle_set G) \<ge> D * ?n^3"
	using triangle_set_graph_edge_ss_bound by (smt (verit) edges fin local.wf of_nat_mono verts)
	have "card (triangle_set G) > \<delta> * ?n^3"
	proof -
	have "?n^3 > 0"
	by (simp add: \<open>uverts G \<noteq> {}\<close> card_gt_0_iff fin)
	with \<delta> \<open>D0 \<le> D\<close> have "D * ?n^3 > \<delta> * ?n^3"
	by force
	thus "card (triangle_set G) > \<delta> * ?n ^3"
	using g_tset_bound unfolding D_def by linarith
	qed
	thus False
	using ineq by linarith
	qed
	show "real (card (uedges G - uedges Gnew)) \<le> \<epsilon> * real ((card (uverts G))\<^sup>2)"
	using cardbound edges verts by blast
	qed
	qed (rule \<open>0 < \<delta>\<close>)
	qed

	subsection \<open>Roth's Theorem\<close>

	text\<open>We will first need the following corollary of the Triangle Removal Lemma.
	This is Corollary 3.18 in Zhao's notes:\<close>

	corollary corollary_triangle_removal:
	fixes \<epsilon> :: real
	assumes "0 < \<epsilon>"
	shows "\<exists>N>0. \<forall>G. card(uverts G) > N \<longrightarrow> uwellformed G \<longrightarrow> unique_triangles G \<longrightarrow>
	card (uedges G) \<le> \<epsilon> * (card (uverts G))\<^sup>2"
	proof -
	have "\<epsilon>/3 > 0"
	using assms by auto
	then obtain \<delta>::real where "\<delta> > 0"
	and \<delta>: "\<And>G. \<lbrakk>card(uverts G) > 0; uwellformed G;
	card (triangle_set G) \<le> \<delta> * card(uverts G) ^ 3\<rbrakk> \<Longrightarrow>
	(\<exists>Gnew. triangle_free_graph Gnew \<and> uverts Gnew = uverts G \<and> (uedges Gnew \<subseteq> uedges G) \<and>
	card (uedges G - uedges Gnew) \<le> \<epsilon>/3 * (card (uverts G))\<^sup>2)"
	using triangle_removal_lemma by metis
	obtain N::nat where N: "real N \<ge> 1 / (3*\<delta>)"
	by (meson real_arch_simple)
	show ?thesis
	proof (intro exI conjI strip)
	show "N > 0"
	using N \<open>0 < \<delta>\<close> zero_less_iff_neq_zero by fastforce
	fix G
	let ?n = "card (uverts G)"
	assume G_gt_N: "N < ?n"
	and wf: "uwellformed G"
	and uniq: "unique_triangles G"
	have G_ne: "?n > 0"
	using G_gt_N by linarith
	obtain TF where TF: "\<And>e. e \<in> uedges G \<Longrightarrow> \<exists>x y z. TF e = {x,y,z} \<and> triangle_in_graph x y z G \<and> e \<subseteq> TF e"
	using uniq unfolding unique_triangles_def by metis
	let ?TWO = "(\<lambda>t. [t]\<^bsup>2\<^esup>)"
	have tri_nsets_2: "[{x,y,z}]\<^bsup>2\<^esup> = {{x,y},{y,z},{x,z}}" if "triangle_in_graph x y z G" for x y z
	using that unfolding nsets_def triangle_in_graph_def card_2_iff doubleton_eq_iff
	by (blast dest!: edge_vertices_not_equal [OF wf])
	have tri_nsets_3: "{{x,y},{y,z},{x,z}} \<in> [uedges G]\<^bsup>3\<^esup>" if "triangle_in_graph x y z G" for x y z
	using that
	by (simp add: nsets_def card_3_iff triangle_in_graph_def) (metis doubleton_eq_iff
	edge_vertices_not_equal [OF wf])
	have sub: "?TWO ` triangle_set G \<subseteq> [uedges G]\<^bsup>3\<^esup>"
	using tri_nsets_2 tri_nsets_3 triangle_set_def by auto
	have "\<And>i. i \<in> triangle_set G \<Longrightarrow> ?TWO i \<noteq> {}"
	using tri_nsets_2 triangle_set_def by auto
	moreover have dfam: "disjoint_family_on ?TWO (triangle_set G)"
	using sub [unfolded image_subset_iff] uniq
	unfolding disjoint_family_on_def triangle_set_def nsets_def unique_triangles_def
	by (smt (verit) disjoint_iff_not_equal insert_subset mem_Collect_eq mk_disjoint_insert )
	ultimately have inj: "inj_on ?TWO (triangle_set G)"
	by (simp add: disjoint_family_on_iff_disjoint_image)
	have \<section>: "\<exists>T\<in>triangle_set G. e \<in> [T]\<^bsup>2\<^esup>" if "e \<in> uedges G" for e
	using uniq [unfolded unique_triangles_def] that local.wf
	apply (simp add: triangle_set_def triangle_in_graph_def nsets_def uwellformed_def)
	by (metis (mono_tags, lifting) finite.emptyI finite.insertI finite_subset)
	with sub have "\<Union>(?TWO ` triangle_set G) = uedges G"
	by (auto simp: image_subset_iff nsets_def)
	then have "card (\<Union>(?TWO ` triangle_set G)) = card (uedges G)"
	by simp
	moreover have "card (\<Union>(?TWO ` triangle_set G)) = 3 * card (triangle_set G)"
	proof (subst card_UN_disjoint' [OF dfam])
	show "finite ([i]\<^bsup>2\<^esup>)" if "i \<in> triangle_set G" for i
	using that tri_nsets_2 triangle_set_def by fastforce
	show "finite (triangle_set G)"
	- by (meson G_ne card_gt_0_iff local.wf triangle_set_finite)
	+ by (meson G_ne card_gt_0_iff local.wf finite_triangle_set)
	have "card ([i]\<^bsup>2\<^esup>) = 3" if "i \<in> triangle_set G" for i
	- using that wf
	- unfolding triangle_set_def triangle_in_graph_def uwellformed_def
	- by (smt (z3) image_subset_iff mem_Collect_eq nsets_def sub that)
	+ using that wf nsets_def tri_nsets_2 tri_nsets_3 triangle_set_def by fastforce
	then show "(\<Sum>i\<in>triangle_set G. card ([i]\<^bsup>2\<^esup>)) = 3 * card (triangle_set G)"
	by simp
	qed
	ultimately have A: "3 * card (triangle_set G) = card (uedges G)"
	by auto
	have "card (uedges G) \<le> card (all_edges(uverts G))"
	by (meson G_ne all_edges_finite card_gt_0_iff card_mono local.wf wellformed_all_edges)
	also have "\<dots> = card (uverts G) choose 2"
	by (metis G_ne card_all_edges card_eq_0_iff not_less0)
	also have "\<dots> = card (uverts G) * (card (uverts G) - 1) div 2"
	by (meson n_choose_2_nat)
	also have "\<dots> < (card (uverts G))\<^sup>2"
	by (simp add: G_ne less_imp_diff_less less_mult_imp_div_less power2_eq_square)
	finally have B: "card (uedges G) < (card (uverts G))\<^sup>2" .

	have "card (triangle_set G) \<le> (card (uverts G))\<^sup>2 / 3"
	using A B by linarith
	also have "\<dots> \<le> \<delta> * card(uverts G) ^ 3"
	proof -
	have "1 \<le> 3 * \<delta> * N"
	using N \<open>\<delta> > 0\<close> by (simp add: field_simps)
	also have "\<dots> \<le> 3 * \<delta> * ?n"
	using G_gt_N \<open>0 < \<delta>\<close> by force
	finally have "1 * ?n^2 \<le> (3 * \<delta> * ?n) * ?n^2"
	by (simp add: G_ne)
	then show ?thesis
	by (simp add: eval_nat_numeral mult_ac)
	qed
	finally have "card (triangle_set G) \<le> \<delta> * ?n ^ 3" .
	then obtain Gnew where Gnew: "triangle_free_graph Gnew" "uverts Gnew = uverts G"
	"uedges Gnew \<subseteq> uedges G" and card_edge_diff: "card (uedges G - uedges Gnew) \<le> \<epsilon>/3 * ?n\<^sup>2"
	using G_ne \<delta> local.wf by meson

	text\<open>Deleting an edge removes at most one triangle from the graph by assumption,
	so the number of edges removed in this process is at least the number of triangles.\<close>

	have False
	if non: "\<And>e. e \<in> uedges G - uedges Gnew \<Longrightarrow> {x,y,z} \<noteq> TF e"
	and tri: "triangle_in_graph x y z G" for x y z
	proof -
	have "\<not> triangle_in_graph x y z Gnew"
	using Gnew triangle_free_graph_def by blast
	with tri obtain e where eG: "e \<in> uedges G - uedges Gnew" and esub: "e \<subseteq> {x,y,z}"
	using insert_commute triangle_in_graph_def by auto
	then show False
	by (metis DiffD1 TF tri uniq unique_triangles_def non [OF eG])
	qed
	then have "triangle_set G \<subseteq> TF ` (uedges G - uedges Gnew)"
	unfolding triangle_set_def by blast
	moreover have "finite (uedges G - uedges Gnew)"
	by (meson G_ne card_gt_0_iff finite_Diff finite_graph_def wf wellformed_finite)
	ultimately have "card (triangle_set G) \<le> card (uedges G - uedges Gnew)"
	by (meson surj_card_le)
	then show "card (uedges G) \<le> \<epsilon> * ?n\<^sup>2"
	using A card_edge_diff by linarith
	qed
	qed

	text\<open>We are now ready to proceed to the proof of Roth's Theorem for Arithmetic Progressions. \<close>

	definition progression3 :: "'a::comm_monoid_add \<Rightarrow> 'a \<Rightarrow> 'a set"
	where "progression3 k d \<equiv> {k, k+d, k+d+d}"

	lemma p3_int_iff: "progression3 (int k) (int d) \<subseteq> int ` A \<longleftrightarrow> progression3 k d \<subseteq> A"
	apply (simp add: progression3_def image_iff)
	by (smt (verit, best) int_plus of_nat_eq_iff)

	text\<open>We assume that a set of naturals $A \subseteq \{...<N \}$ does not have any arithmetic progression.
	We will then show that @{term A} is of cardinality $o(N)$.\<close>

	lemma RothArithmeticProgressions_aux:
	fixes \<epsilon>::real
	assumes "\<epsilon> > 0"
	obtains X where "\<forall>N \<ge> X. \<forall>A \<subseteq> {..<N}. (\<nexists>k d. d>0 \<and> progression3 k d \<subseteq> A) \<longrightarrow> card A < \<epsilon> * real N"
	proof -
	obtain X where "X>0"
	and X: "\<And>G. \<lbrakk>card(uverts G) > X; uwellformed G; unique_triangles G\<rbrakk>
	\<Longrightarrow> card (uedges G) \<le> \<epsilon>/12 * (card (uverts G))\<^sup>2"
	by (metis assms corollary_triangle_removal less_divide_eq_numeral1(1) mult_eq_0_iff)
	show thesis
	proof (intro strip that)
	fix N A
	assume "X \<le> N" and A: "A \<subseteq> {..<N}"
	and non: "\<nexists>k d. 0 < d \<and> progression3 k d \<subseteq> A"
	then have "N > 0" using \<open>0 < X\<close> by linarith
	define M where "M \<equiv> Suc (2*N)"
	have M_mod_bound[simp]: "x mod M < M" for x
	by (simp add: M_def)
	have "odd M" "M>0" "N<M" by (auto simp: M_def)
	have "coprime M (Suc N)"
	unfolding M_def
	by (metis add.commute coprime_Suc_right_nat coprime_mult_right_iff mult_2 nat_arith.suc1)
	then have cop: "coprime M (1 + int N)"
	by (metis coprime_int_iff of_nat_Suc)
	have A_sub_M: "int ` A \<subseteq> {..<M}"
	using A by (force simp: M_def)
	have non_img_A: "\<nexists>k d. d > 0 \<and> progression3 k d \<subseteq> int ` A"
	by (metis p3_int_iff non pos_int_cases zero_le_imp_eq_int imageE insert_subset of_nat_0_le_iff
	progression3_def)

	text\<open>Construct a tripartite graph @{term G} whose three parts are copies of @{text"\<int>/M\<int>"}.\<close>

	define part_of where "part_of \<equiv> \<lambda>\<xi>. (\<lambda>i. prod_encode (\<xi>,i)) ` {..<M}"
	define label_of_part where "label_of_part \<equiv> \<lambda>p. fst (prod_decode p)"
	define from_part where "from_part \<equiv> \<lambda>p. snd (prod_decode p)"
	have enc_iff [simp]: "prod_encode (a,i) \<in> part_of a' \<longleftrightarrow> a'=a \<and> i<M" for a a' i
	using \<open>0 < M\<close> by (clarsimp simp: part_of_def image_iff Bex_def) presburger
	have part_of_M: "p \<in> part_of a \<Longrightarrow> from_part p < M" for a p
	using from_part_def part_of_def by fastforce
	have disjnt_part_of: "a \<noteq> b \<Longrightarrow> disjnt (part_of a) (part_of b)" for a b
	by (auto simp: part_of_def disjnt_iff)
	have from_enc [simp]: "from_part (prod_encode (a,i)) = i" for a i
	by (simp add: from_part_def)
	have finpart [iff]: "finite (part_of a)" for a
	by (simp add: part_of_def \<open>0 < M\<close>)
	have cardpart [simp]: "card (part_of a) = M" for a
	using \<open>0 < M\<close>
	by (simp add: part_of_def eq_nat_nat_iff inj_on_def card_image)
	let ?X = "part_of 0"
	let ?Y = "part_of (Suc 0)"
	let ?Z = "part_of (Suc (Suc 0))"
	define diff where "diff \<equiv> \<lambda>a b. (int a - int b) mod (int M)"
	have inj_on_diff: "inj_on (\<lambda>x. diff x a) {..<M}" for a
	apply (clarsimp simp: diff_def inj_on_def)
	by (metis diff_add_cancel mod_add_left_eq mod_less nat_int of_nat_mod)
	have eq_mod_M: "(x - y) mod int M = (x' - y) mod int M \<Longrightarrow> x mod int M = x' mod int M" for x x' y
	by (simp add: mod_eq_dvd_iff)

	have diff_invert: "diff y x = int a \<longleftrightarrow> y = (x + a) mod M" if "y < M" "a\<in>A" for x y a
	proof -
	have "a < M"
	using A \<open>N < M\<close> that by auto
	show ?thesis
	proof
	assume "diff y x = int a"
	with that \<open>a<M\<close> have "int y = int (x+a) mod int M"
	unfolding diff_def by (smt (verit, ccfv_SIG) eq_mod_M mod_less of_nat_add zmod_int)
	with that show "y = (x + a) mod M"
	by (metis nat_int zmod_int)
	qed (simp add: \<open>a < M\<close> diff_def mod_diff_left_eq zmod_int)
	qed

	define diff2 where "diff2 \<equiv> \<lambda>a b. ((int a - int b) * int(Suc N)) mod (int M)"
	have inj_on_diff2: "inj_on (\<lambda>x. diff2 x a) {..<M}" for a
	apply (clarsimp simp: diff2_def inj_on_def)
	by (metis eq_mod_M mult_mod_cancel_right [OF _ cop] int_int_eq mod_less zmod_int)
	have [simp]: "(1 + int N) mod int M = 1 + int N"
	using M_def \<open>0 < N\<close> by auto
	have diff2_by2: "(diff2 a b * 2) mod M = diff a b" for a b
	proof -
	have "int M dvd ((int a - int b) * int M)"
	by simp
	then have "int M dvd ((int a - int b) * int (Suc N) * 2 - (int a - int b))"
	by (auto simp: M_def algebra_simps)
	then show ?thesis
	by (metis diff2_def diff_def mod_eq_dvd_iff mod_mult_left_eq)
	qed
	have diff2_invert: "diff2 (((x + a) mod M + a) mod M) x = int a" if "a\<in>A" for x a
	proof -
	have 1: "((x + a) mod M + a) mod M = (x + 2*a) mod M"
	by (metis group_cancel.add1 mod_add_left_eq mult_2)
	have "(int ((x + 2a) mod M) - int x) (1 + int N) mod int M
	= (int (x + 2a) - int x) (1 + int N) mod int M"
	by (metis mod_diff_left_eq mod_mult_cong of_nat_mod)
	also have "\<dots> = int (a * (Suc M)) mod int M"
	by (simp add: algebra_simps M_def)
	also have "\<dots> = int a mod int M"
	by simp
	also have "\<dots> = int a"
	using A M_def subsetD that by auto
	finally show ?thesis
	using that by (auto simp: 1 diff2_def)
	qed

	define Edges where "Edges \<equiv> \<lambda>X Y df. {{x,y}\| x y. x \<in> X \<and> y \<in> Y \<and> df(from_part y) (from_part x) \<in> int ` A}"
	have Edges_subset: "Edges X Y df \<subseteq> Pow (X \<union> Y)" for X Y df
	by (auto simp: Edges_def)
	define XY where "XY \<equiv> Edges ?X ?Y diff"
	define YZ where "YZ \<equiv> Edges ?Y ?Z diff"
	define XZ where "XZ \<equiv> Edges ?X ?Z diff2"
	obtain [simp]: "finite XY" "finite YZ" "finite XZ"
	using Edges_subset unfolding XY_def YZ_def XZ_def
	by (metis finite_Pow_iff finite_UnI finite_subset finpart)
	define G where "G \<equiv> (?X \<union> ?Y \<union> ?Z, XY \<union> YZ \<union> XZ)"
	have finG: "finite (uverts G)" and cardG: "card (uverts G) = 3*M"
	by (simp_all add: G_def card_Un_disjnt disjnt_part_of)
	then have "card(uverts G) > X"
	using M_def \<open>X \<le> N\<close> by linarith
	have "uwellformed G"
	by (fastforce simp: card_insert_if part_of_def G_def XY_def YZ_def XZ_def Edges_def uwellformed_def)
	have [simp]: "{prod_encode (\<xi>,x), prod_encode (\<xi>,y)} \<notin> XY"
	"{prod_encode (\<xi>,x), prod_encode (\<xi>,y)} \<notin> YZ"
	"{prod_encode (\<xi>,x), prod_encode (\<xi>,y)} \<notin> XZ" for x y \<xi>
	by (auto simp: XY_def YZ_def XZ_def Edges_def doubleton_eq_iff)
	have label_ne_XY [simp]: "label_of_part p \<noteq> label_of_part q" if "{p,q} \<in> XY" for p q
	using that by (auto simp add: XY_def part_of_def Edges_def doubleton_eq_iff label_of_part_def)
	then have [simp]: "{p} \<notin> XY" for p
	by (metis insert_absorb2)
	have label_ne_YZ [simp]: "label_of_part p \<noteq> label_of_part q" if "{p,q} \<in> YZ" for p q
	using that by (auto simp add: YZ_def part_of_def Edges_def doubleton_eq_iff label_of_part_def)
	then have [simp]: "{p} \<notin> YZ" for p
	by (metis insert_absorb2)
	have label_ne_XZ [simp]: "label_of_part p \<noteq> label_of_part q" if "{p,q} \<in> XZ" for p q
	using that by (auto simp add: XZ_def part_of_def Edges_def doubleton_eq_iff label_of_part_def)
	then have [simp]: "{p} \<notin> XZ" for p
	by (metis insert_absorb2)
	have label012: "label_of_part v < 3" if "v \<in> uverts G" for v
	using that by (auto simp add: G_def eval_nat_numeral part_of_def label_of_part_def)

	have Edges_distinct: "\<And>p q r \<xi> \<zeta> \<gamma> \<beta> df df'. \<lbrakk>{p,q} \<in> Edges (part_of \<xi>) (part_of \<zeta>) df;
	{q,r} \<in> Edges (part_of \<xi>) (part_of \<zeta>) df;
	{p,r} \<in> Edges (part_of \<gamma>) (part_of \<beta>) df'; \<xi> \<noteq> \<zeta>; \<gamma> \<noteq> \<beta>\<rbrakk> \<Longrightarrow> False"
	apply (auto simp: disjnt_iff Edges_def doubleton_eq_iff conj_disj_distribR ex_disj_distrib)
	apply (metis disjnt_iff disjnt_part_of)+
	done
	have uniq: "\<exists>i<M. \<exists>d\<in>A. \<exists>x \<in> {p,q,r}. \<exists>y \<in> {p,q,r}. \<exists>z \<in> {p,q,r}.
	x = prod_encode(0, i)
	\<and> y = prod_encode(1, (i+d) mod M)
	\<and> z = prod_encode(2, (i+d+d) mod M)"
	if T: "triangle_in_graph p q r G" for p q r
	proof -
	obtain x y z where xy: "{x,y} \<in> XY" and yz: "{y,z} \<in> YZ" and xz: "{x,z} \<in> XZ"
	and x: "x \<in> {p,q,r}" and y: "y \<in> {p,q,r}" and z: "z \<in> {p,q,r}"
	using T apply (simp add: triangle_in_graph_def G_def XY_def YZ_def XZ_def)
	by (smt (verit, ccfv_SIG) Edges_distinct Zero_not_Suc insert_commute n_not_Suc_n)
	then have "x \<in> ?X" "y \<in> ?Y" "z \<in> ?Z"
	by (auto simp: XY_def YZ_def XZ_def Edges_def doubleton_eq_iff; metis disjnt_iff disjnt_part_of)+
	then obtain i j k where i: "x = prod_encode(0,i)" and j: "y = prod_encode(1,j)"
	and k: "z = prod_encode(2,k)"
	by (metis One_nat_def Suc_1 enc_iff prod_decode_aux.cases prod_decode_inverse)
	obtain a1 where "a1 \<in> A" and a1: "(int j - int i) mod int M = int a1"
	using xy \<open>x \<in> ?X\<close> i j by (auto simp add: XY_def Edges_def doubleton_eq_iff diff_def)
	obtain a3 where "a3 \<in> A" and a3: "(int k - int j) mod int M = int a3"
	using yz \<open>x \<in> ?X\<close> j k by (auto simp add: YZ_def Edges_def doubleton_eq_iff diff_def)
	obtain a2 where "a2 \<in> A" and a2: "(int k - int i) mod int M = int (a2 * 2) mod int M"
	using xz \<open>x \<in> ?X\<close> i k apply (auto simp add: XZ_def Edges_def doubleton_eq_iff)
	by (metis diff2_by2 diff_def int_plus mult_2_right)
	obtain "a1<N" "a2<N" "a3<N"
	using A \<open>a1 \<in> A\<close> \<open>a2 \<in> A\<close> \<open>a3 \<in> A\<close> by blast
	then obtain "a1+a3 < M" "a2 * 2 < M"
	by (simp add: M_def)
	then have "int (a2 * 2) = int (a2 * 2) mod M"
	by force
	also have "\<dots> = int (a1 + a3) mod int M"
	using a1 a2 a3 by (smt (verit, del_insts) int_plus mod_add_eq)
	also have "\<dots> = int (a1+a3)"
	using \<open>a1 + a3 < M\<close> by force
	finally have "a2*2 = a1+a3"
	by presburger
	then obtain equal: "a3 - a2 = a2 - a1" "a2 - a3 = a1 - a2"
	by (metis Nat.diff_cancel diff_cancel2 mult_2_right)
	with \<open>a1 \<in> A\<close> \<open>a2 \<in> A\<close> \<open>a3 \<in> A\<close> have "progression3 a1 (a2 - a1) \<subseteq> A"
	apply (clarsimp simp: progression3_def)
	by (metis diff_is_0_eq' le_add_diff_inverse nle_le)
	with non equal have "a2 = a1"
	unfolding progression3_def
	by (metis \<open>a2 \<in> A\<close> \<open>a3 \<in> A\<close> add.right_neutral diff_is_0_eq insert_subset
	le_add_diff_inverse not_gr_zero)
	then have "a3 = a2"
	using \<open>a2 * 2 = a1 + a3\<close> by force
	have k_minus_j: "(int k - int j) mod int M = int a1"
	by (simp add: \<open>a2 = a1\<close> \<open>a3 = a2\<close> a3)
	have i_to_j: "j mod M = (i+a1) mod M"
	by (metis a1 add_diff_cancel_left' add_diff_eq mod_add_right_eq nat_int of_nat_add of_nat_mod)
	have j_to_k: "k mod M = (j+a1) mod M"
	by (metis \<open>a2 = a1\<close> \<open>a3 = a2\<close> a3 add_diff_cancel_left' add_diff_eq mod_add_right_eq
	nat_int of_nat_add of_nat_mod)
	have "i<M"
	using \<open>x \<in> ?X\<close> i by simp
	then show ?thesis
	using i j k x y z \<open>a1 \<in> A\<close>
	by (metis \<open>y \<in> ?Y\<close> \<open>z \<in>?Z\<close> enc_iff i_to_j j_to_k mod_add_left_eq mod_less)
	qed

	text\<open>Every edge of the graph G lies in exactly one triangle.\<close>

	have "unique_triangles G"
	unfolding unique_triangles_def
	proof (intro strip)
	fix e
	assume "e \<in> uedges G"
	then consider "e \<in> XY" \| "e \<in> YZ" \| "e \<in> XZ"
	using G_def by fastforce
	then show "\<exists>!T. \<exists>x y z. T = {x, y, z} \<and> triangle_in_graph x y z G \<and> e \<subseteq> T"
	proof cases
	case 1
	then obtain i j a where eeq: "e = {prod_encode(0,i), prod_encode(1,j)}"
	and "i<M" and "j<M"
	and df: "diff j i = int a" and "a \<in> A"
	by (auto simp: XY_def Edges_def part_of_def)
	let ?x = "prod_encode (0, i)"
	let ?y = "prod_encode (1, j)"
	let ?z = "prod_encode (2, (j+a) mod M)"
	have yeq: "j = (i+a) mod M"
	using diff_invert using \<open>a \<in> A\<close> df \<open>j<M\<close> by blast
	with \<open>a \<in> A\<close> \<open>j<M\<close> have "{?y,?z} \<in> YZ"
	by (fastforce simp: YZ_def Edges_def image_iff diff_invert)
	moreover have "{?x,?z} \<in> XZ"
	using \<open>a \<in> A\<close> by (fastforce simp: XZ_def Edges_def yeq diff2_invert \<open>i<M\<close>)
	ultimately have T: "triangle_in_graph ?x ?y ?z G"
	using \<open>e \<in> uedges G\<close> by (force simp add: G_def eeq triangle_in_graph_def)
	show ?thesis
	proof (intro ex1I)
	show "\<exists>x y z. {?x,?y,?z} = {x, y, z} \<and> triangle_in_graph x y z G \<and> e \<subseteq> {?x,?y,?z}"
	using T eeq by blast
	fix T
	assume "\<exists>p q r. T = {p, q, r} \<and> triangle_in_graph p q r G \<and> e \<subseteq> T"
	then obtain p q r where Teq: "T = {p,q,r}"
	and tri: "triangle_in_graph p q r G" and "e \<subseteq> T"
	by blast
	with uniq
	obtain i' a' x y z where "i'<M" "a' \<in> A"
	and x: "x \<in> {p,q,r}" and y: "y \<in> {p,q,r}" and z: "z \<in> {p,q,r}"
	and xeq: "x = prod_encode(0, i')"
	and yeq: "y = prod_encode(1, (i'+a') mod M)"
	and zeq: "z = prod_encode(2, (i'+a'+a') mod M)"
	by metis
	then have sets_eq: "{x,y,z} = {p,q,r}" by auto
	with Teq \<open>e \<subseteq> T\<close> have esub': "e \<subseteq> {x,y,z}" by blast
	have "a' < M"
	using A \<open>N < M\<close> \<open>a' \<in> A\<close> by auto
	obtain "?x \<in> e" "?y \<in> e" using eeq by force
	then have "x = ?x"
	using esub' eeq yeq zeq by simp
	then have "y = ?y"
	using esub' eeq zeq by simp
	obtain eq': "i' = i" "(i'+a') mod M = j"
	using \<open>x = ?x\<close> xeq using \<open>y =?y\<close> yeq by auto
	then have "diff (i'+a') i' = int a'"
	by (simp add: diff_def \<open>a' < M\<close>)
	then have "a' = a"
	by (metis eq' df diff_def mod_diff_left_eq nat_int zmod_int)
	then have "z = ?z"
	by (metis \<open>y = ?y\<close> mod_add_left_eq prod_encode_eq snd_conv yeq zeq)
	then show "T = {?x,?y,?z}"
	using Teq \<open>x = ?x\<close> \<open>y = ?y\<close> sets_eq by presburger
	qed
	next
	case 2
	then obtain j k a where eeq: "e = {prod_encode(1,j), prod_encode(2,k)}"
	and "j<M" "k<M"
	and df: "diff k j = int a" and "a \<in> A"
	by (auto simp: YZ_def Edges_def part_of_def numeral_2_eq_2)
	let ?x = "prod_encode (0, (M+j-a) mod M)"
	let ?y = "prod_encode (1, j)"
	let ?z = "prod_encode (2, k)"
	have zeq: "k = (j+a) mod M"
	using diff_invert using \<open>a \<in> A\<close> df \<open>k<M\<close> by blast
	with \<open>a \<in> A\<close> \<open>k<M\<close> have "{?x,?z} \<in> XZ"
	unfolding XZ_def Edges_def image_iff
	apply (clarsimp simp: mod_add_left_eq doubleton_eq_iff conj_disj_distribR ex_disj_distrib)
	apply (smt (verit, ccfv_threshold) A \<open>N < M\<close> diff2_invert le_add_diff_inverse2 lessThan_iff
	linorder_not_less mod_add_left_eq
	mod_add_self1 not_add_less1 order.strict_trans subsetD)
	done
	moreover
	have "a < N" using A \<open>a \<in> A\<close> by blast
	with \<open>N < M\<close> have "((M + j - a) mod M + a) mod M = j mod M"
	by (simp add: mod_add_left_eq)
	then have "{?x,?y} \<in> XY"
	using \<open>a \<in> A\<close> \<open>j<M\<close>
	by (force simp add: XY_def Edges_def zeq image_iff diff_invert
	doubleton_eq_iff ex_disj_distrib)
	ultimately have T: "triangle_in_graph ?x ?y ?z G"
	using \<open>e \<in> uedges G\<close> by (auto simp: G_def eeq triangle_in_graph_def)
	show ?thesis
	proof (intro ex1I)
	show "\<exists>x y z. {?x,?y,?z} = {x, y, z} \<and> triangle_in_graph x y z G \<and> e \<subseteq> {?x,?y,?z}"
	using T eeq by blast
	fix T
	assume "\<exists>p q r. T = {p, q, r} \<and> triangle_in_graph p q r G \<and> e \<subseteq> T"
	then obtain p q r where Teq: "T = {p,q,r}" and tri: "triangle_in_graph p q r G" and "e \<subseteq> T"
	by blast
	with uniq
	obtain i' a' x y z where "i'<M" "a' \<in> A"
	and x: "x \<in> {p,q,r}" and y: "y \<in> {p,q,r}" and z: "z \<in> {p,q,r}"
	and xeq: "x = prod_encode(0, i')"
	and yeq: "y = prod_encode(1, (i'+a') mod M)"
	and zeq: "z = prod_encode(2, (i'+a'+a') mod M)"
	by metis
	then have sets_eq: "{x,y,z} = {p,q,r}" by auto
	with Teq \<open>e \<subseteq> T\<close> have esub': "e \<subseteq> {x,y,z}" by blast
	have "a' < M"
	using A \<open>N < M\<close> \<open>a' \<in> A\<close> by auto
	obtain "?y \<in> e" "?z \<in> e"
	using eeq by force
	then have "y = ?y"
	using esub' eeq xeq zeq by simp
	then have "z = ?z"
	using esub' eeq xeq by simp
	obtain eq': "(i'+a') mod M = j" "(i'+a'+a') mod M = k"
	using \<open>y = ?y\<close> yeq using \<open>z =?z\<close> zeq by auto
	then have "diff (i'+a'+a') (i'+a') = int a'"
	by (simp add: diff_def \<open>a' < M\<close>)
	then have "a' = a"
	by (metis M_mod_bound \<open>a' \<in> A\<close> df diff_invert eq' mod_add_eq mod_if of_nat_eq_iff)
	have "(M + ((i'+a') mod M) - a') mod M = i'"
	by (metis Nat.add_diff_assoc2 \<open>a' < M\<close> \<open>i' < M\<close> add.left_commute add_implies_diff
	less_imp_le_nat mod_add_right_eq mod_add_self2 mod_less)
	with \<open>a' = a\<close> eq' have "(M + j - a) mod M = i'"
	by force
	with xeq have "x = ?x" by blast
	then show "T = {?x,?y,?z}"
	using Teq \<open>z = ?z\<close> \<open>y = ?y\<close> sets_eq by presburger
	qed
	next
	case 3
	then obtain i k a where eeq: "e = {prod_encode(0,i), prod_encode(2,k)}"
	and "i<M" and "k<M"
	and df: "diff2 k i = int a" and "a \<in> A"
	by (auto simp: XZ_def Edges_def part_of_def eval_nat_numeral)
	let ?x = "prod_encode (0, i)"
	let ?y = "prod_encode (1, (i+a) mod M)"
	let ?z = "prod_encode (2, k)"
	have keq: "k = (i+a+a) mod M"
	using diff2_invert [OF \<open>a \<in> A\<close>, of i] df \<open>k<M\<close> using inj_on_diff2 [of i]
	by (simp add: inj_on_def Ball_def mod_add_left_eq)
	with \<open>a \<in> A\<close> have "{?x,?y} \<in> XY"
	using \<open>a \<in> A\<close> \<open>i<M\<close> \<open>k<M\<close> apply (auto simp: XY_def Edges_def)
	by (metis M_mod_bound diff_invert enc_iff from_enc imageI)
	moreover have "{?y,?z} \<in> YZ"
	apply (auto simp: YZ_def Edges_def image_iff eval_nat_numeral)
	by (metis M_mod_bound \<open>a \<in> A\<close> diff_invert enc_iff from_enc mod_add_left_eq keq)
	ultimately have T: "triangle_in_graph ?x ?y ?z G"
	using \<open>e \<in> uedges G\<close> by (force simp add: G_def eeq triangle_in_graph_def)
	show ?thesis
	proof (intro ex1I)
	show "\<exists>x y z. {?x,?y,?z} = {x, y, z} \<and> triangle_in_graph x y z G \<and> e \<subseteq> {?x,?y,?z}"
	using T eeq by blast
	fix T
	assume "\<exists>p q r. T = {p, q, r} \<and> triangle_in_graph p q r G \<and> e \<subseteq> T"
	then obtain p q r where Teq: "T = {p,q,r}" and tri: "triangle_in_graph p q r G" and "e \<subseteq> T"
	by blast
	with uniq obtain i' a' x y z where "i'<M" "a' \<in> A"
	and x: "x \<in> {p,q,r}" and y: "y \<in> {p,q,r}" and z: "z \<in> {p,q,r}"
	and xeq: "x = prod_encode(0, i')"
	and yeq: "y = prod_encode(1, (i'+a') mod M)"
	and zeq: "z = prod_encode(2, (i'+a'+a') mod M)"
	by metis
	then have sets_eq: "{x,y,z} = {p,q,r}" by auto
	with Teq \<open>e \<subseteq> T\<close> have esub': "e \<subseteq> {x,y,z}" by blast
	have "a' < M"
	using A \<open>N < M\<close> \<open>a' \<in> A\<close> by auto
	obtain "?x \<in> e" "?z \<in> e" using eeq by force
	then have "x = ?x"
	using esub' eeq yeq zeq by simp
	then have "z = ?z"
	using esub' eeq yeq by simp
	obtain eq': "i' = i" "(i'+a'+a') mod M = k"
	using \<open>x = ?x\<close> xeq using \<open>z =?z\<close> zeq by auto
	then have "diff (i'+a') i' = int a'"
	by (simp add: diff_def \<open>a' < M\<close>)
	then have "a' = a"
	by (metis \<open>a' \<in> A\<close> add.commute df diff2_invert eq' mod_add_right_eq nat_int)
	then have "y = ?y"
	by (metis \<open>x = ?x\<close> prod_encode_eq snd_conv yeq xeq)
	then show "T = {?x,?y,?z}"
	using Teq \<open>x = ?x\<close> \<open>z = ?z\<close> sets_eq by presburger
	qed
	qed
	qed
	have : "card (uedges G) \<le> \<epsilon>/12 (card (uverts G))\<^sup>2"
	using X \<open>X < card (uverts G)\<close> \<open>unique_triangles G\<close> \<open>uwellformed G\<close> by blast

	have diff_cancel: "\<exists>j<M. diff j i = int a" if "a \<in> A" for i a
	proof -
	have "int a < int M"
	using A M_def that by auto
	then have "(int ((i + a) mod M) - int i) mod int M = int a"
	by (simp add: mod_diff_left_eq of_nat_mod)
	then show ?thesis
	using \<open>0 < M\<close> diff_def mod_less_divisor by blast
	qed
	have diff2_cancel: "\<exists>j<M. diff2 j i = int a" if "a \<in> A" "i<M" for i a
	proof -
	have "a<M"
	using that M_def A by auto
	have "(int ((i + 2a) mod M) - int i) (1 + int N) mod int M =
	(((int i + 2 * int a) mod M) - int i) * (1 + int N) mod int M"
	by (simp add: zmod_int)
	also have "\<dots> = 2 * int a * (1 + int N) mod int M"
	by (smt (verit) mod_diff_left_eq mod_mult_eq mod_mult_right_eq)
	also have "\<dots> = int a mod int M"
	proof -
	have "(2 * int a * (1 + int N) - int a) = M * a"
	by (simp add: M_def algebra_simps)
	then have "M dvd (2 * int a * (1 + int N) - int a)"
	by simp
	then show ?thesis
	using mod_eq_dvd_iff by blast
	qed
	also have "\<dots> = a" by (simp add: \<open>a < M\<close>)
	finally show ?thesis
	by (metis \<open>0 < M\<close> diff2_def mod_less_divisor of_nat_Suc)
	qed

	have card_Edges: "card (Edges (part_of \<xi>) (part_of \<zeta>) df) = M * card A" (is "card ?E = _")
	if "\<xi> \<noteq> \<zeta>" and df_cancel: "\<forall>a\<in>A. \<forall>i<M. \<exists>j<M. df j i = int a"
	and df_inj: "\<forall>a. inj_on (\<lambda>x. df x a) {..<M}" for \<xi> \<zeta> df
	proof -
	define R where "R \<equiv> \<lambda>\<xi> Y df u p. \<exists>x y i a. u = {x,y} \<and> p = (i,a) \<and> x = prod_encode (\<xi>,i)
	\<and> y \<in> Y \<and> a \<in> A \<and> df(from_part y) (from_part x) = int a"
	have R_uniq: "\<lbrakk>R \<xi> (part_of \<zeta>) df u p; R \<xi> (part_of \<zeta>) df u p'; \<xi> \<noteq> \<zeta>\<rbrakk> \<Longrightarrow> p' = p" for u p p' \<xi> \<zeta> df
	by (auto simp add: R_def doubleton_eq_iff)
	define f where "f \<equiv> \<lambda>\<xi> Y df u. @p. R \<xi> Y df u p"
	have f_if_R: "f \<xi> (part_of \<zeta>) df u = p" if "R \<xi> (part_of \<zeta>) df u p" "\<xi> \<noteq> \<zeta>" for u p \<xi> \<zeta> df
	using R_uniq f_def that by blast
	have "bij_betw (f \<xi> (part_of \<zeta>) df) ?E ({..<M} \<times> A)"
	unfolding bij_betw_def inj_on_def
	proof (intro conjI strip)
	fix u u'
	assume "u \<in> ?E" and "u' \<in> ?E"
	and eq: "f \<xi> (part_of \<zeta>) df u = f \<xi> (part_of \<zeta>) df u'"
	obtain x y a where u: "u = {x,y}" "x \<in> part_of \<xi>" "y \<in> part_of \<zeta>" "a \<in> A"
	and df: "df (from_part y) (from_part x) = int a"
	using \<open>u \<in> ?E\<close>
	by (force simp add: Edges_def image_iff)
	then obtain i where i: "x = prod_encode (\<xi>,i)"
	using part_of_def by blast
	with u df R_def f_if_R that have fu: "f \<xi> (part_of \<zeta>) df u = (i,a)"
	by blast
	obtain x' y' a' where u': "u' = {x',y'}" "x' \<in> part_of \<xi>" "y' \<in> part_of \<zeta>" "a'\<in>A"
	and df': "df (from_part y') (from_part x') = int a'"
	using \<open>u' \<in> ?E\<close> by (force simp add: Edges_def image_iff)
	then obtain i' where i': "x' = prod_encode (\<xi>,i')"
	using part_of_def by blast
	with u' df' R_def f_if_R that have fu': "f \<xi> (part_of \<zeta>) df u' = (i',a')"
	by blast
	have "i'=i" "a' = a"
	using fu fu' eq by auto
	with i i' have "x = x'"
	by meson
	moreover have "from_part y = from_part y'"
	using df df' \<open>x = x'\<close> \<open>a' = a\<close> df_inj u'(3) u(3)
	by (clarsimp simp add: inj_on_def) (metis part_of_M lessThan_iff)
	then have "y = y'"
	using part_of_def u'(3) u(3) by fastforce
	ultimately show "u = u'"
	using u'(1) u(1) by force
	next
	have "f \<xi> (part_of \<zeta>) df ` ?E \<subseteq> {..<M} \<times> A"
	proof (clarsimp simp: Edges_def)
	fix i a x y b
	assume "x \<in> part_of \<xi>" "y \<in> part_of \<zeta>" "df (from_part y) (from_part x) = int b"
	"b \<in> A" and feq: "(i, a) = f \<xi> (part_of \<zeta>) df {x, y}"
	then have "R \<xi> (part_of \<zeta>) df {x,y} (from_part x, b)"
	by (auto simp: R_def doubleton_eq_iff part_of_def)
	then have "(from_part x, b) = (i, a)"
	by (simp add: f_if_R feq from_part_def that)
	then show "i < M \<and> a \<in> A"
	using \<open>x \<in> part_of \<xi>\<close> \<open>b \<in> A\<close> part_of_M by fastforce
	qed
	moreover have "{..<M} \<times> A \<subseteq> f \<xi> (part_of \<zeta>) df ` ?E"
	proof clarsimp
	fix i a assume "a \<in> A" and "i < M"
	then obtain j where "j<M" and j: "df j i = int a"
	using df_cancel by metis
	then have fj: "f \<xi> (part_of \<zeta>) df {prod_encode (\<xi>, i), prod_encode (\<zeta>, j)} = (i,a)"
	by (metis R_def \<open>a \<in> A\<close> enc_iff f_if_R from_enc \<open>\<xi> \<noteq> \<zeta>\<close>)
	then have "{prod_encode (\<xi>,i), prod_encode (\<zeta>, j mod M)} \<in> Edges (part_of \<xi>) (part_of \<zeta>) df"
	apply (clarsimp simp: Edges_def doubleton_eq_iff)
	by (metis \<open>a \<in> A\<close> \<open>i < M\<close> \<open>j < M\<close> enc_iff from_enc image_eqI j mod_if)
	then show "(i,a) \<in> f \<xi> (part_of \<zeta>) df ` Edges (part_of \<xi>) (part_of \<zeta>) df"
	using \<open>j < M\<close> fj image_iff by fastforce
	qed
	ultimately show "f \<xi> (part_of \<zeta>) df ` ?E = {..<M} \<times> A" by blast
	qed
	then show ?thesis
	by (simp add: bij_betw_same_card card_cartesian_product)
	qed
	have [simp]: "disjnt XY YZ" "disjnt XY XZ" "disjnt YZ XZ"
	using disjnt_part_of unfolding XY_def YZ_def XZ_def Edges_def disjnt_def
	by (clarsimp simp add: disjoint_iff doubleton_eq_iff, meson disjnt_iff n_not_Suc_n nat.discI)+
	have [simp]: "card XY = M * card A" "card YZ = M * card A"
	by (simp_all add: XY_def YZ_def card_Edges diff_cancel inj_on_diff)
	have [simp]: "card XZ = M * card A"
	by (simp_all add: XZ_def card_Edges diff2_cancel inj_on_diff2)
	have card_edges: "card (uedges G) = 3 * M * card A"
	by (simp add: G_def card_Un_disjnt)
	have "card A \<le> \<epsilon> * (real M / 4)"
	using * \<open>0 < M\<close> by (simp add: cardG card_edges power2_eq_square)
	also have "\<dots> < \<epsilon> * N"
	using \<open>N>0\<close> by (simp add: M_def assms)
	finally show "card A < \<epsilon> * N" .
	qed
	qed

	text\<open>We finally present the main statement formulated using the upper asymptotic density condition.\<close>

	theorem RothArithmeticProgressions:
	assumes "upper_asymptotic_density A > 0"
	shows "\<exists>k d. d>0 \<and> progression3 k d \<subseteq> A"
	proof (rule ccontr)
	assume non: "\<nexists>k d. 0 < d \<and> progression3 k d \<subseteq> A"
	obtain X where X: "\<forall>N \<ge> X. \<forall>A' \<subseteq> {..<N}. (\<nexists>k d. d>0 \<and> progression3 k d \<subseteq> A')
	\<longrightarrow> card A' < upper_asymptotic_density A / 2 * real N"
	by (metis half_gt_zero RothArithmeticProgressions_aux assms)
	then have "\<forall>N \<ge> X. card (A \<inter> {..<N}) < upper_asymptotic_density A / 2 * N"
	by (meson order_trans inf_le1 inf_le2 non)
	then have "upper_asymptotic_density A \<le> upper_asymptotic_density A / 2"
	by (force simp add: eventually_sequentially less_eq_real_def intro!: upper_asymptotic_densityI)
	with assms show False by linarith
	qed

	end



	diff --git a/thys/Signature_Groebner/Prelims.thy b/thys/Signature_Groebner/Prelims.thy
	--- a/thys/Signature_Groebner/Prelims.thy
	+++ b/thys/Signature_Groebner/Prelims.thy
	@@ -1,559 +1,556 @@
	(* Author: Alexander Maletzky *)

	section \<open>Preliminaries\<close>

	theory Prelims
	imports Polynomials.Utils Groebner_Bases.General
	begin

	subsection \<open>Lists\<close>

	subsubsection \<open>Sequences of Lists\<close>

	lemma list_seq_length_mono:
	fixes seq :: "nat \<Rightarrow> 'a list"
	assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i < j"
	shows "length (seq i) < length (seq j)"
	proof -
	from assms(2) obtain k where "j = Suc (i + k)" using less_iff_Suc_add by auto
	show ?thesis unfolding \<open>j = Suc (i + k)\<close>
	proof (induct k)
	case 0
	from assms(1) obtain x where eq: "seq (Suc i) = x # seq i" ..
	show ?case by (simp add: eq)
	next
	case (Suc k)
	from assms(1) obtain x where "seq (Suc (i + Suc k)) = x # seq (i + Suc k)" ..
	hence eq: "seq (Suc (Suc (i + k))) = x # seq (Suc (i + k))" by simp
	note Suc
	also have "length (seq (Suc (i + k))) < length (seq (Suc (i + Suc k)))" by (simp add: eq)
	finally show ?case .
	qed
	qed

	corollary list_seq_length_mono_weak:
	fixes seq :: "nat \<Rightarrow> 'a list"
	assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i \<le> j"
	shows "length (seq i) \<le> length (seq j)"
	proof (cases "i = j")
	case True
	thus ?thesis by simp
	next
	case False
	with assms(2) have "i < j" by simp
	with assms(1) have "length (seq i) < length (seq j)" by (rule list_seq_length_mono)
	thus ?thesis by simp
	qed

	lemma list_seq_indexE_length:
	fixes seq :: "nat \<Rightarrow> 'a list"
	assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)"
	obtains j where "i < length (seq j)"
	proof (induct i arbitrary: thesis)
	case 0
	have "0 \<le> length (seq 0)" by simp
	also from assms lessI have "... < length (seq (Suc 0))" by (rule list_seq_length_mono)
	finally show ?case by (rule 0)
	next
	case (Suc i)
	obtain j where "i < length (seq j)" by (rule Suc(1))
	hence "Suc i \<le> length (seq j)" by simp
	also from assms lessI have "... < length (seq (Suc j))" by (rule list_seq_length_mono)
	finally show ?case by (rule Suc(2))
	qed

	lemma list_seq_nth:
	fixes seq :: "nat \<Rightarrow> 'a list"
	assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i < length (seq j)" and "j \<le> k"
	shows "rev (seq k) ! i = rev (seq j) ! i"
	proof -
	from assms(3) obtain l where "k = j + l" using nat_le_iff_add by blast
	show ?thesis unfolding \<open>k = j + l\<close>
	proof (induct l)
	case 0
	show ?case by simp
	next
	case (Suc l)
	note assms(2)
	also from assms(1) le_add1 have "length (seq j) \<le> length (seq (j + l))"
	by (rule list_seq_length_mono_weak)
	finally have i: "i < length (seq (j + l))" .
	from assms(1) obtain x where "seq (Suc (j + l)) = x # seq (j + l)" ..
	thus ?case by (simp add: nth_append i Suc)
	qed
	qed

	corollary list_seq_nth':
	fixes seq :: "nat \<Rightarrow> 'a list"
	assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i < length (seq j)" and "i < length (seq k)"
	shows "rev (seq k) ! i = rev (seq j) ! i"
	proof (rule linorder_cases)
	assume "j < k"
	hence "j \<le> k" by simp
	with assms(1, 2) show ?thesis by (rule list_seq_nth)
	next
	assume "k < j"
	hence "k \<le> j" by simp
	with assms(1, 3) have "rev (seq j) ! i = rev (seq k) ! i" by (rule list_seq_nth)
	thus ?thesis by (rule HOL.sym)
	next
	assume "j = k"
	thus ?thesis by simp
	qed

	subsubsection \<open>@{const filter}\<close>

	lemma filter_merge_wrt_1:
	assumes "\<And>y. y \<in> set ys \<Longrightarrow> P y \<Longrightarrow> False"
	shows "filter P (merge_wrt rel xs ys) = filter P xs"
	using assms
	proof (induct rel xs ys rule: merge_wrt.induct)
	case (1 rel xs)
	show ?case by simp
	next
	case (2 rel y ys)
	hence "P y \<Longrightarrow> False" and "\<And>z. z \<in> set ys \<Longrightarrow> P z \<Longrightarrow> False" by auto
	thus ?case by (auto simp: filter_empty_conv)
	next
	case (3 rel x xs y ys)
	hence "\<not> P y" and x: "\<And>z. z \<in> set ys \<Longrightarrow> P z \<Longrightarrow> False" by auto
	have a: "filter P (merge_wrt rel xs ys) = filter P xs" if "x = y" using that x by (rule 3(1))
	have b: "filter P (merge_wrt rel xs (y # ys)) = filter P xs" if "x \<noteq> y" and "rel x y"
	using that 3(4) by (rule 3(2))
	have c: "filter P (merge_wrt rel (x # xs) ys) = filter P (x # xs)" if "x \<noteq> y" and "\<not> rel x y"
	using that x by (rule 3(3))
	show ?case by (simp add: a b c \<open>\<not> P y\<close>)
	qed

	lemma filter_merge_wrt_2:
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> P x \<Longrightarrow> False"
	shows "filter P (merge_wrt rel xs ys) = filter P ys"
	using assms
	proof (induct rel xs ys rule: merge_wrt.induct)
	case (1 rel xs)
	thus ?case by (auto simp: filter_empty_conv)
	next
	case (2 rel y ys)
	show ?case by simp
	next
	case (3 rel x xs y ys)
	hence "\<not> P x" and x: "\<And>z. z \<in> set xs \<Longrightarrow> P z \<Longrightarrow> False" by auto
	have a: "filter P (merge_wrt rel xs ys) = filter P ys" if "x = y" using that x by (rule 3(1))
	have b: "filter P (merge_wrt rel xs (y # ys)) = filter P (y # ys)" if "x \<noteq> y" and "rel x y"
	using that x by (rule 3(2))
	have c: "filter P (merge_wrt rel (x # xs) ys) = filter P ys" if "x \<noteq> y" and "\<not> rel x y"
	using that 3(4) by (rule 3(3))
	show ?case by (simp add: a b c \<open>\<not> P x\<close>)
	qed

	lemma length_filter_le_1:
	assumes "length (filter P xs) \<le> 1" and "i < length xs" and "j < length xs"
	and "P (xs ! i)" and "P (xs ! j)"
	shows "i = j"
	proof -
	have *: thesis if "a < b" and "b < length xs"
	and "\<And>as bs cs. as @ ((xs ! a) # (bs @ ((xs ! b) # cs))) = xs \<Longrightarrow> thesis" for a b thesis
	proof (rule that(3))
	from that(1, 2) have 1: "a < length xs" by simp
	with that(1, 2) have 2: "b - Suc a < length (drop (Suc a) xs)" by simp
	from that(1) \<open>a < length xs\<close> have eq: "xs ! b = drop (Suc a) xs ! (b - Suc a)" by simp
	show "(take a xs) @ ((xs ! a) # ((take (b - Suc a) (drop (Suc a) xs)) @ ((xs ! b) #
	drop (Suc (b - Suc a)) (drop (Suc a) xs)))) = xs"
	by (simp only: eq id_take_nth_drop[OF 1, symmetric] id_take_nth_drop[OF 2, symmetric])
	qed
	show ?thesis
	proof (rule linorder_cases)
	assume "i < j"
	then obtain as bs cs where "as @ ((xs ! i) # (bs @ ((xs ! j) # cs))) = xs"
	using assms(3) by (rule *)
	hence "filter P xs = filter P (as @ ((xs ! i) # (bs @ ((xs ! j) # cs))))" by simp
	also from assms(4, 5) have "... = (filter P as) @ ((xs ! i) # ((filter P bs) @ ((xs ! j) # (filter P cs))))"
	by simp
	finally have "\<not> length (filter P xs) \<le> 1" by simp
	thus ?thesis using assms(1) ..
	next
	assume "j < i"
	then obtain as bs cs where "as @ ((xs ! j) # (bs @ ((xs ! i) # cs))) = xs"
	using assms(2) by (rule *)
	hence "filter P xs = filter P (as @ ((xs ! j) # (bs @ ((xs ! i) # cs))))" by simp
	also from assms(4, 5) have "... = (filter P as) @ ((xs ! j) # ((filter P bs) @ ((xs ! i) # (filter P cs))))"
	by simp
	finally have "\<not> length (filter P xs) \<le> 1" by simp
	thus ?thesis using assms(1) ..
	qed
	qed

	lemma length_filter_eq [simp]: "length (filter ((=) x) xs) = count_list xs x"
	by (induct xs, simp_all)

	subsubsection \<open>@{const drop}\<close>

	lemma nth_in_set_dropI:
	assumes "j \<le> i" and "i < length xs"
	shows "xs ! i \<in> set (drop j xs)"
	using assms
	proof (induct xs arbitrary: i j)
	case Nil
	thus ?case by simp
	next
	case (Cons x xs)
	show ?case
	proof (cases j)
	case 0
	with Cons(3) show ?thesis by (metis drop0 nth_mem)
	next
	case (Suc j0)
	with Cons(2) Suc_le_D obtain i0 where i: "i = Suc i0" by blast
	with Cons(2) have "j0 \<le> i0" by (simp add: \<open>j = Suc j0\<close>)
	moreover from Cons(3) have "i0 < length xs" by (simp add: i)
	ultimately have "xs ! i0 \<in> set (drop j0 xs)" by (rule Cons(1))
	thus ?thesis by (simp add: i \<open>j = Suc j0\<close>)
	qed
	qed

	subsubsection \<open>@{const count_list}\<close>

	-lemma count_list_append [simp]: "count_list (xs @ ys) a = count_list xs a + count_list ys a"
	- by (induct xs, simp_all)
	-
	lemma count_list_upt [simp]: "count_list [a..<b] x = (if a \<le> x \<and> x < b then 1 else 0)"
	proof (cases "a \<le> b")
	case True
	then obtain k where "b = a + k" using le_Suc_ex by blast
	show ?thesis unfolding \<open>b = a + k\<close> by (induct k, simp_all)
	next
	case False
	thus ?thesis by simp
	qed

	subsubsection \<open>@{const sorted_wrt}\<close>

	lemma sorted_wrt_upt_iff: "sorted_wrt rel [a..<b] \<longleftrightarrow> (\<forall>i j. a \<le> i \<longrightarrow> i < j \<longrightarrow> j < b \<longrightarrow> rel i j)"
	proof (cases "a \<le> b")
	case True
	then obtain k where "b = a + k" using le_Suc_ex by blast
	show ?thesis unfolding \<open>b = a + k\<close>
	proof (induct k)
	case 0
	show ?case by simp
	next
	case (Suc k)
	show ?case
	proof (simp add: sorted_wrt_append Suc, intro iffI allI ballI impI conjI)
	fix i j
	assume "(\<forall>i\<ge>a. \<forall>j>i. j < a + k \<longrightarrow> rel i j) \<and> (\<forall>x\<in>{a..<a + k}. rel x (a + k))"
	hence 1: "\<And>i' j'. a \<le> i' \<Longrightarrow> i' < j' \<Longrightarrow> j' < a + k \<Longrightarrow> rel i' j'"
	and 2: "\<And>x. a \<le> x \<Longrightarrow> x < a + k \<Longrightarrow> rel x (a + k)" by simp_all
	assume "a \<le> i" and "i < j"
	assume "j < Suc (a + k)"
	hence "j < a + k \<or> j = a + k" by auto
	thus "rel i j"
	proof
	assume "j < a + k"
	with \<open>a \<le> i\<close> \<open>i < j\<close> show ?thesis by (rule 1)
	next
	assume "j = a + k"
	from \<open>a \<le> i\<close> \<open>i < j\<close> show ?thesis unfolding \<open>j = a + k\<close> by (rule 2)
	qed
	next
	fix i j
	assume "\<forall>i\<ge>a. \<forall>j>i. j < Suc (a + k) \<longrightarrow> rel i j" and "a \<le> i" and "i < j" and "j < a + k"
	thus "rel i j" by simp
	next
	fix x
	assume "x \<in> {a..<a + k}"
	hence "a \<le> x" and "x < a + k" by simp_all
	moreover assume "\<forall>i\<ge>a. \<forall>j>i. j < Suc (a + k) \<longrightarrow> rel i j"
	ultimately show "rel x (a + k)" by simp
	qed
	qed
	next
	case False
	thus ?thesis by simp
	qed

	subsubsection \<open>@{const insort_wrt} and @{const merge_wrt}\<close>

	lemma map_insort_wrt:
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> r2 (f y) (f x) \<longleftrightarrow> r1 y x"
	shows "map f (insort_wrt r1 y xs) = insort_wrt r2 (f y) (map f xs)"
	using assms
	proof (induct xs)
	case Nil
	show ?case by simp
	next
	case (Cons x xs)
	have "x \<in> set (x # xs)" by simp
	hence "r2 (f y) (f x) = r1 y x" by (rule Cons(2))
	moreover have "map f (insort_wrt r1 y xs) = insort_wrt r2 (f y) (map f xs)"
	proof (rule Cons(1))
	fix x'
	assume "x' \<in> set xs"
	hence "x' \<in> set (x # xs)" by simp
	thus "r2 (f y) (f x') = r1 y x'" by (rule Cons(2))
	qed
	ultimately show ?case by simp
	qed

	lemma map_merge_wrt:
	assumes "f ` set xs \<inter> f ` set ys = {}"
	and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> r2 (f x) (f y) \<longleftrightarrow> r1 x y"
	shows "map f (merge_wrt r1 xs ys) = merge_wrt r2 (map f xs) (map f ys)"
	using assms
	proof (induct r1 xs ys rule: merge_wrt.induct)
	case (1 uu xs)
	show ?case by simp
	next
	case (2 r1 v va)
	show ?case by simp
	next
	case (3 r1 x xs y ys)
	from 3(4) have "f x \<noteq> f y" and 1: "f ` set xs \<inter> f ` set (y # ys) = {}"
	and 2: "f ` set (x # xs) \<inter> f ` set ys = {}" by auto
	from this(1) have "x \<noteq> y" by auto
	have eq2: "map f (merge_wrt r1 xs (y # ys)) = merge_wrt r2 (map f xs) (map f (y # ys))"
	if "r1 x y" using \<open>x \<noteq> y\<close> that 1
	proof (rule 3(2))
	fix a b
	assume "a \<in> set xs"
	hence "a \<in> set (x # xs)" by simp
	moreover assume "b \<in> set (y # ys)"
	ultimately show "r2 (f a) (f b) \<longleftrightarrow> r1 a b" by (rule 3(5))
	qed
	have eq3: "map f (merge_wrt r1 (x # xs) ys) = merge_wrt r2 (map f (x # xs)) (map f ys)"
	if "\<not> r1 x y" using \<open>x \<noteq> y\<close> that 2
	proof (rule 3(3))
	fix a b
	assume "a \<in> set (x # xs)"
	assume "b \<in> set ys"
	hence "b \<in> set (y # ys)" by simp
	with \<open>a \<in> set (x # xs)\<close> show "r2 (f a) (f b) \<longleftrightarrow> r1 a b" by (rule 3(5))
	qed
	have eq4: "r2 (f x) (f y) \<longleftrightarrow> r1 x y" by (rule 3(5), simp_all)
	show ?case by (simp add: eq2 eq3 eq4 \<open>f x \<noteq> f y\<close> \<open>x \<noteq> y\<close>)
	qed

	subsection \<open>Recursive Functions\<close>

	locale recursive =
	fixes h' :: "'b \<Rightarrow> 'b"
	fixes b :: 'b
	assumes b_fixpoint: "h' b = b"
	begin

	context
	fixes Q :: "'a \<Rightarrow> bool"
	fixes g :: "'a \<Rightarrow> 'b"
	fixes h :: "'a \<Rightarrow> 'a"
	begin

	function (domintros) recfun_aux :: "'a \<Rightarrow> 'b" where
	"recfun_aux x = (if Q x then g x else h' (recfun_aux (h x)))"
	by pat_completeness auto

	lemmas [induct del] = recfun_aux.pinduct

	definition dom :: "'a \<Rightarrow> bool"
	where "dom x \<longleftrightarrow> (\<exists>k. Q ((h ^^ k) x))"

	lemma domI:
	assumes "\<not> Q x \<Longrightarrow> dom (h x)"
	shows "dom x"
	proof (cases "Q x")
	case True
	hence "Q ((h ^^ 0) x)" by simp
	thus ?thesis unfolding dom_def ..
	next
	case False
	hence "dom (h x)" by (rule assms)
	then obtain k where "Q ((h ^^ k) (h x))" unfolding dom_def ..
	hence "Q ((h ^^ (Suc k)) x)" by (simp add: funpow_swap1)
	thus ?thesis unfolding dom_def ..
	qed

	lemma domD:
	assumes "dom x" and "\<not> Q x"
	shows "dom (h x)"
	proof -
	from assms(1) obtain k where *: "Q ((h ^^ k) x)" unfolding dom_def ..
	with assms(2) have "k \<noteq> 0" using funpow_0 by fastforce
	then obtain m where "k = Suc m" using nat.exhaust by blast
	with * have "Q ((h ^^ m) (h x))" by (simp add: funpow_swap1)
	thus ?thesis unfolding dom_def ..
	qed

	lemma recfun_aux_domI:
	assumes "dom x"
	shows "recfun_aux_dom x"
	proof -
	from assms obtain k where "Q ((h ^^ k) x)" unfolding dom_def ..
	thus ?thesis
	proof (induct k arbitrary: x)
	case 0
	hence "Q x" by simp
	with recfun_aux.domintros show ?case by blast
	next
	case (Suc k)
	from Suc(2) have "Q ((h ^^ k) (h x))" by (simp add: funpow_swap1)
	hence "recfun_aux_dom (h x)" by (rule Suc(1))
	with recfun_aux.domintros show ?case by blast
	qed
	qed

	lemma recfun_aux_domD:
	assumes "recfun_aux_dom x"
	shows "dom x"
	using assms
	proof (induct x rule: recfun_aux.pinduct)
	case (1 x)
	show ?case
	proof (cases "Q x")
	case True
	with domI show ?thesis by blast
	next
	case False
	hence "dom (h x)" by (rule 1(2))
	thus ?thesis using domI by blast
	qed
	qed

	corollary recfun_aux_dom_alt: "recfun_aux_dom = dom"
	by (auto dest: recfun_aux_domI recfun_aux_domD)

	definition "fun" :: "'a \<Rightarrow> 'b"
	where "fun x = (if recfun_aux_dom x then recfun_aux x else b)"

	lemma simps: "fun x = (if Q x then g x else h' (fun (h x)))"
	proof (cases "dom x")
	case True
	hence dom: "recfun_aux_dom x" by (rule recfun_aux_domI)
	show ?thesis
	proof (cases "Q x")
	case True
	with dom show ?thesis by (simp add: fun_def recfun_aux.psimps)
	next
	case False
	have "recfun_aux_dom (h x)" by (rule recfun_aux_domI, rule domD, fact True, fact False)
	thus ?thesis by (simp add: fun_def dom False recfun_aux.psimps)
	qed
	next
	case False
	moreover have "\<not> Q x"
	proof
	assume "Q x"
	hence "dom x" using domI by blast
	with False show False ..
	qed
	moreover have "\<not> dom (h x)"
	proof
	assume "dom (h x)"
	hence "dom x" using domI by blast
	with False show False ..
	qed
	ultimately show ?thesis by (simp add: recfun_aux_dom_alt fun_def b_fixpoint split del: if_split)
	qed

	lemma eq_fixpointI: "\<not> dom x \<Longrightarrow> fun x = b"
	by (simp add: fun_def recfun_aux_dom_alt)

	lemma pinduct: "dom x \<Longrightarrow> (\<And>x. dom x \<Longrightarrow> (\<not> Q x \<Longrightarrow> P (h x)) \<Longrightarrow> P x) \<Longrightarrow> P x"
	unfolding recfun_aux_dom_alt[symmetric] by (fact recfun_aux.pinduct)

	end

	end (* recursive *)

	interpretation tailrec: recursive "\<lambda>x. x" undefined
	by (standard, fact refl)

	subsection \<open>Binary Relations\<close>

	lemma almost_full_on_Int:
	assumes "almost_full_on P1 A1" and "almost_full_on P2 A2"
	shows "almost_full_on (\<lambda>x y. P1 x y \<and> P2 x y) (A1 \<inter> A2)" (is "almost_full_on ?P ?A")
	proof (rule almost_full_onI)
	fix f :: "nat \<Rightarrow> 'a"
	assume a: "\<forall>i. f i \<in> ?A"
	define g where "g = (\<lambda>i. (f i, f i))"
	from assms have "almost_full_on (prod_le P1 P2) (A1 \<times> A2)" by (rule almost_full_on_Sigma)
	moreover from a have "\<And>i. g i \<in> A1 \<times> A2" by (simp add: g_def)
	ultimately obtain i j where "i < j" and "prod_le P1 P2 (g i) (g j)" by (rule almost_full_onD)
	from this(2) have "?P (f i) (f j)" by (simp add: g_def prod_le_def)
	with \<open>i < j\<close> show "good ?P f" by (rule goodI)
	qed

	corollary almost_full_on_same:
	assumes "almost_full_on P1 A" and "almost_full_on P2 A"
	shows "almost_full_on (\<lambda>x y. P1 x y \<and> P2 x y) A"
	proof -
	from assms have "almost_full_on (\<lambda>x y. P1 x y \<and> P2 x y) (A \<inter> A)" by (rule almost_full_on_Int)
	thus ?thesis by simp
	qed

	context ord
	begin

	definition is_le_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
	where "is_le_rel rel = (rel = (=) \<or> rel = (\<le>) \<or> rel = (<))"

	lemma is_le_relI [simp]: "is_le_rel (=)" "is_le_rel (\<le>)" "is_le_rel (<)"
	by (simp_all add: is_le_rel_def)

	lemma is_le_relE:
	assumes "is_le_rel rel"
	obtains "rel = (=)" \| "rel = (\<le>)" \| "rel = (<)"
	using assms unfolding is_le_rel_def by blast

	end (* ord *)

	context preorder
	begin

	lemma is_le_rel_le:
	assumes "is_le_rel rel"
	shows "rel x y \<Longrightarrow> x \<le> y"
	using assms by (rule is_le_relE, auto dest: less_imp_le)

	lemma is_le_rel_trans:
	assumes "is_le_rel rel"
	shows "rel x y \<Longrightarrow> rel y z \<Longrightarrow> rel x z"
	using assms by (rule is_le_relE, auto dest: order_trans less_trans)

	lemma is_le_rel_trans_le_left:
	assumes "is_le_rel rel"
	shows "x \<le> y \<Longrightarrow> rel y z \<Longrightarrow> x \<le> z"
	using assms by (rule is_le_relE, auto dest: order_trans le_less_trans less_imp_le)

	lemma is_le_rel_trans_le_right:
	assumes "is_le_rel rel"
	shows "rel x y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
	using assms by (rule is_le_relE, auto dest: order_trans less_le_trans less_imp_le)

	lemma is_le_rel_trans_less_left:
	assumes "is_le_rel rel"
	shows "x < y \<Longrightarrow> rel y z \<Longrightarrow> x < z"
	using assms by (rule is_le_relE, auto dest: less_le_trans less_imp_le)

	lemma is_le_rel_trans_less_right:
	assumes "is_le_rel rel"
	shows "rel x y \<Longrightarrow> y < z \<Longrightarrow> x < z"
	using assms by (rule is_le_relE, auto dest: le_less_trans less_imp_le)

	end (* preorder *)

	context order
	begin

	lemma is_le_rel_distinct:
	assumes "is_le_rel rel"
	shows "rel x y \<Longrightarrow> x \<noteq> y \<Longrightarrow> x < y"
	using assms by (rule is_le_relE, auto)

	lemma is_le_rel_antisym:
	assumes "is_le_rel rel"
	shows "rel x y \<Longrightarrow> rel y x \<Longrightarrow> x = y"
	using assms by (rule is_le_relE, auto)

	end (* order *)

	end (* theory *)
	diff --git a/thys/Smith_Normal_Form/Alternative_Proofs.thy b/thys/Smith_Normal_Form/Alternative_Proofs.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Smith_Normal_Form/Alternative_Proofs.thy
	@@ -0,0 +1,373 @@
	+theory Alternative_Proofs
	+ imports Smith_Normal_Form.Admits_SNF_From_Diagonal_Iff_Bezout_Ring
	+ Smith_Normal_Form.Elementary_Divisor_Rings
	+begin
	+
	+
	+text \<open>Theorem 2: (C) ==> (A)\<close>
	+
	+lemma diagonal_2x2_admits_SNF_imp_bezout_ring_JNF:
	+ assumes admits_SNF: "\<forall>A. (A::'a mat) \<in> carrier_mat 2 2 \<and> isDiagonal_mat A
	+ \<longrightarrow> (\<exists>P Q. P \<in> carrier_mat 2 2 \<and> Q \<in> carrier_mat 2 2 \<and> invertible_mat P \<and> invertible_mat Q
	+ \<and> Smith_normal_form_mat (PAQ))"
	+ shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
	+proof (intro_classes)
	+ fix a b::'a
	+ show "\<exists>p q d. p * a + q * b = d \<and> d dvd a \<and> d dvd b \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd d)"
	+ proof (cases "a=b")
	+ case True
	+ show ?thesis
	+ by (metis True add.right_neutral comm_semiring_class.distrib dvd_refl mult_1)
	+ next
	+ case False note a_not_b = False
	+ let ?A = "Matrix.mat 2 2 (\<lambda>(i,j). if i = 0 \<and> j = 0 then a else if i = 1 \<and> j = 1 then b else 0)"
	+ have A_carrier: "?A \<in> carrier_mat 2 2" by auto
	+ moreover have diag_A: "isDiagonal_mat ?A" by (simp add: isDiagonal_mat_def)
	+ ultimately obtain P Q where P: "P \<in> carrier_mat 2 2"
	+ and Q: "Q \<in> carrier_mat 2 2" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
	+ and SNF_PAQ: "Smith_normal_form_mat (P?AQ)"
	+ using admits_SNF by blast
	+ let ?p = "P$$(0,0)*Q$$(0,0)"
	+ let ?q = "P$$(0,1)*Q$$(1,0)"
	+ let ?d = "(P?AQ) $$ (0,0)"
	+ let ?d' = "(P?AQ) $$ (1,1)"
	+ have d_dvd_d': "?d dvd ?d'"
	+ by (metis (no_types, lifting) A_carrier One_nat_def P Q SNF_PAQ SNF_first_divides_all bot_nat_0.not_eq_extremum
	+ less_Suc_numeral mult_carrier_mat pred_numeral_simps(2) zero_neq_numeral)
	+ have pa_qb_d: "?pa + ?q b = ?d"
	+ proof -
	+ let ?U = "P*?A"
	+ have "?U $$ (0, 0) = P $$ (0,0)* ?A $$ (0,0) + P $$ (0,1)* ?A $$ (1,0)"
	+ by (rule mat_mult2_00, insert P, auto)
	+ also have "... = P $$ (0,0) * a" by auto
	+ finally have 1: "(P?A) $$ (0, 0) = P $$ (0,0) a" .
	+ have "?U $$ (0, 1) = P $$ (0,0)* ?A $$ (0,1) + P $$ (0,1)* ?A $$ (1,1)"
	+ by (rule mat_mult2_01, insert P, auto)
	+ hence 2: "(P?A) $$ (0, 1)= P $$ (0,1) b" by auto
	+ have "?d = ?U $$ (0, 0) * Q $$ (0, 0) + ?U $$ (0, 1) * Q $$ (1, 0)"
	+ by (rule mat_mult2_00, insert Q P, auto)
	+ also have "... = ?pa + ?q b" unfolding 1 unfolding 2 by auto
	+ finally show ?thesis ..
	+ qed
	+ have i: "ideal_generated {a, b} = ideal_generated {?d}"
	+ proof
	+ show "ideal_generated {?d} \<subseteq> ideal_generated {a, b}"
	+ proof (rule ideal_generated_subset2, rule ballI, simp)
	+ fix x
	+ let ?f = "\<lambda>x. if x = a then ?p else ?q"
	+ show "?d \<in> ideal_generated {a, b}"
	+ unfolding ideal_explicit
	+ by simp (rule exI[of _ ?f], rule exI[of _ "{a,b}"],
	+ insert a_not_b One_nat_def pa_qb_d, auto)
	+ qed
	+ show "ideal_generated {a, b} \<subseteq> ideal_generated {?d}"
	+ proof -
	+ obtain P' where inverts_mat_P': "inverts_mat P P' \<and> inverts_mat P' P"
	+ using inv_P unfolding invertible_mat_def by auto
	+ have P': "P' \<in> carrier_mat 2 2"
	+ using inverts_mat_P'
	+ unfolding carrier_mat_def inverts_mat_def
	+ by (auto,metis P carrier_matD index_mult_mat(3) one_carrier_mat)+
	+ obtain Q' where inverts_mat_Q': "inverts_mat Q Q' \<and> inverts_mat Q' Q"
	+ using inv_Q unfolding invertible_mat_def by auto
	+ have Q': "Q' \<in> carrier_mat 2 2"
	+ using inverts_mat_Q'
	+ unfolding carrier_mat_def inverts_mat_def
	+ by (auto,metis Q carrier_matD index_mult_mat(3) one_carrier_mat)+
	+ have rw_PAQ: "(P'(P?AQ)Q') $$ (i, i) = ?A $$ (i,i)" for i
	+ using inv_P'PAQQ'[OF A_carrier P _ _ Q P' Q'] inverts_mat_P' inverts_mat_Q' by auto
	+ have diag_PAQ: "isDiagonal_mat (P?AQ)"
	+ using SNF_PAQ unfolding Smith_normal_form_mat_def by auto
	+ have PAQ_carrier: "(P?AQ) \<in> carrier_mat 2 2" using P Q by auto
	+ have z1: "0<(2::nat)" and z2: "1<(2::nat)" by auto
	+ obtain f where f: "(P'(P?AQ)Q') $$ (0, 0) = (\<Sum>i\<in>set (diag_mat (P?AQ)). f i * i)"
	+ using exists_f_PAQ_Aii[OF diag_PAQ P' PAQ_carrier Q' z1] by blast
	+ obtain g where g: "(P'(P?AQ)Q') $$ (1, 1) = (\<Sum>i\<in>set (diag_mat (P?AQ)). g i * i)"
	+ using exists_f_PAQ_Aii[OF diag_PAQ P' PAQ_carrier Q' z2] by blast
	+ have A00: "?A $$ (0, 0) = (\<Sum>i\<in>set (diag_mat (P?AQ)). f i * i)"
	+ using rw_PAQ[of 0] using f by presburger
	+ have A11: "?A $$ (1, 1) = (\<Sum>i\<in>set (diag_mat (P?AQ)). g i * i)"
	+ using rw_PAQ[of 1] using g by presburger
	+ have d_dvd_a: "?d dvd a" using A00 d_dvd_d'
	+ by (auto, smt (verit, best) A00 A_carrier P Q S00_dvd_all_A SNF_PAQ inv_P inv_Q
	+ numeral_2_eq_2 zero_less_Suc)
	+ have d_dvd_b: "?d dvd b" using A11 d_dvd_d'
	+ by (smt (verit, ccfv_threshold) A_carrier One_nat_def P Q S00_dvd_all_A SNF_PAQ
	+ index_mat(1) inv_P inv_Q lessI nat.simps(3) numeral_2_eq_2 split_conv)
	+ have 1: "a \<in> ideal_generated {?d}" and 2: "b \<in> ideal_generated {?d}"
	+ using d_dvd_a d_dvd_b dvd_ideal_generated_singleton' ideal_generated_subset_generator
	+ by blast+
	+ show ?thesis by (rule ideal_generated_subset2, insert 1 2, auto)
	+ qed
	+ qed
	+ have "\<exists> p q. p * a + q * b = ?d" by (rule ideal_generated_pair_exists[OF i])
	+ moreover have d_dvd_a: "?d dvd a" and d_dvd_b: "?d dvd b"
	+ using i ideal_generated_singleton_dvd by blast+
	+ moreover have "(\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd ?d)" using ideal_generated_dvd[OF i] by auto
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+qed
	+
	+
	+text \<open>Theorem 2: (A) ==> (C)\<close>
	+
	+lemma bezout_ring_imp_diagonal_2x2_admits_SNF_JNF:
	+ assumes c: "OFCLASS('a::comm_ring_1, bezout_ring_class)"
	+ shows "\<forall>A. (A::'a mat) \<in> carrier_mat 2 2 \<and> isDiagonal_mat A
	+ \<longrightarrow> (\<exists>P Q. P \<in> carrier_mat 2 2 \<and> Q \<in> carrier_mat 2 2
	+ \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat (PAQ))"
	+ using bezout_ring_imp_diagonal_admits_SNF_JNF
	+ [OF OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a, OF c]]
	+ unfolding admits_SNF_JNF_def
	+ using \<open>\<forall>A. admits_SNF_JNF A\<close> admits_SNF_JNF_alt_def by blast
	+
	+
	+text \<open>Theorem 2: (A) <==> (C)\<close>
	+
	+lemma diagonal_2x2_admits_SNF_iff_bezout_ring:
	+ shows "OFCLASS('a::comm_ring_1, bezout_ring_class)
	+ \<equiv> (\<And>A::'a mat. A \<in> carrier_mat 2 2 \<longrightarrow> admits_SNF_JNF A)" (is "?lhs \<equiv> ?rhs")
	+proof
	+ fix A::"'a mat"
	+ assume c: "OFCLASS('a, bezout_ring_class)"
	+ show "A \<in> carrier_mat 2 2 \<longrightarrow> admits_SNF_JNF A"
	+ using bezout_ring_imp_diagonal_admits_SNF_JNF
	+ [OF OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a, OF c]]
	+ unfolding admits_SNF_JNF_def by blast
	+next
	+ assume rhs: "(\<And>A::'a mat. A \<in> carrier_mat 2 2 \<longrightarrow> admits_SNF_JNF A)"
	+ show "OFCLASS('a::comm_ring_1, bezout_ring_class)"
	+ by (rule diagonal_2x2_admits_SNF_imp_bezout_ring_JNF, insert rhs, simp add: admits_SNF_JNF_def)
	+qed
	+
	+text \<open>Theorem 2: (B) <==> (C)\<close>
	+lemma diagonal_2x2_admits_SNF_iff_diagonal_admits_SNF:
	+ shows "(\<forall>(A::'a::comm_ring_1 mat). admits_SNF_JNF A) =
	+ (\<forall>(A::'a mat) \<in> carrier_mat 2 2. admits_SNF_JNF A)"
	+proof
	+ assume "\<forall>A::'a mat. admits_SNF_JNF A"
	+ thus "\<forall>(A::'a mat)\<in>carrier_mat 2 2. admits_SNF_JNF A"
	+ by (insert admits_SNF_JNF_alt_def, blast)
	+next
	+ assume "\<forall>A::'a mat \<in>carrier_mat 2 2. admits_SNF_JNF A "
	+ hence H: "OFCLASS('a, bezout_ring_class)"
	+ using diagonal_2x2_admits_SNF_iff_bezout_ring[where ?'a = 'a] by auto
	+ show "\<forall>A::'a mat. admits_SNF_JNF A"
	+ using bezout_ring_imp_diagonal_admits_SNF_JNF
	+ [OF OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a, OF H]]
	+ by simp
	+qed
	+
	+text \<open>Theorem 2: final statements\<close>
	+
	+theorem Theorem2_final:
	+ shows A_imp_B: "OFCLASS('a::comm_ring_1, bezout_ring_class)
	+ \<Longrightarrow> (\<forall>A::'a mat. admits_SNF_JNF A)"
	+ and B_imp_C: "(\<forall>A::'a mat. admits_SNF_JNF A) \<Longrightarrow>
	+ (\<forall>(A::'a mat) \<in> carrier_mat 2 2. admits_SNF_JNF A)"
	+ and C_imp_A: "(\<forall>(A::'a mat) \<in> carrier_mat 2 2. admits_SNF_JNF A)
	+ \<Longrightarrow> OFCLASS('a::comm_ring_1, bezout_ring_class)"
	+proof
	+ fix A::"'a mat"
	+ assume H: "OFCLASS('a, bezout_ring_class)"
	+ show "admits_SNF_JNF A"
	+ using bezout_ring_imp_diagonal_admits_SNF_JNF[OF OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a, OF H]]
	+ by simp
	+next
	+ assume "\<forall>A::'a mat. admits_SNF_JNF A"
	+ thus "\<forall>(A::'a mat)\<in>carrier_mat 2 2. admits_SNF_JNF A"
	+ by (insert admits_SNF_JNF_alt_def, blast)
	+next
	+ assume "\<forall>(A::'a mat)\<in>carrier_mat 2 2. admits_SNF_JNF A"
	+ thus "OFCLASS('a, bezout_ring_class)"
	+ using diagonal_2x2_admits_SNF_iff_bezout_ring[where ?'a = 'a] by auto
	+qed
	+
	+
	+theorem Theorem2_final':
	+ shows A_eq_B: "OFCLASS('a::comm_ring_1, bezout_ring_class) \<equiv> (\<And>A::'a mat. admits_SNF_JNF A)"
	+ and A_eq_C: "OFCLASS('a::comm_ring_1, bezout_ring_class) \<equiv>
	+ (\<And>(A::'a mat). A \<in> carrier_mat 2 2 \<longrightarrow> admits_SNF_JNF A)"
	+ and B_eq_C: "(\<forall>(A::'a::comm_ring_1 mat). admits_SNF_JNF A) =
	+ (\<forall>(A::'a mat) \<in> carrier_mat 2 2. admits_SNF_JNF A)"
	+ using diagonal_admits_SNF_iff_bezout_ring'
	+ using diagonal_2x2_admits_SNF_iff_bezout_ring
	+ using diagonal_2x2_admits_SNF_iff_diagonal_admits_SNF by auto
	+
	+text \<open>Theorem 2: final statement in HA. (A) <==> (C).\<close>
	+
	+theorem Theorem2_A_eq_C_HA:
	+ "OFCLASS('a::comm_ring_1, bezout_ring_class) \<equiv> (\<And>(A::'a^2^2). admits_SNF_HA A)"
	+proof
	+ fix A::"'a^2^2"
	+ assume H: "OFCLASS('a, bezout_ring_class)"
	+ let ?A = "Mod_Type_Connect.from_hma\<^sub>m A"
	+ have A: "?A \<in> carrier_mat 2 2" by auto
	+ have [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A"
	+ unfolding Mod_Type_Connect.HMA_M_def A by auto
	+ have "admits_SNF_JNF ?A" using A_imp_B[OF H] by auto
	+ thus "admits_SNF_HA A" by transfer'
	+next
	+ assume a: "(\<And>A::'a^2^2. admits_SNF_HA A)"
	+ have [transfer_rule]: "Mod_Type_Connect.HMA_M (Mod_Type_Connect.from_hma\<^sub>m A) A" for A::"'a^2^2"
	+ unfolding Mod_Type_Connect.HMA_M_def by auto
	+ have a': "(\<And>A::'a^2^2. admits_SNF_JNF (Mod_Type_Connect.from_hma\<^sub>m A))"
	+ proof -
	+ fix A::"'a^2^2"
	+ have ad: "admits_SNF_HA A" using a by simp
	+ let ?A = "Mod_Type_Connect.from_hma\<^sub>m A"
	+ have A: "?A \<in> carrier_mat 2 2" by auto
	+ have [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A"
	+ unfolding Mod_Type_Connect.HMA_M_def A by auto
	+ show "admits_SNF_JNF (Mod_Type_Connect.from_hma\<^sub>m A)" using ad by transfer'
	+ qed
	+ have "(\<forall>A::'a^2^2. admits_SNF_JNF (Mod_Type_Connect.from_hma\<^sub>m A))
	+ = (\<forall>(A::'a mat)\<in>carrier_mat 2 2. admits_SNF_JNF A)"
	+ proof (auto)
	+ fix A::"'a mat" assume a1: "\<forall>A::'a^2^2. admits_SNF_JNF (Mod_Type_Connect.from_hma\<^sub>m A)"
	+ and "A \<in> carrier_mat 2 2"
	+ thus "admits_SNF_JNF A" by (metis Mod_Type_Connect.from_hma_to_hma\<^sub>m One_nat_def UNIV_1 a1
	+ card.empty card.insert card_bit0 empty_iff finite mult.right_neutral)
	+ next
	+ fix A::"'a^2^2" assume "\<forall>A\<in>carrier_mat 2 2. admits_SNF_JNF A"
	+ have ad: "admits_SNF_HA A" using a by simp
	+ let ?A = "Mod_Type_Connect.from_hma\<^sub>m A"
	+ have A: "?A \<in> carrier_mat 2 2" by auto
	+ have [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A"
	+ unfolding Mod_Type_Connect.HMA_M_def A by auto
	+ show "admits_SNF_JNF (Mod_Type_Connect.from_hma\<^sub>m A)" using ad by transfer'
	+ qed
	+ hence "(\<And>A::'a mat. A \<in> carrier_mat 2 2 \<longrightarrow> admits_SNF_JNF A)" using a' by auto
	+ thus "OFCLASS('a, bezout_ring_class)" using Theorem2_final'[where ?'a='a] by auto
	+qed
	+
	+
	+text \<open>Hermite implies Bezout\<close>
	+
	+text \<open>Theorem 3, proof for 1x2 matrices\<close>
	+lemma theorem3_restricted_12_part1:
	+ assumes T: "(\<forall>a b::'a::comm_ring_1. \<exists> a1 b1 d. a = a1d \<and> b = b1d
	+ \<and> ideal_generated {a1,b1} = ideal_generated {1})"
	+ shows "\<forall>(A::'a mat) \<in> carrier_mat 1 2. admits_triangular_reduction A"
	+proof (rule)
	+ fix A::"'a mat"
	+ assume A: "A \<in> carrier_mat 1 2"
	+ let ?a = "A $$ (0,0)"
	+ let ?b = "A $$ (0,1)"
	+ obtain a1 b1 d where a: "?a = a1d" and b: "?b = b1d"
	+ and i: "ideal_generated {a1,b1} = ideal_generated {1}"
	+ using T by blast
	+ obtain s t where sa1tb1:"sa1+tb1=1" using ideal_generated_pair_exists_pq1[OF i[simplified]] by blast
	+ let ?Q = "Matrix.mat 2 2 (\<lambda>(i,j). if i = 0 \<and> j = 0 then s else
	+ if i = 0 \<and> j = 1 then -b1 else
	+ if i = 1 \<and> j = 0 then t else a1)"
	+ have Q: "?Q \<in> carrier_mat 2 2" by auto
	+ have det_Q: "Determinant.det ?Q = 1" unfolding det_2[OF Q]
	+ using sa1tb1 by (simp add: mult.commute)
	+ hence inv_Q: "invertible_mat ?Q" using invertible_iff_is_unit_JNF[OF Q] by auto
	+ have lower_AQ: "lower_triangular (A*?Q)"
	+ proof -
	+ have "Matrix.row A 0 $v Suc 0 * a1 = Matrix.row A 0 $v 0 * b1" if j2: "j<2" and j0: "0<j" for j
	+ by (metis A One_nat_def a b carrier_matD(1) carrier_matD(2) index_row(1) lessI
	+ more_arith_simps(11) mult.commute numeral_2_eq_2 pos2)
	+ thus ?thesis unfolding lower_triangular_def using A
	+ by (auto simp add: scalar_prod_def sum_two_rw)
	+ qed
	+ show "admits_triangular_reduction A"
	+ unfolding admits_triangular_reduction_def using lower_AQ inv_Q Q A by force
	+qed
	+
	+
	+lemma theorem3_restricted_12_part2:
	+ assumes 1: "\<forall>(A::'a::comm_ring_1 mat) \<in> carrier_mat 1 2. admits_triangular_reduction A"
	+ shows "\<forall>a b::'a. \<exists> a1 b1 d. a = a1d \<and> b = b1d \<and> ideal_generated {a1,b1} = ideal_generated {1}"
	+proof (rule allI)+
	+ fix a b::'a
	+ let ?A = "Matrix.mat 1 2 (\<lambda>(i,j). if i = 0 \<and> j = 0 then a else b)"
	+ obtain Q where AQ: "lower_triangular (?A*Q)" and inv_Q: "invertible_mat Q"
	+ and Q: "Q \<in> carrier_mat 2 2"
	+ using 1 unfolding admits_triangular_reduction_def by fastforce
	+ hence [simp]: "dim_col Q = 2" and [simp]: "dim_row Q = 2" by auto
	+ let ?s = "Q $$ (0,0)"
	+ let ?t = "Q $$ (1,0)"
	+ let ?a1 = "Q $$ (1,1)"
	+ let ?b1 = "-(Q $$ (0,1))"
	+ let ?d = "(?A*Q) $$ (0,0)"
	+ have ab1_ba1: "a?b1 = b?a1"
	+ proof -
	+ have "(?AQ) $$ (0,1) = (\<Sum>i = 0..<2. (if i = 0 then a else b) Q $$ (i, Suc 0))"
	+ unfolding times_mat_def col_def scalar_prod_def by auto
	+ also have "... = (\<Sum>i \<in> {0,1}. (if i = 0 then a else b) * Q $$ (i, Suc 0))"
	+ by (rule sum.cong, auto)
	+ also have "... = - a?b1 + b?a1" by auto
	+ finally have "(?AQ) $$ (0,1) = - a?b1 + b*?a1" by simp
	+ moreover have "(?A*Q) $$ (0,1) = 0" using AQ unfolding lower_triangular_def by auto
	+ ultimately show ?thesis
	+ by (metis add_left_cancel more_arith_simps(3) more_arith_simps(7))
	+ qed
	+ have sa_tb_d: "?sa+?tb = ?d"
	+ proof -
	+ have "?d = (\<Sum>i = 0..<2. (if i = 0 then a else b) * Q $$ (i, 0))"
	+ unfolding times_mat_def col_def scalar_prod_def by auto
	+ also have "... = (\<Sum>i \<in> {0,1}. (if i = 0 then a else b) * Q $$ (i, 0))" by (rule sum.cong, auto)
	+ also have "... = ?sa+?tb" by auto
	+ finally show ?thesis by simp
	+ qed
	+ have det_Q_dvd_1: "(Determinant.det Q dvd 1)"
	+ using invertible_iff_is_unit_JNF[OF Q] inv_Q by auto
	+ moreover have det_Q_eq: "Determinant.det Q = ?s?a1 + ?t?b1" unfolding det_2[OF Q] by simp
	+ ultimately have "?s?a1 + ?t?b1 dvd 1" by auto
	+ from this obtain u where u_eq: "?s?a1 + ?t?b1 = u" and u: "u dvd 1" by auto
	+ hence eq1: "?s?a1a + ?t?b1a = u*a"
	+ by (metis ring_class.ring_distribs(2))
	+ hence "?s?a1a + ?t?a1b = u*a"
	+ by (metis (no_types, lifting) ab1_ba1 mult.assoc mult.commute)
	+ hence a1d_ua:"?a1?d=ua"
	+ by (smt Groups.mult_ac(2) distrib_left more_arith_simps(11) sa_tb_d)
	+ hence b1d_ub: "?b1?d=ub"
	+ by (smt Groups.mult_ac(2) Groups.mult_ac(3) ab1_ba1 distrib_right sa_tb_d u_eq)
	+ obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
	+ by (metis mult.commute)
	+ hence inv_u_dvd_1: "inv_u dvd 1" unfolding dvd_def by auto
	+ have cond1: "(inv_u?b1)?d = b" using b1d_ub inv_u
	+ by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6))
	+ have cond2: "(inv_u?a1)?d = a" using a1d_ua inv_u
	+ by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6))
	+ have "ideal_generated {inv_u?a1, inv_u?b1} = ideal_generated {?a1,?b1}"
	+ by (rule ideal_generated_mult_unit2[OF inv_u_dvd_1])
	+ also have "... = UNIV" using ideal_generated_pair_UNIV[OF u_eq u] by simp
	+ finally have cond3: "ideal_generated {inv_u?a1, inv_u?b1} = ideal_generated {1}" by auto
	+ show "\<exists>a1 b1 d. a = a1 * d \<and> b = b1 * d \<and> ideal_generated {a1, b1} = ideal_generated {1}"
	+ by (rule exI[of _ "inv_u?a1"], rule exI[of _ "inv_u?b1"], rule exI[of _ ?d],
	+ insert cond1 cond2 cond3, auto)
	+qed
	+
	+
	+lemma Hermite_ring_imp_Bezout_ring:
	+ assumes H: "OFCLASS('a::comm_ring_1, Hermite_ring_class)"
	+ shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
	+proof (intro_classes)
	+ fix a b::'a
	+ let ?A = "Matrix.mat 1 2 (\<lambda>(i,j). if i = 0 \<and> j = 0 then a else b)"
	+ have *: "(\<And>(A::'a::comm_ring_1 mat). admits_triangular_reduction A)"
	+ using OFCLASS_Hermite_ring_def[where ?'a='a] H by auto
	+ have "admits_triangular_reduction ?A"
	+ using H unfolding OFCLASS_Hermite_ring_def by auto
	+ have "\<exists> a1 b1 d. a = a1d \<and> b = b1d \<and> ideal_generated {a1,b1} = ideal_generated {1}"
	+ using theorem3_restricted_12_part2 * by auto
	+ from this obtain a1 b1 d where a_a'd: "a = a1d" and b_b'd: "b = b1d"
	+ and a'b'_1: "ideal_generated {a1,b1} = ideal_generated {1}"
	+ by blast
	+ obtain p q where "p * a1 + q * b1 = 1" using a'b'_1
	+ using ideal_generated_pair_exists_UNIV by blast
	+ hence pa_qb_d: "p * a + q * b = d" unfolding a_a'd b_b'd
	+ by (metis mult.assoc mult_1 ring_class.ring_distribs(2))
	+ moreover have d_dvd_a: "d dvd a" using a_a'd by auto
	+ moreover have d_dvd_b: "d dvd b" using b_b'd by auto
	+ moreover have "(\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd d)" using pa_qb_d by force
	+ ultimately show "\<exists>p q d. p * a + q * b = d \<and> d dvd a \<and> d dvd b
	+ \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd d)" by blast
	+qed
	+
	+end
	diff --git a/thys/Smith_Normal_Form/ROOT b/thys/Smith_Normal_Form/ROOT
	--- a/thys/Smith_Normal_Form/ROOT
	+++ b/thys/Smith_Normal_Form/ROOT
	@@ -1,20 +1,21 @@
	chapter AFP

	session Smith_Normal_Form (AFP) = Hermite +
	options [timeout = 2400]
	sessions
	"HOL-Types_To_Sets"
	Perron_Frobenius
	"List-Index"
	Berlekamp_Zassenhaus
	theories
	Diagonal_To_Smith
	SNF_Uniqueness
	Cauchy_Binet_HOL_Analysis
	SNF_Algorithm_Two_Steps
	SNF_Algorithm_Two_Steps_JNF
	SNF_Algorithm_HOL_Analysis
	SNF_Algorithm_Euclidean_Domain
	Smith_Certified
	+ Alternative_Proofs
	document_files
	"root.tex"
	diff --git a/thys/Stirling_Formula/Gamma_Asymptotics.thy b/thys/Stirling_Formula/Gamma_Asymptotics.thy
	--- a/thys/Stirling_Formula/Gamma_Asymptotics.thy
	+++ b/thys/Stirling_Formula/Gamma_Asymptotics.thy
	@@ -1,1893 +1,1893 @@
	(*
	File: Gamma_Asymptotics.thy
	Author: Manuel Eberl

	The complete asymptotics of the real and complex logarithmic Gamma functions.
	Also of the real Polygamma functions (could be extended to the complex ones fairly easily
	if needed).
	*)
	section \<open>Complete asymptotics of the logarithmic Gamma function\<close>
	theory Gamma_Asymptotics
	imports
	"HOL-Complex_Analysis.Complex_Analysis"
	"HOL-Real_Asymp.Real_Asymp"
	Bernoulli.Bernoulli_FPS
	Bernoulli.Periodic_Bernpoly
	Stirling_Formula
	begin

	subsection \<open>Auxiliary Facts\<close>

	(* TODO: could be automated with Laurent series expansions in the future *)
	lemma stirling_limit_aux1:
	"((\<lambda>y. Ln (1 + z * of_real y) / of_real y) \<longlongrightarrow> z) (at_right 0)" for z :: complex
	proof (cases "z = 0")
	case True
	then show ?thesis by simp
	next
	case False
	have "((\<lambda>y. ln (1 + z * of_real y)) has_vector_derivative 1 * z) (at 0)"
	by (rule has_vector_derivative_real_field) (auto intro!: derivative_eq_intros)
	then have "(\<lambda>y. (Ln (1 + z * of_real y) - of_real y * z) / of_real \<bar>y\<bar>) \<midarrow>0\<rightarrow> 0"
	by (auto simp add: has_vector_derivative_def has_derivative_def netlimit_at
	scaleR_conv_of_real field_simps)
	then have "((\<lambda>y. (Ln (1 + z * of_real y) - of_real y * z) / of_real \<bar>y\<bar>) \<longlongrightarrow> 0) (at_right 0)"
	by (rule filterlim_mono[OF _ _ at_le]) simp_all
	also have "?this \<longleftrightarrow> ((\<lambda>y. Ln (1 + z * of_real y) / (of_real y) - z) \<longlongrightarrow> 0) (at_right 0)"
	using eventually_at_right_less[of "0::real"]
	by (intro filterlim_cong refl) (auto elim!: eventually_mono simp: field_simps)
	finally show ?thesis by (simp only: LIM_zero_iff)
	qed

	lemma stirling_limit_aux2:
	"((\<lambda>y. y * Ln (1 + z / of_real y)) \<longlongrightarrow> z) at_top" for z :: complex
	using stirling_limit_aux1[of z] by (subst filterlim_at_top_to_right) (simp add: field_simps)

	lemma Union_atLeastAtMost:
	assumes "N > 0"
	shows "(\<Union>n\<in>{0..<N}. {real n..real (n + 1)}) = {0..real N}"
	proof (intro equalityI subsetI)
	fix x assume x: "x \<in> {0..real N}"
	thus "x \<in> (\<Union>n\<in>{0..<N}. {real n..real (n + 1)})"
	proof (cases "x = real N")
	case True
	with assms show ?thesis by (auto intro!: bexI[of _ "N - 1"])
	next
	case False
	with x have x: "x \<ge> 0" "x < real N" by simp_all
	hence "x \<ge> real (nat \<lfloor>x\<rfloor>)" "x \<le> real (nat \<lfloor>x\<rfloor> + 1)" by linarith+
	moreover from x have "nat \<lfloor>x\<rfloor> < N" by linarith
	ultimately have "\<exists>n\<in>{0..<N}. x \<in> {real n..real (n + 1)}"
	by (intro bexI[of _ "nat \<lfloor>x\<rfloor>"]) simp_all
	thus ?thesis by blast
	qed
	qed auto


	subsection \<open>Cones in the complex plane\<close>

	definition complex_cone :: "real \<Rightarrow> real \<Rightarrow> complex set" where
	"complex_cone a b = {z. \<exists>y\<in>{a..b}. z = rcis (norm z) y}"

	abbreviation complex_cone' :: "real \<Rightarrow> complex set" where
	"complex_cone' a \<equiv> complex_cone (-a) a"

	lemma zero_in_complex_cone [simp, intro]: "a \<le> b \<Longrightarrow> 0 \<in> complex_cone a b"
	by (auto simp: complex_cone_def)

	lemma complex_coneE:
	assumes "z \<in> complex_cone a b"
	obtains r \<alpha> where "r \<ge> 0" "\<alpha> \<in> {a..b}" "z = rcis r \<alpha>"
	proof -
	from assms obtain y where "y \<in> {a..b}" "z = rcis (norm z) y"
	unfolding complex_cone_def by auto
	thus ?thesis using that[of "norm z" y] by auto
	qed

	lemma arg_cis [simp]:
	assumes "x \<in> {-pi<..pi}"
	shows "Arg (cis x) = x"
	using assms by (intro cis_Arg_unique) auto

	lemma arg_mult_of_real_left [simp]:
	assumes "r > 0"
	shows "Arg (of_real r * z) = Arg z"
	proof (cases "z = 0")
	case False
	thus ?thesis
	using Arg_bounded[of z] assms
	by (intro cis_Arg_unique) (auto simp: sgn_mult sgn_of_real cis_Arg)
	qed auto

	lemma arg_mult_of_real_right [simp]:
	assumes "r > 0"
	shows "Arg (z * of_real r) = Arg z"
	by (subst mult.commute, subst arg_mult_of_real_left) (simp_all add: assms)

	lemma arg_rcis [simp]:
	assumes "x \<in> {-pi<..pi}" "r > 0"
	shows "Arg (rcis r x) = x"
	using assms by (simp add: rcis_def)

	lemma rcis_in_complex_cone [intro]:
	assumes "\<alpha> \<in> {a..b}" "r \<ge> 0"
	shows "rcis r \<alpha> \<in> complex_cone a b"
	using assms by (auto simp: complex_cone_def)

	lemma arg_imp_in_complex_cone:
	assumes "Arg z \<in> {a..b}"
	shows "z \<in> complex_cone a b"
	proof -
	have "z = rcis (norm z) (Arg z)"
	by (simp add: rcis_cmod_Arg)
	also have "\<dots> \<in> complex_cone a b"
	using assms by auto
	finally show ?thesis .
	qed

	lemma complex_cone_altdef:
	assumes "-pi < a" "a \<le> b" "b \<le> pi"
	shows "complex_cone a b = insert 0 {z. Arg z \<in> {a..b}}"
	proof (intro equalityI subsetI)
	fix z assume "z \<in> complex_cone a b"
	then obtain r \<alpha> where *: "r \<ge> 0" "\<alpha> \<in> {a..b}" "z = rcis r \<alpha>"
	by (auto elim: complex_coneE)
	have "Arg z \<in> {a..b}" if [simp]: "z \<noteq> 0"
	proof -
	have "r > 0" using that * by (subst (asm) *) auto
	hence "\<alpha> \<in> {a..b}"
	using (1,2) assms by (auto simp: (1))
	moreover from assms *(2) have "\<alpha> \<in> {-pi<..pi}"
	by auto
	ultimately show ?thesis using *(3) \<open>r > 0\<close>
	by (subst *) auto
	qed
	thus "z \<in> insert 0 {z. Arg z \<in> {a..b}}"
	by auto
	qed (use assms in \<open>auto intro: arg_imp_in_complex_cone\<close>)

	lemma nonneg_of_real_in_complex_cone [simp, intro]:
	assumes "x \<ge> 0" "a \<le> 0" "0 \<le> b"
	shows "of_real x \<in> complex_cone a b"
	proof -
	from assms have "rcis x 0 \<in> complex_cone a b"
	by (intro rcis_in_complex_cone) auto
	thus ?thesis by simp
	qed

	lemma one_in_complex_cone [simp, intro]: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> 1 \<in> complex_cone a b"
	using nonneg_of_real_in_complex_cone[of 1] by (simp del: nonneg_of_real_in_complex_cone)

	lemma of_nat_in_complex_cone [simp, intro]: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> of_nat n \<in> complex_cone a b"
	using nonneg_of_real_in_complex_cone[of "real n"] by (simp del: nonneg_of_real_in_complex_cone)


	subsection \<open>Another integral representation of the Beta function\<close>

	lemma complex_cone_inter_nonpos_Reals:
	assumes "-pi < a" "a \<le> b" "b < pi"
	shows "complex_cone a b \<inter> \<real>\<^sub>\<le>\<^sub>0 = {0}"
	proof (safe elim!: nonpos_Reals_cases)
	fix x :: real
	assume "complex_of_real x \<in> complex_cone a b" "x \<le> 0"
	hence "\<not>(x < 0)"
	using assms by (intro notI) (auto simp: complex_cone_altdef)
	with \<open>x \<le> 0\<close> show "complex_of_real x = 0" by auto
	qed (use assms in auto)

	theorem
	assumes a: "a > 0" and b: "b > (0 :: real)"
	shows has_integral_Beta_real':
	"((\<lambda>u. u powr (b - 1) / (1 + u) powr (a + b)) has_integral Beta a b) {0<..}"
	and Beta_conv_nn_integral:
	"Beta a b = (\<integral>\<^sup>+u. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) \<partial>lborel)"
	proof -
	define I where
	"I = (\<integral>\<^sup>+u. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) \<partial>lborel)"
	have "Gamma (a + b) > 0" "Beta a b > 0"
	using assms by (simp_all add: add_pos_pos Beta_def)
	from a b have "ennreal (Gamma a * Gamma b) =
	(\<integral>\<^sup>+ t. ennreal (indicator {0..} t * t powr (a - 1) / exp t) \<partial>lborel) *
	(\<integral>\<^sup>+ t. ennreal (indicator {0..} t * t powr (b - 1) / exp t) \<partial>lborel)"
	by (subst ennreal_mult') (simp_all add: Gamma_conv_nn_integral_real)
	also have "\<dots> = (\<integral>\<^sup>+t. \<integral>\<^sup>+u. ennreal (indicator {0..} t * t powr (a - 1) / exp t) *
	ennreal (indicator {0..} u * u powr (b - 1) / exp u) \<partial>lborel \<partial>lborel)"
	by (simp add: nn_integral_cmult nn_integral_multc)
	also have "\<dots> = (\<integral>\<^sup>+t. indicator {0<..} t * (\<integral>\<^sup>+u. indicator {0..} u * t powr (a - 1) * u powr (b - 1)
	/ exp (t + u) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"])
	(auto simp: indicator_def divide_ennreal ennreal_mult' [symmetric] exp_add mult_ac)
	also have "\<dots> = (\<integral>\<^sup>+t. indicator {0<..} t * (\<integral>\<^sup>+u. indicator {0..} u * t powr (a - 1) * u powr (b - 1)
	/ exp (t + u)
	\<partial>(density (distr lborel borel ((*) t)) (\<lambda>x. ennreal \<bar>t\<bar>))) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong, subst lborel_distr_mult' [symmetric]) auto
	also have "\<dots> = (\<integral>\<^sup>+(t::real). indicator {0<..} t * (\<integral>\<^sup>+u.
	indicator {0..} (u * t) * t powr a *
	(u * t) powr (b - 1) / exp (t + t * u) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong)
	(auto simp: nn_integral_density nn_integral_distr algebra_simps powr_diff
	simp flip: ennreal_mult)
	also have "\<dots> = (\<integral>\<^sup>+(t::real). \<integral>\<^sup>+u. indicator ({0<..}\<times>{0..}) (t, u) *
	t powr a * (u * t) powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
	by (subst nn_integral_cmult [symmetric], simp, intro nn_integral_cong)
	(auto simp: indicator_def zero_le_mult_iff algebra_simps)
	also have "\<dots> = (\<integral>\<^sup>+(t::real). \<integral>\<^sup>+u. indicator ({0<..}\<times>{0..}) (t, u) *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
	by (intro nn_integral_cong) (auto simp: powr_add powr_diff indicator_def powr_mult field_simps)
	also have "\<dots> = (\<integral>\<^sup>+(u::real). \<integral>\<^sup>+t. indicator ({0<..}\<times>{0..}) (t, u) *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
	by (rule lborel_pair.Fubini') auto
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong) (auto simp: indicator_def)
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"]) (auto simp: indicator_def)
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1))
	\<partial>(density (distr lborel borel ((*) (1/(1+u)))) (\<lambda>x. ennreal \<bar>1/(1+u)\<bar>))) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong, subst lborel_distr_mult' [symmetric]) auto
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u *
	(\<integral>\<^sup>+t. ennreal (1 / (u + 1)) * ennreal (indicator {0<..} (t / (u + 1)) *
	(t / (1+u)) powr (a + b - 1) * u powr (b - 1) / exp t)
	\<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong)
	(auto simp: nn_integral_distr nn_integral_density add_ac)
	also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+t. indicator ({0<..}\<times>{0<..}) (u, t) *
	1/(u+1) * (t / (u+1)) powr (a + b - 1) * u powr (b - 1) / exp t
	\<partial>lborel \<partial>lborel)"
	by (subst nn_integral_cmult [symmetric], simp, intro nn_integral_cong)
	(auto simp: indicator_def field_simps divide_ennreal simp flip: ennreal_mult ennreal_mult')
	also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+t. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) *
	ennreal (indicator {0<..} t * t powr (a + b - 1) / exp t)
	\<partial>lborel \<partial>lborel)"
	by (intro nn_integral_cong)
	(auto simp: indicator_def powr_add powr_diff powr_divide powr_minus divide_simps add_ac
	simp flip: ennreal_mult)
	also have "\<dots> = I * (\<integral>\<^sup>+t. indicator {0<..} t * t powr (a + b - 1) / exp t \<partial>lborel)"
	by (simp add: nn_integral_cmult nn_integral_multc I_def)
	also have "(\<integral>\<^sup>+t. indicator {0<..} t * t powr (a + b - 1) / exp t \<partial>lborel) =
	ennreal (Gamma (a + b))"
	using assms
	by (subst Gamma_conv_nn_integral_real)
	(auto intro!: nn_integral_cong_AE[OF AE_I[of _ _ "{0}"]]
	- simp: indicator_def split: if_splits)
	+ simp: indicator_def split: if_splits split_of_bool_asm)
	finally have "ennreal (Gamma a * Gamma b) = I * ennreal (Gamma (a + b))" .
	hence "ennreal (Gamma a * Gamma b) / ennreal (Gamma (a + b)) =
	I * ennreal (Gamma (a + b)) / ennreal (Gamma (a + b))" by simp
	also have "\<dots> = I"
	using \<open>Gamma (a + b) > 0\<close> by (intro ennreal_mult_divide_eq) (auto simp: )
	also have "ennreal (Gamma a * Gamma b) / ennreal (Gamma (a + b)) =
	ennreal (Gamma a * Gamma b / Gamma (a + b))"
	using assms by (intro divide_ennreal) auto
	also have "\<dots> = ennreal (Beta a b)"
	by (simp add: Beta_def)
	finally show *: "ennreal (Beta a b) = I" .

	define f where "f = (\<lambda>u. u powr (b - 1) / (1 + u) powr (a + b))"
	have "((\<lambda>u. indicator {0<..} u * f u) has_integral Beta a b) UNIV"
	using * \<open>Beta a b > 0\<close>
	by (subst has_integral_iff_nn_integral_lebesgue)
	(auto simp: f_def measurable_completion nn_integral_completion I_def mult_ac)
	also have "(\<lambda>u. indicator {0<..} u * f u) = (\<lambda>u. if u \<in> {0<..} then f u else 0)"
	by (auto simp: fun_eq_iff)
	also have "(\<dots> has_integral Beta a b) UNIV \<longleftrightarrow> (f has_integral Beta a b) {0<..}"
	by (rule has_integral_restrict_UNIV)
	finally show \<dots> by (simp add: f_def)
	qed

	lemma has_integral_Beta2:
	fixes a :: real
	assumes "a < -1/2"
	shows "((\<lambda>x. (1 + x ^ 2) powr a) has_integral Beta (- a - 1 / 2) (1 / 2) / 2) {0<..}"
	proof -
	define f where "f = (\<lambda>u. u powr (-1/2) / (1 + u) powr (-a))"
	define C where "C = Beta (-a-1/2) (1/2)"
	have I: "(f has_integral C) {0<..}"
	using has_integral_Beta_real'[of "-a-1/2" "1/2"] assms
	by (simp_all add: diff_divide_distrib f_def C_def)

	define g where "g = (\<lambda>x. x ^ 2 :: real)"
	have bij: "bij_betw g {0<..} {0<..}"
	by (intro bij_betwI[of _ _ _ sqrt]) (auto simp: g_def)

	have "(f absolutely_integrable_on g ` {0<..} \<and> integral (g ` {0<..}) f = C)"
	using I bij by (simp add: bij_betw_def has_integral_iff absolutely_integrable_on_def f_def)
	also have "?this \<longleftrightarrow> ((\<lambda>x. \<bar>2 * x\<bar> *\<^sub>R f (g x)) absolutely_integrable_on {0<..} \<and>
	integral {0<..} (\<lambda>x. \<bar>2 * x\<bar> *\<^sub>R f (g x)) = C)"
	using bij by (intro has_absolute_integral_change_of_variables_1' [symmetric])
	(auto intro!: derivative_eq_intros simp: g_def bij_betw_def)
	finally have "((\<lambda>x. \<bar>2 * x\<bar> * f (g x)) has_integral C) {0<..}"
	by (simp add: absolutely_integrable_on_def f_def has_integral_iff)
	also have "?this \<longleftrightarrow> ((\<lambda>x::real. 2 * (1 + x\<^sup>2) powr a) has_integral C) {0<..}"
	by (intro has_integral_cong) (auto simp: f_def g_def powr_def exp_minus ln_realpow field_simps)
	finally have "((\<lambda>x::real. 1/2 * (2 * (1 + x\<^sup>2) powr a)) has_integral 1/2 * C) {0<..}"
	by (intro has_integral_mult_right)
	thus ?thesis by (simp add: C_def)
	qed

	lemma has_integral_Beta3:
	fixes a b :: real
	assumes "a < -1/2" and "b > 0"
	shows "((\<lambda>x. (b + x ^ 2) powr a) has_integral
	Beta (-a - 1/2) (1/2) / 2 * b powr (a + 1/2)) {0<..}"
	proof -
	define C where "C = Beta (- a - 1 / 2) (1 / 2) / 2"
	have int: "nn_integral lborel (\<lambda>x. indicator {0<..} x * (1 + x ^ 2) powr a) = C"
	using nn_integral_has_integral_lebesgue[OF _ has_integral_Beta2[OF assms(1)]]
	by (auto simp: C_def)
	have "nn_integral lborel (\<lambda>x. indicator {0<..} x * (b + x ^ 2) powr a) =
	(\<integral>\<^sup>+x. ennreal (indicat_real {0<..} (x * sqrt b) * (b + (x * sqrt b)\<^sup>2) powr a * sqrt b) \<partial>lborel)"
	using assms
	by (subst lborel_distr_mult'[of "sqrt b"])
	(auto simp: nn_integral_density nn_integral_distr mult_ac simp flip: ennreal_mult)
	also have "\<dots> = (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (b * (1 + x ^ 2)) powr a * sqrt b) \<partial>lborel)"
	using assms
	by (intro nn_integral_cong) (auto simp: indicator_def field_simps zero_less_mult_iff)
	also have "\<dots> = (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * b powr (a + 1/2) * (1 + x ^ 2) powr a) \<partial>lborel)"
	using assms
	by (intro nn_integral_cong) (auto simp: indicator_def powr_add powr_half_sqrt powr_mult)
	also have "\<dots> = b powr (a + 1/2) * (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (1 + x ^ 2) powr a) \<partial>lborel)"
	using assms by (subst nn_integral_cmult [symmetric]) (simp_all add: mult_ac flip: ennreal_mult)
	also have "(\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (1 + x ^ 2) powr a) \<partial>lborel) = C"
	using int by simp
	also have "ennreal (b powr (a + 1/2)) * ennreal C = ennreal (C * b powr (a + 1/2))"
	using assms by (subst ennreal_mult) (auto simp: C_def mult_ac Beta_def)
	finally have : "(\<integral>\<^sup>+ x. ennreal (indicat_real {0<..} x (b + x\<^sup>2) powr a) \<partial>lborel) = \<dots>" .
	hence "((\<lambda>x. indicator {0<..} x * (b + x^2) powr a) has_integral C * b powr (a + 1/2)) UNIV"
	using assms
	by (subst has_integral_iff_nn_integral_lebesgue)
	(auto simp: C_def measurable_completion nn_integral_completion Beta_def)
	also have "(\<lambda>x. indicator {0<..} x * (b + x^2) powr a) =
	(\<lambda>x. if x \<in> {0<..} then (b + x^2) powr a else 0)"
	by (auto simp: fun_eq_iff)
	finally show ?thesis
	by (subst (asm) has_integral_restrict_UNIV) (auto simp: C_def)
	qed


	subsection \<open>Asymptotics of the real $\log\Gamma$ function and its derivatives\<close>

	text \<open>
	This is the error term that occurs in the expansion of @{term ln_Gamma}. It can be shown to
	be of order $O(s^{-n})$.
	\<close>
	definition stirling_integral :: "nat \<Rightarrow> 'a :: {real_normed_div_algebra, banach} \<Rightarrow> 'a" where
	"stirling_integral n s =
	lim (\<lambda>N. integral {0..N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))"

	context
	fixes s :: complex assumes s: "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	fixes approx :: "nat \<Rightarrow> complex"
	defines "approx \<equiv> (\<lambda>N.
	(\<Sum>n = 1..<N. s / of_nat n - ln (1 + s / of_nat n)) - (euler_mascheroni * s + ln s) - \<comment> \<open>\<open>\<longrightarrow> ln_Gamma s\<close>\<close>
	(ln_Gamma (of_nat N) - ln (2 * pi / of_nat N) / 2 - of_nat N * ln (of_nat N) + of_nat N) - \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	s * (harm (N - 1) - ln (of_nat (N - 1)) - euler_mascheroni) + \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	s * (ln (of_nat N + s) - ln (of_nat (N - 1))) - \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	(1/2) * (ln (of_nat N + s) - ln (of_nat N)) + \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	of_nat N * (ln (of_nat N + s) - ln (of_nat N)) - \<comment> \<open>\<open>\<longrightarrow> s\<close>\<close>
	(s - 1/2) * ln s - ln (2 * pi) / 2)"
	begin

	qualified lemma
	assumes N: "N > 0"
	shows integrable_pbernpoly_1:
	"(\<lambda>x. of_real (-pbernpoly 1 x) / (of_real x + s)) integrable_on {0..real N}"
	and integral_pbernpoly_1_aux:
	"integral {0..real N} (\<lambda>x. -of_real (pbernpoly 1 x) / (of_real x + s)) = approx N"
	and has_integral_pbernpoly_1:
	"((\<lambda>x. pbernpoly 1 x /(x + s)) has_integral
	(\<Sum>m<N. (of_nat m + 1 / 2 + s) * (ln (of_nat m + s) -
	ln (of_nat m + 1 + s)) + 1)) {0..real N}"
	proof -
	let ?A = "(\<lambda>n. {of_nat n..of_nat (n+1)}) ` {0..<N}"
	have has_integral:
	"((\<lambda>x. -pbernpoly 1 x / (x + s)) has_integral
	(of_nat n + 1/2 + s) * (ln (of_nat (n + 1) + s) - ln (of_nat n + s)) - 1)
	{of_nat n..of_nat (n + 1)}" for n
	proof (rule has_integral_spike)
	have "((\<lambda>x. (of_nat n + 1/2 + s) * (1 / (of_real x + s)) - 1) has_integral
	(of_nat n + 1/2 + s) * (ln (of_real (real (n + 1)) + s) - ln (of_real (real n) + s)) - 1)
	{of_nat n..of_nat (n + 1)}"
	using s has_integral_const_real[of 1 "of_nat n" "of_nat (n + 1)"]
	by (intro has_integral_diff has_integral_mult_right fundamental_theorem_of_calculus)
	(auto intro!: derivative_eq_intros has_vector_derivative_real_field
	simp: has_field_derivative_iff_has_vector_derivative [symmetric] field_simps
	complex_nonpos_Reals_iff)
	thus "((\<lambda>x. (of_nat n + 1/2 + s) * (1 / (of_real x + s)) - 1) has_integral
	(of_nat n + 1/2 + s) * (ln (of_nat (n + 1) + s) - ln (of_nat n + s)) - 1)
	{of_nat n..of_nat (n + 1)}" by simp

	show "-pbernpoly 1 x / (x + s) = (of_nat n + 1/2 + s) * (1 / (x + s)) - 1"
	if "x \<in> {of_nat n..of_nat (n + 1)} - {of_nat (n + 1)}" for x
	proof -
	have x: "x \<ge> real n" "x < real (n + 1)" using that by simp_all
	hence "floor x = int n" by linarith
	moreover from s x have "complex_of_real x \<noteq> -s"
	by (auto simp add: complex_eq_iff complex_nonpos_Reals_iff simp del: of_nat_Suc)
	ultimately show "-pbernpoly 1 x / (x + s) = (of_nat n + 1/2 + s) * (1 / (x + s)) - 1"
	by (auto simp: pbernpoly_def bernpoly_def frac_def divide_simps add_eq_0_iff2)
	qed
	qed simp_all
	hence *: "\<And>I. I\<in>?A \<Longrightarrow> ((\<lambda>x. -pbernpoly 1 x / (x + s)) has_integral
	(Inf I + 1/2 + s) * (ln (Inf I + 1 + s) - ln (Inf I + s)) - 1) I"
	by (auto simp: add_ac)
	have "((\<lambda>x. - pbernpoly 1 x / (x + s)) has_integral
	(\<Sum>I\<in>?A. (Inf I + 1 / 2 + s) * (ln (Inf I + 1 + s) - ln (Inf I + s)) - 1))
	(\<Union>n\<in>{0..<N}. {real n..real (n + 1)})" (is "(_ has_integral ?i) _")
	apply (intro has_integral_Union * finite_imageI)
	apply (force intro!: negligible_atLeastAtMostI pairwiseI)+
	done
	hence has_integral: "((\<lambda>x. - pbernpoly 1 x / (x + s)) has_integral ?i) {0..real N}"
	by (subst has_integral_spike_set_eq)
	(use Union_atLeastAtMost assms in \<open>auto simp: intro!: empty_imp_negligible\<close>)
	hence "(\<lambda>x. - pbernpoly 1 x / (x + s)) integrable_on {0..real N}"
	and integral: "integral {0..real N} (\<lambda>x. - pbernpoly 1 x / (x + s)) = ?i"
	by (simp_all add: has_integral_iff)
	show "(\<lambda>x. - pbernpoly 1 x / (x + s)) integrable_on {0..real N}" by fact

	note has_integral_neg[OF has_integral]
	also have "-?i = (\<Sum>x<N. (of_nat x + 1 / 2 + s) * (ln (of_nat x + s) - ln (of_nat x + 1 + s)) + 1)"
	by (subst sum.reindex)
	(simp_all add: inj_on_def atLeast0LessThan algebra_simps sum_negf [symmetric])
	finally show has_integral:
	"((\<lambda>x. of_real (pbernpoly 1 x) / (of_real x + s)) has_integral \<dots>) {0..real N}" by simp

	note integral
	also have "?i = (\<Sum>n<N. (of_nat n + 1 / 2 + s) *
	(ln (of_nat n + 1 + s) - ln (of_nat n + s))) - N" (is "_ = ?S - _")
	by (subst sum.reindex) (simp_all add: inj_on_def sum_subtractf atLeast0LessThan)
	also have "?S = (\<Sum>n<N. of_nat n * (ln (of_nat n + 1 + s) - ln (of_nat n + s))) +
	(s + 1 / 2) * (\<Sum>n<N. ln (of_nat (Suc n) + s) - ln (of_nat n + s))"
	(is "_ = ?S1 + _ * ?S2") by (simp add: algebra_simps sum.distrib sum_subtractf sum_distrib_left)
	also have "?S2 = ln (of_nat N + s) - ln s" by (subst sum_lessThan_telescope) simp
	also have "?S1 = (\<Sum>n=1..<N. of_nat n * (ln (of_nat n + 1 + s) - ln (of_nat n + s)))"
	by (intro sum.mono_neutral_right) auto
	also have "\<dots> = (\<Sum>n=1..<N. of_nat n * ln (of_nat n + 1 + s)) - (\<Sum>n=1..<N. of_nat n * ln (of_nat n + s))"
	by (simp add: algebra_simps sum_subtractf)
	also have "(\<Sum>n=1..<N. of_nat n * ln (of_nat n + 1 + s)) =
	(\<Sum>n=1..<N. (of_nat n - 1) * ln (of_nat n + s)) + (N - 1) * ln (of_nat N + s)"
	by (induction N) (simp_all add: add_ac of_nat_diff)
	also have "\<dots> - (\<Sum>n = 1..<N. of_nat n * ln (of_nat n + s)) =
	-(\<Sum>n=1..<N. ln (of_nat n + s)) + (N - 1) * ln (of_nat N + s)"
	by (induction N) (simp_all add: algebra_simps)
	also from s have neq: "s + of_nat x \<noteq> 0" for x
	by (auto simp: complex_nonpos_Reals_iff complex_eq_iff)
	hence "(\<Sum>n=1..<N. ln (of_nat n + s)) = (\<Sum>n=1..<N. ln (of_nat n) + ln (1 + s/n))"
	by (intro sum.cong refl, subst Ln_times_of_nat [symmetric]) (auto simp: divide_simps add_ac)
	also have "\<dots> = ln (fact (N - 1)) + (\<Sum>n=1..<N. ln (1 + s/n))"
	by (induction N) (simp_all add: Ln_times_of_nat fact_reduce add_ac)
	also have "(\<Sum>n=1..<N. ln (1 + s/n)) = -(\<Sum>n=1..<N. s / n - ln (1 + s/n)) + s * (\<Sum>n=1..<N. 1 / of_nat n)"
	by (simp add: sum_distrib_left sum_subtractf)
	also from N have "ln (fact (N - 1)) = ln_Gamma (of_nat N :: complex)"
	by (simp add: ln_Gamma_complex_conv_fact)
	also have "{1..<N} = {1..N - 1}" by auto
	hence "(\<Sum>n = 1..<N. 1 / of_nat n) = (harm (N - 1) :: complex)"
	by (simp add: harm_def divide_simps)
	also have "- (ln_Gamma (of_nat N) + (- (\<Sum>n = 1..<N. s / of_nat n - ln (1 + s / of_nat n)) +
	s * harm (N - 1))) + of_nat (N - 1) * ln (of_nat N + s) +
	(s + 1 / 2) * (ln (of_nat N + s) - ln s) - of_nat N = approx N"
	using N by (simp add: field_simps of_nat_diff ln_div approx_def Ln_of_nat
	ln_Gamma_complex_of_real [symmetric])
	finally show "integral {0..of_nat N} (\<lambda>x. -of_real (pbernpoly 1 x) / (of_real x + s)) = \<dots>"
	by simp
	qed

	lemma integrable_ln_Gamma_aux:
	shows "(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n) integrable_on {0..real N}"
	proof (cases "n = 1")
	case True
	with s show ?thesis using integrable_neg[OF integrable_pbernpoly_1[of N]]
	by (cases "N = 0") (simp_all add: integrable_negligible)
	next
	case False
	from s have "of_real x + s \<noteq> 0" if "x \<ge> 0" for x using that
	by (auto simp: complex_eq_iff add_eq_0_iff2 complex_nonpos_Reals_iff)
	with False s show ?thesis
	by (auto intro!: integrable_continuous_real continuous_intros)
	qed

	text \<open>
	This following proof is based on ``Rudiments of the theory of the gamma function''
	by Bruce Berndt~\cite{berndt}.
	\<close>
	lemma tendsto_of_real_0_I:
	"(f \<longlongrightarrow> 0) G \<Longrightarrow> ((\<lambda>x. (of_real (f x))) \<longlongrightarrow> (0 ::'a::real_normed_div_algebra)) G"
	using tendsto_of_real_iff by force

	qualified lemma integral_pbernpoly_1:
	"(\<lambda>N. integral {0..real N} (\<lambda>x. pbernpoly 1 x / (x + s)))
	\<longlonglongrightarrow> -ln_Gamma s - s + (s - 1 / 2) * ln s + ln (2 * pi) / 2"
	proof -
	have neq: "s + of_real x \<noteq> 0" if "x \<ge> 0" for x :: real
	using that s by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	have "(approx \<longlongrightarrow> ln_Gamma s - 0 - 0 + 0 - 0 + s - (s - 1/2) * ln s - ln (2 * pi) / 2) at_top"
	unfolding approx_def
	proof (intro tendsto_add tendsto_diff)
	from s have s': "s \<notin> \<int>\<^sub>\<le>\<^sub>0" by (auto simp: complex_nonpos_Reals_iff elim!: nonpos_Ints_cases)
	have "(\<lambda>n. \<Sum>i=1..<n. s / of_nat i - ln (1 + s / of_nat i)) \<longlonglongrightarrow>
	ln_Gamma s + euler_mascheroni * s + ln s" (is "?f \<longlonglongrightarrow> _")
	using ln_Gamma_series'_aux[OF s'] unfolding sums_def
	by (subst filterlim_sequentially_Suc [symmetric], subst (asm) sum.atLeast1_atMost_eq [symmetric])
	(simp add: atLeastLessThanSuc_atLeastAtMost)
	thus "((\<lambda>n. ?f n - (euler_mascheroni * s + ln s)) \<longlongrightarrow> ln_Gamma s) at_top"
	by (auto intro: tendsto_eq_intros)
	next
	show "(\<lambda>x. complex_of_real (ln_Gamma (real x) - ln (2 * pi / real x) / 2 -
	real x * ln (real x) + real x)) \<longlonglongrightarrow> 0"
	proof (intro tendsto_of_real_0_I
	filterlim_compose[OF tendsto_sandwich filterlim_real_sequentially])
	show "eventually (\<lambda>x::real. ln_Gamma x - ln (2 * pi / x) / 2 - x * ln x + x \<ge> 0) at_top"
	using eventually_ge_at_top[of "1::real"]
	by eventually_elim (insert ln_Gamma_bounds(1), simp add: algebra_simps)
	show "eventually (\<lambda>x::real. ln_Gamma x - ln (2 * pi / x) / 2 - x * ln x + x \<le>
	1 / 12 * inverse x) at_top"
	using eventually_ge_at_top[of "1::real"]
	by eventually_elim (insert ln_Gamma_bounds(2), simp add: field_simps)
	show "((\<lambda>x::real. 1 / 12 * inverse x) \<longlongrightarrow> 0) at_top"
	by (intro tendsto_mult_right_zero tendsto_inverse_0_at_top filterlim_ident)
	qed simp_all
	next
	have "(\<lambda>x. s * of_real (harm (x - 1) - ln (real (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow>
	s * of_real (euler_mascheroni - euler_mascheroni)"
	by (subst filterlim_sequentially_Suc [symmetric], intro tendsto_intros)
	(insert euler_mascheroni_LIMSEQ, simp_all)
	also have "?this \<longleftrightarrow> (\<lambda>x. s * (harm (x - 1) - ln (of_nat (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow> 0"
	by (intro filterlim_cong refl eventually_mono[OF eventually_gt_at_top[of "1::nat"]])
	(auto simp: Ln_of_nat of_real_harm)
	finally show "(\<lambda>x. s * (harm (x - 1) - ln (of_nat (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow> 0" .
	next
	have "((\<lambda>x. ln (1 + (s + 1) / of_real x)) \<longlongrightarrow> ln (1 + 0)) at_top" (is ?P)
	by (intro tendsto_intros tendsto_divide_0[OF tendsto_const])
	(simp_all add: filterlim_ident filterlim_at_infinity_conv_norm_at_top filterlim_abs_real)
	also have "ln (of_real (x + 1) + s) - ln (complex_of_real x) = ln (1 + (s + 1) / of_real x)"
	if "x > 1" for x using that s
	using Ln_divide_of_real[of x "of_real (x + 1) + s", symmetric] neq[of "x+1"]
	by (simp add: field_simps Ln_of_real)
	hence "?P \<longleftrightarrow> ((\<lambda>x. ln (of_real (x + 1) + s) - ln (of_real x)) \<longlongrightarrow> 0) at_top"
	by (intro filterlim_cong refl)
	(auto intro: eventually_mono[OF eventually_gt_at_top[of "1::real"]])
	finally have "((\<lambda>n. ln (of_real (real n + 1) + s) - ln (of_real (real n))) \<longlongrightarrow> 0) at_top"
	by (rule filterlim_compose[OF _ filterlim_real_sequentially])
	hence "((\<lambda>n. ln (of_nat n + s) - ln (of_nat (n - 1))) \<longlongrightarrow> 0) at_top"
	by (subst filterlim_sequentially_Suc [symmetric]) (simp add: add_ac)
	thus "(\<lambda>x. s * (ln (of_nat x + s) - ln (of_nat (x - 1)))) \<longlonglongrightarrow> 0"
	by (rule tendsto_mult_right_zero)
	next
	have "((\<lambda>x. ln (1 + s / of_real x)) \<longlongrightarrow> ln (1 + 0)) at_top" (is ?P)
	by (intro tendsto_intros tendsto_divide_0[OF tendsto_const])
	(simp_all add: filterlim_ident filterlim_at_infinity_conv_norm_at_top filterlim_abs_real)
	also have "ln (of_real x + s) - ln (of_real x) = ln (1 + s / of_real x)" if "x > 0" for x
	using Ln_divide_of_real[of x "of_real x + s"] neq[of x] that
	by (auto simp: field_simps Ln_of_real)
	hence "?P \<longleftrightarrow> ((\<lambda>x. ln (of_real x + s) - ln (of_real x)) \<longlongrightarrow> 0) at_top"
	using s by (intro filterlim_cong refl)
	(auto intro: eventually_mono [OF eventually_gt_at_top[of "1::real"]])
	finally have "(\<lambda>x. (1/2) * (ln (of_real (real x) + s) - ln (of_real (real x)))) \<longlonglongrightarrow> 0"
	by (rule tendsto_mult_right_zero[OF filterlim_compose[OF _ filterlim_real_sequentially]])
	thus "(\<lambda>x. (1/2) * (ln (of_nat x + s) - ln (of_nat x))) \<longlonglongrightarrow> 0" by simp
	next
	have "((\<lambda>x. x * (ln (1 + s / of_real x))) \<longlongrightarrow> s) at_top" (is ?P)
	by (rule stirling_limit_aux2)
	also have "ln (1 + s / of_real x) = ln (of_real x + s) - ln (of_real x)" if "x > 1" for x
	using that s Ln_divide_of_real [of x "of_real x + s", symmetric] neq[of x]
	by (auto simp: Ln_of_real field_simps)
	hence "?P \<longleftrightarrow> ((\<lambda>x. of_real x * (ln (of_real x + s) - ln (of_real x))) \<longlongrightarrow> s) at_top"
	by (intro filterlim_cong refl)
	(auto intro: eventually_mono[OF eventually_gt_at_top[of "1::real"]])
	finally have "(\<lambda>n. of_real (real n) * (ln (of_real (real n) + s) - ln (of_real (real n)))) \<longlonglongrightarrow> s"
	by (rule filterlim_compose[OF _ filterlim_real_sequentially])
	thus "(\<lambda>n. of_nat n * (ln (of_nat n + s) - ln (of_nat n))) \<longlonglongrightarrow> s" by simp
	qed simp_all
	also have "?this \<longleftrightarrow> ((\<lambda>N. integral {0..real N} (\<lambda>x. -pbernpoly 1 x / (x + s))) \<longlongrightarrow>
	ln_Gamma s + s - (s - 1/2) * ln s - ln (2 * pi) / 2) at_top"
	using integral_pbernpoly_1_aux
	by (intro filterlim_cong refl)
	(auto intro: eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
	also have "(\<lambda>N. integral {0..real N} (\<lambda>x. -pbernpoly 1 x / (x + s))) =
	(\<lambda>N. -integral {0..real N} (\<lambda>x. pbernpoly 1 x / (x + s)))"
	by (simp add: fun_eq_iff)
	finally show ?thesis by (simp add: tendsto_minus_cancel_left [symmetric] algebra_simps)
	qed


	qualified lemma pbernpoly_integral_conv_pbernpoly_integral_Suc:
	assumes "n \<ge> 1"
	shows "integral {0..real N} (\<lambda>x. pbernpoly n x / (x + s) ^ n) =
	of_real (pbernpoly (Suc n) (real N)) / (of_nat (Suc n) * (s + of_nat N) ^ n) -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n) + of_nat n / of_nat (Suc n) *
	integral {0..real N} (\<lambda>x. of_real (pbernpoly (Suc n) x) / (of_real x + s) ^ Suc n)"
	proof -
	note [derivative_intros] = has_field_derivative_pbernpoly_Suc'
	define I where "I = -of_real (pbernpoly (Suc n) (of_nat N)) / (of_nat (Suc n) * (of_nat N + s) ^ n) +
	of_real (bernoulli (Suc n) / real (Suc n)) / s ^ n +
	integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)"
	have "((\<lambda>x. (-of_nat n * inverse (of_real x + s) ^ Suc n) *
	(of_real (pbernpoly (Suc n) x) / (of_nat (Suc n))))
	has_integral -I) {0..real N}"
	proof (rule integration_by_parts_interior_strong[OF bounded_bilinear_mult])
	fix x :: real assume x: "x \<in> {0<..<real N} - real ` {0..N}"
	have "x \<notin> \<int>"
	proof
	assume "x \<in> \<int>"
	then obtain n where "x = of_int n" by (auto elim!: Ints_cases)
	with x have x': "x = of_nat (nat n)" by simp
	from x show False by (auto simp: x')
	qed
	hence "((\<lambda>x. of_real (pbernpoly (Suc n) x / of_nat (Suc n))) has_vector_derivative
	complex_of_real (pbernpoly n x)) (at x)"
	by (intro has_vector_derivative_of_real) (auto intro!: derivative_eq_intros)
	thus "((\<lambda>x. of_real (pbernpoly (Suc n) x) / of_nat (Suc n)) has_vector_derivative
	complex_of_real (pbernpoly n x)) (at x)" by simp
	from x s have "complex_of_real x + s \<noteq> 0"
	by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	thus "((\<lambda>x. inverse (of_real x + s) ^ n) has_vector_derivative
	- of_nat n * inverse (of_real x + s) ^ Suc n) (at x)" using x s assms
	by (auto intro!: derivative_eq_intros has_vector_derivative_real_field simp: divide_simps power_add [symmetric]
	simp del: power_Suc)
	next
	have "complex_of_real x + s \<noteq> 0" if "x \<ge> 0" for x
	using that s by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	thus "continuous_on {0..real N} (\<lambda>x. inverse (of_real x + s) ^ n)"
	"continuous_on {0..real N} (\<lambda>x. complex_of_real (pbernpoly (Suc n) x) / of_nat (Suc n))"
	using assms s by (auto intro!: continuous_intros simp del: of_nat_Suc)
	next
	have "((\<lambda>x. inverse (of_real x + s) ^ n * of_real (pbernpoly n x)) has_integral
	pbernpoly (Suc n) (of_nat N) / (of_nat (Suc n) * (of_nat N + s) ^ n) -
	of_real (bernoulli (Suc n) / real (Suc n)) / s ^ n - -I) {0..real N}"
	using integrable_ln_Gamma_aux[of n N] assms
	by (auto simp: I_def has_integral_integral divide_simps)
	thus "((\<lambda>x. inverse (of_real x + s) ^ n * of_real (pbernpoly n x)) has_integral
	inverse (of_real (real N) + s) ^ n * (of_real (pbernpoly (Suc n) (real N)) /
	of_nat (Suc n)) -
	inverse (of_real 0 + s) ^ n * (of_real (pbernpoly (Suc n) 0) / of_nat (Suc n)) - - I)
	{0..real N}" by (simp_all add: field_simps)
	qed simp_all
	also have "(\<lambda>x. - of_nat n * inverse (of_real x + s) ^ Suc n * (of_real (pbernpoly (Suc n) x) /
	of_nat (Suc n))) =
	(\<lambda>x. - (of_nat n / of_nat (Suc n) * of_real (pbernpoly (Suc n) x) /
	(of_real x + s) ^ Suc n))"
	by (simp add: divide_simps fun_eq_iff)
	finally have "((\<lambda>x. - (of_nat n / of_nat (Suc n) * of_real (pbernpoly (Suc n) x) /
	(of_real x + s) ^ Suc n)) has_integral - I) {0..real N}" .
	from has_integral_neg[OF this] show ?thesis
	by (auto simp add: I_def has_integral_iff algebra_simps integral_mult_right [symmetric]
	simp del: power_Suc of_nat_Suc )
	qed

	lemma pbernpoly_over_power_tendsto_0:
	assumes "n > 0"
	shows "(\<lambda>x. of_real (pbernpoly (Suc n) (real x)) / (of_nat (Suc n) * (s + of_nat x) ^ n)) \<longlonglongrightarrow> 0"
	proof -
	from s have neq: "s + of_nat n \<noteq> 0" for n
	by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	obtain c where c: "\<And>x. norm (pbernpoly (Suc n) x) \<le> c"
	using bounded_pbernpoly by auto
	have "eventually (\<lambda>x. real x + Re s > 0) at_top"
	by real_asymp
	hence "eventually (\<lambda>x. norm (of_real (pbernpoly (Suc n) (real x)) /
	(of_nat (Suc n) * (s + of_nat x) ^ n)) \<le>
	(c / real (Suc n)) / (real x + Re s) ^ n) at_top"
	using eventually_gt_at_top[of "0::nat"]
	proof eventually_elim
	case (elim x)
	have "norm (of_real (pbernpoly (Suc n) (real x)) /
	(of_nat (Suc n) * (s + of_nat x) ^ n)) \<le>
	(c / real (Suc n)) / norm (s + of_nat x) ^ n" (is "_ \<le> ?rhs") using c[of x]
	by (auto simp: norm_divide norm_mult norm_power neq field_simps simp del: of_nat_Suc)
	also have "(real x + Re s) \<le> cmod (s + of_nat x)"
	using complex_Re_le_cmod[of "s + of_nat x"] s by (auto simp add: complex_nonpos_Reals_iff)
	hence "?rhs \<le> (c / real (Suc n)) / (real x + Re s) ^ n" using s elim c[of 0] neq[of x]
	by (intro divide_left_mono power_mono mult_pos_pos divide_nonneg_pos zero_less_power) auto
	finally show ?case .
	qed
	moreover have "(\<lambda>x. (c / real (Suc n)) / (real x + Re s) ^ n) \<longlonglongrightarrow> 0"
	using \<open>n > 0\<close> by real_asymp
	ultimately show ?thesis by (rule Lim_null_comparison)
	qed

	lemma convergent_stirling_integral:
	assumes "n > 0"
	shows "convergent (\<lambda>N. integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))" (is "convergent (?f n)")
	proof -
	have "convergent (?f (Suc n))" for n
	proof (induction n)
	case 0
	thus ?case using integral_pbernpoly_1 by (auto intro!: convergentI)
	next
	case (Suc n)
	have "convergent (\<lambda>N. ?f (Suc n) N -
	of_real (pbernpoly (Suc (Suc n)) (real N)) /
	(of_nat (Suc (Suc n)) * (s + of_nat N) ^ Suc n) +
	of_real (bernoulli (Suc (Suc n)) / (real (Suc (Suc n)))) / s ^ Suc n)"
	(is "convergent ?g")
	by (intro convergent_add convergent_diff Suc
	convergent_const convergentI[OF pbernpoly_over_power_tendsto_0]) simp_all
	also have "?g = (\<lambda>N. of_nat (Suc n) / of_nat (Suc (Suc n)) * ?f (Suc (Suc n)) N)" using s
	by (subst pbernpoly_integral_conv_pbernpoly_integral_Suc)
	(auto simp: fun_eq_iff field_simps simp del: of_nat_Suc power_Suc)
	also have "convergent \<dots> \<longleftrightarrow> convergent (?f (Suc (Suc n)))"
	by (intro convergent_mult_const_iff) (simp_all del: of_nat_Suc)
	finally show ?case .
	qed
	from this[of "n - 1"] assms show ?thesis by simp
	qed

	lemma stirling_integral_conv_stirling_integral_Suc:
	assumes "n > 0"
	shows "stirling_integral n s =
	of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	proof -
	have "(\<lambda>N. of_real (pbernpoly (Suc n) (real N)) / (of_nat (Suc n) * (s + of_nat N) ^ n) -
	of_real (bernoulli (Suc n)) / (real (Suc n) * s ^ n) +
	integral {0..real N} (\<lambda>x. of_nat n / of_nat (Suc n) *
	(of_real (pbernpoly (Suc n) x) / (of_real x + s) ^ Suc n)))
	\<longlonglongrightarrow> 0 - of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n) +
	of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s" (is "?f \<longlonglongrightarrow> _")
	unfolding stirling_integral_def integral_mult_right
	using convergent_stirling_integral[of "Suc n"] assms s
	by (intro tendsto_intros pbernpoly_over_power_tendsto_0)
	(auto simp: convergent_LIMSEQ_iff simp del: of_nat_Suc)
	also have "?this \<longleftrightarrow> (\<lambda>N. integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<longlonglongrightarrow>
	of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	using eventually_gt_at_top[of "0::nat"] pbernpoly_integral_conv_pbernpoly_integral_Suc[of n]
	assms unfolding integral_mult_right
	by (intro filterlim_cong refl) (auto elim!: eventually_mono simp del: power_Suc)
	finally show ?thesis unfolding stirling_integral_def[of n] by (rule limI)
	qed

	lemma stirling_integral_1_unfold:
	assumes "m > 0"
	shows "stirling_integral 1 s = stirling_integral m s / of_nat m -
	(\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
	proof -
	have "stirling_integral 1 s = stirling_integral (Suc m) s / of_nat (Suc m) -
	(\<Sum>k=1..<Suc m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))" for m
	proof (induction m)
	case (Suc m)
	let ?C = "(\<Sum>k = 1..<Suc m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
	note Suc.IH
	also have "stirling_integral (Suc m) s / of_nat (Suc m) =
	stirling_integral (Suc (Suc m)) s / of_nat (Suc (Suc m)) -
	of_real (bernoulli (Suc (Suc m))) /
	(of_nat (Suc m) * of_nat (Suc (Suc m)) * s ^ Suc m)"
	(is "_ = ?A - ?B") by (subst stirling_integral_conv_stirling_integral_Suc)
	(simp_all del: of_nat_Suc power_Suc add: divide_simps)
	also have "?A - ?B - ?C = ?A - (?B + ?C)" by (rule diff_diff_eq)
	also have "?B + ?C = (\<Sum>k = 1..<Suc (Suc m). of_real (bernoulli (Suc k)) /
	(of_nat k * of_nat (Suc k) * s ^ k))"
	using s by (simp add: divide_simps)
	finally show ?case .
	qed simp_all
	note this[of "m - 1"]
	also from assms have "Suc (m - 1) = m" by simp
	finally show ?thesis .
	qed

	lemma ln_Gamma_stirling_complex:
	assumes "m > 0"
	shows "ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 +
	(\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k)) -
	stirling_integral m s / of_nat m"
	proof -
	have "ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 - stirling_integral 1 s"
	using limI[OF integral_pbernpoly_1] by (simp add: stirling_integral_def algebra_simps)
	also have "stirling_integral 1 s = stirling_integral m s / of_nat m -
	(\<Sum>k = 1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
	using assms by (rule stirling_integral_1_unfold)
	finally show ?thesis by simp
	qed

	lemma LIMSEQ_stirling_integral:
	"n > 0 \<Longrightarrow> (\<lambda>x. integral {0..real x} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))
	\<longlonglongrightarrow> stirling_integral n s" unfolding stirling_integral_def
	using convergent_stirling_integral[of n] by (simp only: convergent_LIMSEQ_iff)

	end

	lemmas has_integral_of_real = has_integral_linear[OF _ bounded_linear_of_real, unfolded o_def]
	lemmas integral_of_real = integral_linear[OF _ bounded_linear_of_real, unfolded o_def]

	lemma integrable_ln_Gamma_aux_real:
	assumes "0 < s"
	shows "(\<lambda>x. pbernpoly n x / (x + s) ^ n) integrable_on {0..real N}"
	proof -
	have "(\<lambda>x. complex_of_real (pbernpoly n x / (x + s) ^ n)) integrable_on {0..real N}"
	using integrable_ln_Gamma_aux[of "of_real s" n N] assms by simp
	from integrable_linear[OF this bounded_linear_Re] show ?thesis
	by (simp only: o_def Re_complex_of_real)
	qed

	lemma
	assumes "x > 0" "n > 0"
	shows stirling_integral_complex_of_real:
	"stirling_integral n (complex_of_real x) = of_real (stirling_integral n x)"
	and LIMSEQ_stirling_integral_real:
	"(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
	\<longlonglongrightarrow> stirling_integral n x"
	and stirling_integral_real_convergent:
	"convergent (\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))"
	proof -
	have "(\<lambda>N. integral {0..real N} (\<lambda>t. of_real (pbernpoly n t / (t + x) ^ n)))
	\<longlonglongrightarrow> stirling_integral n (complex_of_real x)"
	using LIMSEQ_stirling_integral[of "complex_of_real x" n] assms by simp
	hence "(\<lambda>N. of_real (integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n)))
	\<longlonglongrightarrow> stirling_integral n (complex_of_real x)"
	using integrable_ln_Gamma_aux_real[OF assms(1), of n]
	by (subst (asm) integral_of_real) simp
	from tendsto_Re[OF this]
	have "(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
	\<longlonglongrightarrow> Re (stirling_integral n (complex_of_real x))" by simp
	thus "convergent (\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))"
	by (rule convergentI)
	thus "(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
	\<longlonglongrightarrow> stirling_integral n x" unfolding stirling_integral_def
	by (simp add: convergent_LIMSEQ_iff)
	from tendsto_of_real[OF this, where 'a = complex]
	integrable_ln_Gamma_aux_real[OF assms(1), of n]
	have "(\<lambda>xa. integral {0..real xa}
	(\<lambda>xa. complex_of_real (pbernpoly n xa) / (complex_of_real xa + x) ^ n))
	\<longlonglongrightarrow> complex_of_real (stirling_integral n x)"
	by (subst (asm) integral_of_real [symmetric]) simp_all
	from LIMSEQ_unique[OF this LIMSEQ_stirling_integral[of "complex_of_real x" n]] assms
	show "stirling_integral n (complex_of_real x) = of_real (stirling_integral n x)" by simp
	qed

	lemma ln_Gamma_stirling_real:
	assumes "x > (0 :: real)" "m > (0::nat)"
	shows "ln_Gamma x = (x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
	(\<Sum>k = 1..<m. bernoulli (Suc k) / (of_nat k * of_nat (Suc k) * x ^ k)) -
	stirling_integral m x / of_nat m"
	proof -
	from assms have "complex_of_real (ln_Gamma x) = ln_Gamma (complex_of_real x)"
	by (simp add: ln_Gamma_complex_of_real)
	also have "ln_Gamma (complex_of_real x) = complex_of_real (
	(x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
	(\<Sum>k = 1..<m. bernoulli (Suc k) / (of_nat k * of_nat (Suc k) * x ^ k)) -
	stirling_integral m x / of_nat m)" using assms
	by (subst ln_Gamma_stirling_complex[of _ m])
	(simp_all add: Ln_of_real stirling_integral_complex_of_real)
	finally show ?thesis by (subst (asm) of_real_eq_iff)
	qed


	lemma stirling_integral_bound_aux:
	assumes n: "n > (1::nat)"
	obtains c where "\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral n s) \<le> c / Re s ^ (n - 1)"
	proof -
	obtain c where c: "norm (pbernpoly n x) \<le> c" for x by (rule bounded_pbernpoly[of n]) blast
	have c': "pbernpoly n x \<le> c" for x using c[of x] by (simp add: abs_real_def split: if_splits)
	from c[of 0] have c_nonneg: "c \<ge> 0" by simp
	have "norm (stirling_integral n s) \<le> c / (real n - 1) / Re s ^ (n - 1)" if s: "Re s > 0" for s
	proof (rule Lim_norm_ubound[OF _ LIMSEQ_stirling_integral])
	have pos: "x + norm s > 0" if "x \<ge> 0" for x using s that by (intro add_nonneg_pos) auto
	have nz: "of_real x + s \<noteq> 0" if "x \<ge> 0" for x using s that by (auto simp: complex_eq_iff)
	let ?bound = "\<lambda>N. c / (Re s ^ (n - 1) * (real n - 1)) -
	c / ((real N + Re s) ^ (n - 1) * (real n - 1))"
	show "eventually (\<lambda>N. norm (integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	c / (real n - 1) / Re s ^ (n - 1)) at_top"
	using eventually_gt_at_top[of "0::nat"]
	proof eventually_elim
	case (elim N)
	let ?F = "\<lambda>x. -c / ((x + Re s) ^ (n - 1) * (real n - 1))"
	from n s have "((\<lambda>x. c / (x + Re s) ^ n) has_integral (?F (real N) - ?F 0)) {0..real N}"
	by (intro fundamental_theorem_of_calculus)
	(auto intro!: derivative_eq_intros simp: divide_simps power_diff add_eq_0_iff2
	has_field_derivative_iff_has_vector_derivative [symmetric])
	also have "?F (real N) - ?F 0 = ?bound N" by simp
	finally have *: "((\<lambda>x. c / (x + Re s) ^ n) has_integral ?bound N) {0..real N}" .
	have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	integral {0..real N} (\<lambda>x. c / (x + Re s) ^ n)"
	proof (intro integral_norm_bound_integral integrable_ln_Gamma_aux s ballI)
	fix x assume x: "x \<in> {0..real N}"
	have "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> c / norm (of_real x + s) ^ n"
	unfolding norm_divide norm_power using c by (intro divide_right_mono) simp_all
	also have "\<dots> \<le> c / (x + Re s) ^ n"
	using x c c_nonneg s nz[of x] complex_Re_le_cmod[of "of_real x + s"]
	by (intro divide_left_mono power_mono mult_pos_pos zero_less_power add_nonneg_pos) auto
	finally show "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> \<dots>" .
	qed (insert n s * pos nz c, auto simp: complex_nonpos_Reals_iff)
	also have "\<dots> = ?bound N" using * by (simp add: has_integral_iff)
	also have "\<dots> \<le> c / (Re s ^ (n - 1) * (real n - 1))" using c_nonneg elim s n by simp
	also have "\<dots> = c / (real n - 1) / (Re s ^ (n - 1))" by simp
	finally show "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) /
	(of_real x + s) ^ n)) \<le> c / (real n - 1) / Re s ^ (n - 1)" .
	qed
	qed (insert s n, simp_all add: complex_nonpos_Reals_iff)
	thus ?thesis by (rule that)
	qed

	lemma stirling_integral_bound_aux_integral1:
	fixes a b c :: real and n :: nat
	assumes "a \<ge> 0" "b > 0" "c \<ge> 0" "n > 1" "l < a - b" "r > a + b"
	shows "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral
	2c(n / (n - 1))/b^(n-1) - c/(n-1) * (1/(a-l)^(n-1) + 1/(r-a)^(n-1))) {l..r}"
	proof -
	define x1 x2 where "x1 = a - b" and "x2 = a + b"
	define F1 where "F1 = (\<lambda>x::real. c / (a - x) ^ (n - 1) / (n - 1))"
	define F3 where "F3 = (\<lambda>x::real. -c / (x - a) ^ (n - 1) / (n - 1))"
	have deriv: "(F1 has_vector_derivative (c / (a - x) ^ n)) (at x within A)"
	"(F3 has_vector_derivative (c / (x - a) ^ n)) (at x within A)"
	if "x \<noteq> a" for x :: real and A
	unfolding F1_def F3_def using assms that
	by (auto intro!: derivative_eq_intros simp: divide_simps power_diff add_eq_0_iff2
	simp flip: has_field_derivative_iff_has_vector_derivative)

	from assms have "((\<lambda>x. c / (a - x) ^ n) has_integral (F1 x1 - F1 l)) {l..x1}"
	by (intro fundamental_theorem_of_calculus deriv) (auto simp: x1_def max_def split: if_splits)
	also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l)) {l..x1}"
	using assms
	by (intro has_integral_spike_finite_eq[of "{l}"]) (auto simp: x1_def max_def split: if_splits)
	finally have I1: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l)) {l..x1}" .

	have "((\<lambda>x. c / b ^ n) has_integral (x2 - x1) * c / b ^ n) {x1..x2}"
	using has_integral_const_real[of "c / b ^ n" x1 x2] assms by (simp add: x1_def x2_def)
	also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral ((x2 - x1) * c / b ^ n)) {x1..x2}"
	by (intro has_integral_spike_finite_eq[of "{x1, x2}"])
	(auto simp: x1_def x2_def split: if_splits)
	finally have I2: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral ((x2 - x1) * c / b ^ n)) {x1..x2}" .

	from assms have I3: "((\<lambda>x. c / (x - a) ^ n) has_integral (F3 r - F3 x2)) {x2..r}"
	by (intro fundamental_theorem_of_calculus deriv) (auto simp: x2_def min_def split: if_splits)
	also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F3 r - F3 x2)) {x2..r}"
	using assms
	by (intro has_integral_spike_finite_eq[of "{r}"]) (auto simp: x2_def min_def split: if_splits)
	finally have I3: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F3 r - F3 x2)) {x2..r}" .

	have "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l) + ((x2 - x1) * c / b ^ n) + (F3 r - F3 x2)) {l..r}"
	using assms
	by (intro has_integral_combine[OF _ _ has_integral_combine[OF _ _ I1 I2] I3])
	(auto simp: x1_def x2_def)
	also have "(F1 x1 - F1 l) + ((x2 - x1) * c / b ^ n) + (F3 r - F3 x2) =
	F1 x1 - F1 l + F3 r - F3 x2 + (x2 - x1) * c / b ^ n"
	by (simp add: algebra_simps)
	also have "x2 - x1 = 2 * b"
	using assms by (simp add: x2_def x1_def min_def max_def)
	also have "2 * b * c / b ^ n = 2 * c / b ^ (n - 1)"
	using assms by (simp add: power_diff field_simps)
	also have "F1 x1 - F1 l + F3 r - F3 x2 =
	c/(n-1) * (2/b^(n-1) - 1/(a-l)^(n-1) - 1/(r-a)^(n-1))"
	using assms by (simp add: x1_def x2_def F1_def F3_def field_simps)
	also have "\<dots> + 2 * c / b ^ (n - 1) =
	2c(1 + 1/(n-1))/b^(n-1) - c/(n-1) * (1/(a-l)^(n-1) + 1/(r-a)^(n-1))"
	using assms by (simp add: field_simps)
	also have "1 + 1 / (n - 1) = n / (n - 1)"
	using assms by (simp add: field_simps)
	finally show ?thesis .
	qed

	lemma stirling_integral_bound_aux_integral2:
	fixes a b c :: real and n :: nat
	assumes "a \<ge> 0" "b > 0" "c \<ge> 0" "n > 1"
	obtains I where "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral I) {l..r}"
	"I \<le> 2 * c * (n / (n - 1)) / b ^ (n-1)"
	proof -
	define l' where "l' = min l (a - b - 1)"
	define r' where "r' = max r (a + b + 1)"

	define A where "A = 2 * c * (n / (n - 1)) / b ^ (n - 1)"
	define B where "B = c / real (n - 1) * (1 / (a - l') ^ (n - 1) + 1 / (r' - a) ^ (n - 1))"

	have has_int: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (A - B)) {l'..r'}"
	using assms unfolding A_def B_def
	by (intro stirling_integral_bound_aux_integral1) (auto simp: l'_def r'_def)
	have "(\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) integrable_on {l..r}"
	by (rule integrable_on_subinterval[OF has_integral_integrable[OF has_int]])
	(auto simp: l'_def r'_def)
	then obtain I where has_int': "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral I) {l..r}"
	by (auto simp: integrable_on_def)

	from assms have "I \<le> A - B"
	by (intro has_integral_subset_le[OF _ has_int' has_int]) (auto simp: l'_def r'_def)
	also have "\<dots> \<le> A"
	using assms by (simp add: B_def l'_def r'_def)
	finally show ?thesis using that[of I] has_int' unfolding A_def by blast
	qed

	lemma stirling_integral_bound_aux':
	assumes n: "n > (1::nat)" and \<alpha>: "\<alpha> \<in> {0<..<pi}"
	obtains c where "\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow>
	norm (stirling_integral n s) \<le> c / norm s ^ (n - 1)"
	proof -
	obtain c where c: "norm (pbernpoly n x) \<le> c" for x by (rule bounded_pbernpoly[of n]) blast
	have c': "pbernpoly n x \<le> c" for x using c[of x] by (simp add: abs_real_def split: if_splits)
	from c[of 0] have c_nonneg: "c \<ge> 0" by simp

	define D where "D = c * Beta (- (real_of_int (- int n) / 2) - 1 / 2) (1 / 2) / 2"
	define C where "C = max D (2c(n/(n-1))/sin \<alpha>^(n-1))"

	have *: "norm (stirling_integral n s) \<le> C / norm s ^ (n - 1)"
	if s: "s \<in> complex_cone' \<alpha> - {0}" for s :: complex
	proof (rule Lim_norm_ubound[OF _ LIMSEQ_stirling_integral])
	from s \<alpha> have Arg: "\<bar>Arg s\<bar> \<le> \<alpha>" by (auto simp: complex_cone_altdef)
	have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> s by auto
	from s have [simp]: "s \<noteq> 0" by auto

	show "eventually (\<lambda>N. norm (integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	C / norm s ^ (n - 1)) at_top"
	using eventually_gt_at_top[of "0::nat"]
	proof eventually_elim
	case (elim N)
	show ?case
	proof (cases "Re s > 0")
	case True
	have int: "((\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) has_integral
	D * (norm s ^ 2) powr (-n / 2 + 1 / 2)) {0<..}"
	using has_integral_mult_left[OF has_integral_Beta3[of "-n/2" "norm s ^ 2"], of c] assms True
	unfolding D_def by (simp add: algebra_simps)
	hence int': "((\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) has_integral
	D * (norm s ^ 2) powr (-n / 2 + 1 / 2)) {0..}"
	by (subst has_integral_interior [symmetric]) simp_all
	hence integrable: "(\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) integrable_on {0..}"
	by (simp add: has_integral_iff)

	have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	integral {0..real N} (\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2))"
	proof (intro integral_norm_bound_integral s ballI integrable_ln_Gamma_aux)
	have [simp]: "{0<..} - {0::real..} = {}" "{0..} - {0<..} = {0::real}"
	by auto
	have "(\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on {0<..}"
	using int by (simp add: has_integral_iff)
	also have "?this \<longleftrightarrow> (\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on {0..}"
	by (intro integrable_spike_set_eq) auto
	finally show "(\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on
	{0..real N}" by (rule integrable_on_subinterval) auto
	next
	fix x assume x: "x \<in> {0..real N}"
	have nz: "complex_of_real x + s \<noteq> 0"
	using True x by (auto simp: complex_eq_iff)
	have "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> c / norm (of_real x + s) ^ n"
	unfolding norm_divide norm_power using c by (intro divide_right_mono) simp_all
	also have "\<dots> \<le> c / sqrt (x ^ 2 + norm s ^ 2) ^ n"
	proof (intro divide_left_mono mult_pos_pos zero_less_power power_mono)
	show "sqrt (x\<^sup>2 + (cmod s)\<^sup>2) \<le> cmod (complex_of_real x + s)"
	using x True by (simp add: cmod_def algebra_simps power2_eq_square)
	qed (use x True c_nonneg assms nz in \<open>auto simp: add_nonneg_pos\<close>)
	also have "sqrt (x ^ 2 + norm s ^ 2) ^ n = (x ^ 2 + norm s ^ 2) powr (1/2 * n)"
	by (subst powr_powr [symmetric], subst powr_realpow)
	(auto simp: powr_half_sqrt add_nonneg_pos)
	also have "c / \<dots> = c * (x^2 + norm s^2) powr (-n / 2)"
	by (simp add: powr_minus field_simps)
	finally show "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le> \<dots>" .
	qed fact+
	also have "\<dots> \<le> integral {0..} (\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2))"
	using c_nonneg
	by (intro integral_subset_le integrable integrable_on_subinterval[OF integrable]) auto
	also have "\<dots> = D * (norm s ^ 2) powr (-n / 2 + 1 / 2)"
	using int' by (simp add: has_integral_iff)
	also have "(norm s ^ 2) powr (-n / 2 + 1 / 2) = norm s powr (2 * (-n / 2 + 1 / 2))"
	by (subst powr_powr [symmetric]) auto
	also have "\<dots> = norm s powr (-real (n - 1))"
	using assms by (simp add: of_nat_diff)
	also have "D * \<dots> = D / norm s ^ (n - 1)"
	by (auto simp: powr_minus powr_realpow field_simps)
	also have "\<dots> \<le> C / norm s ^ (n - 1)"
	by (intro divide_right_mono) (auto simp: C_def)
	finally show "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le> \<dots>" .

	next

	case False
	have "cos \<bar>Arg s\<bar> = cos (Arg s)"
	by (simp add: abs_if)
	also have "cos (Arg s) = Re (rcis (norm s) (Arg s)) / norm s"
	by (subst Re_rcis) auto
	also have "\<dots> = Re s / norm s"
	by (subst rcis_cmod_Arg) auto
	also have "\<dots> \<le> cos (pi / 2)"
	using False by (auto simp: field_simps)
	finally have "\<bar>Arg s\<bar> \<ge> pi / 2"
	using Arg \<alpha> by (subst (asm) cos_mono_le_eq) auto

	have "sin \<alpha> * norm s = sin (pi - \<alpha>) * norm s"
	by simp
	also have "\<dots> \<le> sin (pi - \<bar>Arg s\<bar>) * norm s"
	using \<alpha> Arg \<open>\<bar>Arg s\<bar> \<ge> pi / 2\<close>
	by (intro mult_right_mono sin_monotone_2pi_le) auto
	also have "sin \<bar>Arg s\<bar> \<ge> 0"
	using Arg_bounded[of s] by (intro sin_ge_zero) auto
	hence "sin (pi - \<bar>Arg s\<bar>) = \<bar>sin \<bar>Arg s\<bar>\<bar>"
	by simp
	also have "\<dots> = \<bar>sin (Arg s)\<bar>"
	by (simp add: abs_if)
	also have "\<dots> * norm s = \<bar>Im (rcis (norm s) (Arg s))\<bar>"
	by (simp add: abs_mult)
	also have "\<dots> = \<bar>Im s\<bar>"
	by (subst rcis_cmod_Arg) auto
	finally have abs_Im_ge: "\<bar>Im s\<bar> \<ge> sin \<alpha> * norm s" .

	have [simp]: "Im s \<noteq> 0" "s \<noteq> 0"
	using s \<open>s \<notin> \<real>\<^sub>\<le>\<^sub>0\<close> False
	by (auto simp: cmod_def zero_le_mult_iff complex_nonpos_Reals_iff)
	have "sin \<alpha> > 0"
	using assms by (intro sin_gt_zero) auto

	obtain I where I: "((\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n) has_integral I) {0..real N}"
	"I \<le> 2c(n/(n-1)) / \<bar>Im s\<bar> ^ (n - 1)"
	using s c_nonneg assms False
	stirling_integral_bound_aux_integral2[of "-Re s" "\<bar>Im s\<bar>" c n 0 "real N"] by auto

	have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	integral {0..real N} (\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n)"
	proof (intro integral_norm_bound_integral integrable_ln_Gamma_aux s ballI)
	show "(\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n) integrable_on {0..real N}"
	using I(1) by (simp add: has_integral_iff)
	next
	fix x assume x: "x \<in> {0..real N}"
	have nz: "complex_of_real x + s \<noteq> 0"
	by (auto simp: complex_eq_iff)
	have "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le>
	c / norm (complex_of_real x + s) ^ n"
	unfolding norm_divide norm_power using c[of x] by (intro divide_right_mono) simp_all
	also have "\<dots> \<le> c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n"
	using c_nonneg nz abs_Re_le_cmod[of "of_real x + s"] abs_Im_le_cmod[of "of_real x + s"]
	by (intro divide_left_mono power_mono mult_pos_pos zero_less_power)
	(auto simp: less_max_iff_disj)
	finally show "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le> \<dots>" .
	qed (auto simp: complex_nonpos_Reals_iff)
	also have "\<dots> \<le> 2c(n/(n-1)) / \<bar>Im s\<bar> ^ (n - 1)"
	using I by (simp add: has_integral_iff)
	also have "\<dots> \<le> 2c(n/(n-1)) / (sin \<alpha> * norm s) ^ (n - 1)"
	using \<open>sin \<alpha> > 0\<close> s c_nonneg abs_Im_ge
	by (intro divide_left_mono mult_pos_pos zero_less_power power_mono mult_nonneg_nonneg) auto
	also have "\<dots> = 2c(n/(n-1))/sin \<alpha>^(n-1) / norm s ^ (n - 1)"
	by (simp add: field_simps)
	also have "\<dots> \<le> C / norm s ^ (n - 1)"
	by (intro divide_right_mono) (auto simp: C_def)
	finally show ?thesis .
	qed
	qed
	qed (use that assms complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> in auto)
	thus ?thesis by (rule that)
	qed

	lemma stirling_integral_bound:
	assumes "n > 0"
	obtains c where
	"\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral n s) \<le> c / Re s ^ n"
	proof -
	let ?f = "\<lambda>s. of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	from stirling_integral_bound_aux[of "Suc n"] assms obtain c where
	c: "\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral (Suc n) s) \<le> c / Re s ^ n" by auto
	define c1 where "c1 = real n / real (Suc n) * c"
	define c2 where "c2 = \<bar>bernoulli (Suc n)\<bar> / real (Suc n)"
	have c2_nonneg: "c2 \<ge> 0" by (simp add: c2_def)
	show ?thesis
	proof (rule that)
	fix s :: complex assume s: "Re s > 0"
	hence s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0" by (auto simp: complex_nonpos_Reals_iff)
	have "stirling_integral n s = ?f s" using s' assms
	by (rule stirling_integral_conv_stirling_integral_Suc)
	also have "norm \<dots> \<le> norm (of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s) +
	norm (of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n))"
	by (rule norm_triangle_ineq4)
	also have "\<dots> = real n / real (Suc n) * norm (stirling_integral (Suc n) s) +
	c2 / norm s ^ n" (is "_ = ?A + ?B")
	by (simp add: norm_divide norm_mult norm_power c2_def field_simps del: of_nat_Suc)
	also have "?A \<le> real n / real (Suc n) * (c / Re s ^ n)"
	by (intro mult_left_mono c s) simp_all
	also have "\<dots> = c1 / Re s ^ n" by (simp add: c1_def)
	also have "c2 / norm s ^ n \<le> c2 / Re s ^ n" using s c2_nonneg
	by (intro divide_left_mono power_mono complex_Re_le_cmod mult_pos_pos zero_less_power) auto
	also have "c1 / Re s ^ n + c2 / Re s ^ n = (c1 + c2) / Re s ^ n"
	using s by (simp add: field_simps)
	finally show "norm (stirling_integral n s) \<le> (c1 + c2) / Re s ^ n" by - simp_all
	qed
	qed

	lemma stirling_integral_bound':
	assumes "n > 0" and "\<alpha> \<in> {0<..<pi}"
	obtains c where
	"\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral n s) \<le> c / norm s ^ n"
	proof -
	let ?f = "\<lambda>s. of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	from stirling_integral_bound_aux'[of "Suc n"] assms obtain c where
	c: "\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow>
	norm (stirling_integral (Suc n) s) \<le> c / norm s ^ n" by auto
	define c1 where "c1 = real n / real (Suc n) * c"
	define c2 where "c2 = \<bar>bernoulli (Suc n)\<bar> / real (Suc n)"
	have c2_nonneg: "c2 \<ge> 0" by (simp add: c2_def)
	show ?thesis
	proof (rule that)
	fix s :: complex assume s: "s \<in> complex_cone' \<alpha> - {0}"
	have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] assms s by auto

	have "stirling_integral n s = ?f s" using s' assms
	by (intro stirling_integral_conv_stirling_integral_Suc) auto
	also have "norm \<dots> \<le> norm (of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s) +
	norm (of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n))"
	by (rule norm_triangle_ineq4)
	also have "\<dots> = real n / real (Suc n) * norm (stirling_integral (Suc n) s) +
	c2 / norm s ^ n" (is "_ = ?A + ?B")
	by (simp add: norm_divide norm_mult norm_power c2_def field_simps del: of_nat_Suc)
	also have "?A \<le> real n / real (Suc n) * (c / norm s ^ n)"
	by (intro mult_left_mono c s) simp_all
	also have "\<dots> = c1 / norm s ^ n" by (simp add: c1_def)
	also have "c1 / norm s ^ n + c2 / norm s ^ n = (c1 + c2) / norm s ^ n"
	using s by (simp add: divide_simps)
	finally show "norm (stirling_integral n s) \<le> (c1 + c2) / norm s ^ n" by - simp_all
	qed
	qed


	lemma stirling_integral_holomorphic [holomorphic_intros]:
	assumes m: "m > 0" and "A \<inter> \<real>\<^sub>\<le>\<^sub>0 = {}"
	shows "stirling_integral m holomorphic_on A"
	proof -
	from assms have [simp]: "z \<notin> \<real>\<^sub>\<le>\<^sub>0" if "z \<in> A" for z
	using that by auto
	let ?f = "\<lambda>s::complex. of_nat m * ((s - 1 / 2) * Ln s - s + of_real (ln (2 * pi) / 2) +
	(\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k)) -
	ln_Gamma s)"
	have "?f holomorphic_on A" using assms
	by (auto intro!: holomorphic_intros simp del: of_nat_Suc elim!: nonpos_Reals_cases)
	also have "?this \<longleftrightarrow> stirling_integral m holomorphic_on A"
	using assms by (intro holomorphic_cong refl)
	(simp_all add: field_simps ln_Gamma_stirling_complex)
	finally show "stirling_integral m holomorphic_on A" .
	qed

	lemma stirling_integral_continuous_on_complex [continuous_intros]:
	assumes m: "m > 0" and "A \<inter> \<real>\<^sub>\<le>\<^sub>0 = {}"
	shows "continuous_on A (stirling_integral m :: _ \<Rightarrow> complex)"
	by (intro holomorphic_on_imp_continuous_on stirling_integral_holomorphic assms)

	lemma has_field_derivative_stirling_integral_complex:
	fixes x :: complex
	assumes "x \<notin> \<real>\<^sub>\<le>\<^sub>0" "n > 0"
	shows "(stirling_integral n has_field_derivative deriv (stirling_integral n) x) (at x)"
	using assms
	by (intro holomorphic_derivI[OF stirling_integral_holomorphic, of n "-\<real>\<^sub>\<le>\<^sub>0"]) auto



	lemma
	assumes n: "n > 0" and "x > 0"
	shows deriv_stirling_integral_complex_of_real:
	"(deriv ^^ j) (stirling_integral n) (complex_of_real x) =
	complex_of_real ((deriv ^^ j) (stirling_integral n) x)" (is "?lhs x = ?rhs x")
	and differentiable_stirling_integral_real:
	"(deriv ^^ j) (stirling_integral n) field_differentiable at x" (is ?thesis2)
	proof -
	let ?A = "{s. Re s > 0}"
	let ?f = "\<lambda>j x. (deriv ^^ j) (stirling_integral n) (complex_of_real x)"
	let ?f' = "\<lambda>j x. complex_of_real ((deriv ^^ j) (stirling_integral n) x)"

	have [simp]: "open ?A" by (simp add: open_halfspace_Re_gt)

	have "?lhs x = ?rhs x \<and> (deriv ^^ j) (stirling_integral n) field_differentiable at x"
	if "x > 0" for x using that
	proof (induction j arbitrary: x)
	case 0
	have "((\<lambda>x. Re (stirling_integral n (of_real x))) has_field_derivative
	Re (deriv (\<lambda>x. stirling_integral n x) (of_real x))) (at x)" using 0 n
	by (auto intro!: derivative_intros has_vector_derivative_real_field
	field_differentiable_derivI holomorphic_on_imp_differentiable_at[of _ ?A]
	stirling_integral_holomorphic simp: complex_nonpos_Reals_iff)
	also have "?this \<longleftrightarrow> (stirling_integral n has_field_derivative
	Re (deriv (\<lambda>x. stirling_integral n x) (of_real x))) (at x)"
	using eventually_nhds_in_open[of "{0<..}" x] 0 n
	by (intro has_field_derivative_cong_ev refl)
	(auto elim!: eventually_mono simp: stirling_integral_complex_of_real)
	finally have "stirling_integral n field_differentiable at x"
	by (auto simp: field_differentiable_def)
	with 0 n show ?case by (auto simp: stirling_integral_complex_of_real)
	next
	case (Suc j x)
	note IH = conjunct1[OF Suc.IH] conjunct2[OF Suc.IH]
	have *: "(deriv ^^ Suc j) (stirling_integral n) (complex_of_real x) =
	of_real ((deriv ^^ Suc j) (stirling_integral n) x)" if x: "x > 0" for x
	proof -
	have "deriv ((deriv ^^ j) (stirling_integral n)) (complex_of_real x) =
	vector_derivative (\<lambda>x. (deriv ^^ j) (stirling_integral n) (of_real x)) (at x)"
	using n x
	by (intro vector_derivative_of_real_right [symmetric]
	holomorphic_on_imp_differentiable_at[of _ ?A] holomorphic_higher_deriv
	stirling_integral_holomorphic) (auto simp: complex_nonpos_Reals_iff)
	also have "\<dots> = vector_derivative (\<lambda>x. of_real ((deriv ^^ j) (stirling_integral n) x)) (at x)"
	using eventually_nhds_in_open[of "{0<..}" x] x
	by (intro vector_derivative_cong_eq) (auto elim!: eventually_mono simp: IH(1))
	also have "\<dots> = of_real (deriv ((deriv ^^ j) (stirling_integral n)) x)"
	by (intro vector_derivative_of_real_left holomorphic_on_imp_differentiable_at[of _ ?A]
	field_differentiable_imp_differentiable IH(2) x)
	finally show ?thesis by simp
	qed
	have "((\<lambda>x. Re ((deriv ^^ Suc j) (stirling_integral n) (of_real x))) has_field_derivative
	Re (deriv ((deriv ^^ Suc j) (stirling_integral n)) (of_real x))) (at x)"
	using Suc.prems n
	by (intro derivative_intros has_vector_derivative_real_field field_differentiable_derivI
	holomorphic_on_imp_differentiable_at[of _ ?A] stirling_integral_holomorphic
	holomorphic_higher_deriv) (auto simp: complex_nonpos_Reals_iff)
	also have "?this \<longleftrightarrow> ((deriv ^^ Suc j) (stirling_integral n) has_field_derivative
	Re (deriv ((deriv ^^ Suc j) (stirling_integral n)) (of_real x))) (at x)"
	using eventually_nhds_in_open[of "{0<..}" x] Suc.prems *
	by (intro has_field_derivative_cong_ev refl) (auto elim!: eventually_mono)
	finally have "(deriv ^^ Suc j) (stirling_integral n) field_differentiable at x"
	by (auto simp: field_differentiable_def)
	with *[OF Suc.prems] show ?case by blast
	qed
	from this[OF assms(2)] show "?lhs x = ?rhs x" ?thesis2 by blast+
	qed

	text \<open>
	Unfortunately, asymptotic power series cannot, in general, be differentiated. However, since
	@{term ln_Gamma} is holomorphic on the entire positive real half-space, we can differentiate
	its asymptotic expansion after all.

	To do this, we use an ad-hoc version of the more general approach outlined in Erdelyi's
	``Asymptotic Expansions'' for holomorphic functions: We bound the value of the $j$-th derivative
	of the remainder term at some value $x$ by applying Cauchy's integral formula along a circle
	centred at $x$ with radius $\frac{1}{2} x$.
	\<close>
	lemma deriv_stirling_integral_real_bound:
	assumes m: "m > 0"
	shows "(deriv ^^ j) (stirling_integral m) \<in> O(\<lambda>x::real. 1 / x ^ (m + j))"
	proof -
	obtain c where c: "\<And>s. 0 < Re s \<Longrightarrow> cmod (stirling_integral m s) \<le> c / Re s ^ m"
	using stirling_integral_bound[OF m] by auto
	have "0 \<le> cmod (stirling_integral m 1)" by simp
	also have "\<dots> \<le> c" using c[of 1] by simp
	finally have c_nonneg: "c \<ge> 0" .
	define B where "B = c * 2 ^ (m + Suc j)"
	define B' where "B' = B * fact j / 2"

	have "eventually (\<lambda>x::real. norm ((deriv ^^ j) (stirling_integral m) x) \<le>
	B' * norm (1 / x ^ (m+ j))) at_top"
	using eventually_gt_at_top[of "0::real"]
	proof eventually_elim
	case (elim x)
	have "s \<notin> \<real>\<^sub>\<le>\<^sub>0" if "s \<in> cball (of_real x) (x/2)" for s :: complex
	proof -
	have "x - Re s \<le> norm (of_real x - s)" using complex_Re_le_cmod[of "of_real x - s"] by simp
	also from that have "\<dots> \<le> x/2" by (simp add: dist_complex_def)
	finally show ?thesis using elim by (auto simp: complex_nonpos_Reals_iff)
	qed
	hence "((\<lambda>u. stirling_integral m u / (u - of_real x) ^ Suc j) has_contour_integral
	complex_of_real (2 * pi) * \<i> / fact j *
	(deriv ^^ j) (stirling_integral m) (of_real x)) (circlepath (of_real x) (x/2))"
	using m elim
	by (intro Cauchy_has_contour_integral_higher_derivative_circlepath
	stirling_integral_continuous_on_complex stirling_integral_holomorphic) auto
	hence "norm (of_real (2 * pi) * \<i> / fact j * (deriv ^^ j) (stirling_integral m) (of_real x)) \<le>
	B / x ^ (m + Suc j) * (2 * pi * (x / 2))"
	proof (rule has_contour_integral_bound_circlepath)
	fix u :: complex assume dist: "norm (u - of_real x) = x / 2"
	have "Re (of_real x - u) \<le> norm (of_real x - u)" by (rule complex_Re_le_cmod)
	also have "\<dots> = x / 2" using dist by (simp add: norm_minus_commute)
	finally have Re_u: "Re u \<ge> x/2" using elim by simp
	have "norm (stirling_integral m u / (u - of_real x) ^ Suc j) \<le>
	c / Re u ^ m / (x / 2) ^ Suc j" using Re_u elim
	unfolding norm_divide norm_power dist
	by (intro divide_right_mono zero_le_power c) simp_all
	also have "\<dots> \<le> c / (x/2) ^ m / (x / 2) ^ Suc j" using c_nonneg elim Re_u
	by (intro divide_right_mono divide_left_mono power_mono) simp_all
	also have "\<dots> = B / x ^ (m + Suc j)" using elim by (simp add: B_def field_simps power_add)
	finally show "norm (stirling_integral m u / (u - of_real x) ^ Suc j) \<le> B / x ^ (m + Suc j)" .
	qed (insert elim c_nonneg, auto simp: B_def simp del: power_Suc)
	hence "cmod ((deriv ^^ j) (stirling_integral m) (of_real x)) \<le> B' / x ^ (j + m)"
	using elim by (simp add: field_simps norm_divide norm_mult norm_power B'_def)
	with elim m show ?case by (simp_all add: add_ac deriv_stirling_integral_complex_of_real)
	qed
	thus ?thesis by (rule bigoI)
	qed

	definition stirling_sum where
	"stirling_sum j m x =
	(-1) ^ j * (\<Sum>k = 1..<m. (of_real (bernoulli (Suc k)) * pochhammer (of_nat k) j / (of_nat k *
	of_nat (Suc k))) * inverse x ^ (k + j))"

	definition stirling_sum' where
	"stirling_sum' j m x =
	(-1) ^ (Suc j) * (\<Sum>k\<le>m. (of_real (bernoulli' k) *
	pochhammer (of_nat (Suc k)) (j - 1) * inverse x ^ (k + j)))"

	lemma stirling_sum_complex_of_real:
	"stirling_sum j m (complex_of_real x) = complex_of_real (stirling_sum j m x)"
	by (simp add: stirling_sum_def pochhammer_of_real [symmetric] del: of_nat_Suc)

	lemma stirling_sum'_complex_of_real:
	"stirling_sum' j m (complex_of_real x) = complex_of_real (stirling_sum' j m x)"
	by (simp add: stirling_sum'_def pochhammer_of_real [symmetric] del: of_nat_Suc)

	lemma has_field_derivative_stirling_sum_complex [derivative_intros]:
	"Re x > 0 \<Longrightarrow> (stirling_sum j m has_field_derivative stirling_sum (Suc j) m x) (at x)"
	unfolding stirling_sum_def [abs_def] sum_distrib_left
	by (rule DERIV_sum) (auto intro!: derivative_eq_intros simp del: of_nat_Suc
	simp: pochhammer_Suc power_diff)

	lemma has_field_derivative_stirling_sum_real [derivative_intros]:
	"x > (0::real) \<Longrightarrow> (stirling_sum j m has_field_derivative stirling_sum (Suc j) m x) (at x)"
	unfolding stirling_sum_def [abs_def] sum_distrib_left
	by (rule DERIV_sum) (auto intro!: derivative_eq_intros simp del: of_nat_Suc
	simp: pochhammer_Suc power_diff)

	lemma has_field_derivative_stirling_sum'_complex [derivative_intros]:
	assumes "j > 0" "Re x > 0"
	shows "(stirling_sum' j m has_field_derivative stirling_sum' (Suc j) m x) (at x)"
	proof (cases j)
	case (Suc j')
	from assms have [simp]: "x \<noteq> 0" by auto
	define c where "c = (\<lambda>n. (-1) ^ Suc j * complex_of_real (bernoulli' n) *
	pochhammer (of_nat (Suc n)) j')"
	define T where "T = (\<lambda>n x. c n * inverse x ^ (j + n))"
	define T' where "T' = (\<lambda>n x. - (of_nat (j + n)) * c n * inverse x ^ (Suc (j + n)))"
	have "((\<lambda>x. \<Sum>k\<le>m. T k x) has_field_derivative (\<Sum>k\<le>m. T' k x)) (at x)" using assms Suc
	by (intro DERIV_sum)
	(auto simp: T_def T'_def intro!: derivative_eq_intros
	simp: field_simps power_add [symmetric] simp del: of_nat_Suc power_Suc of_nat_add)
	also have "(\<lambda>x. (\<Sum>k\<le>m. T k x)) = stirling_sum' j m"
	by (simp add: Suc T_def c_def stirling_sum'_def fun_eq_iff add_ac mult.assoc sum_distrib_left)
	also have "(\<Sum>k\<le>m. T' k x) = stirling_sum' (Suc j) m x"
	by (simp add: T'_def c_def Suc stirling_sum'_def sum_distrib_left
	sum_distrib_right algebra_simps pochhammer_Suc)
	finally show ?thesis .
	qed (insert assms, simp_all)

	lemma has_field_derivative_stirling_sum'_real [derivative_intros]:
	assumes "j > 0" "x > (0::real)"
	shows "(stirling_sum' j m has_field_derivative stirling_sum' (Suc j) m x) (at x)"
	proof (cases j)
	case (Suc j')
	from assms have [simp]: "x \<noteq> 0" by auto
	define c where "c = (\<lambda>n. (-1) ^ Suc j * (bernoulli' n) * pochhammer (of_nat (Suc n)) j')"
	define T where "T = (\<lambda>n x. c n * inverse x ^ (j + n))"
	define T' where "T' = (\<lambda>n x. - (of_nat (j + n)) * c n * inverse x ^ (Suc (j + n)))"
	have "((\<lambda>x. \<Sum>k\<le>m. T k x) has_field_derivative (\<Sum>k\<le>m. T' k x)) (at x)" using assms Suc
	by (intro DERIV_sum)
	(auto simp: T_def T'_def intro!: derivative_eq_intros
	simp: field_simps power_add [symmetric] simp del: of_nat_Suc power_Suc of_nat_add)
	also have "(\<lambda>x. (\<Sum>k\<le>m. T k x)) = stirling_sum' j m"
	by (simp add: Suc T_def c_def stirling_sum'_def fun_eq_iff add_ac mult.assoc sum_distrib_left)
	also have "(\<Sum>k\<le>m. T' k x) = stirling_sum' (Suc j) m x"
	by (simp add: T'_def c_def Suc stirling_sum'_def sum_distrib_left
	sum_distrib_right algebra_simps pochhammer_Suc)
	finally show ?thesis .
	qed (insert assms, simp_all)

	lemma higher_deriv_stirling_sum_complex:
	"Re x > 0 \<Longrightarrow> (deriv ^^ i) (stirling_sum j m) x = stirling_sum (i + j) m x"
	proof (induction i arbitrary: x)
	case (Suc i)
	have "deriv ((deriv ^^ i) (stirling_sum j m)) x = deriv (stirling_sum (i + j) m) x"
	using eventually_nhds_in_open[of "{x. Re x > 0}" x] Suc.prems
	by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: open_halfspace_Re_gt Suc.IH)
	also from Suc.prems have "\<dots> = stirling_sum (Suc (i + j)) m x"
	by (intro DERIV_imp_deriv has_field_derivative_stirling_sum_complex)
	finally show ?case by simp
	qed simp_all


	definition Polygamma_approx :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a :: {real_normed_field, ln}" where
	"Polygamma_approx j m =
	(deriv ^^ j) (\<lambda>x. (x - 1 / 2) * ln x - x + of_real (ln (2 * pi)) / 2 + stirling_sum 0 m x)"

	lemma Polygamma_approx_Suc: "Polygamma_approx (Suc j) m = deriv (Polygamma_approx j m)"
	by (simp add: Polygamma_approx_def)

	lemma Polygamma_approx_0:
	"Polygamma_approx 0 m x = (x - 1/2) * ln x - x + of_real (ln (2*pi)) / 2 + stirling_sum 0 m x"
	by (simp add: Polygamma_approx_def)

	lemma Polygamma_approx_1_complex:
	"Re x > 0 \<Longrightarrow>
	Polygamma_approx (Suc 0) m x = ln x - 1 / (2*x) + stirling_sum (Suc 0) m x"
	unfolding Polygamma_approx_Suc Polygamma_approx_0
	by (intro DERIV_imp_deriv)
	(auto intro!: derivative_eq_intros elim!: nonpos_Reals_cases simp: field_simps)

	lemma Polygamma_approx_1_real:
	"x > (0 :: real) \<Longrightarrow>
	Polygamma_approx (Suc 0) m x = ln x - 1 / (2*x) + stirling_sum (Suc 0) m x"
	unfolding Polygamma_approx_Suc Polygamma_approx_0
	by (intro DERIV_imp_deriv)
	(auto intro!: derivative_eq_intros elim!: nonpos_Reals_cases simp: field_simps)

	lemma stirling_sum_2_conv_stirling_sum'_1:
	fixes x :: "'a :: {real_div_algebra, field_char_0}"
	assumes "m > 0" "x \<noteq> 0"
	shows "stirling_sum' 1 m x = 1 / x + 1 / (2 * x^2) + stirling_sum 2 m x"
	proof -
	have pochhammer_2: "pochhammer (of_nat k) 2 = of_nat k * of_nat (Suc k)" for k
	by (simp add: pochhammer_Suc eval_nat_numeral add_ac)
	have "stirling_sum 2 m x =
	(\<Sum>k = Suc 0..<m. of_real (bernoulli' (Suc k)) * inverse x ^ Suc (Suc k))"
	unfolding stirling_sum_def pochhammer_2 power2_minus power_one mult_1_left
	by (intro sum.cong refl)
	(simp_all add: stirling_sum_def pochhammer_2 power2_eq_square divide_simps bernoulli'_def
	del: of_nat_Suc power_Suc)
	also have "1 / (2 * x^2) + \<dots> =
	(\<Sum>k=0..<m. of_real (bernoulli' (Suc k)) * inverse x ^ Suc (Suc k))" using assms
	by (subst (2) sum.atLeast_Suc_lessThan) (simp_all add: power2_eq_square field_simps)
	also have "1 / x + \<dots> = (\<Sum>k=0..<Suc m. of_real (bernoulli' k) * inverse x ^ Suc k)"
	by (subst sum.atLeast0_lessThan_Suc_shift) (simp_all add: bernoulli'_def divide_simps)
	also have "\<dots> = (\<Sum>k\<le>m. of_real (bernoulli' k) * inverse x ^ Suc k)"
	by (intro sum.cong) auto
	also have "\<dots> = stirling_sum' 1 m x" by (simp add: stirling_sum'_def)
	finally show ?thesis by (simp add: add_ac)
	qed

	lemma Polygamma_approx_2_real:
	assumes "x > (0::real)" "m > 0"
	shows "Polygamma_approx (Suc (Suc 0)) m x = stirling_sum' 1 m x"
	proof -
	have "Polygamma_approx (Suc (Suc 0)) m x = deriv (Polygamma_approx (Suc 0) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (\<lambda>x. ln x - 1 / (2*x) + stirling_sum (Suc 0) m x) x"
	using eventually_nhds_in_open[of "{0<..}" x] assms
	by (intro deriv_cong_ev) (auto elim!: eventually_mono simp: Polygamma_approx_1_real)
	also have "\<dots> = 1 / x + 1 / (2*x^2) + stirling_sum (Suc (Suc 0)) m x" using assms
	by (intro DERIV_imp_deriv) (auto intro!: derivative_eq_intros
	elim!: nonpos_Reals_cases simp: field_simps power2_eq_square)
	also have "\<dots> = stirling_sum' 1 m x" using stirling_sum_2_conv_stirling_sum'_1[of m x] assms
	by (simp add: eval_nat_numeral)
	finally show ?thesis .
	qed

	lemma Polygamma_approx_2_complex:
	assumes "Re x > 0" "m > 0"
	shows "Polygamma_approx (Suc (Suc 0)) m x = stirling_sum' 1 m x"
	proof -
	have "Polygamma_approx (Suc (Suc 0)) m x = deriv (Polygamma_approx (Suc 0) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (\<lambda>x. ln x - 1 / (2*x) + stirling_sum (Suc 0) m x) x"
	using eventually_nhds_in_open[of "{s. Re s > 0}" x] assms
	by (intro deriv_cong_ev)
	(auto simp: open_halfspace_Re_gt elim!: eventually_mono simp: Polygamma_approx_1_complex)
	also have "\<dots> = 1 / x + 1 / (2*x^2) + stirling_sum (Suc (Suc 0)) m x" using assms
	by (intro DERIV_imp_deriv) (auto intro!: derivative_eq_intros
	elim!: nonpos_Reals_cases simp: field_simps power2_eq_square)
	also have "\<dots> = stirling_sum' 1 m x" using stirling_sum_2_conv_stirling_sum'_1[of m x] assms
	by (subst stirling_sum_2_conv_stirling_sum'_1) (auto simp: eval_nat_numeral)
	finally show ?thesis .
	qed

	lemma Polygamma_approx_ge_2_real:
	assumes "x > (0::real)" "m > 0"
	shows "Polygamma_approx (Suc (Suc j)) m x = stirling_sum' (Suc j) m x"
	using assms(1)
	proof (induction j arbitrary: x)
	case (0 x)
	with assms show ?case by (simp add: Polygamma_approx_2_real)
	next
	case (Suc j x)
	have "Polygamma_approx (Suc (Suc (Suc j))) m x = deriv (Polygamma_approx (Suc (Suc j)) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (stirling_sum' (Suc j) m) x"
	using eventually_nhds_in_open[of "{0<..}" x] Suc.prems
	by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: Suc.IH)
	also have "\<dots> = stirling_sum' (Suc (Suc j)) m x" using Suc.prems
	by (intro DERIV_imp_deriv derivative_intros) simp_all
	finally show ?case .
	qed

	lemma Polygamma_approx_ge_2_complex:
	assumes "Re x > 0" "m > 0"
	shows "Polygamma_approx (Suc (Suc j)) m x = stirling_sum' (Suc j) m x"
	using assms(1)
	proof (induction j arbitrary: x)
	case (0 x)
	with assms show ?case by (simp add: Polygamma_approx_2_complex)
	next
	case (Suc j x)
	have "Polygamma_approx (Suc (Suc (Suc j))) m x = deriv (Polygamma_approx (Suc (Suc j)) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (stirling_sum' (Suc j) m) x"
	using eventually_nhds_in_open[of "{x. Re x > 0}" x] Suc.prems
	by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: Suc.IH open_halfspace_Re_gt)
	also have "\<dots> = stirling_sum' (Suc (Suc j)) m x" using Suc.prems
	by (intro DERIV_imp_deriv derivative_intros) simp_all
	finally show ?case .
	qed

	lemma Polygamma_approx_complex_of_real:
	assumes "x > 0" "m > 0"
	shows "Polygamma_approx j m (complex_of_real x) = of_real (Polygamma_approx j m x)"
	proof (cases j)
	case 0
	with assms show ?thesis by (simp add: Polygamma_approx_0 Ln_of_real stirling_sum_complex_of_real)
	next
	case [simp]: (Suc j')
	thus ?thesis
	proof (cases j')
	case 0
	with assms show ?thesis
	by (simp add: Polygamma_approx_1_complex
	Polygamma_approx_1_real stirling_sum_complex_of_real Ln_of_real)
	next
	case (Suc j'')
	with assms show ?thesis
	by (simp add: Polygamma_approx_ge_2_complex Polygamma_approx_ge_2_real
	stirling_sum'_complex_of_real)
	qed
	qed

	lemma higher_deriv_Polygamma_approx [simp]:
	"(deriv ^^ j) (Polygamma_approx i m) = Polygamma_approx (j + i) m"
	by (simp add: Polygamma_approx_def funpow_add)

	lemma stirling_sum_holomorphic [holomorphic_intros]:
	"0 \<notin> A \<Longrightarrow> stirling_sum j m holomorphic_on A"
	unfolding stirling_sum_def by (intro holomorphic_intros) auto

	lemma Polygamma_approx_holomorphic [holomorphic_intros]:
	"Polygamma_approx j m holomorphic_on {s. Re s > 0}"
	unfolding Polygamma_approx_def
	by (intro holomorphic_intros) (auto simp: open_halfspace_Re_gt elim!: nonpos_Reals_cases)

	lemma higher_deriv_lnGamma_stirling:
	assumes m: "m > 0"
	shows "(\<lambda>x::real. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x) \<in> O(\<lambda>x. 1 / x ^ (m + j))"
	proof -
	have "eventually (\<lambda>x. \<bar>(deriv ^^ j) ln_Gamma x - Polygamma_approx j m x\<bar> =
	inverse (real m) * \<bar>(deriv ^^ j) (stirling_integral m) x\<bar>) at_top"
	using eventually_gt_at_top[of "0::real"]
	proof eventually_elim
	case (elim x)
	note x = this
	have "\<forall>\<^sub>F y in nhds (complex_of_real x). y \<in> - \<real>\<^sub>\<le>\<^sub>0"
	using elim by (intro eventually_nhds_in_open) auto
	hence "(deriv ^^ j) (\<lambda>x. ln_Gamma x - Polygamma_approx 0 m x) (complex_of_real x) =
	(deriv ^^ j) (\<lambda>x. (-inverse (of_nat m)) * stirling_integral m x) (complex_of_real x)"
	using x m
	by (intro higher_deriv_cong_ev refl)
	(auto elim!: eventually_mono simp: ln_Gamma_stirling_complex Polygamma_approx_def
	field_simps open_halfspace_Re_gt stirling_sum_def)
	also have "\<dots> = - inverse (of_nat m) * (deriv ^^ j) (stirling_integral m) (of_real x)" using x m
	by (intro higher_deriv_cmult[of _ "-\<real>\<^sub>\<le>\<^sub>0"] stirling_integral_holomorphic)
	(auto simp: open_halfspace_Re_gt)
	also have "(deriv ^^ j) (\<lambda>x. ln_Gamma x - Polygamma_approx 0 m x) (complex_of_real x) =
	(deriv ^^ j) ln_Gamma (of_real x) - (deriv ^^ j) (Polygamma_approx 0 m) (of_real x)"
	using x
	by (intro higher_deriv_diff[of _ "{s. Re s > 0}"])
	(auto intro!: holomorphic_intros elim!: nonpos_Reals_cases simp: open_halfspace_Re_gt)
	also have "(deriv ^^ j) (Polygamma_approx 0 m) (complex_of_real x) =
	of_real (Polygamma_approx j m x)" using x m
	by (simp add: Polygamma_approx_complex_of_real)
	also have "norm (- inverse (of_nat m) * (deriv ^^ j) (stirling_integral m) (complex_of_real x)) =
	inverse (real m) * \<bar>(deriv ^^ j) (stirling_integral m) x\<bar>"
	using x m by (simp add: norm_mult norm_inverse deriv_stirling_integral_complex_of_real)
	also have "(deriv ^^ j) ln_Gamma (complex_of_real x) = of_real ((deriv ^^ j) ln_Gamma x)" using x
	by (simp add: higher_deriv_ln_Gamma_complex_of_real)
	also have "norm (\<dots> - of_real (Polygamma_approx j m x)) =
	\<bar>(deriv ^^ j) ln_Gamma x - Polygamma_approx j m x\<bar>"
	by (simp only: of_real_diff [symmetric] norm_of_real)
	finally show ?case .
	qed
	from bigthetaI_cong[OF this] m
	have "(\<lambda>x::real. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x) \<in>
	\<Theta>(\<lambda>x. (deriv ^^ j) (stirling_integral m) x)" by simp
	also have "(\<lambda>x::real. (deriv ^^ j) (stirling_integral m) x) \<in> O(\<lambda>x. 1 / x ^ (m + j))" using m
	by (rule deriv_stirling_integral_real_bound)
	finally show ?thesis .
	qed

	lemma Polygamma_approx_1_real':
	assumes x: "(x::real) > 0" and m: "m > 0"
	shows "Polygamma_approx 1 m x = ln x - (\<Sum>k = Suc 0..m. bernoulli' k * inverse x ^ k / real k)"
	proof -
	have "Polygamma_approx 1 m x = ln x - (1 / (2 * x) +
	(\<Sum>k=Suc 0..<m. bernoulli (Suc k) * inverse x ^ Suc k / real (Suc k)))"
	(is "_ = _ - (_ + ?S)") using x by (simp add: Polygamma_approx_1_real stirling_sum_def)
	also have "?S = (\<Sum>k=Suc 0..<m. bernoulli' (Suc k) * inverse x ^ Suc k / real (Suc k))"
	by (intro sum.cong refl) (simp_all add: bernoulli'_def)
	also have "1 / (2 * x) + \<dots> =
	(\<Sum>k=0..<m. bernoulli' (Suc k) * inverse x ^ Suc k / real (Suc k))" using m
	by (subst (2) sum.atLeast_Suc_lessThan) (simp_all add: field_simps)
	also have "\<dots> = (\<Sum>k = Suc 0..m. bernoulli' k * inverse x ^ k / real k)" using assms
	by (subst sum.shift_bounds_Suc_ivl [symmetric]) (simp add: atLeastLessThanSuc_atLeastAtMost)
	finally show ?thesis .
	qed

	theorem
	assumes m: "m > 0"
	shows ln_Gamma_real_asymptotics:
	"(\<lambda>x. ln_Gamma x - ((x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
	(\<Sum>k = 1..<m. bernoulli (Suc k) / (real k * real (Suc k)) / x^k)))
	\<in> O(\<lambda>x. 1 / x ^ m)" (is ?th1)
	and Digamma_real_asymptotics:
	"(\<lambda>x. Digamma x - (ln x - (\<Sum>k=1..m. bernoulli' k / real k / x ^ k)))
	\<in> O(\<lambda>x. 1 / (x ^ Suc m))" (is ?th2)
	and Polygamma_real_asymptotics: "j > 0 \<Longrightarrow>
	(\<lambda>x. Polygamma j x - (- 1) ^ Suc j * (\<Sum>k\<le>m. bernoulli' k *
	pochhammer (real (Suc k)) (j - 1) / x ^ (k + j)))
	\<in> O(\<lambda>x. 1 / x ^ (m+j+1))" (is "_ \<Longrightarrow> ?th3")
	proof -
	define G :: "nat \<Rightarrow> real \<Rightarrow> real" where
	"G = (\<lambda>m. if m = 0 then ln_Gamma else Polygamma (m - 1))"
	have *: "(\<lambda>x. G j x - h x) \<in> O(\<lambda>x. 1 / x ^ (m + j))"
	if "\<And>x::real. x > 0 \<Longrightarrow> Polygamma_approx j m x = h x" for j h
	proof -
	have "(\<lambda>x. G j x - h x) \<in>
	\<Theta>(\<lambda>x. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x)" (is "_ \<in> \<Theta>(?f)")
	using that
	by (intro bigthetaI_cong) (auto intro: eventually_mono[OF eventually_gt_at_top[of "0::real"]]
	simp del: funpow.simps simp: higher_deriv_ln_Gamma_real G_def)
	also have "?f \<in> O(\<lambda>x::real. 1 / x ^ (m + j))" using m
	by (rule higher_deriv_lnGamma_stirling)
	finally show ?thesis .
	qed

	note [[simproc del: simplify_landau_sum]]
	from *[OF Polygamma_approx_0] assms show ?th1
	by (simp add: G_def Polygamma_approx_0 stirling_sum_def field_simps)
	from *[OF Polygamma_approx_1_real'] assms show ?th2 by (simp add: G_def field_simps)

	assume j: "j > 0"
	from *[OF Polygamma_approx_ge_2_real, of "j - 1"] assms j show ?th3
	by (simp add: G_def stirling_sum'_def power_add power_diff field_simps)
	qed




	subsection \<open>Asymptotics of the complex Gamma function\<close>

	text \<open>
	The \<open>m\<close>-th order remainder of Stirling's formula for $\log\Gamma$ is $O(s^{-m})$ uniformly over
	any complex cone $\text{Arg}(z) \leq \alpha$, $z\neq 0$ for any angle
	$\alpha\in(0, \pi)$. This means that there is bounded by $c z^{-m}$ for some constant $c$ for
	all $z$ in this cone.
	\<close>
	context
	fixes F and \<alpha>
	assumes \<alpha>: "\<alpha> \<in> {0<..<pi}"
	defines "F \<equiv> principal (complex_cone' \<alpha> - {0})"
	begin

	lemma stirling_integral_bigo:
	fixes m :: nat
	assumes m: "m > 0"
	shows "stirling_integral m \<in> O[F](\<lambda>s. 1 / s ^ m)"
	proof -
	obtain c where c: "\<And>s. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral m s) \<le> c / norm s ^ m"
	using stirling_integral_bound'[OF \<open>m > 0\<close> \<alpha>] by blast
	have "0 \<le> norm (stirling_integral m 1 :: complex)"
	by simp
	also have "\<dots> \<le> c"
	using c[of 1] \<alpha> by simp
	finally have "c \<ge> 0" .

	have "eventually (\<lambda>s. s \<in> complex_cone' \<alpha> - {0}) F"
	unfolding F_def by (auto simp: eventually_principal)
	hence "eventually (\<lambda>s. norm (stirling_integral m s) \<le>
	c * norm (1 / s ^ m)) F"
	by eventually_elim (use c in \<open>simp add: norm_divide norm_power\<close>)
	thus "stirling_integral m \<in> O[F](\<lambda>s. 1 / s ^ m)"
	by (intro bigoI[of _ c]) auto
	qed

	end

	text \<open>
	The following is a more explicit statement of this:
	\<close>
	theorem ln_Gamma_complex_asymptotics_explicit:
	fixes m :: nat and \<alpha> :: real
	assumes "m > 0" and "\<alpha> \<in> {0<..<pi}"
	obtains C :: real and R :: "complex \<Rightarrow> complex"
	where "\<forall>s::complex. s \<notin> \<real>\<^sub>\<le>\<^sub>0 \<longrightarrow>
	ln_Gamma s = (s - 1/2) * ln s - s + ln (2 * pi) / 2 +
	(\<Sum>k=1..<m. bernoulli (k+1) / (k * (k+1) * s ^ k)) - R s"
	and "\<forall>s. s \<noteq> 0 \<and> \<bar>Arg s\<bar> \<le> \<alpha> \<longrightarrow> norm (R s) \<le> C / norm s ^ m"
	proof -
	obtain c where c: "\<And>s. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral m s) \<le> c / norm s ^ m"
	using stirling_integral_bound'[OF assms] by blast
	have "0 \<le> norm (stirling_integral m 1 :: complex)"
	by simp
	also have "\<dots> \<le> c"
	using c[of 1] assms by simp
	finally have "c \<ge> 0" .
	define R where "R = (\<lambda>s::complex. stirling_integral m s / of_nat m)"
	show ?thesis
	proof (rule that)
	from ln_Gamma_stirling_complex[of _ m] assms show
	"\<forall>s::complex. s \<notin> \<real>\<^sub>\<le>\<^sub>0 \<longrightarrow>
	ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 +
	(\<Sum>k=1..<m. bernoulli (k+1) / (k * (k+1) * s ^ k)) - R s"
	by (auto simp add: R_def algebra_simps)
	show "\<forall>s. s \<noteq> 0 \<and> \<bar>Arg s\<bar> \<le> \<alpha> \<longrightarrow> cmod (R s) \<le> c / real m / cmod s ^ m"
	proof (safe, goal_cases)
	case (1 s)
	show ?case
	using 1 c[of s] assms
	by (auto simp: complex_cone_altdef abs_le_iff R_def norm_divide field_simps)
	qed
	qed
	qed


	text \<open>
	Lastly, we can also derive the asymptotics of $\Gamma$ itself:
	\[\Gamma(z) \sim \sqrt{2\pi / z} \left(\frac{z}{e}\right)^z\]
	uniformly for $\|z\|\to\infty$ within the cone $\text{Arg}(z) \leq \alpha$ for $\alpha\in(0,\pi)$:
	\<close>

	context
	fixes F and \<alpha>
	assumes \<alpha>: "\<alpha> \<in> {0<..<pi}"
	defines "F \<equiv> inf at_infinity (principal (complex_cone' \<alpha>))"
	begin

	lemma Gamma_complex_asymp_equiv:
	"Gamma \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2))"
	proof -
	define I :: "complex \<Rightarrow> complex" where "I = stirling_integral 1"
	have "eventually (\<lambda>s. s \<in> complex_cone' \<alpha>) F"
	by (auto simp: eventually_inf_principal F_def)
	moreover have "eventually (\<lambda>s. s \<noteq> 0) F"
	unfolding F_def eventually_inf_principal
	using eventually_not_equal_at_infinity by eventually_elim auto
	ultimately have "eventually (\<lambda>s. Gamma s =
	sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s)) F"
	proof eventually_elim
	case (elim s)
	from elim have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> by auto
	from elim have [simp]: "s \<noteq> 0" by auto
	from s' have "Gamma s = exp (ln_Gamma s)"
	unfolding Gamma_complex_altdef using nonpos_Ints_subset_nonpos_Reals by auto
	also from s' have "ln_Gamma s = (s-1/2) * Ln s - s + complex_of_real (ln (2 * pi) / 2) - I s"
	by (subst ln_Gamma_stirling_complex[of _ 1]) (simp_all add: exp_add exp_diff I_def)
	also have "exp \<dots> = exp ((s - 1 / 2) * Ln s) / exp s *
	exp (complex_of_real (ln (2 * pi) / 2)) / exp (I s)"
	unfolding exp_diff exp_add by (simp add: exp_diff exp_add)
	also have "exp ((s - 1 / 2) * Ln s) = s powr (s - 1 / 2)"
	by (simp add: powr_def)
	also have "exp (complex_of_real (ln (2 * pi) / 2)) = sqrt (2 * pi)"
	by (subst exp_of_real) (auto simp: powr_def simp flip: powr_half_sqrt)
	also have "exp s = exp 1 powr s"
	by (simp add: powr_def)
	also have "s powr (s - 1 / 2) / exp 1 powr s = (s powr s / exp 1 powr s) / s powr (1/2)"
	by (subst powr_diff) auto
	also have *: "Ln (s / exp 1) = Ln s - 1"
	using Ln_divide_of_real[of "exp 1" s] by (simp flip: exp_of_real)
	hence "s powr s / exp 1 powr s = (s / exp 1) powr s"
	unfolding powr_def by (subst *) (auto simp: exp_diff field_simps)
	finally show "Gamma s = sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s)"
	by (simp add: algebra_simps)
	qed
	hence "Gamma \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s))"
	by (rule asymp_equiv_refl_ev)
	also have "\<dots> \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / 1)"
	proof (intro asymp_equiv_intros)
	have "F \<le> principal (complex_cone' \<alpha> - {0})"
	unfolding le_principal F_def eventually_inf_principal
	using eventually_not_equal_at_infinity by eventually_elim auto
	moreover have "I \<in> O[principal (complex_cone' \<alpha> - {0})](\<lambda>s. 1 / s)"
	using stirling_integral_bigo[of \<alpha> 1] \<alpha> unfolding F_def by (simp add: I_def)
	ultimately have "I \<in> O[F](\<lambda>s. 1 / s)"
	by (rule landau_o.big.filter_mono)
	also have "(\<lambda>s. 1 / s) \<in> o[F](\<lambda>s. 1)"
	proof (rule landau_o.smallI)
	fix c :: real
	assume c: "c > 0"
	hence "eventually (\<lambda>z::complex. norm z \<ge> 1 / c) at_infinity"
	by (auto simp: eventually_at_infinity)
	moreover have "eventually (\<lambda>z::complex. z \<noteq> 0) at_infinity"
	by (rule eventually_not_equal_at_infinity)
	ultimately show "eventually (\<lambda>z::complex. norm (1 / z) \<le> c * norm (1 :: complex)) F"
	unfolding F_def eventually_inf_principal
	by eventually_elim (use \<open>c > 0\<close> in \<open>auto simp: norm_divide field_simps\<close>)
	qed
	finally have "I \<in> o[F](\<lambda>s. 1)" .
	from smalloD_tendsto[OF this] have [tendsto_intros]: "(I \<longlongrightarrow> 0) F"
	by simp
	show "(\<lambda>x. exp (I x)) \<sim>[F] (\<lambda>x. 1)"
	by (rule asymp_equivI' tendsto_eq_intros refl \| simp)+
	qed
	finally show ?thesis by simp
	qed

	end

	end
	diff --git a/thys/Sunflowers/Erdos_Rado_Sunflower.thy b/thys/Sunflowers/Erdos_Rado_Sunflower.thy
	--- a/thys/Sunflowers/Erdos_Rado_Sunflower.thy
	+++ b/thys/Sunflowers/Erdos_Rado_Sunflower.thy
	@@ -1,358 +1,358 @@
	(* author: R. Thiemann *)

	section \<open>The Sunflower Lemma\<close>

	text \<open>We formalize the proof of the sunflower lemma of Erd\H{o}s and Rado~\cite{erdos_rado},
	as it is presented in the textbook~\cite[Chapter~6]{book}.
	We further integrate Exercise 6.2 from the textbook,
	which provides a lower bound on the existence of sunflowers.\<close>

	theory Erdos_Rado_Sunflower
	imports
	Sunflower
	begin

	text \<open>When removing an element from all subsets, then one can afterwards
	add these elements to a sunflower and get a new sunflower.\<close>

	lemma sunflower_remove_element_lift:
	assumes S: "S \<subseteq> { A - {a} \| A . A \<in> F \<and> a \<in> A}"
	and sf: "sunflower S"
	shows "\<exists> Sa. sunflower Sa \<and> Sa \<subseteq> F \<and> card Sa = card S \<and> Sa = insert a ` S"
	proof (intro exI[of _ "insert a ` S"] conjI refl)
	let ?Sa = "insert a ` S"
	{
	fix B
	assume "B \<in> ?Sa"
	then obtain C where C: "C \<in> S" and B: "B = insert a C"
	by auto
	from C S obtain T where "T \<in> F" "a \<in> T" "C = T - {a}"
	by auto
	with B have "B = T" by auto
	with \<open>T \<in> F\<close> have "B \<in> F" by auto
	}
	thus SaF: "?Sa \<subseteq> F" by auto
	have inj: "inj_on (insert a) S" using S
	by (intro inj_on_inverseI[of _ "\<lambda> B. B - {a}"], auto)
	thus "card ?Sa = card S" by (rule card_image)
	show "sunflower ?Sa" unfolding sunflower_def
	proof (intro allI, intro impI)
	fix x
	assume "\<exists>C D. C \<in> ?Sa \<and> D \<in> ?Sa \<and> C \<noteq> D \<and> x \<in> C \<and> x \<in> D"
	then obtain C D where *: "C \<in> ?Sa" "D \<in> ?Sa" "C \<noteq> D" "x \<in> C" "x \<in> D"
	by auto
	from *(1-2) obtain C' D' where
	**: "C' \<in> S" "D' \<in> S" "C = insert a C'" "D = insert a D'"
	by auto
	with \<open>C \<noteq> D\<close> inj have CD': "C' \<noteq> D'" by auto
	show "\<forall>E. E \<in> ?Sa \<longrightarrow> x \<in> E"
	proof (cases "x = a")
	case False
	with * ** have "x \<in> C'" "x \<in> D'" by auto
	with ** CD' have "\<exists>C D. C \<in> S \<and> D \<in> S \<and> C \<noteq> D \<and> x \<in> C \<and> x \<in> D" by auto
	from sf[unfolded sunflower_def, rule_format, OF this]
	show ?thesis by auto
	qed auto
	qed
	qed

	text \<open>The sunflower-lemma of Erd\H{o}s and Rado:
	if a set has a certain size and all elements
	have the same cardinality, then a sunflower exists.\<close>

	lemma Erdos_Rado_sunflower_same_card:
	assumes "\<forall> A \<in> F. finite A \<and> card A = k"
	and "card F > (r - 1)^k * fact k"
	shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> {} \<notin> S"
	using assms
	proof (induct k arbitrary: F)
	case 0
	hence "F = {{}} \<or> F = {}" "card F \<ge> 2" by auto
	hence False by auto
	thus ?case by simp
	next
	case (Suc k F)
	define pd_sub :: "'a set set \<Rightarrow> nat \<Rightarrow> bool" where
	"pd_sub = (\<lambda> G t. G \<subseteq> F \<and> card G = t \<and> pairwise disjnt G \<and> {} \<notin> G)"
	show ?case
	proof (cases "\<exists> t G. pd_sub G t \<and> t \<ge> r")
	case True
	then obtain t G where pd_sub: "pd_sub G t" and t: "t \<ge> r" by auto
	from pd_sub[unfolded pd_sub_def] pairwise_disjnt_imp_sunflower
	have *: "G \<subseteq> F" "card G = t" "sunflower G" "{} \<notin> G" by auto
	from t \<open>card G = t\<close> obtain H where "H \<subseteq> G" "card H = r"
	by (metis obtain_subset_with_card_n)
	with sunflower_subset[OF \<open>H \<subseteq> G\<close>] * show ?thesis by blast
	next
	case False
	define P where "P = (\<lambda> t. \<exists> G. pd_sub G t)"
	have ex: "\<exists> t. P t" unfolding P_def
	by (intro exI[of _ 0] exI[of _ "{}"], auto simp: pd_sub_def)
	have large': "\<And> t. P t \<Longrightarrow> t < r" using False unfolding P_def by auto
	hence large: "\<And> t. P t \<Longrightarrow> t \<le> r" by fastforce
	define t where "t = (GREATEST t. P t)"
	from GreatestI_ex_nat[OF ex large, folded t_def] have Pt: "P t" .
	from Greatest_le_nat[of P, OF _ large]
	have greatest: "\<And> s. P s \<Longrightarrow> s \<le> t" unfolding t_def by auto
	from large'[OF Pt] have tr: "t \<le> r - 1" by simp
	from Pt[unfolded P_def pd_sub_def] obtain G where
	cardG: "card G = t" and
	disj: "pairwise disjnt G" and
	GF: "G \<subseteq> F"
	by blast
	define A where "A = (\<Union> G)"
	from Suc(3) have "card F > 0" by simp
	hence "finite F" by (rule card_ge_0_finite)
	from GF \<open>finite F\<close> have finG: "finite G" by (rule finite_subset)
	- have "card (\<Union> G) \<le> sum card G"
	- by (rule card_Union_le_sum_card, insert Suc(2) GF, auto)
	- also have "\<dots> \<le> of_nat (card G) * Suc k"
	- by (rule sum_bounded_above, insert GF Suc(2), auto)
	+ have "card (\<Union> G) \<le> sum card G"
	+ using card_Union_le_sum_card by blast
	+ also have "\<dots> \<le> of_nat (card G) * Suc k"
	+ by (metis GF Suc.prems(1) le_Suc_eq subsetD sum_bounded_above)
	also have "\<dots> \<le> (r - 1) * Suc k"
	using tr[folded cardG] by (metis id_apply mult_le_mono1 of_nat_eq_id)
	finally have cardA: "card A \<le> (r - 1) * Suc k" unfolding A_def .
	{
	fix B
	assume *: "B \<in> F"
	with Suc(2) have nE: "B \<noteq> {}" by auto
	from Suc(2) have eF: "{} \<notin> F" by auto
	have "B \<inter> A \<noteq> {}"
	proof
	assume dis: "B \<inter> A = {}"
	hence disj: "pairwise disjnt ({B} \<union> G)" using disj unfolding A_def
	by (smt (verit, ccfv_SIG) Int_commute Un_iff
	Union_disjoint disjnt_def pairwise_def singleton_iff)
	from nE dis have "B \<notin> G" unfolding A_def by auto
	with finG have c: "card ({B} \<union> G) = Suc t" by (simp add: cardG)
	have "P (Suc t)" unfolding P_def pd_sub_def
	by (intro exI[of _ "{B} \<union> G"], insert eF disj c * GF, auto)
	with greatest show False by force
	qed
	} note overlap = this
	have "F \<noteq> {}" using Suc(2-) by auto
	with overlap have Ane: "A \<noteq> {}" unfolding A_def by auto
	have "finite A" unfolding A_def using finG Suc(2-) GF by auto
	let ?g = "\<lambda> B x. x \<in> B \<inter> A"
	define f where "f = (\<lambda> B. SOME x. ?g B x)"
	have "f \<in> F \<rightarrow> A"
	proof
	fix B
	assume "B \<in> F"
	from overlap[OF this] have "\<exists> x. ?g B x" unfolding A_def by auto
	from someI_ex[OF this] show "f B \<in> A" unfolding f_def by auto
	qed
	from pigeonhole_card[OF this \<open>finite F\<close> \<open>finite A\<close> Ane]
	obtain a where a: "a \<in> A"
	and le: "card F \<le> card (f -` {a} \<inter> F) * card A" by auto
	{
	fix S
	assume "S \<in> F" "f S \<in> {a}"
	with someI_ex[of "?g S"] a overlap[OF this(1)]
	have "a \<in> S" unfolding f_def by auto
	} note FaS = this
	let ?F = "{S - {a} \| S . S \<in> F \<and> f S \<in> {a}}"
	from cardA have "((r - 1) ^ k * fact k) * card A \<le> ((r - 1) ^ k * fact k) * ((r - 1) * Suc k)"
	by simp
	also have "\<dots> = (r - 1) ^ (Suc k) * fact (Suc k)"
	by (metis (no_types, lifting) fact_Suc mult.assoc mult.commute of_nat_id power_Suc2)
	also have "\<dots> < card (f -` {a} \<inter> F) * card A"
	using Suc(3) le by auto
	also have "f -` {a} \<inter> F = {S \<in> F. f S \<in> {a}}" by auto
	also have "card \<dots> = card ((\<lambda> S. S - {a}) ` {S \<in> F. f S \<in> {a}})"
	by (subst card_image; intro inj_onI refl, insert FaS) auto
	also have "(\<lambda> S. S - {a}) ` {S \<in> F. f S \<in> {a}} = ?F" by auto
	finally have lt: "(r - 1) ^ k * fact k < card ?F" by simp
	have "\<forall> A \<in> ?F. finite A \<and> card A = k" using Suc(2) FaS by auto
	from Suc(1)[OF this lt] obtain S
	where "sunflower S" "card S = r" "S \<subseteq> ?F" by auto
	from \<open>S \<subseteq> ?F\<close> FaS have "S \<subseteq> {A - {a} \|A. A \<in> F \<and> a \<in> A}" by auto
	from sunflower_remove_element_lift[OF this \<open>sunflower S\<close>] \<open>card S = r\<close>
	show ?thesis by auto
	qed
	qed

	text \<open>Using @{thm [source] sunflower_card_subset_lift} we can easily
	replace the condition that the cardinality is exactly @{term k}
	by the requirement that the cardinality is at most @{term k}.
	However, then @{term "{} \<notin> S"} cannot be ensured.
	Consider @{term "(r :: nat) = 1 \<and> (k :: nat) > 0 \<and> F = {{}}"}.\<close>

	lemma Erdos_Rado_sunflower:
	assumes "\<forall> A \<in> F. finite A \<and> card A \<le> k"
	and "card F > (r - 1)^k * fact k"
	shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r"
	by (rule sunflower_card_subset_lift[OF _ assms],
	metis Erdos_Rado_sunflower_same_card)

	text \<open>We further provide a lower bound on the existence of sunflowers,
	i.e., Exercise 6.2 of the textbook~\cite{book}.
	To be more precise, we prove that there is a set of sets of cardinality
	@{term \<open>(r - 1 :: nat)^k\<close>}, where each element is a set of cardinality
	@{term k}, such that there is no subset which is a sunflower with cardinality
	of at least @{term r}.\<close>

	lemma sunflower_lower_bound:
	assumes inf: "infinite (UNIV :: 'a set)"
	and r: "r \<noteq> 0"
	and rk: "r = 1 \<Longrightarrow> k \<noteq> 0"
	shows "\<exists> F.
	card F = (r - 1)^k \<and> finite F \<and>
	(\<forall> A \<in> F. finite (A :: 'a set) \<and> card A = k) \<and>
	(\<nexists> S. S \<subseteq> F \<and> sunflower S \<and> card S \<ge> r)"
	proof (cases "r = 1")
	case False
	with r have r: "r > 1" by auto
	show ?thesis
	proof (induct k)
	case 0
	have id: "S \<subseteq> {{}} \<longleftrightarrow> (S = {} \<or> S = {{}})" for S :: "'a set set" by auto
	show ?case using r
	by (intro exI[of _ "{{}}"], auto simp: id)
	next
	case (Suc k)
	then obtain F where
	cardF: "card F = (r - 1) ^ k" and
	fin: "finite F" and
	AF: "\<And> A. (A :: 'a set) \<in> F \<Longrightarrow> finite A \<and> card A = k" and
	sf: "\<not> (\<exists>S\<subseteq>F. sunflower S \<and> r \<le> card S)"
	by metis
	text \<open>main idea: get @{term "k-1 :: nat"} fresh elements
	and add one of these to all elements of F\<close>
	have "finite (\<Union> F)" using fin AF by simp
	hence "infinite (UNIV - \<Union> F)" using inf by simp
	from infinite_arbitrarily_large[OF this, of "r - 1"]
	obtain New where New: "finite New" "card New = r - 1"
	"New \<inter> \<Union> F = {}" by auto
	define G where "G = (\<lambda> (A, a). insert a A) ` (F \<times> New)"
	show ?case
	proof (intro exI[of _ G] conjI)
	show "finite G" using New fin unfolding G_def by simp
	have "card G = card (F \<times> New)" unfolding G_def
	proof ((subst card_image; (intro refl)?), intro inj_onI, clarsimp, goal_cases)
	case (1 A a B b)
	hence ab: "a = b" using New by auto
	from 1(1) have "insert a A - {a} = insert b B - {a}" by simp
	also have "insert a A - {a} = A" using New 1 by auto
	also have "insert b B - {a} = B" using New 1 ab[symmetric] by auto
	finally show ?case using ab by auto
	qed
	also have "\<dots> = card F * card New" using New fin by auto
	finally show "card G = (r - 1) ^ Suc k"
	unfolding cardF New by simp
	{
	fix B
	assume "B \<in> G"
	then obtain a A where G: "a \<in> New" "A \<in> F" "B = insert a A"
	unfolding G_def by auto
	with AF[of A] New have "finite B" "card B = Suc k"
	by (auto simp: card_insert_if)
	}
	thus "\<forall>A\<in>G. finite A \<and> card A = Suc k" by auto
	show "\<not> (\<exists>S\<subseteq>G. sunflower S \<and> r \<le> card S)"
	proof (intro notI, elim exE conjE)
	fix S
	assume *: "S \<subseteq> G" "sunflower S" "r \<le> card S"
	define g where "g B = (SOME a. a \<in> New \<and> a \<in> B)" for B
	{
	fix B
	assume "B \<in> S"
	with \<open>S \<subseteq> G\<close> have "B \<in> G" by auto
	hence "\<exists> a. a \<in> New \<and> a \<in> B" unfolding G_def by auto
	from someI_ex[OF this, folded g_def]
	have "g B \<in> New" "g B \<in> B" by auto
	} note gB = this
	have "card (g ` S) \<le> card New"
	by (rule card_mono, insert New gB, auto)
	also have "\<dots> < r" unfolding New using r by simp
	also have "\<dots> \<le> card S" by fact
	finally have "card (g ` S) < card S" .
	from pigeonhole[OF this] have "\<not> inj_on g S" .
	then obtain B1 B2 where B12: "B1 \<in> S" "B2 \<in> S" "B1 \<noteq> B2" "g B1 = g B2"
	unfolding inj_on_def by auto
	define a where "a = g B2"
	from B12 gB[of B1] gB[of B2] have a: "a \<in> New" "a \<in> B1" "a \<in> B2"
	unfolding a_def by auto
	with B12 have "\<exists>B1 B2. B1 \<in> S \<and> B2 \<in> S \<and> B1 \<noteq> B2 \<and> a \<in> B1 \<and> a \<in> B2"
	unfolding a_def by blast
	from \<open>sunflower S\<close>[unfolded sunflower_def, rule_format, OF this]
	have aS: "B \<in> S \<Longrightarrow> a \<in> B" for B by auto
	define h where "h B = B - {a}" for B
	define T where "T = h ` S"
	have "\<exists>S\<subseteq>F. sunflower S \<and> r \<le> card S"
	proof (intro exI[of _ T] conjI)
	{
	fix B
	assume "B \<in> S"
	have hB: "h B = B - {a}"
	unfolding h_def T_def by auto
	from aS \<open>B \<in> S\<close> have aB: "a \<in> B" by auto
	from \<open>B \<in> S\<close> \<open>S \<subseteq> G\<close> obtain a' A where AF: "A \<in> F"
	and B: "B = insert a' A"
	and a': "a' \<in> New" unfolding G_def by force
	from aB B a' New AF a(1) hB AF have "insert a (h B) = B" "h B = A" by auto
	hence "insert a (h B) = B" "h B \<in> F" "insert a (h B) \<in> S" using AF \<open>B \<in> S\<close> by auto
	} note main = this
	have CTS: "C \<in> T \<Longrightarrow> insert a C \<in> S" for C using main unfolding T_def by force
	show "T \<subseteq> F" unfolding T_def using main by auto
	have "r \<le> card S" by fact
	also have "\<dots> = card T" unfolding T_def
	by (subst card_image, intro inj_on_inverseI[of _ "insert a"], insert main, auto)
	finally show "r \<le> card T" .
	show "sunflower T" unfolding sunflower_def
	proof (intro allI impI, elim exE conjE, goal_cases)
	case (1 x C C1 C2)
	from CTS[OF \<open>C1 \<in> T\<close>] CTS[OF \<open>C2 \<in> T\<close>] CTS[OF \<open>C \<in> T\<close>]
	have *: "insert a C1 \<in> S" "insert a C2 \<in> S" "insert a C \<in> S" by auto
	from 1 have "insert a C1 \<noteq> insert a C2" using main
	unfolding T_def by auto
	hence "\<exists>A B. A \<in> S \<and> B \<in> S \<and> A \<noteq> B \<and> x \<in> A \<and> x \<in> B"
	using * 1 by auto
	from \<open>sunflower S\<close>[unfolded sunflower_def, rule_format, OF this *(3)]
	have "x \<in> insert a C" .
	with 1 show "x \<in> C" unfolding T_def h_def by auto
	qed
	qed
	with sf
	show False ..
	qed
	qed
	qed
	next
	case r: True
	with rk have "k \<noteq> 0" by auto
	then obtain l where k: "k = Suc l" by (cases k, auto)
	show ?thesis unfolding r k
	by (intro exI[of _ "{}"], auto)
	qed

	text \<open>The difference between the lower and the
	upper bound on the existence of sunflowers as they have been formalized
	is @{term \<open>fact k\<close>}. There is more recent work with tighter bounds
	\cite{sunflower_new}, but we only integrate the initial
	result of Erd\H{o}s and Rado in this theory.\<close>

	text \<open>We further provide the Erd\H{o}s Rado lemma
	lifted to obtain non-empty cores or cores of arbitrary cardinality.\<close>

	lemma Erdos_Rado_sunflower_card_core:
	assumes "finite E"
	and "\<forall> A \<in> F. A \<subseteq> E \<and> s \<le> card A \<and> card A \<le> k"
	and "card F > (card E choose s) * (r - 1)^k * fact k"
	and "s \<noteq> 0"
	and "r \<noteq> 0"
	shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> card (\<Inter> S) \<ge> s"
	by (rule sunflower_card_core_lift[OF assms(1) _ assms(2) _ assms(4-5),
	of "(r - 1)^k * fact k"],
	rule Erdos_Rado_sunflower, insert assms(3), auto simp: ac_simps)

	lemma Erdos_Rado_sunflower_nonempty_core:
	assumes "finite E"
	and "\<forall> A \<in> F. A \<subseteq> E \<and> card A \<le> k"
	and "{} \<notin> F"
	and "card F > card E * (r - 1)^k * fact k"
	shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> \<Inter> S \<noteq> {}"
	by (rule sunflower_nonempty_core_lift[OF assms(1)
	_ assms(2-3), of "(r - 1)^k * fact k"],
	rule Erdos_Rado_sunflower, insert assms(4), auto simp: ac_simps)

	end
	diff --git a/thys/Szemeredi_Regularity/Szemeredi.thy b/thys/Szemeredi_Regularity/Szemeredi.thy
	--- a/thys/Szemeredi_Regularity/Szemeredi.thy
	+++ b/thys/Szemeredi_Regularity/Szemeredi.thy
	@@ -1,1071 +1,1018 @@
	section \<open>Szemerédi's Regularity Lemma\<close>

	theory Szemeredi
	imports Complex_Main "HOL-Library.Disjoint_Sets" "Girth_Chromatic.Ugraphs"

	begin

	text\<open>We formalise Szemerédi's Regularity Lemma, which is a major result in the study of large graphs
	(extremal graph theory).
	We follow Yufei Zhao's notes ``Graph Theory and Additive Combinatorics'' (MIT)
	\<^url>\<open>https://ocw.mit.edu/courses/mathematics/18-217-graph-theory-and-additive-combinatorics-fall-2019/lecture-notes/MIT18_217F19_ch3.pdf\<close>
	and W.T. Gowers's notes ``Topics in Combinatorics'' (University of Cambridge, Lent 2004, Chapter 3)
	\<^url>\<open>https://www.dpmms.cam.ac.uk/~par31/notes/tic.pdf\<close>.
	We also refer to a third source, also by Zhao and also entitled
	``Graph Theory and Additive Combinatorics'': \<^url>\<open>https://yufeizhao.com/gtac/gtac17.pdf\<close>.\<close>


	subsection \<open>Miscellaneous\<close>

	text \<open>A technical lemma used below in @{text \<open>energy_graph_partition_half\<close>}\<close>
	lemma sum_products_le:
	fixes a :: "'a \<Rightarrow> 'b::linordered_idom"
	assumes "\<And>i. i \<in> I \<Longrightarrow> a i \<ge> 0"
	shows "(\<Sum>i\<in>I. a i * b i)\<^sup>2 \<le> (\<Sum>i\<in>I. a i) * (\<Sum>i\<in>I. a i * (b i)\<^sup>2)"
	using assms
	proof (induction I rule: infinite_finite_induct)
	case (insert j I)
	then have "(\<Sum>i\<in>insert j I. a i * b i)\<^sup>2
	\<le> (a j * b j)\<^sup>2 + 2 * a j * b j * (\<Sum>i\<in>I. a i * b i) + (\<Sum>i\<in>I. a i) * (\<Sum>i\<in>I. a i * (b i)\<^sup>2)"
	using insert by (simp add: algebra_simps power2_eq_square)
	also have "\<dots> \<le> a j * (a j * (b j)\<^sup>2) + (a j * (sum a I * (b j)\<^sup>2 + (\<Sum>i\<in>I. a i * (b i)\<^sup>2))
	+ sum a I * (\<Sum>i\<in>I. a i * (b i)\<^sup>2))"
	proof -
	have "0 \<le> (\<Sum>i\<in>I. a i * (b i - b j)\<^sup>2)"
	by (simp add: insert.prems sum_nonneg)
	then have "2 * b j * (\<Sum>i\<in>I. a i * b i) \<le> (sum a I * (b j)\<^sup>2) + (\<Sum>i\<in>I. a i * (b i)\<^sup>2)"
	by (simp add: power2_eq_square algebra_simps sum_subtractf sum.distrib sum_distrib_left)
	then show ?thesis
	by (simp add: insert.prems power2_eq_square mult.commute mult.left_commute mult_left_mono)
	qed
	finally show ?case
	by (simp add: insert algebra_simps)
	qed auto

	subsubsection \<open>Partitions indexed by integers\<close>

	definition finite_graph_partition :: "[uvert set, uvert set set, nat] \<Rightarrow> bool"
	where "finite_graph_partition V P n \<equiv> partition_on V P \<and> finite P \<and> card P = n"

	lemma finite_graph_partition_0 [iff]:
	"finite_graph_partition V P 0 \<longleftrightarrow> V = {} \<and> P = {}"
	by (auto simp: finite_graph_partition_def partition_on_def)

	lemma finite_graph_partition_empty [iff]:
	"finite_graph_partition {} P n \<longleftrightarrow> P = {} \<and> n = 0"
	by (auto simp: finite_graph_partition_def partition_on_def)

	lemma finite_graph_partition_equals:
	"finite_graph_partition V P n \<Longrightarrow> (\<Union>P) = V"
	by (meson finite_graph_partition_def partition_on_def)

	lemma finite_graph_partition_subset:
	"\<lbrakk>finite_graph_partition V P n; X \<in> P\<rbrakk> \<Longrightarrow> X \<subseteq> V"
	using finite_graph_partition_equals by blast

	lemma trivial_graph_partition_exists:
	assumes "V \<noteq> {}"
	shows "finite_graph_partition V {V} (Suc 0)"
	by (simp add: assms finite_graph_partition_def partition_on_space)

	lemma finite_graph_partition_finite:
	assumes "finite_graph_partition V P k" "finite V" "X \<in> P"
	shows "finite X"
	by (meson assms finite_graph_partition_subset infinite_super)

	-lemma finite_graph_partition_le:
	- assumes "finite_graph_partition V P k" "finite V" "X \<in> P"
	- shows "card X \<le> card V"
	- by (meson assms card_mono finite_graph_partition_subset)
	-
	lemma finite_graph_partition_gt0:
	assumes "finite_graph_partition V P k" "finite V" "X \<in> P"
	shows "card X > 0"
	by (metis assms card_0_eq finite_graph_partition_def finite_graph_partition_finite gr_zeroI partition_on_def)

	lemma card_finite_graph_partition:
	assumes "finite_graph_partition V P k" "finite V"
	shows "(\<Sum>X\<in>P. card X) = card V"
	by (metis assms finite_graph_partition_def finite_graph_partition_finite product_partition)

	-lemma finite_graph_partition_obtain:
	- assumes "finite_graph_partition V P k" "x \<in> V"
	- obtains X where "X \<in> P" and "x \<in> X"
	- using assms finite_graph_partition_equals by force
	-
	subsubsection \<open>Tools to combine the refinements of the partition @{term "P i"} for each @{term i}\<close>

	text \<open>These are needed to retain the ``intuitive'' idea of partitions as indexed by integers.\<close>

	subsection \<open>Edges\<close>

	text \<open>All edges between two sets of vertices, @{term X} and @{term Y}, in a graph, @{term G}\<close>

	definition all_edges_between :: "nat set \<Rightarrow> nat set \<Rightarrow> nat set \<times> nat set set \<Rightarrow> (nat \<times> nat) set"
	where "all_edges_between X Y G \<equiv> {(x,y). x\<in>X \<and> y\<in>Y \<and> {x,y} \<in> uedges G}"

	lemma all_edges_between_subset: "all_edges_between X Y G \<subseteq> X\<times>Y"
	by (auto simp: all_edges_between_def)

	lemma max_all_edges_between:
	assumes "finite X" "finite Y"
	shows "card (all_edges_between X Y G) \<le> card X * card Y"
	by (metis assms card_mono finite_SigmaI all_edges_between_subset card_cartesian_product)

	lemma all_edges_between_empty [simp]:
	"all_edges_between {} Z G = {}" "all_edges_between Z {} G = {}"
	by (auto simp: all_edges_between_def)

	lemma all_edges_between_disjnt1:
	assumes "disjnt X Y"
	shows "disjnt (all_edges_between X Z G) (all_edges_between Y Z G)"
	using assms by (auto simp: all_edges_between_def disjnt_iff)

	lemma all_edges_between_disjnt2:
	assumes "disjnt Y Z"
	shows "disjnt (all_edges_between X Y G) (all_edges_between X Z G)"
	using assms by (auto simp: all_edges_between_def disjnt_iff)

	lemma all_edges_between_Un1:
	"all_edges_between (X \<union> Y) Z G = all_edges_between X Z G \<union> all_edges_between Y Z G"
	by (auto simp: all_edges_between_def)

	lemma all_edges_between_Un2:
	"all_edges_between X (Y \<union> Z) G = all_edges_between X Y G \<union> all_edges_between X Z G"
	by (auto simp: all_edges_between_def)

	lemma finite_all_edges_between:
	assumes "finite X" "finite Y"
	shows "finite (all_edges_between X Y G)"
	by (meson all_edges_between_subset assms finite_cartesian_product finite_subset)

	subsection \<open>Edge Density and Regular Pairs\<close>

	text \<open>The edge density between two sets of vertices, @{term X} and @{term Y}, in @{term G}.
	Authors disagree on whether the sets are assumed to be disjoint!.
	Quite a few authors assume disjointness, e.g. Malliaris and Shelah \<^url>\<open>https://www.jstor.org/stable/23813167\<close>
	For the following definitions, see pages 49--50 in Zhao's notes.\<close>
	definition "edge_density X Y G \<equiv> card(all_edges_between X Y G) / (card X * card Y)"

	lemma edge_density_ge0: "edge_density X Y G \<ge> 0"
	by (auto simp: edge_density_def)

	lemma edge_density_le1: "edge_density K Y G \<le> 1"
	proof (cases "finite K \<and> finite Y")
	case True
	then show ?thesis
	using of_nat_mono [OF max_all_edges_between, of K Y]
	by (fastforce simp add: edge_density_def divide_simps)
	qed (auto simp: edge_density_def)

	lemma all_edges_between_swap:
	"all_edges_between X Y G = (\<lambda>(x,y). (y,x)) ` (all_edges_between Y X G)"
	unfolding all_edges_between_def
	by (auto simp add: insert_commute image_iff split: prod.split)

	lemma card_all_edges_between_commute:
	"card (all_edges_between X Y G) = card (all_edges_between Y X G)"
	proof -
	have "inj_on (\<lambda>(x, y). (y, x)) A" for A :: "(nat*nat)set"
	by (auto simp: inj_on_def)
	then show ?thesis
	by (simp add: all_edges_between_swap [of X Y] card_image)
	qed

	lemma edge_density_commute: "edge_density X Y G = edge_density Y X G"
	by (simp add: edge_density_def card_all_edges_between_commute mult.commute)


	text \<open>$\epsilon$-regular pairs, for two sets of vertices. Again, authors disagree on whether the
	sets need to be disjoint, though it seems that overlapping sets cause double-counting. Authors also
	disagree about whether or not to use the strict subset relation here. The proofs below are easier if
	it is strict but later proofs require the non-strict version. The two definitions can be proved to
	be equivalent under fairly mild conditions, but even those conditions turn out to be onerous.\<close>

	definition regular_pair:: "uvert set \<Rightarrow> uvert set \<Rightarrow> ugraph \<Rightarrow> real \<Rightarrow> bool"
	where "regular_pair X Y G \<epsilon> \<equiv>
	\<forall>A B. A \<subseteq> X \<and> B \<subseteq> Y \<and> (card A \<ge> \<epsilon> * card X) \<and> (card B \<ge> \<epsilon> * card Y) \<longrightarrow>
	\<bar>edge_density A B G - edge_density X Y G\<bar> \<le> \<epsilon>" for \<epsilon>::real

	lemma regular_pair_commute: "regular_pair X Y G \<epsilon> \<longleftrightarrow> regular_pair Y X G \<epsilon>"
	by (metis edge_density_commute regular_pair_def)

	-abbreviation "irregular_pair X Y G \<epsilon> \<equiv> \<not> regular_pair X Y G \<epsilon>"
	-
	-lemma irregular_pair_E:
	- fixes \<epsilon>::real
	- assumes "irregular_pair X Y G \<epsilon>"
	- obtains A B where "A \<subseteq> X \<and> B \<subseteq> Y \<and> (card A \<ge> \<epsilon> * card X) \<and> (card B \<ge> \<epsilon> * card Y)"
	- "\<bar>edge_density A B G - edge_density X Y G\<bar> > \<epsilon>"
	- using assms by (auto simp: not_le regular_pair_def)
	-
	-lemma irregular_pair_I:
	- fixes \<epsilon>::real
	- assumes "A \<subseteq> X" "B \<subseteq> Y" "(card A \<ge> \<epsilon> * card X)" "(card B \<ge> \<epsilon> * card Y)"
	- "\<bar>edge_density A B G - edge_density X Y G\<bar> > \<epsilon>"
	- shows "irregular_pair X Y G \<epsilon>"
	- using assms by (auto simp: not_le regular_pair_def)
	-
	lemma edge_density_Un:
	- assumes "disjnt X1 X2" "finite X1" "finite X2" "finite Y"
	+ assumes "disjnt X1 X2" "finite X1" "finite X2"
	shows "edge_density (X1 \<union> X2) Y G = (edge_density X1 Y G * card X1 + edge_density X2 Y G * card X2) / (card X1 + card X2)"
	- using assms unfolding edge_density_def
	- by (simp add: all_edges_between_disjnt1 all_edges_between_Un1 finite_all_edges_between card_Un_disjnt divide_simps)
	+proof (cases "finite Y")
	+ case True
	+ with assms show ?thesis
	+ by (simp add: edge_density_def all_edges_between_disjnt1 all_edges_between_Un1 finite_all_edges_between card_Un_disjnt card_ge_0_finite divide_simps)
	+qed (simp add: edge_density_def)

	lemma edge_density_partition:
	- assumes U: "finite U" "finite_graph_partition U P n" and "finite W"
	+ assumes "finite_graph_partition U P n"
	shows "edge_density U W G = (\<Sum>X\<in>P. edge_density X W G * card X) / card U"
	-proof -
	+proof (cases "finite U")
	+ case True
	have "finite P"
	using assms finite_graph_partition_def by blast
	then show ?thesis
	- using U
	+ using True assms
	proof (induction P arbitrary: n U)
	case empty
	then show ?case
	by (simp add: edge_density_def finite_graph_partition_def partition_on_def)
	next
	case (insert X P)
	then have "n > 0"
	by (metis finite_graph_partition_0 gr_zeroI insert_not_empty)
	with insert.prems insert.hyps
	have UX: "finite_graph_partition (U-X) P (n-1)"
	by (auto simp: finite_graph_partition_def partition_on_def disjnt_iff pairwise_insert)
	then have finU: "finite (\<Union>P)"
	- using finite_graph_partition_equals insert by auto
	+ by (simp add: finite_graph_partition_equals insert)
	then have sumXP: "card U = card X + card (\<Union>P)"
	by (metis UX card_finite_graph_partition finite_graph_partition_equals insert.hyps insert.prems sum.insert)
	have FUX: "finite (U - X)"
	by (simp add: insert.prems)
	have XUP: "X \<union> (\<Union>P) = U"
	using finite_graph_partition_equals insert.prems(2) by auto
	then have "edge_density U W G = edge_density (X \<union> \<Union>P) W G"
	by auto
	also have "\<dots> = (edge_density X W G * card X + edge_density (\<Union>P) W G * card (\<Union>P))
	/ (card X + card (\<Union>P))"
	proof (rule edge_density_Un)
	show "disjnt X (\<Union>P)"
	using UX disjnt_iff finite_graph_partition_equals by auto
	show "finite X"
	using XUP \<open>finite U\<close> by blast
	- qed (use \<open>finite W\<close> finU in auto)
	+ qed (use finU in auto)
	also have "\<dots> = (edge_density X W G * card X + edge_density (U-X) W G * card (\<Union>P))
	/ card U"
	using UX card_finite_graph_partition finite_graph_partition_equals insert.prems(1) insert.prems(2) sumXP by auto
	also have "\<dots> = (\<Sum>Y \<in> insert X P. edge_density Y W G * card Y) / card U"
	using UX insert.prems insert.hyps
	apply (simp add: insert.IH [OF FUX UX] divide_simps algebra_simps finite_graph_partition_equals)
	by (metis (no_types, lifting) Diff_eq_empty_iff finite_graph_partition_empty sum.empty)
	finally show ?case .
	qed
	-qed
	-
	+qed (simp add: edge_density_def)

	text\<open>Let @{term P}, @{term Q} be partitions of a set of vertices @{term V}.
	Then @{term P} refines @{term Q} if for all @{term \<open>A \<in> P\<close>} there is @{term \<open>B \<in> Q\<close>}
	such that @{term \<open>A \<subseteq> B\<close>}.\<close>

	text \<open>For the sake of generality, and following Zhao's Online Lecture
	\<^url>\<open>https://www.youtube.com/watch?v=vcsxCFSLyP8&t=16s\<close>
	we do not impose disjointness: we do not include @{term "i\<noteq>j"} below.\<close>

	definition irregular_set:: "[real, ugraph, uvert set set] \<Rightarrow> (uvert set \<times> uvert set) set"
	- where "irregular_set \<equiv> \<lambda>\<epsilon>::real. \<lambda>G P. {(R,S)\|R S. R\<in>P \<and> S\<in>P \<and> irregular_pair R S G \<epsilon>}"
	+ where "irregular_set \<equiv> \<lambda>\<epsilon>::real. \<lambda>G P. {(R,S)\|R S. R\<in>P \<and> S\<in>P \<and> \<not> regular_pair R S G \<epsilon>}"

	text\<open>A regular partition may contain a few irregular pairs as long as their total size is bounded as follows.\<close>
	definition regular_partition:: "[real, ugraph, uvert set set] \<Rightarrow> bool"
	where
	"regular_partition \<equiv> \<lambda>\<epsilon>::real. \<lambda>G P .
	partition_on (uverts G) P \<and>
	(\<Sum>(R,S) \<in> irregular_set \<epsilon> G P. card R * card S) \<le> \<epsilon> * (card (uverts G))\<^sup>2"

	lemma irregular_set_subset: "irregular_set \<epsilon> G P \<subseteq> P \<times> P"
	by (auto simp: irregular_set_def)

	lemma irregular_set_swap: "(i,j) \<in> irregular_set \<epsilon> G P \<longleftrightarrow> (j,i) \<in> irregular_set \<epsilon> G P"
	by (auto simp add: irregular_set_def regular_pair_commute)

	lemma finite_irregular_set [simp]: "finite P \<Longrightarrow> finite (irregular_set \<epsilon> G P)"
	by (metis finite_SigmaI finite_subset irregular_set_subset)

	subsection \<open>Energy of a Graph\<close>

	-text \<open>Definition 3.7 (Energy), written @{term "q(\<U>,\<W>)"}\<close>
	+text \<open>Definition 3.7 (Energy), written @{term "q(U,W)"}\<close>
	definition energy_graph_subsets:: "[uvert set, uvert set, ugraph] \<Rightarrow> real" where
	- "energy_graph_subsets \<U> \<W> G \<equiv>
	- card \<U> * card \<W> * (edge_density \<U> \<W> G)\<^sup>2 / (card (uverts G))\<^sup>2"
	+ "energy_graph_subsets U W G \<equiv>
	+ card U * card W * (edge_density U W G)\<^sup>2 / (card (uverts G))\<^sup>2"

	text \<open>Definition for partitions\<close>
	-definition energy_graph_partitions_subsets
	- :: "[ugraph, uvert set set, uvert set set] \<Rightarrow> real"
	- where "energy_graph_partitions_subsets G U W \<equiv>
	- \<Sum>R\<in>U.\<Sum>S\<in>W. energy_graph_subsets R S G"
	+definition energy_graph_partitions :: "[ugraph, uvert set set, uvert set set] \<Rightarrow> real"
	+ where "energy_graph_partitions G U W \<equiv> \<Sum>R\<in>U.\<Sum>S\<in>W. energy_graph_subsets R S G"

	lemma energy_graph_subsets_0 [simp]:
	"energy_graph_subsets {} B G = 0" "energy_graph_subsets A {} G = 0"
	by (auto simp: energy_graph_subsets_def)

	lemma energy_graph_subsets_ge0 [simp]:
	- "energy_graph_subsets \<U> \<W> G \<ge> 0"
	+ "energy_graph_subsets U W G \<ge> 0"
	by (auto simp: energy_graph_subsets_def)

	-lemma energy_graph_partitions_subsets_ge0 [simp]:
	- "energy_graph_partitions_subsets G U W \<ge> 0"
	- by (auto simp: sum_nonneg energy_graph_partitions_subsets_def)
	+lemma energy_graph_partitions_ge0 [simp]:
	+ "energy_graph_partitions G U W \<ge> 0"
	+ by (auto simp: sum_nonneg energy_graph_partitions_def)

	lemma energy_graph_subsets_commute:
	- "energy_graph_subsets \<U> \<W> G = energy_graph_subsets \<W> \<U> G"
	+ "energy_graph_subsets U W G = energy_graph_subsets W U G"
	by (simp add: energy_graph_subsets_def edge_density_commute)

	-lemma energy_graph_partitions_subsets_commute:
	- "energy_graph_partitions_subsets G W U = energy_graph_partitions_subsets G U W"
	- by (simp add: energy_graph_partitions_subsets_def energy_graph_subsets_commute sum.swap [where A=W])
	+lemma energy_graph_partitions_commute:
	+ "energy_graph_partitions G W U = energy_graph_partitions G U W"
	+ by (simp add: energy_graph_partitions_def energy_graph_subsets_commute sum.swap [where A=W])

	text\<open>Definition 3.7 (Energy of a Partition), or following Gowers, mean square density:
	a version of energy for a single partition of the vertex set. \<close>

	abbreviation mean_square_density :: "[ugraph, uvert set set] \<Rightarrow> real"
	- where "mean_square_density G U \<equiv> energy_graph_partitions_subsets G U U"
	+ where "mean_square_density G U \<equiv> energy_graph_partitions G U U"

	lemma mean_square_density:
	"mean_square_density G U \<equiv>
	(\<Sum>R\<in>U. \<Sum>S\<in>U. card R * card S * (edge_density R S G)\<^sup>2) / (card (uverts G))\<^sup>2"
	- by (simp add: energy_graph_partitions_subsets_def energy_graph_subsets_def sum_divide_distrib)
	+ by (simp add: energy_graph_partitions_def energy_graph_subsets_def sum_divide_distrib)

	text\<open>Observation: the energy is between 0 and 1 because the edge density is bounded above by 1.\<close>

	lemma sum_partition_le:
	assumes "finite_graph_partition V P k" "finite V"
	shows "(\<Sum>R\<in>P. \<Sum>S\<in>P. real (card R * card S)) \<le> (real(card V))\<^sup>2"
	proof -
	have "finite P"
	using assms finite_graph_partition_def by blast
	then show ?thesis
	using assms
	proof (induction P arbitrary: V k)
	case (insert X P)
	have [simp]: "finite Y" if "Y \<in> insert X P" for Y
	by (meson finite_graph_partition_finite insert.prems that)
	have C: "card Y \<le> card V" if"Y \<in> insert X P" for Y
	- by (meson finite_graph_partition_le insert.prems that)
	+ by (meson card_mono finite_graph_partition_subset insert.prems that)
	have D [simp]: "(\<Sum>Y\<in>P. real (card Y)) = real (card V) - real (card X)"
	by (smt (verit) card_finite_graph_partition insert.hyps insert.prems of_nat_sum sum.cong sum.insert)
	have "disjnt X (\<Union>P)"
	using insert.prems insert.hyps
	by (auto simp add: finite_graph_partition_def disjnt_iff pairwise_insert partition_on_def)
	with insert have : "(\<Sum>R\<in>P. \<Sum>S\<in>P. real (card R card S)) \<le> (real (card (V - X)))\<^sup>2"
	unfolding finite_graph_partition_def
	by (simp add: lessThan_Suc partition_on_insert disjoint_family_on_insert sum.distrib)
	have [simp]: "V \<inter>X = X"
	using finite_graph_partition_equals insert.prems by blast
	have "(\<Sum>R \<in> insert X P. \<Sum>S \<in> insert X P. real (card R * card S))
	= real (card X * card X) + 2 * (card V - card X) * card X
	+ (\<Sum>R\<in>P. \<Sum>S\<in>P. real (card R * card S))"
	using \<open>X \<notin> P\<close> \<open>finite P\<close>
	by (simp add: C of_nat_diff sum.distrib algebra_simps flip: sum_distrib_right)
	also have "\<dots> \<le> real (card X * card X) + 2 * (card V - card X) * card X + (real (card (V - X)))\<^sup>2"
	using * by linarith
	also have "\<dots> \<le> (real (card V))\<^sup>2"
	by (simp add: of_nat_diff C card_Diff_subset_Int algebra_simps power2_eq_square)
	finally show ?case .
	qed auto
	qed

	lemma mean_square_density_bounded:
	assumes "finite_graph_partition (uverts G) P k" "finite (uverts G)"
	shows "mean_square_density G P \<le> 1"
	proof-
	have "(\<Sum>R\<in>P. \<Sum>S\<in>P. real (card R * card S) * (edge_density R S G)\<^sup>2)
	\<le> (\<Sum>R\<in>P. \<Sum>S\<in>P. real (card R * card S))"
	by (intro sum_mono mult_right_le_one_le) (auto simp: abs_square_le_1 edge_density_ge0 edge_density_le1)
	also have "\<dots> \<le> (real(card (uverts G)))\<^sup>2"
	using sum_partition_le assms by blast
	finally show ?thesis
	by (simp add: mean_square_density divide_simps)
	qed

	subsection \<open>Partitioning and Energy\<close>

	text\<open>Zhao's Lemma 3.8 and Gowers's remark after Lemma 11.
	Further partitioning of subsets of the vertex set cannot make the energy decrease.
	We follow Gowers's proof, which avoids the use of probability.\<close>

	lemma energy_graph_partition_half:
	- assumes fin: "finite \<U>" "finite \<W>" and U: "finite_graph_partition \<U> U n"
	- shows "card \<U> * (edge_density \<U> \<W> G)\<^sup>2 \<le> (\<Sum>R\<in>U. card R * (edge_density R \<W> G)\<^sup>2)"
	-proof -
	- have \<section>: "(\<Sum>R\<in>U. card R * edge_density R \<W> G)\<^sup>2
	- \<le> (sum card U) * (\<Sum>R\<in>U. card R * (edge_density R \<W> G)\<^sup>2)"
	+ assumes P: "finite_graph_partition U P n"
	+ shows "card U * (edge_density U W G)\<^sup>2 \<le> (\<Sum>R\<in>P. card R * (edge_density R W G)\<^sup>2)"
	+proof (cases "finite U")
	+ case True
	+ have \<section>: "(\<Sum>R\<in>P. card R * edge_density R W G)\<^sup>2
	+ \<le> (sum card P) * (\<Sum>R\<in>P. card R * (edge_density R W G)\<^sup>2)"
	by (simp add: sum_products_le)
	- have "card \<U> * (edge_density \<U> \<W> G)\<^sup>2 = (\<Sum>R\<in>U. card R * (edge_density \<U> \<W> G)\<^sup>2)"
	- by (metis \<open>finite \<U>\<close> U sum_distrib_right card_finite_graph_partition of_nat_sum)
	- also have "\<dots> = edge_density \<U> \<W> G * (\<Sum>R\<in>U. edge_density \<U> \<W> G * card R)"
	+ have "card U * (edge_density U W G)\<^sup>2 = (\<Sum>R\<in>P. card R * (edge_density U W G)\<^sup>2)"
	+ by (metis \<open>finite U\<close> P sum_distrib_right card_finite_graph_partition of_nat_sum)
	+ also have "\<dots> = edge_density U W G * (\<Sum>R\<in>P. edge_density U W G * card R)"
	by (simp add: sum_distrib_left power2_eq_square mult_ac)
	- also have "\<dots> = (\<Sum>R\<in>U. edge_density R \<W> G * real (card R)) * edge_density \<U> \<W> G"
	+ also have "\<dots> = (\<Sum>R\<in>P. edge_density R W G * real (card R)) * edge_density U W G"
	proof -
	- have "edge_density \<U> \<W> G * (\<Sum>R\<in>U. edge_density R \<W> G * card R)
	- = edge_density \<U> \<W> G * (edge_density \<U> \<W> G * (\<Sum>R\<in>U. card R))"
	- using assms card_finite_graph_partition by (auto simp: edge_density_partition [OF _ U])
	+ have "edge_density U W G * (\<Sum>R\<in>P. edge_density R W G * card R)
	+ = edge_density U W G * (edge_density U W G * (\<Sum>R\<in>P. card R))"
	+ using \<open>finite U\<close> assms card_finite_graph_partition by (auto simp: edge_density_partition [OF P])
	then show ?thesis
	by (simp add: mult.commute sum_distrib_left)
	qed
	- also have "\<dots> = (\<Sum>R\<in>U. card R * edge_density R \<W> G) * edge_density \<U> \<W> G"
	+ also have "\<dots> = (\<Sum>R\<in>P. card R * edge_density R W G) * edge_density U W G"
	by (simp add: sum_distrib_left mult_ac)
	- also have "\<dots> = (\<Sum>R\<in>U. card R * edge_density R \<W> G)\<^sup>2 / card \<U>"
	- using assms
	- by (simp add: edge_density_partition [OF _ U] mult_ac flip: power2_eq_square)
	- also have "\<dots> \<le> (\<Sum>R\<in>U. card R * (edge_density R \<W> G)\<^sup>2)"
	- using \<section> U card_finite_graph_partition fin by (force simp add: mult_ac divide_simps simp flip: of_nat_sum)
	+ also have "\<dots> = (\<Sum>R\<in>P. card R * edge_density R W G)\<^sup>2 / card U"
	+ using assms by (simp add: edge_density_partition [OF P] mult_ac flip: power2_eq_square)
	+ also have "\<dots> \<le> (\<Sum>R\<in>P. card R * (edge_density R W G)\<^sup>2)"
	+ using \<section> P card_finite_graph_partition \<open>finite U\<close>
	+ by (force simp add: mult_ac divide_simps simp flip: of_nat_sum)
	finally show ?thesis .
	-qed
	+qed (simp add: sum_nonneg)

	proposition energy_graph_partition_increase:
	- assumes fin: "finite \<U>" "finite \<W>"
	- and U: "finite_graph_partition \<U> U k"
	- and V: "finite_graph_partition \<W> W l"
	- shows "energy_graph_partitions_subsets G U W \<ge> energy_graph_subsets \<U> \<W> G"
	+ assumes P: "finite_graph_partition U P k" and V: "finite_graph_partition W Q l"
	+ shows "energy_graph_partitions G P Q \<ge> energy_graph_subsets U W G"
	proof -
	- have "(card \<U> * card \<W>) * (edge_density \<U> \<W> G)\<^sup>2 = card \<W> * (card \<U> * (edge_density \<U> \<W> G)\<^sup>2)"
	- using fin by (simp add: mult_ac)
	- also have "\<dots> \<le> card \<W> * (\<Sum>R\<in>U. card R * (edge_density R \<W> G)\<^sup>2)"
	- by (intro mult_left_mono energy_graph_partition_half fin) (use assms in auto)
	- also have "\<dots> = (\<Sum>R\<in>U. card R * (card \<W> * (edge_density \<W> R G)\<^sup>2))"
	+ have "(card U * card W) * (edge_density U W G)\<^sup>2 = card W * (card U * (edge_density U W G)\<^sup>2)"
	+ by (simp add: mult_ac)
	+ also have "\<dots> \<le> card W * (\<Sum>R\<in>P. card R * (edge_density R W G)\<^sup>2)"
	+ by (intro mult_left_mono energy_graph_partition_half) (use assms in auto)
	+ also have "\<dots> = (\<Sum>R\<in>P. card R * (card W * (edge_density W R G)\<^sup>2))"
	by (simp add: sum_distrib_left edge_density_commute mult_ac)
	- also have "\<dots> \<le> (\<Sum>R\<in>U. card R * (\<Sum>S\<in>W. card S * (edge_density S R G)\<^sup>2))"
	- proof (intro mult_left_mono energy_graph_partition_half sum_mono fin)
	- show "finite R" if "R \<in> U" for R
	- using that U fin finite_graph_partition_finite by blast
	- qed (use assms in auto)
	- also have "\<dots> \<le> (\<Sum>R\<in>U. \<Sum>S\<in>W. (card R * card S) * (edge_density R S G)\<^sup>2)"
	+ also have "\<dots> \<le> (\<Sum>R\<in>P. card R * (\<Sum>S\<in>Q. card S * (edge_density S R G)\<^sup>2))"
	+ by (intro mult_left_mono energy_graph_partition_half sum_mono) (use assms in auto)
	+ also have "\<dots> \<le> (\<Sum>R\<in>P. \<Sum>S\<in>Q. (card R * card S) * (edge_density R S G)\<^sup>2)"
	by (simp add: sum_distrib_left edge_density_commute mult_ac)
	finally
	- have "(card \<U> * card \<W>) * (edge_density \<U> \<W> G)\<^sup>2
	- \<le> (\<Sum>R\<in>U. \<Sum>S\<in>W. (card R * card S) * (edge_density R S G)\<^sup>2)" .
	+ have "(card U * card W) * (edge_density U W G)\<^sup>2
	+ \<le> (\<Sum>R\<in>P. \<Sum>S\<in>Q. (card R * card S) * (edge_density R S G)\<^sup>2)" .
	then show ?thesis
	- unfolding energy_graph_partitions_subsets_def energy_graph_subsets_def
	+ unfolding energy_graph_partitions_def energy_graph_subsets_def
	by (simp add: divide_simps flip: sum_divide_distrib)
	qed

	text \<open>The following is the fully general version of Gowers's Lemma 11 and Zhao's Lemma 3.9.
	Further partitioning of subsets of the vertex set cannot make the energy decrease.
	Note that @{term V} should be @{term "uverts G"} even though this more general version holds.\<close>

	-lemma energy_graph_partitions_subsets_increase_half:
	+lemma energy_graph_partitions_increase_half:
	assumes ref: "refines V Y X" and "finite V" and part_VX: "partition_on V X"
	- and U: "{} \<notin> U" "finite (\<Union>U)"
	- shows "energy_graph_partitions_subsets G X U \<le> energy_graph_partitions_subsets G Y U"
	- (is "?lhs \<le> ?rhs")
	+ and U: "{} \<notin> U"
	+ shows "energy_graph_partitions G Y U \<ge> energy_graph_partitions G X U"
	+ (is "?Y \<ge> ?X")
	proof -
	have "\<exists>F. partition_on R F \<and> F = {S\<in>Y. S \<subseteq> R}" if "R\<in>X" for R
	using ref refines_obtains_subset that by blast
	then obtain F where F: "\<And>R. R \<in> X \<Longrightarrow> partition_on R (F R) \<and> F R = {S\<in>Y. S \<subseteq> R}"
	by fastforce
	have injF: "inj_on F X"
	by (metis F inj_on_inverseI partition_on_def)
	have finite_X: "finite R" if "R \<in> X" for R
	- by (metis Union_upper assms(2) part_VX finite_subset partition_on_def that)
	+ by (metis Union_upper \<open>finite V\<close> part_VX finite_subset partition_on_def that)
	then have finite_F: "finite (F R)" if "R \<in> X" for R
	using that by (simp add: F)
	have dFX: "disjoint (F ` X)"
	using part_VX
	by (smt (verit, best) F Union_upper disjnt_iff disjointD le_inf_iff pairwise_imageI partition_on_def subset_empty)
	have F_ne: "F R \<noteq> {}" if "R \<in> X" for R
	by (metis F Sup_empty part_VX partition_on_def that)
	have F_sums_Y: "(\<Sum>R\<in>X. \<Sum>U\<in>F R. f U) = (\<Sum>S\<in>Y. f S)" for f :: "nat set \<Rightarrow> real"
	proof -
	have Yn_eq: "Y = (\<Union>R \<in> X. F R)"
	using ref by (force simp add: refines_def dest: F)
	then have "(\<Sum>S\<in>Y. f S) = sum f (\<Union>R \<in> X. F R)"
	by blast
	also have "\<dots> = (sum \<circ> sum) f (F ` X)"
	by (smt (verit, best) dFX disjnt_def finite_F image_iff pairwiseD sum.Union_disjoint)
	also have "\<dots> = (\<Sum>R \<in> X. \<Sum>U\<in>F R. f U)"
	unfolding comp_apply by (metis injF sum.reindex_cong)
	finally show ?thesis
	by simp
	qed
	- have "?lhs = (\<Sum>R \<in> X. \<Sum>T\<in>U. energy_graph_subsets R T G)"
	- by (simp add: energy_graph_partitions_subsets_def)
	- also have "\<dots> \<le> (\<Sum>R\<in>X. \<Sum>T\<in>U. energy_graph_partitions_subsets G (F R) {T})"
	+ have "?X = (\<Sum>R \<in> X. \<Sum>T\<in>U. energy_graph_subsets R T G)"
	+ by (simp add: energy_graph_partitions_def)
	+ also have "\<dots> \<le> (\<Sum>R\<in>X. \<Sum>T\<in>U. energy_graph_partitions G (F R) {T})"
	proof -
	have "finite_graph_partition R (F R) (card (F R))"
	if "R \<in> X" for R
	by (meson F finite_F finite_graph_partition_def that)
	moreover have "finite_graph_partition T {T} (Suc 0)"
	if "T \<in> U" for T
	using U by (metis that trivial_graph_partition_exists)
	- moreover have "finite T" if "T \<in> U" for T
	- using U by (meson Sup_upper infinite_super that)
	ultimately show ?thesis
	using finite_X by (intro sum_mono energy_graph_partition_increase) auto
	qed
	also have "\<dots> = (\<Sum>R \<in> X. \<Sum>D \<in> F R. \<Sum>T\<in>U. energy_graph_subsets D T G)"
	- by (simp add: energy_graph_partitions_subsets_def sum.swap [where B = "U"])
	- also have "\<dots> = ?rhs"
	- by (simp add: energy_graph_partitions_subsets_def F_sums_Y)
	+ by (simp add: energy_graph_partitions_def sum.swap [where B = "U"])
	+ also have "\<dots> = ?Y"
	+ by (simp add: energy_graph_partitions_def F_sums_Y)
	finally show ?thesis .
	qed

	-proposition energy_graph_partitions_subsets_increase:
	- assumes refX: "refines V Y X" and refU: "refines V' W U"
	+proposition energy_graph_partitions_increase:
	+ assumes "refines V Y X" "refines V' W U"
	and "finite V" "finite V'"
	- shows "energy_graph_partitions_subsets G X U \<le> energy_graph_partitions_subsets G Y W"
	- (is "?lhs \<le> ?rhs")
	+ shows "energy_graph_partitions G Y W \<ge> energy_graph_partitions G X U"
	proof -
	- obtain U: "finite (\<Union>U)" "{} \<notin> U"
	- using assms unfolding refines_def partition_on_def by presburger
	- obtain Y: "finite (\<Union>Y)" "{} \<notin> Y"
	+ obtain "{} \<notin> U" "{} \<notin> Y"
	using assms unfolding refines_def partition_on_def by presburger
	- have "?lhs \<le> energy_graph_partitions_subsets G Y U"
	- using assms energy_graph_partitions_subsets_increase_half U assms
	- using refines_def by blast
	- also have "\<dots> = energy_graph_partitions_subsets G U Y"
	- by (meson energy_graph_partitions_subsets_commute)
	- also have "\<dots> \<le> energy_graph_partitions_subsets G W Y"
	- using Y \<open>finite V'\<close> energy_graph_partitions_subsets_increase_half refU refines_def by blast
	- also have "\<dots> = ?rhs"
	- by (simp add: energy_graph_partitions_subsets_commute)
	- finally show ?thesis .
	+ then show ?thesis
	+ using assms unfolding refines_def
	+ by (smt (verit, ccfv_SIG) assms energy_graph_partitions_commute energy_graph_partitions_increase_half)
	qed

	text \<open>The original version of Gowers's Lemma 11 and Zhao's Lemma 3.9
	is not general enough to be used for anything.\<close>
	corollary mean_square_density_increase:
	assumes "refines V Y X" "finite V"
	- shows "mean_square_density G X \<le> mean_square_density G Y"
	- using assms energy_graph_partitions_subsets_increase by presburger
	+ shows "mean_square_density G Y \<ge> mean_square_density G X"
	+ using assms energy_graph_partitions_increase by presburger


	text\<open>The Energy Boost Lemma (Lemma 3.10 in Zhao's notes) says that an
	irregular partition increases the energy substantially. We assume that @{term "\<U> \<subseteq> uverts G"}
	and @{term "\<W> \<subseteq> uverts G"} are not irregular, as witnessed by their subsets @{term"U1 \<subseteq> \<U>"} and @{term"W1 \<subseteq> \<W>"}.
	The proof follows Lemma 12 of Gowers. \<close>

	-definition "P2 X Y \<equiv> if X \<subset> Y then {X,Y-X} else {Y}"
	-
	-lemma card_P2: "card (P2 X Y) \<le> 2"
	- by (simp add: P2_def card_insert_if)
	+definition "part2 X Y \<equiv> if X \<subset> Y then {X,Y-X} else {Y}"

	-lemma sum_P2: "\<lbrakk>X \<subseteq> Y; f{} = 0\<rbrakk> \<Longrightarrow> sum f (P2 X Y) = f X + f (Y-X)"
	- by (force simp add: P2_def sum.insert_if)
	+lemma card_part2: "card (part2 X Y) \<le> 2"
	+ by (simp add: part2_def card_insert_if)

	-lemma partition_P2:
	+lemma sum_part2: "\<lbrakk>X \<subseteq> Y; f{} = 0\<rbrakk> \<Longrightarrow> sum f (part2 X Y) = f X + f (Y-X)"
	+ by (force simp add: part2_def sum.insert_if)
	+
	+lemma partition_part2:
	assumes "A \<subseteq> B" "A \<noteq> {}"
	- shows "partition_on B (P2 A B)"
	- using assms by (auto simp add: partition_on_def P2_def disjnt_iff pairwise_insert)
	+ shows "partition_on B (part2 A B)"
	+ using assms by (auto simp add: partition_on_def part2_def disjnt_iff pairwise_insert)

	proposition energy_boost:
	- fixes \<epsilon>::real and \<U> \<W> G
	- defines "alpha \<equiv> edge_density \<U> \<W> G"
	+ fixes \<epsilon>::real and U W G
	+ defines "alpha \<equiv> edge_density U W G"
	defines "u \<equiv> \<lambda>X Y. edge_density X Y G - alpha"
	- assumes "finite \<U>" "finite \<W>"
	- and "U1 \<subseteq> \<U>" "W1 \<subseteq> \<W>" "\<epsilon> > 0"
	- and U1: "card U1 \<ge> \<epsilon> * card \<U>" and W1: "card W1 \<ge> \<epsilon> * card \<W>"
	- and gt: "\<bar>u U1 W1\<bar> > \<epsilon>"
	- shows "(\<Sum>A \<in> P2 U1 \<U>. \<Sum>B \<in> P2 W1 \<W>. energy_graph_subsets A B G)
	- \<ge> energy_graph_subsets \<U> \<W> G + \<epsilon>^4 * (card \<U> * card \<W>) / (card (uverts G))\<^sup>2"
	+ assumes "finite U" "finite W"
	+ and "U' \<subseteq> U" "W' \<subseteq> W" "\<epsilon> > 0"
	+ and U': "card U' \<ge> \<epsilon> * card U" and W': "card W' \<ge> \<epsilon> * card W"
	+ and gt: "\<bar>u U' W'\<bar> > \<epsilon>"
	+ shows "(\<Sum>A \<in> part2 U' U. \<Sum>B \<in> part2 W' W. energy_graph_subsets A B G)
	+ \<ge> energy_graph_subsets U W G + \<epsilon>^4 * (card U * card W) / (card (uverts G))\<^sup>2"
	(is "?lhs \<ge> ?rhs")
	proof -
	- define UF where "UF \<equiv> P2 U1 \<U>"
	- define WF where "WF \<equiv> P2 W1 \<W>"
	- obtain [simp]: "finite \<U>" "finite \<W>"
	+ define UF where "UF \<equiv> part2 U' U"
	+ define WF where "WF \<equiv> part2 W' W"
	+ obtain [simp]: "finite U" "finite W"
	using assms by (meson finite_subset)
	- obtain 1: "card U1 > 0" "card W1 > 0"
	- using gt \<open>\<epsilon> > 0\<close> U1 W1
	+ obtain card': "card U' > 0" "card W' > 0"
	+ using gt \<open>\<epsilon> > 0\<close> U' W'
	by (force simp: u_def alpha_def edge_density_def mult_le_0_iff zero_less_mult_iff)
	- then obtain 0: "card \<U> > 0" "card \<W> > 0"
	+ then obtain card: "card U > 0" "card W > 0"
	using assms by fastforce
	- then obtain 1: "card U1 > 0" "card W1 > 0"
	- by (smt (verit) U1 W1 \<open>\<epsilon> > 0\<close> of_nat_0_less_iff zero_less_mult_iff)
	- then obtain [simp]: "finite U1" "finite W1"
	- by (meson card_ge_0_finite)
	- obtain [simp]: "W1 \<noteq> \<W> - W1" "U1 \<noteq> \<U> - U1"
	- by (metis DiffD2 1 all_not_in_conv card.empty less_irrefl)
	- have 2 [simp]: "card x > 0" if "x \<in> UF" for x
	- using "1"(1) assms that by (auto simp: UF_def P2_def split: if_split_asm)
	- have 3 [simp]: "card x > 0" if "x \<in> WF" for x
	- using "1"(2) assms that by (auto simp: WF_def P2_def split: if_split_asm)
	- have cardUW: "card \<U> = card U1 + card(\<U> - U1)" "card \<W> = card W1 + card(\<W> - W1)"
	- using 0 1 \<open>U1 \<subseteq> \<U>\<close> \<open>W1 \<subseteq> \<W>\<close>
	+ then obtain [simp]: "finite U'" "finite W'"
	+ by (meson card' card_ge_0_finite)
	+ obtain [simp]: "W' \<noteq> W - W'" "U' \<noteq> U - U'"
	+ by (metis DiffD2 card' all_not_in_conv card.empty less_irrefl)
	+ have UF_ne: "card x \<noteq> 0" if "x \<in> UF" for x
	+ using card' assms that by (auto simp: UF_def part2_def split: if_split_asm)
	+ have WF_ne: "card x \<noteq> 0" if "x \<in> WF" for x
	+ using card' assms that by (auto simp: WF_def part2_def split: if_split_asm)
	+ have cardUW: "card U = card U' + card(U - U')" "card W = card W' + card(W - W')"
	+ using card card' \<open>U' \<subseteq> U\<close> \<open>W' \<subseteq> W\<close>
	by (metis card_eq_0_iff card_Diff_subset card_mono le_add_diff_inverse less_le)+
	- have "\<U> = (\<U> - U1) \<union> U1" "disjnt (\<U> - U1) U1"
	- using \<open>U1 \<subseteq> \<U>\<close> by (force simp: disjnt_iff)+
	- then have CU: "card (all_edges_between \<U> Z G)
	- = card (all_edges_between (\<U> - U1) Z G) + card (all_edges_between U1 Z G)"
	+ have "U = (U - U') \<union> U'" "disjnt (U - U') U'"
	+ using \<open>U' \<subseteq> U\<close> by (force simp: disjnt_iff)+
	+ then have CU: "card (all_edges_between U Z G)
	+ = card (all_edges_between (U - U') Z G) + card (all_edges_between U' Z G)"
	if "finite Z" for Z
	- by (metis \<open>finite U1\<close> all_edges_between_Un1 all_edges_between_disjnt1 \<open>finite \<U>\<close>
	+ by (metis \<open>finite U'\<close> all_edges_between_Un1 all_edges_between_disjnt1 \<open>finite U\<close>
	card_Un_disjnt finite_Diff finite_all_edges_between that)

	- have "\<W> = (\<W> - W1) \<union> W1" "disjnt (\<W> - W1) W1"
	- using \<open>W1 \<subseteq> \<W>\<close> by (force simp: disjnt_iff)+
	- then have CW: "card (all_edges_between Z \<W> G)
	- = card (all_edges_between Z (\<W> - W1) G) + card (all_edges_between Z W1 G)"
	+ have "W = (W - W') \<union> W'" "disjnt (W - W') W'"
	+ using \<open>W' \<subseteq> W\<close> by (force simp: disjnt_iff)+
	+ then have CW: "card (all_edges_between Z W G)
	+ = card (all_edges_between Z (W - W') G) + card (all_edges_between Z W' G)"
	if "finite Z" for Z
	- by (metis \<open>finite W1\<close> all_edges_between_Un2 all_edges_between_disjnt2 \<open>finite \<W>\<close>
	+ by (metis \<open>finite W'\<close> all_edges_between_Un2 all_edges_between_disjnt2 \<open>finite W\<close>
	card_Un_disjnt finite_Diff2 finite_all_edges_between that)
	- have *: "(\<Sum>i\<in>UF. \<Sum>j\<in>WF. real (card (all_edges_between i j G)))
	- = card (all_edges_between \<U> \<W> G)"
	- by (simp add: UF_def WF_def cardUW CU CW sum_P2 \<open>U1 \<subseteq> \<U>\<close> \<open>W1 \<subseteq> \<W>\<close>)
	+ have *: "(\<Sum>X\<in>UF. \<Sum>Y\<in>WF. real (card (all_edges_between X Y G)))
	+ = card (all_edges_between U W G)"
	+ by (simp add: UF_def WF_def cardUW CU CW sum_part2 \<open>U' \<subseteq> U\<close> \<open>W' \<subseteq> W\<close>)
	+ have *: "real (card U) real (card W) = (\<Sum>X\<in>UF. \<Sum>Y\<in>WF. card X * card Y)"
	+ by (simp add: UF_def WF_def cardUW sum_part2 \<open>U' \<subseteq> U\<close> \<open>W' \<subseteq> W\<close> algebra_simps)

	- have *: "real (card \<U>) real (card \<W>) = (\<Sum>i\<in>UF. \<Sum>j\<in>WF. card i * card j)"
	- by (simp add: UF_def WF_def cardUW sum_P2 \<open>U1 \<subseteq> \<U>\<close> \<open>W1 \<subseteq> \<W>\<close> algebra_simps)
	-
	- let ?S = "\<Sum>i\<in>UF. \<Sum>j\<in>WF. (card i * card j) / (card \<U> * card \<W>) * (edge_density i j G)\<^sup>2"
	- have \<section>: "2 * (\<Sum>i\<in>UF. \<Sum>j\<in>WF.
	- (card i * card j) / (card \<U> * card \<W>) * (edge_density i j G))
	- = alpha + alpha * (\<Sum>i\<in>UF. \<Sum>j\<in>WF. (card i * card j) / (card \<U> * card \<W>))"
	- unfolding alpha_def
	- by (simp add: * ** edge_density_def divide_simps sum_P2 \<open>U1 \<subseteq> \<U>\<close> \<open>W1 \<subseteq> \<W>\<close> flip: sum_divide_distrib)
	- have "\<epsilon> * \<epsilon> \<le> u U1 W1 * u U1 W1"
	+ let ?S = "\<Sum>X\<in>UF. \<Sum>Y\<in>WF. (card X * card Y) / (card U * card W) * (edge_density X Y G)\<^sup>2"
	+ define T where "T \<equiv> (\<Sum>X\<in>UF. \<Sum>Y\<in>WF. (card X * card Y) / (card U * card W) * (edge_density X Y G))"
	+ have \<section>: "2 * T = alpha + alpha * (\<Sum>X\<in>UF. \<Sum>Y\<in>WF. (card X * card Y) / (card U * card W))"
	+ unfolding alpha_def T_def
	+ by (simp add: * ** edge_density_def divide_simps sum_part2 \<open>U' \<subseteq> U\<close> \<open>W' \<subseteq> W\<close> UF_ne WF_ne flip: sum_divide_distrib)
	+ have "\<epsilon> * \<epsilon> \<le> u U' W' * u U' W'"
	by (metis abs_ge_zero abs_mult_self_eq \<open>\<epsilon> > 0\<close> gt less_le mult_mono)
	- then have "(\<epsilon>\<epsilon>)(\<epsilon>\<epsilon>) \<le> (card U1 card W1) / (card \<U> * card \<W>) * (u U1 W1)\<^sup>2"
	- using 0 mult_mono [OF U1 W1] \<open>\<epsilon> > 0\<close>
	+ then have "(\<epsilon>\<epsilon>)(\<epsilon>\<epsilon>) \<le> (card U' card W') / (card U * card W) * (u U' W')\<^sup>2"
	+ using card mult_mono [OF U' W'] \<open>\<epsilon> > 0\<close>
	apply (simp add: divide_simps eval_nat_numeral)
	by (smt (verit, del_insts) mult.assoc mult.commute mult_mono' of_nat_0_le_iff zero_le_mult_iff)
	- also have "\<dots> \<le> (\<Sum>i\<in>UF. \<Sum>j\<in>WF. (card i * card j) / (card \<U> * card \<W>) * (u i j)\<^sup>2)"
	- by (simp add: UF_def WF_def sum_P2 \<open>U1 \<subseteq> \<U>\<close> \<open>W1 \<subseteq> \<W>\<close>)
	- also have "\<dots> = ?S - 2 * alpha * (\<Sum>i\<in>UF. \<Sum>j\<in>WF.
	- (card i * card j) / (card \<U> * card \<W>) * edge_density i j G)
	- + alpha\<^sup>2 * (\<Sum>i\<in>UF. \<Sum>j\<in>WF. (card i * card j) / (card \<U> * card \<W>))"
	- by (simp add: u_def power2_diff mult_ac ring_distribs divide_simps
	+ also have "\<dots> \<le> (\<Sum>X\<in>UF. \<Sum>Y\<in>WF. (card X * card Y) / (card U * card W) * (u X Y)\<^sup>2)"
	+ by (simp add: UF_def WF_def sum_part2 \<open>U' \<subseteq> U\<close> \<open>W' \<subseteq> W\<close>)
	+ also have "\<dots> = ?S - 2 * T * alpha
	+ + alpha\<^sup>2 * (\<Sum>X\<in>UF. \<Sum>Y\<in>WF. (card X * card Y) / (card U * card W))"
	+ by (simp add: u_def T_def power2_diff mult_ac ring_distribs divide_simps
	sum_distrib_left sum_distrib_right sum_subtractf sum.distrib flip: sum_divide_distrib)
	also have "\<dots> = ?S - alpha\<^sup>2"
	using \<section> by (simp add: power2_eq_square algebra_simps)
	finally have 12: "alpha\<^sup>2 + \<epsilon>^4 \<le> ?S"
	by (simp add: eval_nat_numeral)
	- have "?rhs = (alpha\<^sup>2 + \<epsilon>^4) * (card \<U> * card \<W> / (card (uverts G))\<^sup>2)"
	+ have "?rhs = (alpha\<^sup>2 + \<epsilon>^4) * (card U * card W / (card (uverts G))\<^sup>2)"
	unfolding alpha_def energy_graph_subsets_def
	by (simp add: ring_distribs divide_simps power2_eq_square)
	- also have "\<dots> \<le> ?S * (card \<U> * card \<W> / (card (uverts G))\<^sup>2)"
	+ also have "\<dots> \<le> ?S * (card U * card W / (card (uverts G))\<^sup>2)"
	by (rule mult_right_mono [OF 12]) auto
	also have "\<dots> = ?lhs"
	- using 0 unfolding energy_graph_subsets_def UF_def WF_def
	- by (auto simp add: algebra_simps sum_P2 \<open>U1 \<subseteq> \<U>\<close> \<open>W1 \<subseteq> \<W>\<close> )
	+ using card unfolding energy_graph_subsets_def UF_def WF_def
	+ by (auto simp add: algebra_simps sum_part2 \<open>U' \<subseteq> U\<close> \<open>W' \<subseteq> W\<close> )
	finally show ?thesis .
	qed

	subsection \<open>Towards Zhao's Lemma 3.11\<close>

	text\<open>Lemma 3.11 says that we can always find a refinement
	that increases the energy by a certain amount.\<close>

	text \<open>A necessary lemma for the tower of exponentials in the result. Angeliki's proof\<close>
	lemma le_tower_2: "k * (2 ^ Suc k) \<le> 2^(2^k)"
	proof (induction k rule: less_induct)
	case (less k)
	show ?case
	proof (cases "k \<le> Suc (Suc 0)")
	case False
	define j where "j = k - Suc 0"
	have kj: "k = Suc j"
	using False j_def by force
	- have "(3::nat) \<le> 2 ^ j"
	- by (metis kj False Suc_leI less_trans_Suc less_exp not_less numeral_3_eq_3)
	- then have \<section>: "(2^j + 3) \<le> (2::nat) ^ k"
	- by (simp add: kj)
	+ with False have \<section>: "(2^j + 3) \<le> (2::nat) ^ k"
	+ by (simp add: Suc_leI le_less_trans not_less_eq_eq numeral_3_eq_3)
	have "k * (2 ^ Suc k) \<le> 6 * j * 2^j"
	using False by (simp add: kj)
	also have "\<dots> \<le> 6 * 2^(2^j)"
	using kj less.IH by force
	- also have "\<dots> < 8 * 2^(2^j)" by simp
	- also have "\<dots> = 2^(2^j + 3)"
	+ also have "\<dots> < 2^(2^j + 3)"
	by (simp add: power_add)
	also have "\<dots> \<le> 2^2^k"
	- using \<section> by (metis One_nat_def less_2_cases_iff power_increasing_iff)
	+ by (simp add: \<section>)
	finally show ?thesis
	by simp
	qed (auto simp: le_Suc_eq)
	qed


	text \<open>Zhao's actual Lemma 3.11. However, the bound $m \le k 2 ^{k+1}$
	comes from a different source by Zhao: ``Graph Theory and Additive Combinatorics'', \<^url>\<open>https://yufeizhao.com/gtac/gtac17.pdf\<close>.
	Zhao's original version, and Gowers', both have incorrect bounds.\<close>
	proposition exists_refinement:
	assumes fgp: "finite_graph_partition (uverts G) P k" and "finite (uverts G)"
	and irreg: "\<not> regular_partition \<epsilon> G P" and "\<epsilon> > 0"
	obtains Q where "refines (uverts G) Q P"
	"mean_square_density G Q \<ge> mean_square_density G P + \<epsilon>^5"
	"\<And>R. R\<in>P \<Longrightarrow> card {S\<in>Q. S \<subseteq> R} \<le> 2 ^ Suc k"
	"card Q \<le> k * 2 ^ Suc k"
	proof -
	define sum_pp where "sum_pp \<equiv> (\<Sum>(R,S) \<in> irregular_set \<epsilon> G P. card R * card S)"
	have cardP: "card P = k"
	using fgp finite_graph_partition_def by force
	then have "k \<noteq> 0"
	using assms unfolding regular_partition_def irregular_set_def finite_graph_partition_def by fastforce
	with assms have G_nonempty: "0 < card (uverts G)"
	by (metis card_gt_0_iff finite_graph_partition_empty)
	have part_GP: "partition_on (uverts G) P"
	using fgp finite_graph_partition_def by blast
	then have finP: "finite R" "R \<noteq> {}" if "R\<in>P" for R
	using assms that partition_onD3 finite_graph_partition_finite by blast+
	have spp: "sum_pp > \<epsilon> * (card (uverts G))\<^sup>2"
	by (metis irreg not_le part_GP regular_partition_def sum_pp_def)
	then have sum_irreg_pos: "sum_pp > 0"
	using \<open>\<epsilon> > 0\<close> G_nonempty less_asym by fastforce
	have "\<exists>X\<subseteq>R. \<exists>Y\<subseteq>S. \<epsilon> * card R \<le> card X \<and> \<epsilon> * card S \<le> card Y \<and>
	\<bar>edge_density X Y G - edge_density R S G\<bar> > \<epsilon>"
	if "(R,S) \<in> irregular_set \<epsilon> G P" for R S
	using that fgp finite_graph_partition_subset by (simp add: irregular_set_def regular_pair_def not_le)
	then obtain X0 Y0
	where XY0_psub_P: "\<And>R S. \<lbrakk>(R,S) \<in> irregular_set \<epsilon> G P\<rbrakk> \<Longrightarrow> X0 R S \<subseteq> R \<and> Y0 R S \<subseteq> S"
	and XY0_eps:
	"\<And>R S. (R,S) \<in> irregular_set \<epsilon> G P
	\<Longrightarrow> \<epsilon> * card R \<le> card (X0 R S) \<and> \<epsilon> * card S \<le> card (Y0 R S) \<and>
	\<bar>edge_density (X0 R S) (Y0 R S) G - edge_density R S G\<bar> > \<epsilon>"
	by metis
	obtain iP where iP: "bij_betw iP P {..<k}"
	by (metis fgp finite_graph_partition_def to_nat_on_finite cardP)
	define X where "X \<equiv> \<lambda>R S. if iP R < iP S then Y0 S R else X0 R S"
	define Y where "Y \<equiv> \<lambda>R S. if iP R < iP S then X0 S R else Y0 R S"
	have XY_psub_P: "\<And>R S. \<lbrakk>(R,S) \<in> irregular_set \<epsilon> G P\<rbrakk> \<Longrightarrow> X R S \<subseteq> R \<and> Y R S \<subseteq> S"
	using XY0_psub_P by (force simp: X_def Y_def irregular_set_swap)
	have XY_eps:
	"\<And>R S. (R,S) \<in> irregular_set \<epsilon> G P
	\<Longrightarrow> \<epsilon> * card R \<le> card (X R S) \<and> \<epsilon> * card S \<le> card (Y R S) \<and>
	\<bar>edge_density (X R S) (Y R S) G - edge_density R S G\<bar> > \<epsilon>"
	using XY0_eps by (force simp: X_def Y_def edge_density_commute irregular_set_swap)
	have card_elem_P: "card R > 0" if "R\<in>P" for R
	by (metis card_eq_0_iff finP neq0_conv that)
	have XY_nonempty: "X R S \<noteq> {}" "Y R S \<noteq> {}" if "(R,S) \<in> irregular_set \<epsilon> G P" for R S
	using XY_eps [OF that] that \<open>\<epsilon> > 0\<close> card_elem_P [of R] card_elem_P [of S]
	by (auto simp: irregular_set_def mult_le_0_iff)

	text\<open>By the assumption that our partition is irregular, there are many irregular pairs.
	For each irregular pair, find pairs of subsets that witness irregularity.\<close>
	- define XP where "XP R \<equiv> ((\<lambda>S. P2 (X R S) R) ` {S. (R,S) \<in> irregular_set \<epsilon> G P})" for R
	- define YP where "YP S \<equiv> ((\<lambda>R. P2 (Y R S) S) ` {R. (R,S) \<in> irregular_set \<epsilon> G P})" for S
	+ define XP where "XP R \<equiv> ((\<lambda>S. part2 (X R S) R) ` {S. (R,S) \<in> irregular_set \<epsilon> G P})" for R
	+ define YP where "YP S \<equiv> ((\<lambda>R. part2 (Y R S) S) ` {R. (R,S) \<in> irregular_set \<epsilon> G P})" for S

	text \<open>include degenerate partition to ensure it works whether or not there's an irregular pair\<close>
	define PP where "PP \<equiv> \<lambda>R. insert {R} (XP R \<union> YP R)"
	define QS where "QS R \<equiv> common_refinement (PP R)" for R
	define r where "r R \<equiv> card (QS R)" for R
	have "finite P"
	using fgp finite_graph_partition_def by blast
	then have finPP: "finite (PP R)" for R
	by (simp add: PP_def XP_def YP_def irregular_set_def)
	have inPP_fin: "P \<in> PP R \<Longrightarrow> finite P" for P R
	- by (auto simp: PP_def XP_def YP_def P2_def)
	+ by (auto simp: PP_def XP_def YP_def part2_def)
	have finite_QS: "finite (QS R)" for R
	by (simp add: QS_def finPP finite_common_refinement inPP_fin)

	have part_QS: "partition_on R (QS R)" if "R \<in> P" for R
	unfolding QS_def
	proof (intro partition_on_common_refinement partition_onI)
	show "\<And>\<A>. \<A> \<in> PP R \<Longrightarrow> {} \<notin> \<A>"
	- using that XY_nonempty XY_psub_P finP(2)
	- by (fastforce simp add: PP_def XP_def YP_def P2_def)
	- qed (auto simp: disjnt_iff PP_def XP_def YP_def P2_def dest: XY_psub_P)
	+ using that XY_nonempty XY_psub_P finP
	+ by (fastforce simp add: PP_def XP_def YP_def part2_def)
	+ qed (auto simp: disjnt_iff PP_def XP_def YP_def part2_def dest: XY_psub_P)

	have part_P_QS: "finite_graph_partition R (QS R) (r R)" if "R\<in>P" for R
	by (simp add: finite_QS finite_graph_partition_def part_QS r_def that)
	then have fin_SQ [simp]: "finite (QS R)" if "R\<in>P" for R
	using QS_def finite_QS by force
	have QS_ne: "{} \<notin> QS R" if "R\<in>P" for R
	using QS_def part_QS partition_onD3 that by blast
	have QS_subset_P: "q \<in> QS R \<Longrightarrow> q \<subseteq> R" if "R\<in>P" for R q
	by (meson finite_graph_partition_subset part_P_QS that)
	then have QS_inject: "R = R'"
	if "R\<in>P" "R'\<in>P" "q \<in> QS R" "q \<in> QS R'" for R R' q
	by (metis UnionI disjnt_iff equals0I pairwiseD part_GP part_QS partition_on_def that)
	define Q where "Q \<equiv> (\<Union>R\<in>P. QS R)"
	define m where "m \<equiv> \<Sum>R\<in>P. r R"
	show thesis
	proof
	show ref_QP: "refines (uverts G) Q P"
	unfolding refines_def
	proof (intro conjI strip part_GP)
	fix X
	assume "X \<in> Q"
	then show "\<exists>Y\<in>P. X \<subseteq> Y"
	by (metis QS_subset_P Q_def UN_iff)
	next
	show "partition_on (uverts G) Q"
	proof (intro conjI partition_onI)
	show "\<Union>Q = uverts G"
	proof
	show "\<Union>Q \<subseteq> uverts G"
	using QS_subset_P Q_def fgp finite_graph_partition_equals by fastforce
	show "uverts G \<subseteq> \<Union>Q"
	by (metis Q_def Sup_least UN_upper Union_mono part_GP part_QS partition_onD1)
	qed
	show "disjnt p q" if "p \<in> Q" and "q \<in> Q" and "p \<noteq> q" for p q
	proof -
	from that
	obtain R S where "R\<in>P" "S\<in>P"
	and *: "p \<in> QS R" "q \<in> QS S"
	by (auto simp: Q_def QS_def)
	show ?thesis
	proof (cases "R=S")
	case True
	then show ?thesis
	using part_QS [of R]
	by (metis \<open>R \<in> P\<close> * pairwiseD partition_on_def \<open>p \<noteq> q\<close>)
	next
	case False
	with * show ?thesis
	by (metis QS_subset_P \<open>R \<in> P\<close> \<open>S \<in> P\<close> disjnt_iff pairwiseD part_GP partition_on_def subsetD)
	qed
	qed
	show "{} \<notin> Q"
	using QS_ne Q_def by blast
	qed
	qed
	have disj_QSP: "disjoint_family_on QS P"
	unfolding disjoint_family_on_def by (metis Int_emptyI QS_inject)
	let ?PP = "P \<times> P"
	let ?REG = "?PP - irregular_set \<epsilon> G P"
	define sum_eps where "sum_eps \<equiv> (\<Sum>(R,S) \<in> irregular_set \<epsilon> G P. \<epsilon>^4 * (card R * card S) / (card (uverts G))\<^sup>2)"
	have A: "energy_graph_subsets R S G + \<epsilon>^4 * (card R * card S) / (card (uverts G))\<^sup>2
	- \<le> energy_graph_partitions_subsets G (P2 (X R S) R) (P2 (Y R S) S)"
	+ \<le> energy_graph_partitions G (part2 (X R S) R) (part2 (Y R S) S)"
	(is "?L \<le> ?R")
	if *: "(R,S) \<in> irregular_set \<epsilon> G P" for R S
	proof -
	have "R\<in>P" "S\<in>P"
	using * by (auto simp: irregular_set_def)
	- have "?L \<le> (\<Sum>A \<in> P2 (X R S) R. \<Sum>B \<in> P2 (Y R S) S. energy_graph_subsets A B G)"
	+ have "?L \<le> (\<Sum>A \<in> part2 (X R S) R. \<Sum>B \<in> part2 (Y R S) S. energy_graph_subsets A B G)"
	using XY_psub_P [OF ] XY_eps [OF ] assms
	by (intro energy_boost \<open>R \<in> P\<close> \<open>S \<in> P\<close> finP \<open>\<epsilon>>0\<close>) auto
	also have "\<dots> \<le> ?R"
	- by (simp add: energy_graph_partitions_subsets_def)
	+ by (simp add: energy_graph_partitions_def)
	finally show ?thesis .
	qed
	- have B: "energy_graph_partitions_subsets G (P2 (X R S) R) (P2 (Y R S) S)
	- \<le> energy_graph_partitions_subsets G (QS R) (QS S)"
	+ have B: "energy_graph_partitions G (part2 (X R S) R) (part2 (Y R S) S)
	+ \<le> energy_graph_partitions G (QS R) (QS S)"
	if "(R,S) \<in> irregular_set \<epsilon> G P" for R S
	proof -
	have "R\<in>P" "S\<in>P" using that by (auto simp: irregular_set_def)
	have [simp]: "\<not> X R S \<subset> R \<longleftrightarrow> X R S = R" "\<not> Y R S \<subset> S \<longleftrightarrow> Y R S = S"
	using XY_psub_P that by blast+
	- have XPX: "P2 (X R S) R \<in> PP R"
	+ have XPX: "part2 (X R S) R \<in> PP R"
	using that by (simp add: PP_def XP_def)
	have I: "partition_on R (QS R)"
	using QS_def \<open>R \<in> P\<close> part_QS by force
	- moreover have "\<forall>q \<in> QS R. \<exists>b \<in> P2 (X R S) R. q \<subseteq> b"
	+ moreover have "\<forall>q \<in> QS R. \<exists>b \<in> part2 (X R S) R. q \<subseteq> b"
	using common_refinement_exists [OF _ XPX] by (simp add: QS_def)
	- ultimately have ref_XP: "refines R (QS R) (P2 (X R S) R)"
	- by (simp add: refines_def XY_nonempty XY_psub_P that partition_P2)
	- have YPY: "P2 (Y R S) S \<in> PP S"
	+ ultimately have ref_XP: "refines R (QS R) (part2 (X R S) R)"
	+ by (simp add: refines_def XY_nonempty XY_psub_P that partition_part2)
	+ have YPY: "part2 (Y R S) S \<in> PP S"
	using that by (simp add: PP_def YP_def)
	have J: "partition_on S (QS S)"
	using QS_def \<open>S \<in> P\<close> part_QS by force
	- moreover have "\<forall>q \<in> QS S. \<exists>b \<in> P2 (Y R S) S. q \<subseteq> b"
	+ moreover have "\<forall>q \<in> QS S. \<exists>b \<in> part2 (Y R S) S. q \<subseteq> b"
	using common_refinement_exists [OF _ YPY] by (simp add: QS_def)
	- ultimately have ref_YP: "refines S (QS S) (P2 (Y R S) S)"
	- by (simp add: XY_nonempty XY_psub_P that partition_P2 refines_def)
	+ ultimately have ref_YP: "refines S (QS S) (part2 (Y R S) S)"
	+ by (simp add: XY_nonempty XY_psub_P that partition_part2 refines_def)
	show ?thesis
	using \<open>R \<in> P\<close> \<open>S \<in> P\<close>
	- by (simp add: finP energy_graph_partitions_subsets_increase [OF ref_XP ref_YP])
	+ by (simp add: finP energy_graph_partitions_increase [OF ref_XP ref_YP])
	qed
	have "mean_square_density G P + \<epsilon>^5 \<le> mean_square_density G P + sum_eps"
	proof -
	have "\<epsilon>^5 = (\<epsilon> * (card (uverts G))\<^sup>2) * (\<epsilon>^4 / (card (uverts G))\<^sup>2)"
	using G_nonempty by (simp add: field_simps eval_nat_numeral)
	also have "\<dots> \<le> sum_pp * (sum_eps / sum_pp)"
	proof (rule mult_mono)
	show "\<epsilon>^4 / real ((card (uverts G))\<^sup>2) \<le> sum_eps / sum_pp"
	using sum_irreg_pos sum_eps_def sum_pp_def
	by (auto simp add: case_prod_unfold sum.neutral simp flip: sum_distrib_left sum_divide_distrib of_nat_sum of_nat_mult)
	qed (use spp sum_nonneg in auto)
	also have "\<dots> \<le> sum_eps"
	by (simp add: sum_irreg_pos)
	finally show ?thesis by simp
	qed
	also have "\<dots> = (\<Sum>(i,j)\<in>?REG. energy_graph_subsets i j G)
	+ (\<Sum>(i,j)\<in>irregular_set \<epsilon> G P. energy_graph_subsets i j G) + sum_eps"
	- by (simp add: \<open>finite P\<close> energy_graph_partitions_subsets_def sum.cartesian_product irregular_set_subset sum.subset_diff)
	+ by (simp add: \<open>finite P\<close> energy_graph_partitions_def sum.cartesian_product irregular_set_subset sum.subset_diff)
	also have "\<dots> \<le> (\<Sum>(i,j) \<in> ?REG. energy_graph_subsets i j G)
	- + (\<Sum>(i,j) \<in> irregular_set \<epsilon> G P. energy_graph_partitions_subsets G (P2 (X i j) i) (P2 (Y i j) j))"
	+ + (\<Sum>(i,j) \<in> irregular_set \<epsilon> G P. energy_graph_partitions G (part2 (X i j) i) (part2 (Y i j) j))"
	using A unfolding sum_eps_def case_prod_unfold
	by (force intro: sum_mono simp flip: sum.distrib)
	- also have "\<dots> \<le> (\<Sum>(i,j) \<in> ?REG. energy_graph_partitions_subsets G (QS i) (QS j))
	- + (\<Sum>(i,j) \<in> irregular_set \<epsilon> G P. energy_graph_partitions_subsets G (P2 (X i j) i) (P2 (Y i j) j))"
	- by (auto simp: finP intro!: part_P_QS sum_mono energy_graph_partition_increase)
	- also have "\<dots> \<le> (\<Sum>(i,j) \<in> ?REG. energy_graph_partitions_subsets G (QS i) (QS j))
	- + (\<Sum>(i,j) \<in> irregular_set \<epsilon> G P. energy_graph_partitions_subsets G (QS i) (QS j))"
	+ also have "\<dots> \<le> (\<Sum>(i,j) \<in> ?REG. energy_graph_partitions G (QS i) (QS j))
	+ + (\<Sum>(i,j) \<in> irregular_set \<epsilon> G P. energy_graph_partitions G (part2 (X i j) i) (part2 (Y i j) j))"
	+ by (auto intro!: part_P_QS sum_mono energy_graph_partition_increase)
	+ also have "\<dots> \<le> (\<Sum>(i,j) \<in> ?REG. energy_graph_partitions G (QS i) (QS j))
	+ + (\<Sum>(i,j) \<in> irregular_set \<epsilon> G P. energy_graph_partitions G (QS i) (QS j))"
	using B
	proof (intro sum_mono add_mono ordered_comm_monoid_add_class.sum_mono2)
	qed (auto split: prod.split)
	- also have "\<dots> = (\<Sum>(i,j) \<in> ?PP. energy_graph_partitions_subsets G (QS i) (QS j))"
	+ also have "\<dots> = (\<Sum>(i,j) \<in> ?PP. energy_graph_partitions G (QS i) (QS j))"
	by (metis (no_types, lifting) \<open>finite P\<close> finite_SigmaI irregular_set_subset sum.subset_diff)
	- also have "\<dots> = (\<Sum>i\<in>P. \<Sum>j\<in>P. energy_graph_partitions_subsets G (QS i) (QS j))"
	+ also have "\<dots> = (\<Sum>i\<in>P. \<Sum>j\<in>P. energy_graph_partitions G (QS i) (QS j))"
	by (simp flip: sum.cartesian_product)
	also have "\<dots> = (\<Sum>A \<in> Q. \<Sum>B \<in> Q. energy_graph_subsets A B G)"
	- unfolding energy_graph_partitions_subsets_def Q_def
	+ unfolding energy_graph_partitions_def Q_def
	by (simp add: disj_QSP \<open>finite P\<close> sum.UNION_disjoint_family sum.swap [of _ "P" "QS _"])
	also have "\<dots> = mean_square_density G Q"
	by (simp add: mean_square_density energy_graph_subsets_def sum_divide_distrib)
	finally show "mean_square_density G P + \<epsilon> ^ 5 \<le> mean_square_density G Q" .

	define QinP where "QinP \<equiv> \<lambda>i. {j\<in>Q. j \<subseteq> i}"
	show card_QP: "card (QinP i) \<le> 2 ^ Suc k"
	if "i \<in> P" for i
	proof -
	have less_cardP: "iP i < k"
	using iP bij_betwE that by blast
	have card_cr: "card (QS i) \<le> 2 ^ Suc k"
	proof -
	have "card (QS i) \<le> prod card (PP i)"
	by (simp add: QS_def card_common_refinement finPP inPP_fin)
	also have "\<dots> = prod card (XP i \<union> YP i)"
	using finPP by (simp add: PP_def prod.insert_if)
	also have "\<dots> \<le> 2 ^ Suc k"
	proof (rule prod_le_power)
	- define XS where "XS \<equiv> (\<Union>R \<in> {R\<in>P. iP R \<le> iP i}. {P2 (X0 i R) i})"
	- define YS where "YS \<equiv> (\<Union>R \<in> {R\<in>P. iP R \<ge> iP i}. {P2 (Y0 R i) i})"
	+ define XS where "XS \<equiv> (\<Union>R \<in> {R\<in>P. iP R \<le> iP i}. {part2 (X0 i R) i})"
	+ define YS where "YS \<equiv> (\<Union>R \<in> {R\<in>P. iP R \<ge> iP i}. {part2 (Y0 R i) i})"
	have 1: "{R \<in> P. iP R \<le> iP i} \<subseteq> iP -` {..iP i} \<inter> P"
	by auto
	have "card XS \<le> card {R \<in> P. iP R \<le> iP i}"
	by (force simp add: XS_def \<open>finite P\<close> intro: order_trans [OF card_UN_le])
	also have "\<dots> \<le> card (iP -` {..iP i} \<inter> P)"
	using 1 by (simp add: \<open>finite P\<close> card_mono)
	also have "\<dots> \<le> Suc (iP i)"
	by (metis card_vimage_inj_on_le bij_betw_def card_atMost finite_atMost iP)
	finally have cXS: "card XS \<le> Suc (iP i)" .
	have 2: "{R \<in> P. iP R \<ge> iP i} \<subseteq> iP -` {iP i..<k} \<inter> P"
	by clarsimp (meson bij_betw_apply iP lessThan_iff nat_less_le)
	have "card YS \<le> card {R \<in> P. iP R \<ge> iP i}"
	by (force simp add: YS_def \<open>finite P\<close> intro: order_trans [OF card_UN_le])
	also have "\<dots> \<le> card (iP -` {iP i..<k} \<inter> P)"
	using 2 by (simp add: \<open>finite P\<close> card_mono)
	also have "\<dots> \<le> card {iP i..<k}"
	by (meson bij_betw_def card_vimage_inj_on_le finite_atLeastLessThan iP)
	finally have "card YS \<le> k - iP i"
	by simp
	with less_cardP cXS have k': "card XS + card YS \<le> Suc k"
	by linarith
	have finXYS: "finite (XS \<union> YS)"
	unfolding XS_def YS_def using \<open>finite P\<close> by (auto intro: finite_vimageI)
	have "XP i \<union> YP i \<subseteq> XS \<union> YS"
	apply (simp add: XP_def X_def YP_def Y_def XS_def YS_def irregular_set_def image_def subset_iff)
	by (metis insert_iff linear not_le)
	then have "card (XP i \<union> YP i) \<le> card XS + card YS"
	by (meson card_Un_le card_mono finXYS order_trans)
	then show "card (XP i \<union> YP i) \<le> Suc k"
	using k' le_trans by blast
	fix x
	assume "x \<in> XP i \<union> YP i"
	then show "0 \<le> card x \<and> card x \<le> 2"
	- using XP_def YP_def card_P2 by force
	+ using XP_def YP_def card_part2 by force
	qed auto
	finally show ?thesis .
	qed
	have "i' = i" if "q \<subseteq> i" "i'\<in>P" "q \<in> QS i'" for i' q
	by (metis QS_ne QS_subset_P \<open>i \<in> P\<close> disjnt_iff equals0I pairwiseD part_GP partition_on_def subset_eq that)
	then have "QinP i \<subseteq> QS i"
	by (auto simp: QinP_def Q_def)
	then have "card (QinP i) \<le> card (QS i)"
	by (simp add: card_mono that)
	also have "\<dots> \<le> 2 ^ Suc k"
	using QS_def card_cr by presburger
	finally show ?thesis .
	qed
	- have "card Q = card (\<Union> (QS ` P))"
	- unfolding Q_def ..
	- also have "\<dots> \<le> card (\<Union>i\<in>P. QinP i)"
	+ have "card Q \<le> card (\<Union>i\<in>P. QinP i)"
	+ unfolding Q_def
	proof (rule card_mono)
	show "(\<Union> (QS ` P)) \<subseteq> (\<Union>i\<in>P. QinP i)"
	using ref_QP QS_subset_P Q_def QinP_def by blast
	show "finite (\<Union>i\<in>P. QinP i)"
	by (simp add: Q_def QinP_def \<open>finite P\<close>)
	qed
	- also have "\<dots> \<le> (\<Sum>i\<in>P. card (QinP i))"
	- using card_UN_le \<open>finite P\<close> by blast
	also have "\<dots> \<le> (\<Sum>i\<in>P. 2 ^ Suc k)"
	- using card_QP sum_mono by force
	+ by (smt (verit) \<open>finite P\<close> card_QP card_UN_le order_trans sum_mono)
	finally show "card Q \<le> k * 2 ^ Suc k"
	by (simp add: cardP)
	qed
	qed

	subsection \<open>The Regularity Proof Itself\<close>

	text\<open>Szemerédi's Regularity Lemma is Theorem 3.5 in Zhao's notes.\<close>

	text\<open>We start with a trivial partition (one part). If it is already $\epsilon$-regular, we are done. If
	not, we refine it by applying lemma @{thm[source]"exists_refinement"} above, which increases the
	energy. We can repeat this step, but it cannot increase forever: by @{thm [source]
	mean_square_density_bounded} it cannot exceed~1. This defines an algorithm that must stop
	after at most $\epsilon^{-5}$ steps, resulting in an $\epsilon$-regular partition.\<close>
	theorem Szemeredi_Regularity_Lemma:
	assumes "\<epsilon> > 0"
	obtains M where "\<And>G. card (uverts G) > 0 \<Longrightarrow> \<exists>P. regular_partition \<epsilon> G P \<and> card P \<le> M"
	proof
	fix G
	assume "card (uverts G) > 0"
	then obtain finG: "finite (uverts G)" and nonempty: "uverts G \<noteq> {}"
	by (simp add: card_gt_0_iff)
	define \<Phi> where "\<Phi> \<equiv> \<lambda>Q P. refines (uverts G) Q P \<and>
	mean_square_density G Q \<ge> mean_square_density G P + \<epsilon>^5 \<and>
	card Q \<le> card P * 2 ^ Suc (card P)"
	define nxt where "nxt \<equiv> \<lambda>P. if regular_partition \<epsilon> G P then P else SOME Q. \<Phi> Q P"
	define iter where "iter \<equiv> \<lambda>i. (nxt ^^ i) {uverts G}"
	define last where "last \<equiv> Suc (nat\<lceil>1 / \<epsilon> ^ 5\<rceil>)"
	have iter_Suc [simp]: "iter (Suc i) = nxt (iter i)" for i
	by (simp add: iter_def)
	have \<Phi>: "\<Phi> (nxt P) P"
	if Pk: "partition_on (uverts G) P" and irreg: "\<not> regular_partition \<epsilon> G P" for P
	proof -
	have "finite_graph_partition (uverts G) P (card P)"
	by (meson Pk finG finite_elements finite_graph_partition_def)
	then show ?thesis
	using that exists_refinement [OF _ finG irreg assms] irreg Pk
	- apply (simp only: nxt_def if_False)
	- by (metis (no_types, lifting) \<Phi>_def someI)
	+ unfolding \<Phi>_def nxt_def by (smt (verit) someI)
	qed
	have partition_on: "partition_on (uverts G) (iter i)" for i
	proof (induction i)
	case 0
	then show ?case
	by (simp add: iter_def nonempty trivial_graph_partition_exists partition_on_space)
	next
	case (Suc i)
	with \<Phi> show ?case
	by (metis \<Phi>_def iter_Suc nxt_def refines_def)
	qed
	have False if irreg: "\<And>i. i\<le>last \<Longrightarrow> \<not> regular_partition \<epsilon> G (iter i)"
	proof -
	have \<Phi>_loop: "\<Phi> (nxt (iter i)) (iter i)" if "i\<le>last" for i
	using \<Phi> irreg partition_on that by blast
	have iter_grow: "mean_square_density G (iter i) \<ge> i * \<epsilon>^5" if "i\<le>last" for i
	using that
	proof (induction i)
	case (Suc i)
	then show ?case
	by (clarsimp simp: algebra_simps) (smt (verit, best) Suc_leD \<Phi>_def \<Phi>_loop)
	qed (auto simp: iter_def)
	have "last * \<epsilon>^5 \<le> mean_square_density G (iter last)"
	by (simp add: iter_grow)
	also have "\<dots> \<le> 1"
	by (meson finG finite_elements finite_graph_partition_def mean_square_density_bounded partition_on)
	finally have "real last * \<epsilon> ^ 5 \<le> 1" .
	with assms show False
	unfolding last_def by (meson lessI natceiling_lessD not_less pos_divide_less_eq zero_less_power)
	qed
	then obtain i where "i \<le> last" and "regular_partition \<epsilon> G (iter i)"
	by force
	then have reglar: "regular_partition \<epsilon> G (iter (i + d))" for d
	by (induction d) (auto simp add: nxt_def)
	define tower where "tower \<equiv> \<lambda>k. (power(2::nat) ^^ k) 2"
	have [simp]: "tower (Suc k) = 2 ^ tower k" for k
	by (simp add: tower_def)
	have iter_tower: "card (iter i) \<le> tower (2*i)" for i
	proof (induction i)
	case (Suc i)
	then have Qm: "card (iter i) \<le> tower (2 * i)"
	by simp
	then have : "card (nxt (iter i)) \<le> card (iter i) 2 ^ Suc (card (iter i))"
	using \<Phi> by (simp add: \<Phi>_def nxt_def partition_on)
	also have "\<dots> \<le> 2 ^ 2 ^ tower (2 * i)"
	by (metis One_nat_def Suc.IH le_tower_2 lessI numeral_2_eq_2 order.trans power_increasing_iff)
	finally show ?case
	by (simp add: Qm)
	qed (auto simp: iter_def tower_def)
	then show "\<exists>P. regular_partition \<epsilon> G P \<and> card P \<le> tower(2 * last)"
	by (metis \<open>i \<le> last\<close> nat_le_iff_add reglar)
	qed

	text \<open>The actual value of the bound is visible above: a tower of exponentials of height $2(1 + \epsilon^{-5})$.\<close>

	end
	diff --git a/thys/Universal_Hash_Families/Carter_Wegman_Hash_Family.thy b/thys/Universal_Hash_Families/Carter_Wegman_Hash_Family.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Universal_Hash_Families/Carter_Wegman_Hash_Family.thy
	@@ -0,0 +1,293 @@
	+section \<open>Carter-Wegman Hash Family\label{sec:carter_wegman}\<close>
	+
	+theory Carter_Wegman_Hash_Family
	+ imports
	+ Interpolation_Polynomials_HOL_Algebra.Interpolation_Polynomial_Cardinalities
	+ Preliminary_Results
	+begin
	+
	+text \<open>The Carter-Wegman hash family is a generic method to obtain
	+$k$-universal hash families for arbitrary $k$. (There are faster solutions, such as tabulation
	+hashing, which are limited to a specific $k$. See for example \cite{thorup2010}.)
	+
	+The construction was described by Wegman and Carter~\cite{wegman1981}, it is a hash
	+family between the elements of a finite field and works by choosing randomly a polynomial
	+over the field with degree less than $k$. The hash function is the evaluation of a such a
	+polynomial.
	+
	+Using the property that the fraction of polynomials interpolating a given set of $s \leq k$
	+points is @{term "1/(card (carrier R)^s)"}, which is shown in
	+\cite{Interpolation_Polynomials_HOL_Algebra-AFP}, it is possible to obtain both that
	+the hash functions are $k$-wise independent and uniformly distributed.
	+
	+In the following two locales are introduced, the main reason for both is to make the statements
	+of the theorems and proofs more concise. The first locale @{term "poly_hash_family"} fixes a finite
	+ring $R$ and the probability space of the polynomials of degree less than $k$. Because the ring is
	+not a field, the family is not yet $k$-universal, but it is still possible to state a few results such
	+as the fact that the range of the hash function is a subset of the carrier of the ring.
	+
	+The second locale @{term "carter_wegman_hash_family"} is an extension of the former with the
	+assumption that $R$ is a field with which the $k$-universality follows.
	+
	+The reason for using two separate locales is to support use cases, where the ring is only probably
	+a field. For example if it is the set of integers modulo an approximate prime, in such a situation a
	+subset of the properties of an algorithm using approximate primes would need to be verified
	+even if $R$ is only a ring.\<close>
	+
	+definition (in ring) "hash x \<omega> = eval \<omega> x"
	+
	+locale poly_hash_family = ring +
	+ fixes k :: nat
	+ assumes finite_carrier[simp]: "finite (carrier R)"
	+ assumes k_ge_0: "k > 0"
	+begin
	+
	+definition space where "space = bounded_degree_polynomials R k"
	+definition M where "M = measure_pmf (pmf_of_set space)"
	+
	+lemma finite_space[simp]:"finite space"
	+ unfolding space_def using fin_degree_bounded finite_carrier by simp
	+
	+lemma non_empty_bounded_degree_polynomials[simp]:"space \<noteq> {}"
	+ unfolding space_def using non_empty_bounded_degree_polynomials by simp
	+
	+text \<open>This is to add @{thm [source] carrier_not_empty} to the simp set in the context of
	+@{locale "poly_hash_family"}:\<close>
	+
	+lemma non_empty_carrier[simp]: "carrier R \<noteq> {}"
	+ by (simp add:carrier_not_empty)
	+
	+sublocale prob_space "M"
	+ by (simp add:M_def prob_space_measure_pmf)
	+
	+lemma hash_range[simp]:
	+ assumes "\<omega> \<in> space"
	+ assumes "x \<in> carrier R"
	+ shows "hash x \<omega> \<in> carrier R"
	+ using assms unfolding hash_def space_def bounded_degree_polynomials_def
	+ by (simp, metis eval_in_carrier polynomial_incl univ_poly_carrier)
	+
	+lemma hash_range_2:
	+ assumes "\<omega> \<in> space"
	+ shows "(\<lambda>x. hash x \<omega>) ` carrier R \<subseteq> carrier R"
	+ using hash_range assms by auto
	+
	+lemma integrable_M[simp]:
	+ fixes f :: "'a list \<Rightarrow> 'c::{banach, second_countable_topology}"
	+ shows "integrable M f"
	+ unfolding M_def
	+ by (rule integrable_measure_pmf_finite, simp)
	+
	+end
	+
	+locale carter_wegman_hash_family = poly_hash_family +
	+ assumes field_R: "field R"
	+begin
	+sublocale field
	+ using field_R by simp
	+
	+abbreviation "field_size \<equiv> card (carrier R)"
	+
	+lemma poly_cards:
	+ assumes "K \<subseteq> carrier R"
	+ assumes "card K \<le> k"
	+ assumes "y ` K \<subseteq> (carrier R)"
	+ shows
	+ "card {\<omega> \<in> space. (\<forall>k \<in> K. eval \<omega> k = y k)} = field_size^(k-card K)"
	+ unfolding space_def
	+ using interpolating_polynomials_card[where n="k-card K" and K="K"] assms
	+ using finite_carrier finite_subset by fastforce
	+
	+lemma poly_cards_single:
	+ assumes "x \<in> carrier R"
	+ assumes "y \<in> carrier R"
	+ shows "card {\<omega> \<in> space. eval \<omega> x = y} = field_size^(k-1)"
	+ using poly_cards[where K="{x}" and y="\<lambda>_. y", simplified] assms k_ge_0 by simp
	+
	+lemma hash_prob:
	+ assumes "K \<subseteq> carrier R"
	+ assumes "card K \<le> k"
	+ assumes "y ` K \<subseteq> carrier R"
	+ shows
	+ "prob {\<omega>. (\<forall>x \<in> K. hash x \<omega> = y x)} = 1/(real field_size)^card K"
	+proof -
	+ have "\<zero> \<in> carrier R" by simp
	+
	+ hence a:"field_size > 0"
	+ using finite_carrier card_gt_0_iff by blast
	+
	+ have b:"real (card {\<omega> \<in> space. \<forall>x\<in>K. eval \<omega> x = y x}) / real (card space) =
	+ 1 / real field_size ^ card K"
	+ using a assms(2)
	+ apply (simp add: frac_eq_eq poly_cards[OF assms(1,2,3)] power_add[symmetric])
	+ by (simp add:space_def bounded_degree_polynomials_card)
	+
	+ show ?thesis
	+ unfolding M_def
	+ by (simp add:hash_def measure_pmf_of_set Int_def b)
	+qed
	+
	+lemma prob_single:
	+ assumes "x \<in> carrier R" "y \<in> carrier R"
	+ shows "prob {\<omega>. hash x \<omega> = y} = 1/(real field_size)"
	+ using hash_prob[where K="{x}"] assms finite_carrier k_ge_0 by simp
	+
	+lemma prob_range:
	+ assumes [simp]:"x \<in> carrier R"
	+ shows "prob {\<omega>. hash x \<omega> \<in> A} = card (A \<inter> carrier R) / field_size"
	+proof -
	+ have "prob {\<omega>. hash x \<omega> \<in> A} = prob (\<Union>a \<in> A \<inter> carrier R. {\<omega>. hash x \<omega> = a})"
	+ by (rule measure_pmf_eq, auto simp:M_def)
	+ also have "... = (\<Sum> a \<in> (A \<inter> carrier R). prob {\<omega>. hash x \<omega> = a})"
	+ by (rule measure_finite_Union, auto simp:M_def disjoint_family_on_def)
	+ also have "... = (\<Sum> a \<in> (A \<inter> carrier R). 1/(real field_size))"
	+ by (rule sum.cong, auto simp:prob_single)
	+ also have "... = card (A \<inter> carrier R) / field_size"
	+ by simp
	+ finally show ?thesis by simp
	+qed
	+
	+lemma indep:
	+ assumes "J \<subseteq> carrier R"
	+ assumes "card J \<le> k"
	+ shows "indep_vars (\<lambda>_. discrete) hash J"
	+proof -
	+ have "\<zero> \<in> carrier R" by simp
	+ hence card_R_ge_0:"field_size > 0"
	+ using card_gt_0_iff finite_carrier by blast
	+
	+ have fin_J: "finite J"
	+ using finite_carrier assms(1) finite_subset by blast
	+
	+ show ?thesis
	+ proof (rule indep_vars_pmf[OF M_def])
	+ fix a
	+ fix J'
	+ assume a: "J' \<subseteq> J" "finite J'"
	+ have card_J': "card J' \<le> k"
	+ by (metis card_mono order_trans a(1) assms(2) fin_J)
	+ have J'_in_carr: "J' \<subseteq> carrier R" by (metis order_trans a(1) assms(1))
	+
	+ show "prob {\<omega>. \<forall>x\<in>J'. hash x \<omega> = a x} = (\<Prod>x\<in>J'. prob {\<omega>. hash x \<omega> = a x})"
	+ proof (cases "a ` J' \<subseteq> carrier R")
	+ case True
	+ have a_carr: "\<And>x. x \<in> J' \<Longrightarrow> a x \<in> carrier R" using True by force
	+ have "prob {\<omega>. \<forall>x\<in>J'. hash x \<omega> = a x} =
	+ real (card {\<omega> \<in> space. \<forall>x\<in>J'. eval \<omega> x = a x}) / real (card space)"
	+ by (simp add:M_def measure_pmf_of_set Int_def hash_def)
	+ also have "... = real (field_size ^ (k - card J')) / real (card space)"
	+ using True by (simp add: poly_cards[OF J'_in_carr card_J'])
	+ also have
	+ "... = real field_size ^ (k - card J') / real field_size ^ k"
	+ by (simp add:space_def bounded_degree_polynomials_card)
	+ also have
	+ "... = real field_size ^ ((k - 1) * card J') / real field_size ^ (k * card J')"
	+ using card_J' by (simp add:power_add[symmetric] power_mult[symmetric]
	+ diff_mult_distrib frac_eq_eq add.commute)
	+ also have
	+ "... = (real field_size ^ (k - 1)) ^ card J' / (real field_size ^ k) ^ card J'"
	+ by (simp add:power_add power_mult)
	+ also have
	+ "... = (\<Prod>x\<in>J'. real (card {\<omega> \<in> space. eval \<omega> x = a x}) / real (card space))"
	+ using a_carr poly_cards_single[OF subsetD[OF J'_in_carr]]
	+ by (simp add:space_def bounded_degree_polynomials_card power_divide)
	+ also have "... = (\<Prod>x\<in>J'. prob {\<omega>. hash x \<omega> = a x})"
	+ by (simp add:measure_pmf_of_set M_def Int_def hash_def)
	+ finally show ?thesis by simp
	+ next
	+ case False
	+ then obtain j where j_def: "j \<in> J'" "a j \<notin> carrier R" by blast
	+ have "{\<omega> \<in> space. hash j \<omega> = a j} \<subseteq> {\<omega> \<in> space. hash j \<omega> \<notin> carrier R}"
	+ by (rule subsetI, simp add:j_def)
	+ also have "... \<subseteq> {}" using j_def(1) J'_in_carr hash_range by blast
	+ finally have b:"{\<omega> \<in> space. hash j \<omega> = a j} = {}" by simp
	+ hence "real (card ({\<omega> \<in> space. hash j \<omega> = a j})) = 0" by simp
	+ hence "(\<Prod>x\<in>J'. real (card {\<omega> \<in> space. hash x \<omega> = a x})) = 0"
	+ using a(2) prod_zero[OF a(2)] j_def(1) by auto
	+ moreover have
	+ "{\<omega> \<in> space. \<forall>x\<in>J'. hash x \<omega> = a x} \<subseteq> {\<omega> \<in> space. hash j \<omega> = a j}"
	+ using j_def by blast
	+ hence "{\<omega> \<in> space. \<forall>x\<in>J'. hash x \<omega> = a x} = {}" using b by blast
	+ ultimately show ?thesis
	+ by (simp add:measure_pmf_of_set M_def Int_def prod_dividef)
	+ qed
	+ qed
	+qed
	+
	+lemma k_wise_indep:
	+ "k_wise_indep_vars k (\<lambda>_. discrete) hash (carrier R)"
	+ unfolding k_wise_indep_vars_def using indep by simp
	+
	+lemma inj_if_degree_1:
	+ assumes "\<omega> \<in> space"
	+ assumes "degree \<omega> = 1"
	+ shows "inj_on (\<lambda>x. hash x \<omega>) (carrier R)"
	+ using assms eval_inj_if_degree_1
	+ by (simp add:M_def space_def bounded_degree_polynomials_def hash_def)
	+
	+lemma uniform:
	+ assumes "i \<in> carrier R"
	+ shows "uniform_on (hash i) (carrier R)"
	+proof -
	+ have a:
	+ "\<And>a. prob {\<omega>. hash i \<omega> \<in> {a}} = indicat_real (carrier R) a / real field_size"
	+ by (subst prob_range[OF assms], simp add:indicator_def)
	+ show ?thesis
	+ by (rule uniform_onI, use a M_def in auto)
	+qed
	+
	+text \<open>This the main result of this section - the Carter-Wegman hash family is $k$-universal.\<close>
	+
	+theorem k_universal:
	+ "k_universal k hash (carrier R) (carrier R)"
	+ using uniform k_wise_indep by (simp add:k_universal_def)
	+
	+end
	+
	+lemma poly_hash_familyI:
	+ assumes "ring R"
	+ assumes "finite (carrier R)"
	+ assumes "0 < k"
	+ shows "poly_hash_family R k"
	+ using assms
	+ by (simp add:poly_hash_family_def poly_hash_family_axioms_def)
	+
	+lemma carter_wegman_hash_familyI:
	+ assumes "field F"
	+ assumes "finite (carrier F)"
	+ assumes "0 < k"
	+ shows "carter_wegman_hash_family F k"
	+ using assms field.is_ring[OF assms(1)] poly_hash_familyI
	+ by (simp add:carter_wegman_hash_family_def carter_wegman_hash_family_axioms_def)
	+
	+lemma hash_k_wise_indep:
	+ assumes "field F \<and> finite (carrier F)"
	+ assumes "1 \<le> n"
	+ shows
	+ "prob_space.k_wise_indep_vars (pmf_of_set (bounded_degree_polynomials F n)) n
	+ (\<lambda>_. pmf_of_set (carrier F)) (ring.hash F) (carrier F)"
	+proof -
	+ interpret carter_wegman_hash_family "F" "n"
	+ using assms carter_wegman_hash_familyI by force
	+ have "k_wise_indep_vars n (\<lambda>_. pmf_of_set (carrier F)) hash (carrier F)"
	+ by (rule k_wise_indep_vars_compose[OF k_wise_indep], simp)
	+ thus ?thesis
	+ by (simp add:M_def space_def)
	+qed
	+
	+lemma hash_prob_single:
	+ assumes "field F \<and> finite (carrier F)"
	+ assumes "x \<in> carrier F"
	+ assumes "1 \<le> n"
	+ assumes "y \<in> carrier F"
	+ shows
	+ "\<P>(\<omega> in pmf_of_set (bounded_degree_polynomials F n). ring.hash F x \<omega> = y)
	+ = 1/(real (card (carrier F)))"
	+proof -
	+ interpret carter_wegman_hash_family "F" "n"
	+ using assms carter_wegman_hash_familyI by force
	+ show ?thesis
	+ using prob_single[OF assms(2,4)] by (simp add:M_def space_def)
	+qed
	+
	+end
	diff --git a/thys/Universal_Hash_Families/Definitions.thy b/thys/Universal_Hash_Families/Definitions.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Universal_Hash_Families/Definitions.thy
	@@ -0,0 +1,81 @@
	+section \<open>Introduction and Definition\<close>
	+
	+theory Definitions
	+ imports "HOL-Probability.Independent_Family"
	+begin
	+
	+text \<open>Universal hash families are commonly used in randomized algorithms and data structures to
	+randomize the input of algorithms, such that probabilistic methods can be employed without requiring
	+any assumptions about the input distribution.
	+
	+If we regard a family of hash functions from a domain $D$ to a finite range $R$ as a uniform probability
	+space, then the family is $k$-universal if:
	+\begin{itemize}
	+\item For each $x \in D$ the evaluation of the functions at $x$ forms a uniformly distributed random variable on $R$.
	+\item The evaluation random variables for $k$ or fewer distinct domain elements form an
	+independent family of random variables.
	+\end{itemize}
	+
	+This definition closely follows the definition from Vadhan~\cite[\textsection 3.5.5]{vadhan2012}, with the minor
	+modification that independence is required not only for exactly $k$, but also for \emph{fewer} than $k$ distinct
	+domain elements. The correction is due to the fact that in the corner case where $D$ has fewer than $k$ elements,
	+the second part of their definition becomes void. In the formalization this helps avoid an unnecessary assumption in
	+the theorems.
	+
	+The following definition introduces the notion of $k$-wise independent random variables:\<close>
	+
	+definition (in prob_space) k_wise_indep_vars where
	+ "k_wise_indep_vars k M' X I =
	+ (\<forall>J \<subseteq> I. card J \<le> k \<longrightarrow> finite J \<longrightarrow> indep_vars M' X J)"
	+
	+lemma (in prob_space) k_wise_indep_vars_subset:
	+ assumes "k_wise_indep_vars k M' X I"
	+ assumes "J \<subseteq> I"
	+ assumes "finite J"
	+ assumes "card J \<le> k"
	+ shows "indep_vars M' X J"
	+ using assms
	+ by (simp add:k_wise_indep_vars_def)
	+
	+text \<open>Similarly for a finite non-empty set $A$ the predicate @{term "uniform_on X A"} indicates that
	+the random variable is uniformly distributed on $A$:\<close>
	+
	+definition (in prob_space) "uniform_on X A = (
	+ distr M (count_space UNIV) X = uniform_measure (count_space UNIV) A \<and>
	+ A \<noteq> {} \<and> finite A \<and> random_variable (count_space UNIV) X)"
	+
	+lemma (in prob_space) uniform_onD:
	+ assumes "uniform_on X A"
	+ shows "prob {\<omega> \<in> space M. X \<omega> \<in> B} = card (A \<inter> B) / card A"
	+proof -
	+ have "prob {\<omega> \<in> space M. X \<omega> \<in> B} = prob (X -` B \<inter> space M)"
	+ by (subst Int_commute, simp add:vimage_def Int_def)
	+ also have "... = measure (distr M (count_space UNIV) X) B"
	+ using assms by (subst measure_distr, auto simp:uniform_on_def)
	+ also have "... = measure (uniform_measure (count_space UNIV) A) B"
	+ using assms by (simp add:uniform_on_def)
	+ also have "... = card (A \<inter> B) / card A"
	+ using assms by (subst measure_uniform_measure, auto simp:uniform_on_def)+
	+ finally show ?thesis by simp
	+qed
	+
	+text \<open>With the two previous definitions it is possible to define the $k$-universality condition for a family
	+of hash functions from $D$ to $R$:\<close>
	+
	+definition (in prob_space) "k_universal k X D R = (
	+ k_wise_indep_vars k (\<lambda>_. count_space UNIV) X D \<and>
	+ (\<forall>i \<in> D. uniform_on (X i) R))"
	+
	+text \<open>Note: The definition is slightly more generic then the informal specification from above.
	+This is because usually a family is formed by a single function with a variable seed parameter. Instead of
	+choosing a random function from a probability space, a random seed is chosen from the probability space
	+which parameterizes the hash function.
	+
	+The following section contains some preliminary results about independent families
	+of random variables.
	+Section~\ref{sec:carter_wegman} introduces the Carter-Wegman hash family, which is an
	+explicit construction of $k$-universal families for arbitrary $k$ using polynomials over finite fields.
	+The last section contains a proof that the factor ring of the integers modulo a prime ideal is a finite field,
	+followed by an isomorphic construction of prime fields over an initial segment of the natural numbers.\<close>
	+
	+end
	diff --git a/thys/Universal_Hash_Families/Field.thy b/thys/Universal_Hash_Families/Field.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Universal_Hash_Families/Field.thy
	@@ -0,0 +1,389 @@
	+section \<open>Finite Fields\<close>
	+
	+theory Field
	+ imports "HOL-Algebra.Ring_Divisibility" "HOL-Algebra.IntRing"
	+begin
	+
	+text \<open>This section contains a proof that the factor ring @{term "ZFact p"} for
	+@{term [names_short] "prime p"} is a field. Note that the bulk of the work has already been done in
	+HOL-Algebra, in particular it is established that @{term "ZFact p"} is a domain.
	+
	+However, any domain with a finite carrier is already a field. This can be seen by establishing that
	+multiplication by a non-zero element is an injective map between the elements of the carrier of the
	+domain. But an injective map between sets of the same non-finite cardinality is also surjective.
	+Hence it is possible to find the unit element in the image of such a map.
	+
	+The following definition introduces the canonical embedding of @{term "{..<(p::nat)}"} into @{term "ZFact p"}.
	+It will be shown that it is a bijection which establishes that @{term "ZFact p"} is finite.\<close>
	+
	+definition zfact_iso :: "nat \<Rightarrow> nat \<Rightarrow> int set" where
	+ "zfact_iso p k = Idl\<^bsub>\<Z>\<^esub> {int p} +>\<^bsub>\<Z>\<^esub> (int k)"
	+
	+context
	+ fixes n :: nat
	+ fixes I :: "int set"
	+ assumes n_ge_0: "n > 0"
	+ defines "I \<equiv> Idl\<^bsub>\<Z>\<^esub> {int n}"
	+begin
	+
	+lemma ideal_I: "ideal I \<Z>"
	+ unfolding I_def by (simp add: int.genideal_ideal)
	+
	+lemma zfact_iso_inj:
	+ "inj_on (zfact_iso n) {..<n}"
	+proof (rule inj_onI)
	+ fix x y
	+ assume a:"x \<in> {..<n}"
	+ assume b:"y \<in> {..<n}"
	+ assume "zfact_iso n x = zfact_iso n y"
	+ hence "I +>\<^bsub>\<Z>\<^esub> (int x) = I +>\<^bsub>\<Z>\<^esub> (int y)"
	+ by (simp add:zfact_iso_def I_def)
	+ hence "int x - int y \<in> I"
	+ by (subst int.quotient_eq_iff_same_a_r_cos[OF ideal_I], auto)
	+ hence "int x mod int n = int y mod int n"
	+ unfolding I_def
	+ by (meson Idl_subset_eq_dvd int_Idl_subset_ideal mod_eq_dvd_iff)
	+ thus "x = y"
	+ using a b by simp
	+qed
	+
	+lemma I_shift:
	+ assumes "u mod (int n) = v mod (int n)"
	+ shows "I +>\<^bsub>\<Z>\<^esub> u = I +>\<^bsub>\<Z>\<^esub> v"
	+proof -
	+ have "u - v \<in> I"
	+ unfolding I_def
	+ by (metis Idl_subset_eq_dvd assms int_Idl_subset_ideal mod_eq_dvd_iff)
	+ thus ?thesis
	+ using ideal_I int.quotient_eq_iff_same_a_r_cos by simp
	+qed
	+
	+lemma zfact_iso_ran:
	+ "zfact_iso n ` {..<n} = carrier (ZFact (int n))"
	+proof -
	+ have "zfact_iso n ` {..<n} \<subseteq> carrier (ZFact (int n))"
	+ unfolding zfact_iso_def ZFact_def FactRing_simps
	+ using int.a_rcosetsI by auto
	+ moreover have "\<And>x. x \<in> carrier (ZFact (int n)) \<Longrightarrow> x \<in> zfact_iso n ` {..<n}"
	+ proof -
	+ fix x
	+ assume "x \<in> carrier (ZFact (int n))"
	+ then obtain y where y_def: "x = I +>\<^bsub>\<Z>\<^esub> y"
	+ unfolding I_def ZFact_def FactRing_simps by auto
	+ obtain z where z_def: "(int z) mod (int n) = y mod (int n)" "z < n"
	+ by (metis Euclidean_Division.pos_mod_sign mod_mod_trivial n_ge_0 nonneg_int_cases
	+ of_nat_0_less_iff of_nat_mod unique_euclidean_semiring_numeral_class.pos_mod_bound)
	+ have "x = I +>\<^bsub>\<Z>\<^esub> y"
	+ by (simp add:y_def)
	+ also have "... = I +>\<^bsub>\<Z>\<^esub> (int z)"
	+ by (rule I_shift, simp add:z_def)
	+ also have "... = zfact_iso n z"
	+ by (simp add:zfact_iso_def I_def)
	+ finally have "x = zfact_iso n z"
	+ by simp
	+ thus "x \<in> zfact_iso n ` {..<n}"
	+ using z_def(2) by blast
	+ qed
	+ ultimately show ?thesis by auto
	+qed
	+
	+lemma zfact_iso_0: "zfact_iso n 0 = \<zero>\<^bsub>ZFact (int n)\<^esub>"
	+proof -
	+ interpret i:ideal "I" "\<Z>" using ideal_I by simp
	+ interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) I"
	+ using i.rcos_ring_hom_ring ZFact_def I_def by auto
	+
	+ show ?thesis
	+ by (simp add:zfact_iso_def ZFact_def I_def[symmetric])
	+qed
	+
	+lemma zfact_iso_bij:
	+ "bij_betw (zfact_iso n) {..<n} (carrier (ZFact (int n)))"
	+ using bij_betw_def zfact_iso_inj zfact_iso_ran by blast
	+
	+lemma zfact_card:
	+ "card (carrier (ZFact (int n))) = n"
	+ using bij_betw_same_card[OF zfact_iso_bij] by simp
	+
	+lemma zfact_finite:
	+ "finite (carrier (ZFact (int n)))"
	+ by (metis n_ge_0 zfact_card card.infinite less_nat_zero_code)
	+
	+end
	+
	+lemma finite_domains_are_fields:
	+ assumes "domain R"
	+ assumes "finite (carrier R)"
	+ shows "field R"
	+proof -
	+ interpret domain R using assms by auto
	+ have "Units R = carrier R - {\<zero>\<^bsub>R\<^esub>}"
	+ proof
	+ have "Units R \<subseteq> carrier R" by (simp add:Units_def)
	+ moreover have "\<zero>\<^bsub>R\<^esub> \<notin> Units R"
	+ by (meson assms(1) domain.zero_is_prime(1) primeE)
	+ ultimately show "Units R \<subseteq> carrier R - {\<zero>\<^bsub>R\<^esub>}" by blast
	+ next
	+ show "carrier R - {\<zero>\<^bsub>R\<^esub>} \<subseteq> Units R"
	+ proof
	+ fix x
	+ assume a:"x \<in> carrier R - {\<zero>\<^bsub>R\<^esub>}"
	+ hence x_carr: "x \<in> carrier R" by blast
	+ define f where "f = (\<lambda>y. y \<otimes>\<^bsub>R\<^esub> x)"
	+ have "inj_on f (carrier R)" unfolding f_def
	+ by (rule inj_onI, metis DiffD1 DiffD2 a assms(1) domain.m_rcancel insertI1)
	+ hence "card (carrier R) = card (f ` carrier R)"
	+ by (metis card_image)
	+ moreover have "f ` carrier R \<subseteq> carrier R" unfolding f_def
	+ by (rule image_subsetI, simp add: ring.ring_simprules x_carr)
	+ ultimately have "f ` carrier R = carrier R"
	+ using card_subset_eq assms(2) by metis
	+ moreover have "\<one>\<^bsub>R\<^esub> \<in> carrier R" by simp
	+ ultimately have "\<exists>y \<in> carrier R. f y = \<one>\<^bsub>R\<^esub>"
	+ by (metis image_iff)
	+ then obtain y where y_carrier: "y \<in> carrier R" and y_left_inv: "y \<otimes>\<^bsub>R\<^esub> x = \<one>\<^bsub>R\<^esub>"
	+ using f_def by blast
	+ hence y_right_inv: "x \<otimes>\<^bsub>R\<^esub> y = \<one>\<^bsub>R\<^esub>" using assms(1) a
	+ by (metis DiffD1 a cring.cring_simprules(14) domain.axioms(1))
	+ show "x \<in> Units R" using y_carrier y_left_inv y_right_inv
	+ by (metis DiffD1 a assms(1) cring.divides_one domain.axioms(1) factor_def)
	+ qed
	+ qed
	+ then show "field R" by (simp add: assms(1) field.intro field_axioms.intro)
	+qed
	+
	+lemma zfact_prime_is_field:
	+ assumes "Factorial_Ring.prime (p :: nat)"
	+ shows "field (ZFact (int p))"
	+proof -
	+ have "finite (carrier (ZFact (int p)))"
	+ using zfact_finite assms prime_gt_0_nat by blast
	+ moreover have "domain (ZFact (int p))"
	+ using ZFact_prime_is_domain assms by auto
	+ ultimately show ?thesis
	+ using finite_domains_are_fields by blast
	+qed
	+
	+text \<open>In some applications it is more convenient to work with natural numbers instead of
	+@{term "ZFact p"} whose elements are cosets. To support that use case the following definition
	+introduces an additive and multiplicative structure on @{term "{..<p}"}. After verifying that
	+the function @{term "zfact_iso"} and its inverse are homomorphisms, the ring and field property
	+can be transfered from @{term "ZFact p"} to to the structure on @{term "{..<p}"}.\<close>
	+
	+definition mod_ring :: "nat => nat ring"
	+ where "mod_ring n = \<lparr>
	+ carrier = {..<n},
	+ mult = (\<lambda> x y. (x * y) mod n),
	+ one = 1,
	+ zero = 0,
	+ add = (\<lambda> x y. (x + y) mod n) \<rparr>"
	+
	+definition zfact_iso_inv :: "nat \<Rightarrow> int set \<Rightarrow> nat" where
	+ "zfact_iso_inv p = inv_into {..<p} (zfact_iso p)"
	+
	+lemma zfact_iso_inv_0:
	+ assumes n_ge_0: "n > 0"
	+ shows "zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> = 0"
	+ unfolding zfact_iso_inv_def zfact_iso_0[OF n_ge_0, symmetric] using n_ge_0
	+ by (rule inv_into_f_f[OF zfact_iso_inj], simp add:mod_ring_def)
	+
	+lemma zfact_coset:
	+ assumes n_ge_0: "n > 0"
	+ assumes "x \<in> carrier (ZFact (int n))"
	+ defines "I \<equiv> Idl\<^bsub>\<Z>\<^esub> {int n}"
	+ shows "x = I +>\<^bsub>\<Z>\<^esub> (int (zfact_iso_inv n x))"
	+proof -
	+ have "x \<in> zfact_iso n ` {..<n}"
	+ using assms zfact_iso_ran by simp
	+ hence "zfact_iso n (zfact_iso_inv n x) = x"
	+ unfolding zfact_iso_inv_def by (rule f_inv_into_f)
	+ thus ?thesis unfolding zfact_iso_def I_def by blast
	+qed
	+
	+lemma zfact_iso_inv_is_ring_iso:
	+ assumes n_ge_1: "n > 1"
	+ shows "zfact_iso_inv n \<in> ring_iso (ZFact (int n)) (mod_ring n)"
	+proof (rule ring_iso_memI)
	+ interpret r:cring "(ZFact (int n))"
	+ using ZFact_is_cring by simp
	+
	+ define I where "I = Idl\<^bsub>\<Z>\<^esub> {int n}"
	+
	+ have n_ge_0: "n > 0" using n_ge_1 by simp
	+
	+ interpret i:ideal "I" "\<Z>"
	+ using ideal_I[OF n_ge_0] I_def by simp
	+
	+ interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) I"
	+ using i.rcos_ring_hom_ring ZFact_def I_def by auto
	+
	+ show
	+ "\<And>x. x \<in> carrier (ZFact (int n)) \<Longrightarrow> zfact_iso_inv n x \<in> carrier (mod_ring n)"
	+ proof -
	+ fix x
	+ assume "x \<in> carrier (ZFact (int n))"
	+ hence "zfact_iso_inv n x \<in> {..<n}"
	+ unfolding zfact_iso_inv_def
	+ using zfact_iso_ran[OF n_ge_0] inv_into_into by metis
	+
	+ thus "zfact_iso_inv n x \<in> carrier (mod_ring n)"
	+ unfolding mod_ring_def by simp
	+ qed
	+
	+ show "\<And>x y. x \<in> carrier (ZFact (int n)) \<Longrightarrow> y \<in> carrier (ZFact (int n)) \<Longrightarrow>
	+ zfact_iso_inv n (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) =
	+ zfact_iso_inv n x \<otimes>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
	+ proof -
	+ fix x y
	+ assume x_carr: "x \<in> carrier (ZFact (int n))"
	+ define x' where "x' = zfact_iso_inv n x"
	+ assume y_carr: "y \<in> carrier (ZFact (int n))"
	+ define y' where "y' = zfact_iso_inv n y"
	+ have "x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<otimes>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
	+ unfolding x'_def y'_def
	+ using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
	+ also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' * int y'))"
	+ by simp
	+ also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' * y') mod n)))"
	+ unfolding I_def zmod_int by (rule I_shift[OF n_ge_0],simp)
	+ also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<otimes>\<^bsub>mod_ring n\<^esub> y'))"
	+ unfolding mod_ring_def by simp
	+ also have "... = zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')"
	+ unfolding zfact_iso_def I_def by simp
	+ finally have a:"x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')"
	+ by simp
	+ have b:"x' \<otimes>\<^bsub>mod_ring n\<^esub> y' \<in> {..<n}"
	+ using mod_ring_def n_ge_0 by auto
	+ have "zfact_iso_inv n (zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')) = x' \<otimes>\<^bsub>mod_ring n\<^esub> y'"
	+ unfolding zfact_iso_inv_def
	+ by (rule inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
	+ thus
	+ "zfact_iso_inv n (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) =
	+ zfact_iso_inv n x \<otimes>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
	+ using a x'_def y'_def by simp
	+ qed
	+
	+ show "\<And>x y. x \<in> carrier (ZFact (int n)) \<Longrightarrow> y \<in> carrier (ZFact (int n)) \<Longrightarrow>
	+ zfact_iso_inv n (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) =
	+ zfact_iso_inv n x \<oplus>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
	+ proof -
	+ fix x y
	+ assume x_carr: "x \<in> carrier (ZFact (int n))"
	+ define x' where "x' = zfact_iso_inv n x"
	+ assume y_carr: "y \<in> carrier (ZFact (int n))"
	+ define y' where "y' = zfact_iso_inv n y"
	+ have "x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<oplus>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
	+ unfolding x'_def y'_def
	+ using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
	+ also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' + int y'))"
	+ by simp
	+ also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' + y') mod n)))"
	+ unfolding I_def zmod_int by (rule I_shift[OF n_ge_0],simp)
	+ also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<oplus>\<^bsub>mod_ring n\<^esub> y'))"
	+ unfolding mod_ring_def by simp
	+ also have "... = zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')"
	+ unfolding zfact_iso_def I_def by simp
	+ finally have a:"x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')"
	+ by simp
	+ have b:"x' \<oplus>\<^bsub>mod_ring n\<^esub> y' \<in> {..<n}"
	+ using mod_ring_def n_ge_0 by auto
	+ have "zfact_iso_inv n (zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')) = x' \<oplus>\<^bsub>mod_ring n\<^esub> y'"
	+ unfolding zfact_iso_inv_def
	+ by (rule inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
	+ thus
	+ "zfact_iso_inv n (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) =
	+ zfact_iso_inv n x \<oplus>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
	+ using a x'_def y'_def by simp
	+ qed
	+
	+ have "\<one>\<^bsub>ZFact (int n)\<^esub> = zfact_iso n (\<one>\<^bsub>mod_ring n\<^esub>)"
	+ by (simp add:zfact_iso_def ZFact_def I_def[symmetric] mod_ring_def)
	+
	+ thus "zfact_iso_inv n \<one>\<^bsub>ZFact (int n)\<^esub> = \<one>\<^bsub>mod_ring n\<^esub>"
	+ unfolding zfact_iso_inv_def mod_ring_def
	+ using inv_into_f_f[OF zfact_iso_inj] n_ge_1 by simp
	+
	+ show "bij_betw (zfact_iso_inv n) (carrier (ZFact (int n))) (carrier (mod_ring n))"
	+ using zfact_iso_inv_def mod_ring_def zfact_iso_bij[OF n_ge_0] bij_betw_inv_into
	+ by force
	+qed
	+
	+lemma mod_ring_finite:
	+ "finite (carrier (mod_ring n))"
	+ by (simp add:mod_ring_def)
	+
	+lemma mod_ring_carr:
	+ "x \<in> carrier (mod_ring n) \<longleftrightarrow> x < n"
	+ by (simp add:mod_ring_def)
	+
	+lemma mod_ring_is_cring:
	+ assumes n_ge_1: "n > 1"
	+ shows "cring (mod_ring n)"
	+proof -
	+ have n_ge_0: "n > 0" using n_ge_1 by simp
	+
	+ interpret cring "ZFact (int n)"
	+ using ZFact_is_cring by simp
	+
	+ have "cring ((mod_ring n) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr>)"
	+ by (rule ring_iso_imp_img_cring[OF zfact_iso_inv_is_ring_iso[OF n_ge_1]])
	+ moreover have
	+ "(mod_ring n) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr> = mod_ring n"
	+ using zfact_iso_inv_0[OF n_ge_0]
	+ by (simp add:mod_ring_def)
	+ ultimately show ?thesis by simp
	+qed
	+
	+lemma zfact_iso_is_ring_iso:
	+ assumes n_ge_1: "n > 1"
	+ shows "zfact_iso n \<in> ring_iso (mod_ring n) (ZFact (int n))"
	+proof -
	+ have r:"ring (ZFact (int n))"
	+ using ZFact_is_cring cring.axioms(1) by blast
	+
	+ interpret s: ring "(mod_ring n)"
	+ using mod_ring_is_cring cring.axioms(1) n_ge_1 by blast
	+ have n_ge_0: "n > 0" using n_ge_1 by linarith
	+
	+ have
	+ "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n)
	+ \<in> ring_iso (mod_ring n) (ZFact (int n))"
	+ using ring_iso_set_sym[OF r zfact_iso_inv_is_ring_iso[OF n_ge_1]] by simp
	+ moreover have "\<And>x. x \<in> carrier (mod_ring n) \<Longrightarrow>
	+ inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
	+ proof -
	+ fix x
	+ assume "x \<in> carrier (mod_ring n)"
	+ hence "x \<in> {..<n}" by (simp add:mod_ring_def)
	+ thus "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
	+ unfolding zfact_iso_inv_def
	+ by (simp add:inv_into_inv_into_eq[OF zfact_iso_bij[OF n_ge_0]])
	+ qed
	+
	+ ultimately show ?thesis
	+ using s.ring_iso_restrict by blast
	+qed
	+
	+text \<open>If @{term "p"} is a prime than @{term "mod_ring p"} is a field:\<close>
	+
	+lemma mod_ring_is_field:
	+ assumes"Factorial_Ring.prime p"
	+ shows "field (mod_ring p)"
	+proof -
	+ have p_ge_0: "p > 0" using assms prime_gt_0_nat by blast
	+ have p_ge_1: "p > 1" using assms prime_gt_1_nat by blast
	+
	+ interpret field "ZFact (int p)"
	+ using zfact_prime_is_field[OF assms] by simp
	+
	+ have "field ((mod_ring p) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr>)"
	+ by (rule ring_iso_imp_img_field[OF zfact_iso_inv_is_ring_iso[OF p_ge_1]])
	+
	+ moreover have
	+ "(mod_ring p) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr> = mod_ring p"
	+ using zfact_iso_inv_0[OF p_ge_0]
	+ by (simp add:mod_ring_def)
	+ ultimately show ?thesis by simp
	+qed
	+
	+end
	diff --git a/thys/Universal_Hash_Families/Preliminary_Results.thy b/thys/Universal_Hash_Families/Preliminary_Results.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Universal_Hash_Families/Preliminary_Results.thy
	@@ -0,0 +1,346 @@
	+section \<open>Preliminary Results\<close>
	+
	+theory Preliminary_Results
	+ imports
	+ "Definitions"
	+ "HOL-Probability.Stream_Space"
	+ "HOL-Probability.Probability_Mass_Function"
	+begin
	+
	+lemma set_comp_image_cong:
	+ assumes "\<And>x. P x \<Longrightarrow> f x = h (g x)"
	+ shows "{f x\| x. P x} = h ` {g x\| x. P x}"
	+ using assms by (auto simp: setcompr_eq_image)
	+
	+lemma (in prob_space) k_wise_indep_vars_compose:
	+ assumes "k_wise_indep_vars k M' X I"
	+ assumes "\<And>i. i \<in> I \<Longrightarrow> Y i \<in> measurable (M' i) (N i)"
	+ shows "k_wise_indep_vars k N (\<lambda>i x. Y i (X i x)) I"
	+ using indep_vars_compose2[where N="N" and X="X" and Y="Y" and M'="M'"] assms
	+ by (simp add: k_wise_indep_vars_def subsetD)
	+
	+text \<open>The following two lemmas are of independent interest, they help infer independence of events
	+and random variables on distributions. (Candidates for
	+@{theory "HOL-Probability.Independent_Family"}).\<close>
	+
	+lemma (in prob_space) indep_sets_distr:
	+ fixes A
	+ assumes "random_variable N f"
	+ defines "F \<equiv> (\<lambda>i. (\<lambda>a. f -` a \<inter> space M) ` A i)"
	+ assumes indep_F: "indep_sets F I"
	+ assumes sets_A: "\<And>i. i \<in> I \<Longrightarrow> A i \<subseteq> sets N"
	+ shows "prob_space.indep_sets (distr M N f) A I"
	+proof (rule prob_space.indep_setsI)
	+ show "\<And>A' J. J \<noteq> {} \<Longrightarrow> J \<subseteq> I \<Longrightarrow> finite J \<Longrightarrow> \<forall>j\<in>J. A' j \<in> A j \<Longrightarrow>
	+ measure (distr M N f) (\<Inter> (A' ` J)) = (\<Prod>j\<in>J. measure (distr M N f) (A' j))"
	+ proof -
	+ fix A' J
	+ assume a:"J \<subseteq> I" "finite J" "J \<noteq> {}" "\<forall>j \<in> J. A' j \<in> A j"
	+
	+ define F' where "F' = (\<lambda>i. f -` A' i \<inter> space M)"
	+
	+ have "\<Inter> (F' ` J) = f -` (\<Inter> (A' ` J)) \<inter> space M"
	+ unfolding set_eq_iff F'_def using a(3) by simp
	+ moreover have "\<Inter> (A' ` J) \<in> sets N"
	+ by (metis a sets_A sets.finite_INT subset_iff)
	+ ultimately have b:
	+ "measure (distr M N f) (\<Inter> (A' ` J)) = measure M (\<Inter> (F' ` J))"
	+ by (metis assms(1) measure_distr)
	+
	+ have "\<And>j. j \<in> J \<Longrightarrow> F' j \<in> F j"
	+ using a(4) F'_def F_def by blast
	+ hence c:"measure M (\<Inter> (F' ` J)) = (\<Prod>j\<in> J. measure M (F' j))"
	+ by (metis indep_F indep_setsD a(1,2,3))
	+
	+ have "\<And>j. j \<in> J \<Longrightarrow> F' j = f -` A' j \<inter> space M"
	+ by (simp add:F'_def)
	+ moreover have "\<And>j. j \<in> J \<Longrightarrow> A' j \<in> sets N"
	+ using a(1,4) sets_A by blast
	+ ultimately have d:
	+ "\<And>j. j \<in> J \<Longrightarrow> measure M (F' j) = measure (distr M N f) (A' j)"
	+ using assms(1) measure_distr by metis
	+
	+ show
	+ "measure (distr M N f) (\<Inter> (A' ` J)) = (\<Prod>j\<in>J. measure (distr M N f) (A' j))"
	+ using b c d by auto
	+ qed
	+ show "prob_space (distr M N f)" using prob_space_distr assms by blast
	+ show "\<And>i. i \<in> I \<Longrightarrow> A i \<subseteq> sets (distr M N f)" using sets_A sets_distr by blast
	+qed
	+
	+lemma (in prob_space) indep_vars_distr:
	+ assumes "f \<in> measurable M N"
	+ assumes "\<And>i. i \<in> I \<Longrightarrow> X' i \<in> measurable N (M' i)"
	+ assumes "indep_vars M' (\<lambda>i. (X' i) \<circ> f) I"
	+ shows "prob_space.indep_vars (distr M N f) M' X' I"
	+proof -
	+ interpret D: prob_space "(distr M N f)"
	+ using prob_space_distr[OF assms(1)] by simp
	+
	+ have a: "f \<in> space M \<rightarrow> space N" using assms(1) by (simp add:measurable_def)
	+
	+ have "D.indep_sets (\<lambda>i. {X' i -` A \<inter> space N \|A. A \<in> sets (M' i)}) I"
	+ proof (rule indep_sets_distr[OF assms(1)])
	+ have "\<And>i. i \<in> I \<Longrightarrow> {(X' i \<circ> f) -` A \<inter> space M \|A. A \<in> sets (M' i)} =
	+ (\<lambda>a. f -` a \<inter> space M) ` {X' i -` A \<inter> space N \|A. A \<in> sets (M' i)}"
	+ by (rule set_comp_image_cong, simp add:set_eq_iff, use a in blast)
	+ thus "indep_sets (\<lambda>i. (\<lambda>a. f -` a \<inter> space M) `
	+ {X' i -` A \<inter> space N \|A. A \<in> sets (M' i)}) I"
	+ using assms(3) by (simp add:indep_vars_def2 cong:indep_sets_cong)
	+ next
	+ fix i
	+ assume "i \<in> I"
	+ thus "{X' i -` A \<inter> space N \|A. A \<in> sets (M' i)} \<subseteq> sets N"
	+ using assms(2) measurable_sets by blast
	+ qed
	+ thus ?thesis
	+ using assms by (simp add:D.indep_vars_def2)
	+qed
	+
	+lemma range_inter: "range ((\<inter>) F) = Pow F"
	+ unfolding image_def by auto
	+
	+text \<open>The singletons and the empty set form an intersection stable generator of a countable
	+discrete $\sigma$-algebra:\<close>
	+
	+lemma sigma_sets_singletons_and_empty:
	+ assumes "countable M"
	+ shows "sigma_sets M (insert {} ((\<lambda>k. {k}) ` M)) = Pow M"
	+proof -
	+ have "sigma_sets M ((\<lambda>k. {k}) ` M) = Pow M"
	+ using assms sigma_sets_singletons by auto
	+ hence "Pow M \<subseteq> sigma_sets M (insert {} ((\<lambda>k. {k}) ` M))"
	+ by (metis sigma_sets_subseteq subset_insertI)
	+ moreover have "(insert {} ((\<lambda>k. {k}) ` M)) \<subseteq> Pow M" by blast
	+ hence "sigma_sets M (insert {} ((\<lambda>k. {k}) ` M)) \<subseteq> Pow M"
	+ by (meson sigma_algebra.sigma_sets_subset sigma_algebra_Pow)
	+ ultimately show ?thesis by force
	+qed
	+
	+text \<open>In some of the following theorems, the premise @{term "M = measure_pmf p"} is used. This allows stating
	+theorems that hold for pmfs more concisely, for example, instead of
	+@{term "measure_pmf.prob p A \<le> measure_pmf.prob p B"} we can
	+just write @{term "M = measure_pmf p \<Longrightarrow> prob A \<le> prob B"} in the locale @{locale "prob_space"}.\<close>
	+
	+lemma prob_space_restrict_space:
	+ assumes [simp]:"M = measure_pmf p"
	+ shows "prob_space (restrict_space M (set_pmf p))"
	+ by (rule prob_spaceI, auto simp:emeasure_restrict_space emeasure_pmf)
	+
	+text \<open>The abbreviation below is used to specify the discrete $\sigma$-algebra on @{term "UNIV"}
	+as a measure space. It is used in places where the existing definitions, such as @{term "indep_vars"},
	+expect a measure space even though only a \emph{measurable} space is really needed, i.e., in cases
	+where the property is invariant with respect to the actual measure.\<close>
	+
	+abbreviation "discrete \<equiv> count_space UNIV"
	+
	+lemma (in prob_space) indep_vars_restrict_space:
	+ assumes [simp]:"M = measure_pmf p"
	+ assumes
	+ "prob_space.indep_vars (restrict_space M (set_pmf p)) (\<lambda>_. discrete) X I"
	+ shows "indep_vars (\<lambda>_. discrete) X I"
	+proof -
	+ have a: "id \<in> restrict_space M (set_pmf p) \<rightarrow>\<^sub>M M"
	+ by (simp add:measurable_def range_inter sets_restrict_space)
	+
	+ have "prob_space.indep_vars (distr (restrict_space M (set_pmf p)) M id) (\<lambda>_. discrete) X I"
	+ using assms a prob_space_restrict_space by (auto intro!:prob_space.indep_vars_distr)
	+ moreover have
	+ "\<And>A. emeasure (distr (restrict_space M (set_pmf p)) M id) A = emeasure M A"
	+ using emeasure_distr[OF a]
	+ by (auto simp add: emeasure_restrict_space emeasure_Int_set_pmf)
	+ hence "distr (restrict_space M p) M id = M"
	+ by (auto intro: measure_eqI)
	+ ultimately show ?thesis by simp
	+qed
	+
	+lemma (in prob_space) measure_pmf_eq:
	+ assumes "M = measure_pmf p"
	+ assumes "\<And>x. x \<in> set_pmf p \<Longrightarrow> (x \<in> P) = (x \<in> Q)"
	+ shows "prob P = prob Q"
	+ unfolding assms(1)
	+ by (rule measure_eq_AE, rule AE_pmfI[OF assms(2)], auto)
	+
	+text \<open>The following lemma is an intro rule for the independence of random variables defined on pmfs.
	+In that case it is possible, to check the independence of random variables point-wise.
	+
	+The proof relies on the fact that the support of a pmf is countable and the $\sigma$-algebra of
	+such a set can be generated by singletons.\<close>
	+
	+lemma (in prob_space) indep_vars_pmf:
	+ assumes [simp]:"M = measure_pmf p"
	+ assumes "\<And>a J. J \<subseteq> I \<Longrightarrow> finite J \<Longrightarrow>
	+ prob {\<omega>. \<forall>i \<in> J. X i \<omega> = a i} = (\<Prod>i \<in> J. prob {\<omega>. X i \<omega> = a i})"
	+ shows "indep_vars (\<lambda>_. discrete) X I"
	+proof -
	+ interpret R:prob_space "(restrict_space M (set_pmf p))"
	+ using prob_space_restrict_space by auto
	+
	+ have events_eq_pow: "R.events = Pow (set_pmf p)"
	+ by (simp add:sets_restrict_space range_inter)
	+
	+ define G where "G = (\<lambda>i. {{}} \<union> (\<lambda>x. {x}) ` (X i ` set_pmf p))"
	+ define F where "F = (\<lambda>i. {X i -` a \<inter> set_pmf p\|a. a \<in> G i})"
	+
	+ have sigma_sets_pow:
	+ "\<And>i. i \<in> I \<Longrightarrow> sigma_sets (X i ` set_pmf p) (G i) = Pow (X i ` set_pmf p)"
	+ by (simp add:G_def, metis countable_image countable_set_pmf sigma_sets_singletons_and_empty)
	+
	+ have F_in_events: "\<And>i. i \<in> I \<Longrightarrow> F i \<subseteq> Pow (set_pmf p)"
	+ unfolding F_def by blast
	+
	+ have as_sigma_sets:
	+ "\<And>i. i \<in> I \<Longrightarrow> {u. \<exists>A. u = X i -` A \<inter> set_pmf p} = sigma_sets (set_pmf p) (F i)"
	+ proof -
	+ fix i
	+ assume a:"i \<in> I"
	+ have "\<And>A. X i -` A \<inter> set_pmf p = X i -` (A \<inter> X i ` set_pmf p) \<inter> set_pmf p"
	+ by auto
	+ hence "{u. \<exists>A. u = X i -` A \<inter> set_pmf p} =
	+ {X i -` A \<inter> set_pmf p \|A. A \<subseteq> X i ` set_pmf p}"
	+ by (metis (no_types, opaque_lifting) inf_le2)
	+ also have
	+ "... = {X i -` A \<inter> set_pmf p \|A. A \<in> sigma_sets (X i ` set_pmf p) (G i)}"
	+ using a by (simp add:sigma_sets_pow)
	+ also have "... = sigma_sets (set_pmf p) {X i -` a \<inter> set_pmf p \|a. a \<in> G i}"
	+ by (subst sigma_sets_vimage_commute[symmetric], auto)
	+ also have "... = sigma_sets (set_pmf p) (F i)"
	+ by (simp add:F_def)
	+ finally show
	+ "{u. \<exists>A. u = X i -` A \<inter> set_pmf p} = sigma_sets (set_pmf p) (F i)"
	+ by simp
	+ qed
	+
	+ have F_Int_stable: "\<And>i. i \<in> I \<Longrightarrow> Int_stable (F i)"
	+ proof (rule Int_stableI)
	+ fix i a b
	+ assume "i \<in> I" "a \<in> F i" "b \<in> F i"
	+ thus "a \<inter> b \<in> (F i)"
	+ unfolding F_def G_def by (cases "a \<inter> b = {}", auto)
	+ qed
	+
	+ have F_indep_sets:"R.indep_sets F I"
	+ proof (rule R.indep_setsI)
	+ fix i
	+ assume "i \<in> I"
	+ show "F i \<subseteq> R.events"
	+ unfolding F_def events_eq_pow by blast
	+ next
	+ fix A
	+ fix J
	+ assume a:"J \<subseteq> I" "J \<noteq> {}" "finite J" "\<forall>j\<in>J. A j \<in> F j"
	+ have b: "\<And>j. j \<in> J \<Longrightarrow> A j \<subseteq> set_pmf p"
	+ by (metis PowD a(1,4) subsetD F_in_events)
	+ obtain x where x_def:"\<And>j. j \<in> J \<Longrightarrow> A j = X j -` x j \<inter> set_pmf p \<and> x j \<in> G j"
	+ using a by (simp add:Pi_def F_def, metis)
	+
	+ show "R.prob (\<Inter> (A ` J)) = (\<Prod>j\<in>J. R.prob (A j))"
	+ proof (cases "\<exists>j \<in> J. A j = {}")
	+ case True
	+ hence "\<Inter> (A ` J) = {}" by blast
	+ then show ?thesis
	+ using a True by (simp, metis measure_empty)
	+ next
	+ case False
	+ then have "\<And>j. j \<in> J \<Longrightarrow> x j \<noteq> {}" using x_def by auto
	+ hence "\<And>j. j \<in> J \<Longrightarrow> x j \<in> (\<lambda>x. {x}) ` X j ` set_pmf p"
	+ using x_def by (simp add:G_def)
	+ then obtain y where y_def: "\<And>j. j \<in> J \<Longrightarrow> x j = {y j}"
	+ by (simp add:image_def, metis)
	+
	+ have "\<Inter> (A ` J) \<subseteq> set_pmf p" using b a(2) by blast
	+ hence "R.prob (\<Inter> (A ` J)) = prob (\<Inter> j \<in> J. A j)"
	+ by (simp add: measure_restrict_space)
	+ also have "... = prob ({\<omega>. \<forall>j \<in> J. X j \<omega> = y j})"
	+ using a x_def y_def apply (simp add:vimage_def measure_Int_set_pmf)
	+ by (rule arg_cong2 [where f="measure"], auto)
	+ also have "... = (\<Prod> j\<in> J. prob (A j))"
	+ using x_def y_def a assms(2)
	+ by (simp add:vimage_def measure_Int_set_pmf)
	+ also have "... = (\<Prod>j\<in>J. R.prob (A j))"
	+ using b by (simp add: measure_restrict_space cong:prod.cong)
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ have "R.indep_sets (\<lambda>i. sigma_sets (set_pmf p) (F i)) I"
	+ using R.indep_sets_sigma[simplified] F_Int_stable F_indep_sets
	+ by (auto simp:space_restrict_space)
	+
	+ hence "R.indep_sets (\<lambda>i. {u. \<exists>A. u = X i -` A \<inter> set_pmf p}) I"
	+ by (simp add: as_sigma_sets cong:R.indep_sets_cong)
	+
	+ hence "R.indep_vars (\<lambda>_. discrete) X I"
	+ unfolding R.indep_vars_def2
	+ by (simp add:measurable_def sets_restrict_space range_inter)
	+
	+ thus ?thesis
	+ using indep_vars_restrict_space[OF assms(1)] by simp
	+qed
	+
	+lemma (in prob_space) split_indep_events:
	+ assumes "M = measure_pmf p"
	+ assumes "indep_vars (\<lambda>i. discrete) X' I"
	+ assumes "K \<subseteq> I" "finite K"
	+ shows "prob {\<omega>. \<forall>x \<in> K. P x (X' x \<omega>)} = (\<Prod>x \<in> K. prob {\<omega>. P x (X' x \<omega>)})"
	+proof -
	+ have [simp]: "space M = UNIV" "events = UNIV" "prob UNIV = 1"
	+ by (simp add:assms(1))+
	+
	+ have "indep_vars (\<lambda>_. discrete) X' K"
	+ using assms(2,3) indep_vars_subset by blast
	+ hence "indep_events (\<lambda>x. {\<omega> \<in> space M. P x (X' x \<omega>)}) K"
	+ using indep_eventsI_indep_vars by force
	+ hence a:"indep_events (\<lambda>x. {\<omega>. P x (X' x \<omega>)}) K"
	+ by simp
	+
	+ have "prob {\<omega>. \<forall>x \<in> K. P x (X' x \<omega>)} = prob (\<Inter>x \<in> K. {\<omega>. P x (X' x \<omega>)})"
	+ by (simp add: measure_pmf_eq[OF assms(1)])
	+ also have "... = (\<Prod> x \<in> K. prob {\<omega>. P x (X' x \<omega>)})"
	+ using a assms(4) by (cases "K = {}", auto simp: indep_events_def)
	+ finally show ?thesis by simp
	+qed
	+
	+lemma pmf_of_set_eq_uniform:
	+ assumes "finite A" "A \<noteq> {}"
	+ shows "measure_pmf (pmf_of_set A) = uniform_measure discrete A"
	+proof -
	+ have a:"real (card A) > 0" using assms
	+ by (simp add: card_gt_0_iff)
	+
	+ have b:
	+ "\<And>Y. emeasure (pmf_of_set A) Y = emeasure (uniform_measure discrete A) Y"
	+ using assms a
	+ by (simp add: emeasure_pmf_of_set divide_ennreal ennreal_of_nat_eq_real_of_nat)
	+
	+ show ?thesis
	+ by (rule measure_eqI, auto simp add: b)
	+qed
	+
	+lemma (in prob_space) uniform_onI:
	+ assumes "M = measure_pmf p"
	+ assumes "finite A" "A \<noteq> {}"
	+ assumes "\<And>a. prob {\<omega>. X \<omega> = a} = indicator A a / card A"
	+ shows "uniform_on X A"
	+proof -
	+ have a:"\<And>a. measure_pmf.prob p {x. X x = a} = indicator A a / card A"
	+ using assms(1,4) by simp
	+
	+ have b:"map_pmf X p = pmf_of_set A"
	+ by (rule pmf_eqI, simp add:assms pmf_map vimage_def a)
	+
	+ have "distr M discrete X = map_pmf X p"
	+ by (simp add: map_pmf_rep_eq assms(1))
	+ also have "... = measure_pmf (pmf_of_set A)"
	+ using b by simp
	+ also have "... = uniform_measure discrete A"
	+ by (rule pmf_of_set_eq_uniform[OF assms(2,3)])
	+ finally have "distr M discrete X = uniform_measure discrete A"
	+ by simp
	+ moreover have "random_variable discrete X"
	+ by (simp add: assms(1))
	+ ultimately show ?thesis using assms(2,3)
	+ by (simp add: uniform_on_def)
	+qed
	+
	+end
	diff --git a/thys/Universal_Hash_Families/ROOT b/thys/Universal_Hash_Families/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Universal_Hash_Families/ROOT
	@@ -0,0 +1,15 @@
	+chapter AFP
	+
	+session Universal_Hash_Families (AFP) = "HOL-Probability" +
	+ options [timeout = 600]
	+ sessions
	+ "HOL-Algebra"
	+ "Interpolation_Polynomials_HOL_Algebra"
	+ theories
	+ Definitions
	+ Preliminary_Results
	+ Carter_Wegman_Hash_Family
	+ Field
	+ document_files
	+ "root.tex"
	+ "root.bib"
	diff --git a/thys/Universal_Hash_Families/document/root.bib b/thys/Universal_Hash_Families/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Universal_Hash_Families/document/root.bib
	@@ -0,0 +1,49 @@
	+@article{wegman1981,
	+ title = {New hash functions and their use in authentication and set equality},
	+ journal = {Journal of Computer and System Sciences},
	+ volume = {22},
	+ number = {3},
	+ pages = {265--279},
	+ year = {1981},
	+ issn = {0022-0000},
	+ _doi = {https://doi.org/10.1016/0022-0000(81)90033-7},
	+ _url = {https://www.sciencedirect.com/science/article/pii/0022000081900337},
	+ author = {Mark N. Wegman and J. Lawrence Carter},
	+}
	+
	+@article{Interpolation_Polynomials_HOL_Algebra-AFP,
	+ author = {Emin Karayel},
	+ title = {Interpolation Polynomials (in HOL-Algebra)},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Interpolation_Polynomials_HOL_Algebra.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+
	+@inproceedings{thorup2010,
	+ author = {Thorup, Mikkel and Zhang, Yin},
	+ title = {Tabulation Based 5-Universal Hashing and Linear Probing},
	+ year = {2010},
	+ publisher = {Society for Industrial and Applied Mathematics},
	+ address = {USA},
	+ booktitle = {Proceedings of the Meeting on Algorithm Engineering \& Expermiments},
	+ pages = {62--76},
	+ numpages = {15},
	+ location = {Austin, Texas},
	+ series = {ALENEX '10}
	+}
	+
	+@article{vadhan2012,
	+ _url = {http://dx.doi.org/10.1561/0400000010},
	+ year = {2012},
	+ volume = {7},
	+ journal = {Foundations and Trends\textregistered in Theoretical Computer Science},
	+ title = {Pseudorandomness},
	+ _doi = {10.1561/0400000010},
	+ issn = {1551-305X},
	+ number = {1-3},
	+ pages = {1--336},
	+ author = {Salil P. Vadhan}
	+}
	diff --git a/thys/Universal_Hash_Families/document/root.tex b/thys/Universal_Hash_Families/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Universal_Hash_Families/document/root.tex
	@@ -0,0 +1,44 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amssymb}
	+\usepackage{pdfsetup}
	+
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+\begin{document}
	+
	+\title{Universal Hash Families}
	+\author{Emin Karayel}
	+\maketitle
	+
	+\begin{abstract}
	+A $k$-universal hash family is a probability space of functions, which have uniform distribution and
	+form $k$-wise independent random variables.
	+
	+They can often be used in place of classic (or cryptographic) hash functions and allow the
	+rigorous analysis of the performance of randomized algorithms and data structures that
	+rely on hash functions.
	+
	+In 1981 Wegman and Carter~\cite{wegman1981} introduced a generic construction for such
	+families with arbitrary $k$ using polynomials over a finite field. This entry contains a formalization
	+of them and establishes the property of $k$-universality.
	+
	+To be useful the formalization also provides an explicit construction of finite fields using the
	+factor ring of integers modulo a prime. Additionally, some generic results about independent
	+families are shown that might be of independent interest.
	+\end{abstract}
	+
	+\parindent 0pt\parskip 0.5ex
	+
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+\end{document}
	+
	+%%% Local Variables:
	+%%% mode: latex
	+%%% TeX-master: t
	+%%% End:
	diff --git a/thys/VYDRA_MDL/Interval.thy b/thys/VYDRA_MDL/Interval.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Interval.thy
	@@ -0,0 +1,107 @@
	+(<)
	+theory Interval
	+ imports "HOL-Library.Product_Lexorder" Timestamp
	+begin
	+(>)
	+
	+section \<open>Intervals\<close>
	+
	+typedef (overloaded) ('a :: timestamp) \<I> = "{(i :: 'a, j :: 'a, lei :: bool, lej :: bool). 0 \<le> i \<and> i \<le> j \<and> i \<in> tfin \<and> \<not>(j = 0 \<and> \<not>lej)}"
	+ by (intro exI[of _ "(0, 0, True, True)"]) (auto intro: zero_tfin)
	+
	+setup_lifting type_definition_\<I>
	+
	+instantiation \<I> :: (timestamp) equal begin
	+
	+lift_definition equal_\<I> :: "'a \<I> \<Rightarrow> 'a \<I> \<Rightarrow> bool" is "(=)" .
	+
	+instance by standard (transfer, auto)
	+
	+end
	+
	+lift_definition right :: "'a :: timestamp \<I> \<Rightarrow> 'a" is "fst \<circ> snd" .
	+
	+lift_definition memL :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> 'a \<I> \<Rightarrow> bool" is
	+ "\<lambda>t t' (a, b, lei, lej). if lei then t + a \<le> t' else t + a < t'" .
	+
	+lift_definition memR :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> 'a \<I> \<Rightarrow> bool" is
	+ "\<lambda>t t' (a, b, lei, lej). if lej then t' \<le> t + b else t' < t + b" .
	+
	+definition mem :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> 'a \<I> \<Rightarrow> bool" where
	+ "mem t t' I \<longleftrightarrow> memL t t' I \<and> memR t t' I"
	+
	+lemma memL_mono: "memL t t' I \<Longrightarrow> t'' \<le> t \<Longrightarrow> memL t'' t' I"
	+ by transfer (auto simp: add.commute order_le_less_subst2 order_subst2 add_mono split: if_splits)
	+
	+lemma memL_mono': "memL t t' I \<Longrightarrow> t' \<le> t'' \<Longrightarrow> memL t t'' I"
	+ by transfer (auto split: if_splits)
	+
	+lemma memR_mono: "memR t t' I \<Longrightarrow> t \<le> t'' \<Longrightarrow> memR t'' t' I"
	+ apply transfer
	+ apply (simp split: prod.splits)
	+ apply (meson add_mono_comm dual_order.trans order_less_le_trans)
	+ done
	+
	+lemma memR_mono': "memR t t' I \<Longrightarrow> t'' \<le> t' \<Longrightarrow> memR t t'' I"
	+ by transfer (auto split: if_splits)
	+
	+lemma memR_dest: "memR t t' I \<Longrightarrow> t' \<le> t + right I"
	+ by transfer (auto split: if_splits)
	+
	+lemma memR_tfin_refl:
	+ assumes fin: "t \<in> tfin"
	+ shows "memR t t I"
	+ by (transfer fixing: t) (force split: if_splits intro: order_trans[OF _ add_mono, where ?x=t and ?a1=t and ?c1=0] add_pos[OF fin])
	+
	+lemma right_I_add_mono:
	+ fixes x :: "'a :: timestamp"
	+ shows "x \<le> x + right I"
	+ by transfer (auto split: if_splits intro: order_trans[OF _ add_mono, of _ _ 0])
	+
	+lift_definition interval :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> 'a \<I>" is
	+ "\<lambda>i j lei lej. (if 0 \<le> i \<and> i \<le> j \<and> i \<in> tfin \<and> \<not>(j = 0 \<and> \<not>lej)then (i, j, lei, lej) else Code.abort (STR ''malformed interval'') (\<lambda>_. (0, 0, True, True)))"
	+ by (auto intro: zero_tfin)
	+
	+lemma "Rep_\<I> I = (l, r, b1, b2) \<Longrightarrow> memL 0 0 I \<longleftrightarrow> l = 0 \<and> b1"
	+ by transfer auto
	+
	+lift_definition dropL :: "'a :: timestamp \<I> \<Rightarrow> 'a \<I>" is
	+ "\<lambda>(l, r, b1, b2). (0, r, True, b2)"
	+ by (auto intro: zero_tfin)
	+
	+lemma memL_dropL: "t \<le> t' \<Longrightarrow> memL t t' (dropL I)"
	+ by transfer auto
	+
	+lemma memR_dropL: "memR t t' (dropL I) = memR t t' I"
	+ by transfer auto
	+
	+lift_definition flipL :: "'a :: timestamp \<I> \<Rightarrow> 'a \<I>" is
	+ "\<lambda>(l, r, b1, b2). if \<not>(l = 0 \<and> b1) then (0, l, True, \<not>b1) else Code.abort (STR ''invalid flipL'') (\<lambda>_. (0, 0, True, True))"
	+ by (auto intro: zero_tfin split: if_splits)
	+
	+lemma memL_flipL: "t \<le> t' \<Longrightarrow> memL t t' (flipL I)"
	+ by transfer (auto split: if_splits)
	+
	+lemma memR_flipLD: "\<not>memL 0 0 I \<Longrightarrow> memR t t' (flipL I) \<Longrightarrow> \<not>memL t t' I"
	+ by transfer (auto split: if_splits)
	+
	+lemma memR_flipLI:
	+ fixes t :: "'a :: timestamp"
	+ shows "(\<And>u v. (u :: 'a :: timestamp) \<le> v \<or> v \<le> u) \<Longrightarrow> \<not>memL t t' I \<Longrightarrow> memR t t' (flipL I)"
	+ by transfer (force split: if_splits)
	+
	+lemma "t \<in> tfin \<Longrightarrow> memL 0 0 I \<longleftrightarrow> memL t t I"
	+ apply transfer
	+ apply (simp split: prod.splits)
	+ apply (metis add.right_neutral add_pos antisym_conv2 dual_order.eq_iff order_less_imp_not_less)
	+ done
	+
	+definition "full (I :: ('a :: timestamp) \<I>) \<longleftrightarrow> (\<forall>t t'. 0 \<le> t \<and> t \<le> t' \<and> t \<in> tfin \<and> t' \<in> tfin \<longrightarrow> mem t t' I)"
	+
	+lemma "memL 0 0 (I :: ('a :: timestamp_total) \<I>) \<Longrightarrow> right I \<notin> tfin \<Longrightarrow> full I"
	+ unfolding full_def mem_def
	+ by transfer (fastforce split: if_splits dest: add_not_tfin)
	+
	+(<)
	+end
	+(>)
	diff --git a/thys/VYDRA_MDL/MDL.thy b/thys/VYDRA_MDL/MDL.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/MDL.thy
	@@ -0,0 +1,350 @@
	+theory MDL
	+ imports Interval Trace
	+begin
	+
	+section \<open>Formulas and Satisfiability\<close>
	+
	+declare [[typedef_overloaded]]
	+
	+datatype ('a, 't :: timestamp) formula = Bool bool \| Atom 'a \| Neg "('a, 't) formula" \|
	+ Bin "bool \<Rightarrow> bool \<Rightarrow> bool" "('a, 't) formula" "('a, 't) formula" \|
	+ Prev "'t \<I>" "('a, 't) formula" \| Next "'t \<I>" "('a, 't) formula" \|
	+ Since "('a, 't) formula" "'t \<I>" "('a, 't) formula" \|
	+ Until "('a, 't) formula" "'t \<I>" "('a, 't) formula" \|
	+ MatchP "'t \<I>" "('a, 't) regex" \| MatchF "'t \<I>" "('a, 't) regex"
	+ and ('a, 't) regex = Lookahead "('a, 't) formula" \| Symbol "('a, 't) formula" \|
	+ Plus "('a, 't) regex" "('a, 't) regex" \| Times "('a, 't) regex" "('a, 't) regex" \|
	+ Star "('a, 't) regex"
	+
	+fun eps :: "('a, 't :: timestamp) regex \<Rightarrow> bool" where
	+ "eps (Lookahead phi) = True"
	+\| "eps (Symbol phi) = False"
	+\| "eps (Plus r s) = (eps r \<or> eps s)"
	+\| "eps (Times r s) = (eps r \<and> eps s)"
	+\| "eps (Star r) = True"
	+
	+fun atms :: "('a, 't :: timestamp) regex \<Rightarrow> ('a, 't) formula set" where
	+ "atms (Lookahead phi) = {phi}"
	+\| "atms (Symbol phi) = {phi}"
	+\| "atms (Plus r s) = atms r \<union> atms s"
	+\| "atms (Times r s) = atms r \<union> atms s"
	+\| "atms (Star r) = atms r"
	+
	+lemma size_atms[termination_simp]: "phi \<in> atms r \<Longrightarrow> size phi < size r"
	+ by (induction r) auto
	+
	+fun wf_fmla :: "('a, 't :: timestamp) formula \<Rightarrow> bool"
	+ and wf_regex :: "('a, 't) regex \<Rightarrow> bool" where
	+ "wf_fmla (Bool b) = True"
	+\| "wf_fmla (Atom a) = True"
	+\| "wf_fmla (Neg phi) = wf_fmla phi"
	+\| "wf_fmla (Bin f phi psi) = (wf_fmla phi \<and> wf_fmla psi)"
	+\| "wf_fmla (Prev I phi) = wf_fmla phi"
	+\| "wf_fmla (Next I phi) = wf_fmla phi"
	+\| "wf_fmla (Since phi I psi) = (wf_fmla phi \<and> wf_fmla psi)"
	+\| "wf_fmla (Until phi I psi) = (wf_fmla phi \<and> wf_fmla psi)"
	+\| "wf_fmla (MatchP I r) = (wf_regex r \<and> (\<forall>phi \<in> atms r. wf_fmla phi))"
	+\| "wf_fmla (MatchF I r) = (wf_regex r \<and> (\<forall>phi \<in> atms r. wf_fmla phi))"
	+\| "wf_regex (Lookahead phi) = False"
	+\| "wf_regex (Symbol phi) = wf_fmla phi"
	+\| "wf_regex (Plus r s) = (wf_regex r \<and> wf_regex s)"
	+\| "wf_regex (Times r s) = (wf_regex s \<and> (\<not>eps s \<or> wf_regex r))"
	+\| "wf_regex (Star r) = wf_regex r"
	+
	+fun progress :: "('a, 't :: timestamp) formula \<Rightarrow> 't list \<Rightarrow> nat" where
	+ "progress (Bool b) ts = length ts"
	+\| "progress (Atom a) ts = length ts"
	+\| "progress (Neg phi) ts = progress phi ts"
	+\| "progress (Bin f phi psi) ts = min (progress phi ts) (progress psi ts)"
	+\| "progress (Prev I phi) ts = min (length ts) (Suc (progress phi ts))"
	+\| "progress (Next I phi) ts = (case progress phi ts of 0 \<Rightarrow> 0 \| Suc k \<Rightarrow> k)"
	+\| "progress (Since phi I psi) ts = min (progress phi ts) (progress psi ts)"
	+\| "progress (Until phi I psi) ts = (if length ts = 0 then 0 else
	+ (let k = min (length ts - 1) (min (progress phi ts) (progress psi ts)) in
	+ Min {j. 0 \<le> j \<and> j \<le> k \<and> memR (ts ! j) (ts ! k) I}))"
	+\| "progress (MatchP I r) ts = Min ((\<lambda>f. progress f ts) ` atms r)"
	+\| "progress (MatchF I r) ts = (if length ts = 0 then 0 else
	+ (let k = min (length ts - 1) (Min ((\<lambda>f. progress f ts) ` atms r)) in
	+ Min {j. 0 \<le> j \<and> j \<le> k \<and> memR (ts ! j) (ts ! k) I}))"
	+
	+fun bounded_future_fmla :: "('a, 't :: timestamp) formula \<Rightarrow> bool"
	+ and bounded_future_regex :: "('a, 't) regex \<Rightarrow> bool" where
	+ "bounded_future_fmla (Bool b) \<longleftrightarrow> True"
	+\| "bounded_future_fmla (Atom a) \<longleftrightarrow> True"
	+\| "bounded_future_fmla (Neg phi) \<longleftrightarrow> bounded_future_fmla phi"
	+\| "bounded_future_fmla (Bin f phi psi) \<longleftrightarrow> bounded_future_fmla phi \<and> bounded_future_fmla psi"
	+\| "bounded_future_fmla (Prev I phi) \<longleftrightarrow> bounded_future_fmla phi"
	+\| "bounded_future_fmla (Next I phi) \<longleftrightarrow> bounded_future_fmla phi"
	+\| "bounded_future_fmla (Since phi I psi) \<longleftrightarrow> bounded_future_fmla phi \<and> bounded_future_fmla psi"
	+\| "bounded_future_fmla (Until phi I psi) \<longleftrightarrow> bounded_future_fmla phi \<and> bounded_future_fmla psi \<and> right I \<in> tfin"
	+\| "bounded_future_fmla (MatchP I r) \<longleftrightarrow> bounded_future_regex r"
	+\| "bounded_future_fmla (MatchF I r) \<longleftrightarrow> bounded_future_regex r \<and> right I \<in> tfin"
	+\| "bounded_future_regex (Lookahead phi) \<longleftrightarrow> bounded_future_fmla phi"
	+\| "bounded_future_regex (Symbol phi) \<longleftrightarrow> bounded_future_fmla phi"
	+\| "bounded_future_regex (Plus r s) \<longleftrightarrow> bounded_future_regex r \<and> bounded_future_regex s"
	+\| "bounded_future_regex (Times r s) \<longleftrightarrow> bounded_future_regex r \<and> bounded_future_regex s"
	+\| "bounded_future_regex (Star r) \<longleftrightarrow> bounded_future_regex r"
	+
	+lemmas regex_induct[case_names Lookahead Symbol Plus Times Star, induct type: regex] =
	+ regex.induct[of "\<lambda>_. True", simplified]
	+
	+definition "Once I \<phi> \<equiv> Since (Bool True) I \<phi>"
	+definition "Historically I \<phi> \<equiv> Neg (Once I (Neg \<phi>))"
	+definition "Eventually I \<phi> \<equiv> Until (Bool True) I \<phi>"
	+definition "Always I \<phi> \<equiv> Neg (Eventually I (Neg \<phi>))"
	+
	+fun rderive :: "('a, 't :: timestamp) regex \<Rightarrow> ('a, 't) regex" where
	+ "rderive (Lookahead phi) = Lookahead (Bool False)"
	+\| "rderive (Symbol phi) = Lookahead phi"
	+\| "rderive (Plus r s) = Plus (rderive r) (rderive s)"
	+\| "rderive (Times r s) = (if eps s then Plus (rderive r) (Times r (rderive s)) else Times r (rderive s))"
	+\| "rderive (Star r) = Times (Star r) (rderive r)"
	+
	+lemma atms_rderive: "phi \<in> atms (rderive r) \<Longrightarrow> phi \<in> atms r \<or> phi = Bool False"
	+ by (induction r) (auto split: if_splits)
	+
	+lemma size_formula_positive: "size (phi :: ('a, 't :: timestamp) formula) > 0"
	+ by (induction phi) auto
	+
	+lemma size_regex_positive: "size (r :: ('a, 't :: timestamp) regex) > Suc 0"
	+ by (induction r) (auto intro: size_formula_positive)
	+
	+lemma size_rderive[termination_simp]: "phi \<in> atms (rderive r) \<Longrightarrow> size phi < size r"
	+ by (drule atms_rderive) (auto intro: size_atms size_regex_positive)
	+
	+locale MDL =
	+ fixes \<sigma> :: "('a, 't :: timestamp) trace"
	+begin
	+
	+fun sat :: "('a, 't) formula \<Rightarrow> nat \<Rightarrow> bool"
	+ and match :: "('a, 't) regex \<Rightarrow> (nat \<times> nat) set" where
	+ "sat (Bool b) i = b"
	+\| "sat (Atom a) i = (a \<in> \<Gamma> \<sigma> i)"
	+\| "sat (Neg \<phi>) i = (\<not> sat \<phi> i)"
	+\| "sat (Bin f \<phi> \<psi>) i = (f (sat \<phi> i) (sat \<psi> i))"
	+\| "sat (Prev I \<phi>) i = (case i of 0 \<Rightarrow> False \| Suc j \<Rightarrow> mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> sat \<phi> j)"
	+\| "sat (Next I \<phi>) i = (mem (\<tau> \<sigma> i) (\<tau> \<sigma> (Suc i)) I \<and> sat \<phi> (Suc i))"
	+\| "sat (Since \<phi> I \<psi>) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> sat \<psi> j \<and> (\<forall>k \<in> {j<..i}. sat \<phi> k))"
	+\| "sat (Until \<phi> I \<psi>) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> sat \<psi> j \<and> (\<forall>k \<in> {i..<j}. sat \<phi> k))"
	+\| "sat (MatchP I r) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> (j, Suc i) \<in> match r)"
	+\| "sat (MatchF I r) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> (i, Suc j) \<in> match r)"
	+\| "match (Lookahead \<phi>) = {(i, i) \| i. sat \<phi> i}"
	+\| "match (Symbol \<phi>) = {(i, Suc i) \| i. sat \<phi> i}"
	+\| "match (Plus r s) = match r \<union> match s"
	+\| "match (Times r s) = match r O match s"
	+\| "match (Star r) = rtrancl (match r)"
	+
	+lemma "sat (Prev I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
	+ "sat (Next I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
	+ "sat (Since \<phi> I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
	+ "sat (Until \<phi> I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
	+ apply (auto split: nat.splits)
	+ done
	+
	+lemma prev_rewrite: "sat (Prev I \<phi>) i \<longleftrightarrow> sat (MatchP I (Times (Symbol \<phi>) (Symbol (Bool True)))) i"
	+ apply (auto split: nat.splits)
	+ subgoal for j
	+ by (fastforce intro: exI[of _ j])
	+ done
	+
	+lemma next_rewrite: "sat (Next I \<phi>) i \<longleftrightarrow> sat (MatchF I (Times (Symbol (Bool True)) (Symbol \<phi>))) i"
	+ by (fastforce intro: exI[of _ "Suc i"])
	+
	+lemma trancl_Base: "{(i, Suc i) \|i. P i}\<^sup>* = {(i, j). i \<le> j \<and> (\<forall>k\<in>{i..<j}. P k)}"
	+proof -
	+ have "(x, y) \<in> {(i, j). i \<le> j \<and> (\<forall>k\<in>{i..<j}. P k)}"
	+ if "(x, y) \<in> {(i, Suc i) \|i. P i}\<^sup>*" for x y
	+ using that by (induct rule: rtrancl_induct) (auto simp: less_Suc_eq)
	+ moreover have "(x, y) \<in> {(i, Suc i) \|i. P i}\<^sup>*"
	+ if "(x, y) \<in> {(i, j). i \<le> j \<and> (\<forall>k\<in>{i..<j}. P k)}" for x y
	+ using that unfolding mem_Collect_eq prod.case Ball_def
	+ by (induct y arbitrary: x)
	+ (auto 0 3 simp: le_Suc_eq intro: rtrancl_into_rtrancl[rotated])
	+ ultimately show ?thesis by blast
	+qed
	+
	+lemma Ball_atLeastLessThan_reindex:
	+ "(\<forall>k\<in>{j..<i}. P (Suc k)) = (\<forall>k \<in> {j<..i}. P k)"
	+ by (auto simp: less_eq_Suc_le less_eq_nat.simps split: nat.splits)
	+
	+lemma since_rewrite: "sat (Since \<phi> I \<psi>) i \<longleftrightarrow> sat (MatchP I (Times (Symbol \<psi>) (Star (Symbol \<phi>)))) i"
	+proof (rule iffI)
	+ assume "sat (Since \<phi> I \<psi>) i"
	+ then obtain j where j_def: "j \<le> i" "mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I" "sat \<psi> j"
	+ "\<forall>k \<in> {j..<i}. sat \<phi> (Suc k)"
	+ by auto
	+ have "k \<in> {Suc j..<Suc i} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)" for k
	+ using j_def(4)
	+ by (cases k) auto
	+ then have "(Suc j, Suc i) \<in> (match (Symbol \<phi>))\<^sup>*"
	+ using j_def(1) trancl_Base
	+ by auto
	+ then show "sat (MatchP I (Times (Symbol \<psi>) (Star (Symbol \<phi>)))) i"
	+ using j_def(1,2,3)
	+ by auto
	+next
	+ assume "sat (MatchP I (Times (Symbol \<psi>) (Star (Symbol \<phi>)))) i"
	+ then obtain j where j_def: "j \<le> i" "mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I" "(Suc j, Suc i) \<in> (match (Symbol \<phi>))\<^sup>*" "sat \<psi> j"
	+ by auto
	+ have "\<And>k. k \<in> {Suc j..<Suc i} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)"
	+ using j_def(3) trancl_Base[of "\<lambda>k. (k, Suc k) \<in> match (Symbol \<phi>)"]
	+ by simp
	+ then have "\<forall>k \<in> {j..<i}. sat \<phi> (Suc k)"
	+ by auto
	+ then show "sat (Since \<phi> I \<psi>) i"
	+ using j_def(1,2,4) Ball_atLeastLessThan_reindex[of j i "sat \<phi>"]
	+ by auto
	+qed
	+
	+lemma until_rewrite: "sat (Until \<phi> I \<psi>) i \<longleftrightarrow> sat (MatchF I (Times (Star (Symbol \<phi>)) (Symbol \<psi>))) i"
	+proof (rule iffI)
	+ assume "sat (Until \<phi> I \<psi>) i"
	+ then obtain j where j_def: "j \<ge> i" "mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I" "sat \<psi> j"
	+ "\<forall>k \<in> {i..<j}. sat \<phi> k"
	+ by auto
	+ have "k \<in> {i..<j} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)" for k
	+ using j_def(4)
	+ by auto
	+ then have "(i, j) \<in> (match (Symbol \<phi>))\<^sup>*"
	+ using j_def(1) trancl_Base
	+ by simp
	+ then show "sat (MatchF I (Times (Star (Symbol \<phi>)) (Symbol \<psi>))) i"
	+ using j_def(1,2,3)
	+ by auto
	+next
	+ assume "sat (MatchF I (Times (Star (Symbol \<phi>)) (Symbol \<psi>))) i"
	+ then obtain j where j_def: "j \<ge> i" "mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I" "(i, j) \<in> (match (Symbol \<phi>))\<^sup>*" "sat \<psi> j"
	+ by auto
	+ have "\<And>k. k \<in> {i..<j} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)"
	+ using j_def(3) trancl_Base[of "\<lambda>k. (k, Suc k) \<in> match (Symbol \<phi>)"]
	+ by auto
	+ then have "\<forall>k \<in> {i..<j}. sat \<phi> k"
	+ by simp
	+ then show "sat (Until \<phi> I \<psi>) i"
	+ using j_def(1,2,4)
	+ by auto
	+qed
	+
	+lemma match_le: "(i, j) \<in> match r \<Longrightarrow> i \<le> j"
	+proof (induction r arbitrary: i j)
	+ case (Times r s)
	+ then show ?case using order.trans by fastforce
	+next
	+ case (Star r)
	+ from Star.prems show ?case
	+ unfolding match.simps
	+ by (induct i j rule: rtrancl.induct) (force dest: Star.IH)+
	+qed auto
	+
	+lemma match_Times: "(i, i + n) \<in> match (Times r s) \<longleftrightarrow>
	+ (\<exists>k \<le> n. (i, i + k) \<in> match r \<and> (i + k, i + n) \<in> match s)"
	+ using match_le by auto (metis le_iff_add nat_add_left_cancel_le)
	+
	+lemma rtrancl_unfold: "(x, z) \<in> rtrancl R \<Longrightarrow>
	+ x = z \<or> (\<exists>y. (x, y) \<in> R \<and> x \<noteq> y \<and> (y, z) \<in> rtrancl R)"
	+ by (induction x z rule: rtrancl.induct) auto
	+
	+lemma rtrancl_unfold': "(x, z) \<in> rtrancl R \<Longrightarrow>
	+ x = z \<or> (\<exists>y. (x, y) \<in> rtrancl R \<and> y \<noteq> z \<and> (y, z) \<in> R)"
	+ by (induction x z rule: rtrancl.induct) auto
	+
	+lemma match_Star: "(i, i + Suc n) \<in> match (Star r) \<longleftrightarrow>
	+ (\<exists>k \<le> n. (i, i + 1 + k) \<in> match r \<and> (i + 1 + k, i + Suc n) \<in> match (Star r))"
	+proof (rule iffI)
	+ assume assms: "(i, i + Suc n) \<in> match (Star r)"
	+ obtain k where k_def: "(i, k) \<in> local.match r" "i \<le> k" "i \<noteq> k"
	+ "(k, i + Suc n) \<in> (local.match r)\<^sup>*"
	+ using rtrancl_unfold[OF assms[unfolded match.simps]] match_le by auto
	+ from k_def(4) have "(k, i + Suc n) \<in> match (Star r)"
	+ unfolding match.simps by simp
	+ then have k_le: "k \<le> i + Suc n"
	+ using match_le by blast
	+ from k_def(2,3) obtain k' where k'_def: "k = i + Suc k'"
	+ by (metis Suc_diff_Suc le_add_diff_inverse le_neq_implies_less)
	+ show "\<exists>k \<le> n. (i, i + 1 + k) \<in> match r \<and> (i + 1 + k, i + Suc n) \<in> match (Star r)"
	+ using k_def k_le unfolding k'_def by auto
	+next
	+ assume assms: "\<exists>k \<le> n. (i, i + 1 + k) \<in> match r \<and>
	+ (i + 1 + k, i + Suc n) \<in> match (Star r)"
	+ then show "(i, i + Suc n) \<in> match (Star r)"
	+ by (induction n) auto
	+qed
	+
	+lemma match_refl_eps: "(i, i) \<in> match r \<Longrightarrow> eps r"
	+proof (induction r)
	+ case (Times r s)
	+ then show ?case
	+ using match_Times[where ?i=i and ?n=0]
	+ by auto
	+qed auto
	+
	+lemma wf_regex_eps_match: "wf_regex r \<Longrightarrow> eps r \<Longrightarrow> (i, i) \<in> match r"
	+ by (induction r arbitrary: i) auto
	+
	+lemma match_Star_unfold: "i < j \<Longrightarrow> (i, j) \<in> match (Star r) \<Longrightarrow> \<exists>k \<in> {i..<j}. (i, k) \<in> match (Star r) \<and> (k, j) \<in> match r"
	+ using rtrancl_unfold'[of i j "match r"] match_le[of _ j r] match_le[of i _ "Star r"]
	+ by auto (meson atLeastLessThan_iff order_le_less)
	+
	+lemma match_rderive: "wf_regex r \<Longrightarrow> i \<le> j \<Longrightarrow> (i, Suc j) \<in> match r \<longleftrightarrow> (i, j) \<in> match (rderive r)"
	+proof (induction r arbitrary: i j)
	+ case (Times r1 r2)
	+ then show ?case
	+ using match_refl_eps[of "Suc j" r2] match_le[of _ "Suc j" r2]
	+ apply (auto)
	+ apply (metis le_Suc_eq relcomp.simps)
	+ apply (meson match_le relcomp.simps)
	+ apply (metis le_SucE relcomp.simps)
	+ apply (meson relcomp.relcompI wf_regex_eps_match)
	+ apply (meson match_le relcomp.simps)
	+ apply (metis le_SucE relcomp.simps)
	+ apply (meson match_le relcomp.simps)
	+ done
	+next
	+ case (Star r)
	+ then show ?case
	+ using match_Star_unfold[of i "Suc j" r]
	+ by auto (meson match_le rtrancl.simps)
	+qed auto
	+
	+end
	+
	+lemma atms_nonempty: "atms r \<noteq> {}"
	+ by (induction r) auto
	+
	+lemma atms_finite: "finite (atms r)"
	+ by (induction r) auto
	+
	+lemma progress_le_ts:
	+ assumes "\<And>t. t \<in> set ts \<Longrightarrow> t \<in> tfin"
	+ shows "progress phi ts \<le> length ts"
	+ using assms
	+proof (induction phi ts rule: progress.induct)
	+ case (8 phi I psi ts)
	+ have "ts \<noteq> [] \<Longrightarrow> Min {j. j \<le> min (length ts - Suc 0) (min (progress phi ts) (progress psi ts)) \<and>
	+ memR (ts ! j) (ts ! min (length ts - Suc 0) (min (progress phi ts) (progress psi ts))) I}
	+ \<le> length ts"
	+ apply (rule le_trans[OF Min_le[where ?x="min (length ts - Suc 0) (min (progress phi ts) (progress psi ts))"]])
	+ apply (auto simp: in_set_conv_nth intro!: memR_tfin_refl 8(3))
	+ apply (metis One_nat_def diff_less length_greater_0_conv less_numeral_extra(1) min.commute min.strict_coboundedI2)
	+ done
	+ then show ?case
	+ by auto
	+next
	+ case (9 I r ts)
	+ then show ?case
	+ using atms_nonempty[of r] atms_finite[of r]
	+ by auto (meson Min_le dual_order.trans finite_imageI image_iff)
	+next
	+ case (10 I r ts)
	+ have "ts \<noteq> [] \<Longrightarrow> Min {j. j \<le> min (length ts - Suc 0) (MIN f\<in>atms r. progress f ts) \<and>
	+ memR (ts ! j) (ts ! min (length ts - Suc 0) (MIN f\<in>atms r. progress f ts)) I}
	+ \<le> length ts"
	+ apply (rule le_trans[OF Min_le[where ?x="min (length ts - Suc 0) (Min ((\<lambda>f. progress f ts) ` atms r))"]])
	+ apply (auto simp: in_set_conv_nth intro!: memR_tfin_refl 10(2))
	+ apply (metis One_nat_def diff_less length_greater_0_conv less_numeral_extra(1) min.commute min.strict_coboundedI2)
	+ done
	+ then show ?case
	+ by auto
	+qed (auto split: nat.splits)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/VYDRA_MDL/Metric_Point_Structure.thy b/thys/VYDRA_MDL/Metric_Point_Structure.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Metric_Point_Structure.thy
	@@ -0,0 +1,169 @@
	+theory Metric_Point_Structure
	+ imports Interval
	+begin
	+
	+(* Conversion from the abstract time domain (Definition 4.1) introduced
	+ in the paper ``Specifying Real-Time Properties with Metric Temporal Logic''
	+ (Koymans, 1990) to our time-stamps. *)
	+
	+(* Metric domain. *)
	+
	+class metric_domain = plus + zero + ord +
	+ assumes \<Delta>1: "x + x' = x' + x"
	+ and \<Delta>2: "(x + x') + x'' = x + (x' + x'')"
	+ and \<Delta>3: "x + 0 = x"
	+ and \<Delta>3': "x = 0 + x"
	+ and \<Delta>4: "x + x' = x + x'' \<Longrightarrow> x' = x''"
	+ and \<Delta>4': "x + x'' = x' + x'' \<Longrightarrow> x = x'"
	+ and \<Delta>5: "x + x' = 0 \<Longrightarrow> x = 0"
	+ and \<Delta>5': "x + x' = 0 \<Longrightarrow> x' = 0"
	+ and \<Delta>6: "\<exists>x''. x = x' + x'' \<or> x' = x + x''"
	+ and metric_domain_le_def: "x \<le> x' \<longleftrightarrow> (\<exists>x''. x' = x + x'')"
	+ and metric_domain_lt_def: "x < x' \<longleftrightarrow> (\<exists>x''. x'' \<noteq> 0 \<and> x' = x + x'')"
	+begin
	+
	+lemma metric_domain_pos: "x \<ge> 0"
	+ using \<Delta>3' local.metric_domain_le_def by auto
	+
	+lemma less_eq_le_neq: "x < x' \<longleftrightarrow> (x \<le> x' \<and> x \<noteq> x')"
	+ apply (auto simp: metric_domain_le_def metric_domain_lt_def)
	+ apply (metis \<Delta>3 \<Delta>4)
	+ apply (metis \<Delta>3)
	+ done
	+
	+end
	+
	+(* Metric domain extended with embedding of natural numbers and syntactically extended with sup, tfin. *)
	+
	+class metric_domain_timestamp = metric_domain + sup + embed_nat + tfin +
	+ assumes metric_domain_sup_def: "sup x x' = (if x \<le> x' then x' else x)"
	+ and metric_domain_\<iota>_mono: "\<And>i j. i \<le> j \<Longrightarrow> \<iota> i \<le> \<iota> j"
	+ and metric_domain_\<iota>_progressing: "\<exists>j. \<not>\<iota> j \<le> \<iota> i + x"
	+ and metric_domain_tfin_def: "tfin = UNIV"
	+
	+subclass (in metric_domain_timestamp) timestamp
	+ apply unfold_locales
	+ apply (auto simp: \<Delta>2)[1]
	+ apply (auto simp: \<Delta>1)[1]
	+ apply (auto simp: \<Delta>3'[symmetric])[1]
	+ subgoal for x y
	+ apply (auto simp: metric_domain_le_def metric_domain_lt_def)
	+ apply (metis \<Delta>2 \<Delta>3 \<Delta>4 \<Delta>5)
	+ apply (metis \<Delta>2 \<Delta>3)
	+ done
	+ using \<Delta>6 apply (auto simp: metric_domain_le_def)[1]
	+ using \<Delta>2 apply (auto simp: metric_domain_le_def)[1]
	+ subgoal for x y
	+ apply (auto simp: metric_domain_le_def metric_domain_lt_def)
	+ apply (metis \<Delta>2 \<Delta>3 \<Delta>4 \<Delta>5)
	+ done
	+ using \<Delta>6 apply (fastforce simp: metric_domain_le_def metric_domain_sup_def)
	+ using \<Delta>6 apply (fastforce simp: metric_domain_le_def metric_domain_sup_def)
	+ apply (auto simp: metric_domain_le_def metric_domain_sup_def)[1]
	+ using metric_domain_\<iota>_mono apply (auto simp: metric_domain_le_def)[1]
	+ apply (auto simp: metric_domain_tfin_def)[1]
	+ using metric_domain_\<iota>_progressing apply (auto simp: metric_domain_le_def)[1]
	+ apply (auto simp: metric_domain_tfin_def)[2]
	+ using \<Delta>2 apply (auto simp: metric_domain_le_def)[1]
	+ using \<Delta>1 \<Delta>3 apply (auto simp: metric_domain_lt_def)
	+ done
	+
	+(* Metric point structure.
	+ We map Koymans' time-stamps t in a trace to d t0 t, where t0 is the initial time-stamp of the trace.
	+ Because Koymans assumes the strict precedence relation on time-stamps to be
	+ ``transitive, irreflexive and comparable'', the precedence relation is actually a partial order. *)
	+
	+locale metric_point_structure =
	+ fixes d :: "'t :: {order} \<Rightarrow> 't \<Rightarrow> 'd :: metric_domain_timestamp"
	+ assumes d1: "d t t' = 0 \<longleftrightarrow> t = t'"
	+ and d2: "d t t' = d t' t"
	+ and d3: "t < t' \<Longrightarrow> t' < t'' \<Longrightarrow> d t t'' = d t t' + d t' t''"
	+ and d3': "t < t' \<Longrightarrow> t' < t'' \<Longrightarrow> d t'' t = d t'' t' + d t' t"
	+begin
	+
	+lemma metric_point_structure_memL_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x \<le> d t t' \<longleftrightarrow> (d t0 t + x \<le> d t0 t')"
	+ apply (rule iffI)
	+ apply (metis \<Delta>1 add_0 add_mono_comm d1 d3 order_le_less)
	+ apply (cases "t0 < t"; cases "t < t'")
	+ apply (auto simp: metric_domain_le_def)
	+ apply (metis \<Delta>4 ab_semigroup_add_class.add_ac(1) d3)
	+ apply (metis comm_monoid_add_class.add_0 group_cancel.add1 metric_domain_lt_def nless_le)
	+ apply (metis \<Delta>3' d1)
	+ apply (metis add_0 d1)
	+ done
	+
	+lemma metric_point_structure_memL_strict_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x < d t t' \<longleftrightarrow> (d t0 t + x < d t0 t')"
	+ using metric_point_structure_memL_aux[of t0 t t' x]
	+ apply auto
	+ apply (metis (no_types, lifting) \<Delta>1 \<Delta>3 \<Delta>4 antisym_conv2 d1 d3)
	+ apply (metis \<Delta>1 add_0 d1 d3 order.order_iff_strict order_less_irrefl)
	+ done
	+
	+lemma metric_point_structure_memR_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' \<le> x \<longleftrightarrow> (d t0 t' \<le> d t0 t + x)"
	+ apply auto
	+ apply (metis \<Delta>1 \<Delta>3 d1 d3 order_le_less add_mono)
	+ apply (smt (verit, ccfv_threshold) \<Delta>1 \<Delta>2 \<Delta>3 \<Delta>4 d1 d3 metric_domain_le_def order_le_less)
	+ done
	+
	+lemma metric_point_structure_memR_strict_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' < x \<longleftrightarrow> (d t0 t' < d t0 t + x)"
	+ by (auto simp add: metric_point_structure_memL_aux metric_point_structure_memR_aux less_le_not_le)
	+
	+lemma metric_point_structure_le_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' \<le> x \<longleftrightarrow> mem (d t0 t) (d t0 t') (interval 0 x True True)"
	+ unfolding mem_def
	+ apply (transfer fixing: d)
	+ using metric_point_structure_memR_aux
	+ apply (auto simp: metric_domain_le_def metric_domain_tfin_def)
	+ apply (metis add.right_neutral d3 order.order_iff_strict)
	+ done
	+
	+lemma metric_point_structure_lt_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> 0 < x \<Longrightarrow> d t t' < x \<longleftrightarrow> mem (d t0 t) (d t0 t') (interval 0 x True False)"
	+ unfolding mem_def
	+ apply (transfer fixing: d)
	+ using metric_point_structure_memR_strict_aux
	+ apply (auto simp: metric_domain_tfin_def)
	+ apply (metis \<Delta>3 metric_domain_pos metric_point_structure_memL_aux)
	+ done
	+
	+lemma metric_point_structure_eq_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' = x \<longleftrightarrow> mem (d t0 t) (d t0 t') (interval x x True True)"
	+ unfolding mem_def
	+ apply (transfer fixing: d)
	+ subgoal for t0 t t' x
	+ using metric_point_structure_memL_aux[of t0 t t' x] metric_point_structure_memR_aux[of t0 t t' x] metric_domain_pos
	+ by (auto simp: metric_domain_tfin_def)
	+ done
	+
	+lemma metric_point_structure_ge_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x \<le> d t t' \<longleftrightarrow> mem (Some (d t0 t)) (Some (d t0 t')) (interval (Some x) None True True)"
	+ unfolding mem_def
	+ apply (transfer fixing: d)
	+ using metric_point_structure_memL_aux by (auto simp: tfin_option_def zero_option_def plus_option_def less_eq_option_def metric_domain_le_def metric_domain_tfin_def split: option.splits)
	+
	+lemma metric_point_structure_gt_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x < d t t' \<longleftrightarrow> mem (Some (d t0 t)) (Some (d t0 t')) (interval (Some x) None False True)"
	+ unfolding mem_def
	+ apply (transfer fixing: d)
	+ using metric_point_structure_memL_strict_aux by (auto simp: tfin_option_def zero_option_def plus_option_def less_option_def less_eq_option_def metric_domain_le_def metric_domain_tfin_def split: option.splits)
	+
	+end
	+
	+instantiation nat :: metric_domain_timestamp
	+begin
	+
	+instance
	+ apply standard
	+ apply auto[8]
	+ apply (meson less_eqE timestamp_total)
	+ using nat_le_iff_add apply blast
	+ using less_imp_add_positive apply auto[1]
	+ apply (auto simp: sup_max)[1]
	+ apply (auto simp: \<iota>_nat_def)[1]
	+ subgoal for i x
	+ apply (auto simp: \<iota>_nat_def)
	+ using add_le_same_cancel1 by blast
	+ apply (auto simp: tfin_nat_def)
	+ done
	+
	+end
	+
	+interpretation nat_metric_point_structure: metric_point_structure "\<lambda>t :: nat. \<lambda>t'. if t \<le> t' then t' - t else t - t'"
	+ by unfold_locales auto
	+
	+end
	diff --git a/thys/VYDRA_MDL/Monitor.thy b/thys/VYDRA_MDL/Monitor.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Monitor.thy
	@@ -0,0 +1,1882 @@
	+theory Monitor
	+ imports MDL Temporal
	+begin
	+
	+type_synonym ('h, 't) time = "('h \<times> 't) option"
	+
	+datatype (dead 'a, dead 't :: timestamp, dead 'h) vydra_aux =
	+ VYDRA_None
	+ \| VYDRA_Bool bool 'h
	+ \| VYDRA_Atom 'a 'h
	+ \| VYDRA_Neg "('a, 't, 'h) vydra_aux"
	+ \| VYDRA_Bin "bool \<Rightarrow> bool \<Rightarrow> bool" "('a, 't, 'h) vydra_aux" "('a, 't, 'h) vydra_aux"
	+ \| VYDRA_Prev "'t \<I>" "('a, 't, 'h) vydra_aux" 'h "('t \<times> bool) option"
	+ \| VYDRA_Next "'t \<I>" "('a, 't, 'h) vydra_aux" 'h "'t option"
	+ \| VYDRA_Since "'t \<I>" "('a, 't, 'h) vydra_aux" "('a, 't, 'h) vydra_aux" "('h, 't) time" nat nat "nat option" "'t option"
	+ \| VYDRA_Until "'t \<I>" "('h, 't) time" "('a, 't, 'h) vydra_aux" "('a, 't, 'h) vydra_aux" "('h, 't) time" nat "('t \<times> bool \<times> bool) option"
	+ \| VYDRA_MatchP "'t \<I>" "transition iarray" nat
	+ "(bool iarray, nat set, 't, ('h, 't) time, ('a, 't, 'h) vydra_aux list) window"
	+ \| VYDRA_MatchF "'t \<I>" "transition iarray" nat
	+ "(bool iarray, nat set, 't, ('h, 't) time, ('a, 't, 'h) vydra_aux list) window"
	+
	+type_synonym ('a, 't, 'h) vydra = "nat \<times> ('a, 't, 'h) vydra_aux"
	+
	+fun msize_vydra :: "nat \<Rightarrow> ('a, 't :: timestamp, 'h) vydra_aux \<Rightarrow> nat" where
	+ "msize_vydra n VYDRA_None = 0"
	+\| "msize_vydra n (VYDRA_Bool b e) = 0"
	+\| "msize_vydra n (VYDRA_Atom a e) = 0"
	+\| "msize_vydra (Suc n) (VYDRA_Bin f v1 v2) = msize_vydra n v1 + msize_vydra n v2 + 1"
	+\| "msize_vydra (Suc n) (VYDRA_Neg v) = msize_vydra n v + 1"
	+\| "msize_vydra (Suc n) (VYDRA_Prev I v e tb) = msize_vydra n v + 1"
	+\| "msize_vydra (Suc n) (VYDRA_Next I v e to) = msize_vydra n v + 1"
	+\| "msize_vydra (Suc n) (VYDRA_Since I vphi vpsi e cphi cpsi cppsi tppsi) = msize_vydra n vphi + msize_vydra n vpsi + 1"
	+\| "msize_vydra (Suc n) (VYDRA_Until I e vphi vpsi epsi c zo) = msize_vydra n vphi + msize_vydra n vpsi + 1"
	+\| "msize_vydra (Suc n) (VYDRA_MatchP I transs qf w) = size_list (msize_vydra n) (w_si w) + size_list (msize_vydra n) (w_sj w) + 1"
	+\| "msize_vydra (Suc n) (VYDRA_MatchF I transs qf w) = size_list (msize_vydra n) (w_si w) + size_list (msize_vydra n) (w_sj w) + 1"
	+\| "msize_vydra _ _ = 0"
	+
	+fun next_vydra :: "('a, 't :: timestamp, 'h) vydra_aux \<Rightarrow> nat" where
	+ "next_vydra (VYDRA_Next I v e None) = 1"
	+\| "next_vydra _ = 0"
	+
	+context
	+ fixes init_hd :: "'h"
	+ and run_hd :: "'h \<Rightarrow> ('h \<times> ('t :: timestamp \<times> 'a set)) option"
	+begin
	+
	+definition t0 :: "('h, 't) time" where
	+ "t0 = (case run_hd init_hd of None \<Rightarrow> None \| Some (e', (t, X)) \<Rightarrow> Some (e', t))"
	+
	+fun run_t :: "('h, 't) time \<Rightarrow> (('h, 't) time \<times> 't) option" where
	+ "run_t None = None"
	+\| "run_t (Some (e, t)) = (case run_hd e of None \<Rightarrow> Some (None, t)
	+ \| Some (e', (t', X)) \<Rightarrow> Some (Some (e', t'), t))"
	+
	+fun read_t :: "('h, 't) time \<Rightarrow> 't option" where
	+ "read_t None = None"
	+\| "read_t (Some (e, t)) = Some t"
	+
	+lemma run_t_read: "run_t x = Some (x', t) \<Longrightarrow> read_t x = Some t"
	+ by (cases x) (auto split: option.splits)
	+
	+lemma read_t_run: "read_t x = Some t \<Longrightarrow> \<exists>x'. run_t x = Some (x', t)"
	+ by (cases x) (auto split: option.splits)
	+
	+lemma reach_event_t: "reaches_on run_hd e vs e'' \<Longrightarrow> run_hd e = Some (e', (t, X)) \<Longrightarrow>
	+ run_hd e'' = Some (e''', (t', X')) \<Longrightarrow>
	+ reaches_on run_t (Some (e', t)) (map fst vs) (Some (e''', t'))"
	+proof (induction e vs e'' arbitrary: t' X' e''' rule: reaches_on_rev_induct)
	+ case (2 s s' v vs s'')
	+ obtain v_t v_X where v_def: "v = (v_t, v_X)"
	+ by (cases v) auto
	+ have run_t_s'': "run_t (Some (s'', v_t)) = Some (Some (e''', t'), v_t)"
	+ by (auto simp: 2(5))
	+ show ?case
	+ using reaches_on_app[OF 2(3)[OF 2(4) 2(2)[unfolded v_def]] run_t_s'']
	+ by (auto simp: v_def)
	+qed (auto intro: reaches_on.intros)
	+
	+lemma reach_event_t0_t:
	+ assumes "reaches_on run_hd init_hd vs e''" "run_hd e'' = Some (e''', (t', X'))"
	+ shows "reaches_on run_t t0 (map fst vs) (Some (e''', t'))"
	+proof -
	+ have t0_not_None: "t0 \<noteq> None"
	+ apply (rule reaches_on.cases[OF assms(1)])
	+ using assms(2)
	+ by (auto simp: t0_def split: option.splits prod.splits)
	+ then show ?thesis
	+ using reach_event_t[OF assms(1) _ assms(2)]
	+ by (auto simp: t0_def split: option.splits)
	+qed
	+
	+lemma reaches_on_run_hd_t:
	+ assumes "reaches_on run_hd init_hd vs e"
	+ shows "\<exists>x. reaches_on run_t t0 (map fst vs) x"
	+proof (cases vs rule: rev_cases)
	+ case (snoc ys y)
	+ show ?thesis
	+ using assms
	+ apply (cases y)
	+ apply (auto simp: snoc dest!: reaches_on_split_last)
	+ apply (meson reaches_on_app[OF reach_event_t0_t] read_t.simps(2) read_t_run)
	+ done
	+qed (auto intro: reaches_on.intros)
	+
	+definition "run_subs run = (\<lambda>vs. let vs' = map run vs in
	+ (if (\<exists>x \<in> set vs'. Option.is_none x) then None
	+ else Some (map (fst \<circ> the) vs', iarray_of_list (map (snd \<circ> snd \<circ> the) vs'))))"
	+
	+lemma run_subs_lD: "run_subs run vs = Some (vs', bs) \<Longrightarrow>
	+ length vs' = length vs \<and> IArray.length bs = length vs"
	+ by (auto simp: run_subs_def Let_def iarray_of_list_def split: option.splits if_splits)
	+
	+lemma run_subs_vD: "run_subs run vs = Some (vs', bs) \<Longrightarrow> j < length vs \<Longrightarrow>
	+ \<exists>vj' tj bj. run (vs ! j) = Some (vj', (tj, bj)) \<and> vs' ! j = vj' \<and> IArray.sub bs j = bj"
	+ apply (cases "run (vs ! j)")
	+ apply (auto simp: Option.is_none_def run_subs_def Let_def iarray_of_list_def
	+ split: option.splits if_splits)
	+ by (metis image_eqI nth_mem)
	+
	+fun msize_fmla :: "('a, 'b :: timestamp) formula \<Rightarrow> nat"
	+ and msize_regex :: "('a, 'b) regex \<Rightarrow> nat" where
	+ "msize_fmla (Bool b) = 0"
	+\| "msize_fmla (Atom a) = 0"
	+\| "msize_fmla (Neg phi) = Suc (msize_fmla phi)"
	+\| "msize_fmla (Bin f phi psi) = Suc (msize_fmla phi + msize_fmla psi)"
	+\| "msize_fmla (Prev I phi) = Suc (msize_fmla phi)"
	+\| "msize_fmla (Next I phi) = Suc (msize_fmla phi)"
	+\| "msize_fmla (Since phi I psi) = Suc (max (msize_fmla phi) (msize_fmla psi))"
	+\| "msize_fmla (Until phi I psi) = Suc (max (msize_fmla phi) (msize_fmla psi))"
	+\| "msize_fmla (MatchP I r) = Suc (msize_regex r)"
	+\| "msize_fmla (MatchF I r) = Suc (msize_regex r)"
	+\| "msize_regex (Lookahead phi) = msize_fmla phi"
	+\| "msize_regex (Symbol phi) = msize_fmla phi"
	+\| "msize_regex (Plus r s) = max (msize_regex r) (msize_regex s)"
	+\| "msize_regex (Times r s) = max (msize_regex r) (msize_regex s)"
	+\| "msize_regex (Star r) = msize_regex r"
	+
	+lemma collect_subfmlas_msize: "x \<in> set (collect_subfmlas r []) \<Longrightarrow>
	+ msize_fmla x \<le> msize_regex r"
	+proof (induction r)
	+ case (Lookahead phi)
	+ then show ?case
	+ by (auto split: if_splits)
	+next
	+ case (Symbol phi)
	+ then show ?case
	+ by (auto split: if_splits)
	+next
	+ case (Plus r1 r2)
	+ then show ?case
	+ by (auto simp: collect_subfmlas_set[of r2 "collect_subfmlas r1 []"])
	+next
	+ case (Times r1 r2)
	+ then show ?case
	+ by (auto simp: collect_subfmlas_set[of r2 "collect_subfmlas r1 []"])
	+next
	+ case (Star r)
	+ then show ?case
	+ by fastforce
	+qed
	+
	+definition "until_ready I t c zo = (case (c, zo) of (Suc _, Some (t', b1, b2)) \<Rightarrow> (b2 \<and> memL t t' I) \<or> \<not>b1 \| _ \<Rightarrow> False)"
	+
	+definition "while_since_cond I t = (\<lambda>(vpsi, e, cpsi :: nat, cppsi, tppsi). cpsi > 0 \<and> memL (the (read_t e)) t I)"
	+definition "while_since_body run =
	+ (\<lambda>(vpsi, e, cpsi :: nat, cppsi, tppsi).
	+ case run vpsi of Some (vpsi', (t', b')) \<Rightarrow>
	+ Some (vpsi', fst (the (run_t e)), cpsi - 1, if b' then Some cpsi else cppsi, if b' then Some t' else tppsi)
	+ \| _ \<Rightarrow> None
	+ )"
	+
	+definition "while_until_cond I t = (\<lambda>(vphi, vpsi, epsi, c, zo). \<not>until_ready I t c zo \<and> (case read_t epsi of Some t' \<Rightarrow> memR t t' I \| None \<Rightarrow> False))"
	+definition "while_until_body run =
	+ (\<lambda>(vphi, vpsi, epsi, c, zo). case run_t epsi of Some (epsi', t') \<Rightarrow>
	+ (case run vphi of Some (vphi', (_, b1)) \<Rightarrow>
	+ (case run vpsi of Some (vpsi', (_, b2)) \<Rightarrow> Some (vphi', vpsi', epsi', Suc c, Some (t', b1, b2))
	+ \| _ \<Rightarrow> None)
	+ \| _ \<Rightarrow> None))"
	+
	+function (sequential) run :: "nat \<Rightarrow> ('a, 't, 'h) vydra_aux \<Rightarrow> (('a, 't, 'h) vydra_aux \<times> ('t \<times> bool)) option" where
	+ "run n (VYDRA_None) = None"
	+\| "run n (VYDRA_Bool b e) = (case run_hd e of None \<Rightarrow> None
	+ \| Some (e', (t, _)) \<Rightarrow> Some (VYDRA_Bool b e', (t, b)))"
	+\| "run n (VYDRA_Atom a e) = (case run_hd e of None \<Rightarrow> None
	+ \| Some (e', (t, X)) \<Rightarrow> Some (VYDRA_Atom a e', (t, a \<in> X)))"
	+\| "run (Suc n) (VYDRA_Neg v) = (case run n v of None \<Rightarrow> None
	+ \| Some (v', (t, b)) \<Rightarrow> Some (VYDRA_Neg v', (t, \<not>b)))"
	+\| "run (Suc n) (VYDRA_Bin f vl vr) = (case run n vl of None \<Rightarrow> None
	+ \| Some (vl', (t, bl)) \<Rightarrow> (case run n vr of None \<Rightarrow> None
	+ \| Some (vr', (_, br)) \<Rightarrow> Some (VYDRA_Bin f vl' vr', (t, f bl br))))"
	+\| "run (Suc n) (VYDRA_Prev I v e tb) = (case run_hd e of Some (e', (t, _)) \<Rightarrow>
	+ (let \<beta> = (case tb of Some (t', b') \<Rightarrow> b' \<and> mem t' t I \| None \<Rightarrow> False) in
	+ case run n v of Some (v', _, b') \<Rightarrow> Some (VYDRA_Prev I v' e' (Some (t, b')), (t, \<beta>))
	+ \| None \<Rightarrow> Some (VYDRA_None, (t, \<beta>)))
	+ \| None \<Rightarrow> None)"
	+\| "run (Suc n) (VYDRA_Next I v e to) = (case run_hd e of Some (e', (t, _)) \<Rightarrow>
	+ (case to of None \<Rightarrow>
	+ (case run n v of Some (v', _, _) \<Rightarrow> run (Suc n) (VYDRA_Next I v' e' (Some t))
	+ \| None \<Rightarrow> None)
	+ \| Some t' \<Rightarrow>
	+ (case run n v of Some (v', _, b) \<Rightarrow> Some (VYDRA_Next I v' e' (Some t), (t', b \<and> mem t' t I))
	+ \| None \<Rightarrow> if mem t' t I then None else Some (VYDRA_None, (t', False))))
	+ \| None \<Rightarrow> None)"
	+\| "run (Suc n) (VYDRA_Since I vphi vpsi e cphi cpsi cppsi tppsi) = (case run n vphi of
	+ Some (vphi', (t, b1)) \<Rightarrow>
	+ let cphi = (if b1 then Suc cphi else 0) in
	+ let cpsi = Suc cpsi in
	+ let cppsi = map_option Suc cppsi in
	+ (case while_break (while_since_cond I t) (while_since_body (run n)) (vpsi, e, cpsi, cppsi, tppsi) of Some (vpsi', e', cpsi', cppsi', tppsi') \<Rightarrow>
	+ (let \<beta> = (case cppsi' of Some k \<Rightarrow> k - 1 \<le> cphi \<and> memR (the tppsi') t I \| _ \<Rightarrow> False) in
	+ Some (VYDRA_Since I vphi' vpsi' e' cphi cpsi' cppsi' tppsi', (t, \<beta>)))
	+ \| _ \<Rightarrow> None)
	+ \| _ \<Rightarrow> None)"
	+\| "run (Suc n) (VYDRA_Until I e vphi vpsi epsi c zo) = (case run_t e of Some (e', t) \<Rightarrow>
	+ (case while_break (while_until_cond I t) (while_until_body (run n)) (vphi, vpsi, epsi, c, zo) of Some (vphi', vpsi', epsi', c', zo') \<Rightarrow>
	+ if c' = 0 then None else
	+ (case zo' of Some (t', b1, b2) \<Rightarrow>
	+ (if b2 \<and> memL t t' I then Some (VYDRA_Until I e' vphi' vpsi' epsi' (c' - 1) zo', (t, True))
	+ else if \<not>b1 then Some (VYDRA_Until I e' vphi' vpsi' epsi' (c' - 1) zo', (t, False))
	+ else (case read_t epsi' of Some t' \<Rightarrow> Some (VYDRA_Until I e' vphi' vpsi' epsi' (c' - 1) zo', (t, False)) \| _ \<Rightarrow> None))
	+ \| _ \<Rightarrow> None)
	+ \| _ \<Rightarrow> None)
	+ \| _ \<Rightarrow> None)"
	+\| "run (Suc n) (VYDRA_MatchP I transs qf w) =
	+ (case eval_matchP (init_args ({0}, NFA.delta' transs qf, NFA.accept' transs qf)
	+ (run_t, read_t) (run_subs (run n))) I w of None \<Rightarrow> None
	+ \| Some ((t, b), w') \<Rightarrow> Some (VYDRA_MatchP I transs qf w', (t, b)))"
	+\| "run (Suc n) (VYDRA_MatchF I transs qf w) =
	+ (case eval_matchF (init_args ({0}, NFA.delta' transs qf, NFA.accept' transs qf)
	+ (run_t, read_t) (run_subs (run n))) I w of None \<Rightarrow> None
	+ \| Some ((t, b), w') \<Rightarrow> Some (VYDRA_MatchF I transs qf w', (t, b)))"
	+\| "run _ _ = undefined"
	+ by pat_completeness auto
	+termination
	+ by (relation "(\<lambda>p. size (fst p)) <mlex> (\<lambda>p. next_vydra (snd p)) <mlex> (\<lambda>p. msize_vydra (fst p) (snd p)) <mlex> {}") (auto simp: mlex_prod_def)
	+
	+lemma wf_since: "wf {(t, s). while_since_cond I tt s \<and> Some t = while_since_body (run n) s}"
	+proof -
	+ let ?X = "{(t, s). while_since_cond I tt s \<and> Some t = while_since_body (run n) s}"
	+ have sub: "?X \<subseteq> measure (\<lambda>(vpsi, e, cpsi, cppsi, tppsi). cpsi)"
	+ by (auto simp: while_since_cond_def while_since_body_def Let_def split: option.splits)
	+ then show ?thesis
	+ using wf_subset[OF wf_measure]
	+ by auto
	+qed
	+
	+definition run_vydra :: "('a, 't, 'h) vydra \<Rightarrow> (('a, 't, 'h) vydra \<times> ('t \<times> bool)) option" where
	+ "run_vydra v = (case v of (n, w) \<Rightarrow> map_option (apfst (Pair n)) (run n w))"
	+
	+fun sub :: "nat \<Rightarrow> ('a, 't) formula \<Rightarrow> ('a, 't, 'h) vydra_aux" where
	+ "sub n (Bool b) = VYDRA_Bool b init_hd"
	+\| "sub n (Atom a) = VYDRA_Atom a init_hd"
	+\| "sub (Suc n) (Neg phi) = VYDRA_Neg (sub n phi)"
	+\| "sub (Suc n) (Bin f phi psi) = VYDRA_Bin f (sub n phi) (sub n psi)"
	+\| "sub (Suc n) (Prev I phi) = VYDRA_Prev I (sub n phi) init_hd None"
	+\| "sub (Suc n) (Next I phi) = VYDRA_Next I (sub n phi) init_hd None"
	+\| "sub (Suc n) (Since phi I psi) = VYDRA_Since I (sub n phi) (sub n psi) t0 0 0 None None"
	+\| "sub (Suc n) (Until phi I psi) = VYDRA_Until I t0 (sub n phi) (sub n psi) t0 0 None"
	+\| "sub (Suc n) (MatchP I r) = (let qf = state_cnt r;
	+ transs = iarray_of_list (build_nfa_impl r (0, qf, [])) in
	+ VYDRA_MatchP I transs qf (init_window (init_args
	+ ({0}, NFA.delta' transs qf, NFA.accept' transs qf)
	+ (run_t, read_t) (run_subs (run n)))
	+ t0 (map (sub n) (collect_subfmlas r []))))"
	+\| "sub (Suc n) (MatchF I r) = (let qf = state_cnt r;
	+ transs = iarray_of_list (build_nfa_impl r (0, qf, [])) in
	+ VYDRA_MatchF I transs qf (init_window (init_args
	+ ({0}, NFA.delta' transs qf, NFA.accept' transs qf)
	+ (run_t, read_t) (run_subs (run n)))
	+ t0 (map (sub n) (collect_subfmlas r []))))"
	+\| "sub _ _ = undefined"
	+
	+definition init_vydra :: "('a, 't) formula \<Rightarrow> ('a, 't, 'h) vydra" where
	+ "init_vydra \<phi> = (let n = msize_fmla \<phi> in (n, sub n \<phi>))"
	+
	+end
	+
	+locale VYDRA_MDL = MDL \<sigma>
	+ for \<sigma> :: "('a, 't :: timestamp) trace" +
	+ fixes init_hd :: "'h"
	+ and run_hd :: "'h \<Rightarrow> ('h \<times> ('t \<times> 'a set)) option"
	+ assumes run_hd_sound: "reaches run_hd init_hd n s \<Longrightarrow> run_hd s = Some (s', (t, X)) \<Longrightarrow> (t, X) = (\<tau> \<sigma> n, \<Gamma> \<sigma> n)"
	+begin
	+
	+lemma reaches_on_run_hd: "reaches_on run_hd init_hd es s \<Longrightarrow> run_hd s = Some (s', (t, X)) \<Longrightarrow> t = \<tau> \<sigma> (length es) \<and> X = \<Gamma> \<sigma> (length es)"
	+ using run_hd_sound
	+ by (auto dest: reaches_on_n)
	+
	+abbreviation "ru_t \<equiv> run_t run_hd"
	+abbreviation "l_t0 \<equiv> t0 init_hd run_hd"
	+abbreviation "ru \<equiv> run run_hd"
	+abbreviation "su \<equiv> sub init_hd run_hd"
	+
	+lemma ru_t_event: "reaches_on ru_t t ts t' \<Longrightarrow> t = l_t0 \<Longrightarrow> ru_t t' = Some (t'', x) \<Longrightarrow>
	+ \<exists>rho e tt. t' = Some (e, tt) \<and> reaches_on run_hd init_hd rho e \<and> length rho = Suc (length ts) \<and>
	+ x = \<tau> \<sigma> (length ts)"
	+proof (induction t ts t' arbitrary: t'' x rule: reaches_on_rev_induct)
	+ case (1 s)
	+ show ?case
	+ using 1 reaches_on_run_hd[OF reaches_on.intros(1)]
	+ by (auto simp: t0_def split: option.splits intro!: reaches_on.intros)
	+next
	+ case (2 s s' v vs s'')
	+ obtain rho e tt where rho_def: "s' = Some (e, tt)" "reaches_on run_hd init_hd rho e"
	+ "length rho = Suc (length vs)"
	+ using 2(3)[OF 2(4,2)]
	+ by auto
	+ then show ?case
	+ using 2(2,5) reaches_on_app[OF rho_def(2)] reaches_on_run_hd[OF rho_def(2)]
	+ by (fastforce split: option.splits)
	+qed
	+
	+lemma ru_t_tau: "reaches_on ru_t l_t0 ts t' \<Longrightarrow> ru_t t' = Some (t'', x) \<Longrightarrow> x = \<tau> \<sigma> (length ts)"
	+ using ru_t_event
	+ by fastforce
	+
	+lemma ru_t_Some_tau:
	+ assumes "reaches_on ru_t l_t0 ts (Some (e, t))"
	+ shows "t = \<tau> \<sigma> (length ts)"
	+proof -
	+ obtain z where z_def: "ru_t (Some (e, t)) = Some (z, t)"
	+ by (cases "run_hd e") auto
	+ show ?thesis
	+ by (rule ru_t_tau[OF assms z_def])
	+qed
	+
	+lemma ru_t_tau_in:
	+ assumes "reaches_on ru_t l_t0 ts t" "j < length ts"
	+ shows "ts ! j = \<tau> \<sigma> j"
	+proof -
	+ obtain t' where t'_def: "reaches_on ru_t l_t0 (take j ts) t'" "reaches_on ru_t t' (drop j ts) t"
	+ using reaches_on_split'[OF assms(1), where ?i=j] assms(2)
	+ by auto
	+ have drop: "drop j ts = ts ! j # tl (drop j ts)"
	+ using assms(2)
	+ by (cases "drop j ts") (auto simp add: nth_via_drop)
	+ obtain t'' where t''_def: "ru_t t' = Some (t'', ts ! j)"
	+ using t'_def(2) assms(2) drop
	+ by (auto elim: reaches_on.cases)
	+ show ?thesis
	+ using ru_t_event[OF t'_def(1) refl t''_def] assms(2)
	+ by auto
	+qed
	+
	+lemmas run_hd_tau_in = ru_t_tau_in[OF reach_event_t0_t, simplified]
	+
	+fun last_before :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat option" where
	+ "last_before P 0 = None"
	+\| "last_before P (Suc n) = (if P n then Some n else last_before P n)"
	+
	+lemma last_before_None: "last_before P n = None \<Longrightarrow> m < n \<Longrightarrow> \<not>P m"
	+proof (induction P n rule: last_before.induct)
	+ case (2 P n)
	+ then show ?case
	+ by (cases "m = n") (auto split: if_splits)
	+qed (auto split: if_splits)
	+
	+lemma last_before_Some: "last_before P n = Some m \<Longrightarrow> m < n \<and> P m \<and> (\<forall>k \<in> {m<..<n}. \<not>P k)"
	+ apply (induction P n rule: last_before.induct)
	+ apply (auto split: if_splits)
	+ apply (metis greaterThanLessThan_iff less_antisym)
	+ done
	+
	+inductive wf_vydra :: "('a, 't :: timestamp) formula \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a, 't, 'h) vydra_aux \<Rightarrow> bool" where
	+ "wf_vydra phi i n w \<Longrightarrow> ru n w = None \<Longrightarrow> wf_vydra (Prev I phi) (Suc i) (Suc n) VYDRA_None"
	+\| "wf_vydra phi i n w \<Longrightarrow> ru n w = None \<Longrightarrow> wf_vydra (Next I phi) i (Suc n) VYDRA_None"
	+\| "reaches_on run_hd init_hd es sub' \<Longrightarrow> length es = i \<Longrightarrow> wf_vydra (Bool b) i n (VYDRA_Bool b sub')"
	+\| "reaches_on run_hd init_hd es sub' \<Longrightarrow> length es = i \<Longrightarrow> wf_vydra (Atom a) i n (VYDRA_Atom a sub')"
	+\| "wf_vydra phi i n v \<Longrightarrow> wf_vydra (Neg phi) i (Suc n) (VYDRA_Neg v)"
	+\| "wf_vydra phi i n v \<Longrightarrow> wf_vydra psi i n v' \<Longrightarrow> wf_vydra (Bin f phi psi) i (Suc n) (VYDRA_Bin f v v')"
	+\| "wf_vydra phi i n v \<Longrightarrow> reaches_on run_hd init_hd es sub' \<Longrightarrow> length es = i \<Longrightarrow>
	+ wf_vydra (Prev I phi) i (Suc n) (VYDRA_Prev I v sub' (case i of 0 \<Rightarrow> None \| Suc j \<Rightarrow> Some (\<tau> \<sigma> j, sat phi j)))"
	+\| "wf_vydra phi i n v \<Longrightarrow> reaches_on run_hd init_hd es sub' \<Longrightarrow> length es = i \<Longrightarrow>
	+ wf_vydra (Next I phi) (i - 1) (Suc n) (VYDRA_Next I v sub' (case i of 0 \<Rightarrow> None \| Suc j \<Rightarrow> Some (\<tau> \<sigma> j)))"
	+\| "wf_vydra phi i n vphi \<Longrightarrow> wf_vydra psi j n vpsi \<Longrightarrow> j \<le> i \<Longrightarrow>
	+ reaches_on ru_t l_t0 es sub' \<Longrightarrow> length es = j \<Longrightarrow> (\<And>t. t \<in> set es \<Longrightarrow> memL t (\<tau> \<sigma> i) I) \<Longrightarrow>
	+ cphi = i - (case last_before (\<lambda>k. \<not>sat phi k) i of None \<Rightarrow> 0 \| Some k \<Rightarrow> Suc k) \<Longrightarrow> cpsi = i - j \<Longrightarrow>
	+ cppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (i - k)) \<Longrightarrow>
	+ tppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (\<tau> \<sigma> k)) \<Longrightarrow>
	+ wf_vydra (Since phi I psi) i (Suc n) (VYDRA_Since I vphi vpsi sub' cphi cpsi cppsi tppsi)"
	+\| "wf_vydra phi j n vphi \<Longrightarrow> wf_vydra psi j n vpsi \<Longrightarrow> i \<le> j \<Longrightarrow>
	+ reaches_on ru_t l_t0 es back \<Longrightarrow> length es = i \<Longrightarrow>
	+ reaches_on ru_t l_t0 es' front \<Longrightarrow> length es' = j \<Longrightarrow> (\<And>t. t \<in> set es' \<Longrightarrow> memR (\<tau> \<sigma> i) t I) \<Longrightarrow>
	+ c = j - i \<Longrightarrow> z = (case j of 0 \<Rightarrow> None \| Suc k \<Rightarrow> Some (\<tau> \<sigma> k, sat phi k, sat psi k)) \<Longrightarrow>
	+ (\<And>k. k \<in> {i..<j - 1} \<Longrightarrow> sat phi k \<and> (memL (\<tau> \<sigma> i) (\<tau> \<sigma> k) I \<longrightarrow> \<not>sat psi k)) \<Longrightarrow>
	+ wf_vydra (Until phi I psi) i (Suc n) (VYDRA_Until I back vphi vpsi front c z)"
	+\| "valid_window_matchP args I l_t0 (map (su n) (collect_subfmlas r [])) xs i w \<Longrightarrow>
	+ n \<ge> msize_regex r \<Longrightarrow> qf = state_cnt r \<Longrightarrow>
	+ transs = iarray_of_list (build_nfa_impl r (0, qf, [])) \<Longrightarrow>
	+ args = init_args ({0}, NFA.delta' transs qf, NFA.accept' transs qf)
	+ (ru_t, read_t) (run_subs (ru n)) \<Longrightarrow>
	+ wf_vydra (MatchP I r) i (Suc n) (VYDRA_MatchP I transs qf w)"
	+\| "valid_window_matchF args I l_t0 (map (su n) (collect_subfmlas r [])) xs i w \<Longrightarrow>
	+ n \<ge> msize_regex r \<Longrightarrow> qf = state_cnt r \<Longrightarrow>
	+ transs = iarray_of_list (build_nfa_impl r (0, qf, [])) \<Longrightarrow>
	+ args = init_args ({0}, NFA.delta' transs qf, NFA.accept' transs qf)
	+ (ru_t, read_t) (run_subs (ru n)) \<Longrightarrow>
	+ wf_vydra (MatchF I r) i (Suc n) (VYDRA_MatchF I transs qf w)"
	+
	+lemma reach_run_subs_len:
	+ assumes reaches_ons: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) rho vs"
	+ shows "length vs = length (collect_subfmlas r [])"
	+ using reaches_ons run_subs_lD
	+ by (induction "map (su n) (collect_subfmlas r [])" rho vs rule: reaches_on_rev_induct) fastforce+
	+
	+lemma reach_run_subs_run:
	+ assumes reaches_ons: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) rho vs"
	+ and subfmla: "j < length (collect_subfmlas r [])" "phi = collect_subfmlas r [] ! j"
	+ shows "\<exists>rho'. reaches_on (ru n) (su n phi) rho' (vs ! j) \<and> length rho' = length rho"
	+ using reaches_ons subfmla
	+proof (induction "map (su n) (collect_subfmlas r [])" rho vs rule: reaches_on_rev_induct)
	+ case 1
	+ then show ?case
	+ by (auto intro: reaches_on.intros)
	+next
	+ case (2 s' v vs' s'')
	+ note len_s'_vs = reach_run_subs_len[OF 2(1)]
	+ obtain rho' where reach_s'_vs: "reaches_on (ru n) (su n phi) rho' (s' ! j)"
	+ "length rho' = length vs'"
	+ using 2(2)[OF 2(4,5)]
	+ by auto
	+ note run_subslD = run_subs_lD[OF 2(3)]
	+ note run_subsvD = run_subs_vD[OF 2(3) 2(4)[unfolded len_s'_vs[symmetric]]]
	+ obtain vj' tj bj where vj'_def: "ru n (s' ! j) = Some (vj', tj, bj)"
	+ "s'' ! j = vj'" "IArray.sub v j = bj"
	+ using run_subsvD by auto
	+ obtain rho'' where rho''_def: "reaches_on (ru n) (su n phi) rho'' (s'' ! j)"
	+ "length rho'' = Suc (length vs')"
	+ using reaches_on_app[OF reach_s'_vs(1) vj'_def(1)] vj'_def(2) reach_s'_vs(2)
	+ by auto
	+ then show ?case
	+ using conjunct1[OF run_subslD, unfolded len_s'_vs[symmetric]]
	+ by auto
	+qed
	+
	+lemma IArray_nth_equalityI: "IArray.length xs = length ys \<Longrightarrow>
	+ (\<And>i. i < IArray.length xs \<Longrightarrow> IArray.sub xs i = ys ! i) \<Longrightarrow> xs = IArray ys"
	+ by (induction xs arbitrary: ys) (auto intro: nth_equalityI)
	+
	+lemma bs_sat:
	+ assumes IH: "\<And>phi i v v' b. phi \<in> set (collect_subfmlas r []) \<Longrightarrow> wf_vydra phi i n v \<Longrightarrow> ru n v = Some (v', b) \<Longrightarrow> snd b = sat phi i"
	+ and reaches_ons: "\<And>j. j < length (collect_subfmlas r []) \<Longrightarrow> wf_vydra (collect_subfmlas r [] ! j) i n (vs ! j)"
	+ and run_subs: "run_subs (ru n) vs = Some (vs', bs)" "length vs = length (collect_subfmlas r [])"
	+ shows "bs = iarray_of_list (map (\<lambda>phi. sat phi i) (collect_subfmlas r []))"
	+proof -
	+ have "\<And>j. j < length (collect_subfmlas r []) \<Longrightarrow>
	+ IArray.sub bs j = sat (collect_subfmlas r [] ! j) i"
	+ proof -
	+ fix j
	+ assume lassm: "j < length (collect_subfmlas r [])"
	+ define phi where "phi = collect_subfmlas r [] ! j"
	+ have phi_in_set: "phi \<in> set (collect_subfmlas r [])"
	+ using lassm
	+ by (auto simp: phi_def)
	+ have wf: "wf_vydra phi i n (vs ! j)"
	+ using reaches_ons lassm phi_def
	+ by metis
	+ show "IArray.sub bs j = sat (collect_subfmlas r [] ! j) i"
	+ using IH(1)[OF phi_in_set wf] run_subs_vD[OF run_subs(1) lassm[folded run_subs(2)]]
	+ unfolding phi_def[symmetric]
	+ by auto
	+ qed
	+ moreover have "length (IArray.list_of bs) = length vs"
	+ using run_subs(1)
	+ by (auto simp: run_subs_def Let_def iarray_of_list_def split: if_splits)
	+ ultimately show ?thesis
	+ using run_subs(2)
	+ by (auto simp: iarray_of_list_def intro!: IArray_nth_equalityI)
	+qed
	+
	+lemma run_induct[case_names Bool Atom Neg Bin Prev Next Since Until MatchP MatchF, consumes 1]:
	+ fixes phi :: "('a, 't) formula"
	+ assumes "msize_fmla phi \<le> n" "(\<And>b n. P n (Bool b))" "(\<And>a n. P n (Atom a))"
	+ "(\<And>n phi. msize_fmla phi \<le> n \<Longrightarrow> P n phi \<Longrightarrow> P (Suc n) (Neg phi))"
	+ "(\<And>n f phi psi. msize_fmla (Bin f phi psi) \<le> Suc n \<Longrightarrow> P n phi \<Longrightarrow> P n psi \<Longrightarrow>
	+ P (Suc n) (Bin f phi psi))"
	+ "(\<And>n I phi. msize_fmla phi \<le> n \<Longrightarrow> P n phi \<Longrightarrow> P (Suc n) (Prev I phi))"
	+ "(\<And>n I phi. msize_fmla phi \<le> n \<Longrightarrow> P n phi \<Longrightarrow> P (Suc n) (Next I phi))"
	+ "(\<And>n I phi psi. msize_fmla phi \<le> n \<Longrightarrow> msize_fmla psi \<le> n \<Longrightarrow> P n phi \<Longrightarrow> P n psi \<Longrightarrow> P (Suc n) (Since phi I psi))"
	+ "(\<And>n I phi psi. msize_fmla phi \<le> n \<Longrightarrow> msize_fmla psi \<le> n \<Longrightarrow> P n phi \<Longrightarrow> P n psi \<Longrightarrow> P (Suc n) (Until phi I psi))"
	+ "(\<And>n I r. msize_fmla (MatchP I r) \<le> Suc n \<Longrightarrow> (\<And>x. msize_fmla x \<le> n \<Longrightarrow> P n x) \<Longrightarrow>
	+ P (Suc n) (MatchP I r))"
	+ "(\<And>n I r. msize_fmla (MatchF I r) \<le> Suc n \<Longrightarrow> (\<And>x. msize_fmla x \<le> n \<Longrightarrow> P n x) \<Longrightarrow>
	+ P (Suc n) (MatchF I r))"
	+ shows "P n phi"
	+ using assms(1)
	+proof (induction n arbitrary: phi rule: nat_less_induct)
	+ case (1 n)
	+ show ?case
	+ proof (cases n)
	+ case 0
	+ show ?thesis
	+ using 1 assms(2-)
	+ by (cases phi) (auto simp: 0)
	+ next
	+ case (Suc m)
	+ show ?thesis
	+ using 1 assms(2-)
	+ by (cases phi) (auto simp: Suc)
	+ qed
	+qed
	+
	+lemma wf_vydra_sub: "msize_fmla \<phi> \<le> n \<Longrightarrow> wf_vydra \<phi> 0 n (su n \<phi>)"
	+proof (induction n \<phi> rule: run_induct)
	+ case (Prev n I phi)
	+ then show ?case
	+ using wf_vydra.intros(7)[where ?i=0, OF _ reaches_on.intros(1)]
	+ by auto
	+next
	+ case (Next n I phi)
	+ then show ?case
	+ using wf_vydra.intros(8)[where ?i=0, OF _ reaches_on.intros(1)]
	+ by auto
	+next
	+ case (MatchP n I r)
	+ let ?qf = "state_cnt r"
	+ let ?transs = "iarray_of_list (build_nfa_impl r (0, ?qf, []))"
	+ let ?args = "init_args ({0}, NFA.delta' ?transs ?qf, NFA.accept' ?transs ?qf) (ru_t, read_t) (run_subs (ru n))"
	+ show ?case
	+ using MatchP valid_init_window[of ?args l_t0 "map (su n) (collect_subfmlas r [])", simplified]
	+ by (auto simp: Let_def valid_window_matchP_def split: option.splits intro: reaches_on.intros
	+ intro!: wf_vydra.intros(11)[where ?xs="[]", OF _ _ refl refl refl])
	+next
	+ case (MatchF n I r)
	+ let ?qf = "state_cnt r"
	+ let ?transs = "iarray_of_list (build_nfa_impl r (0, ?qf, []))"
	+ let ?args = "init_args ({0}, NFA.delta' ?transs ?qf, NFA.accept' ?transs ?qf) (ru_t, read_t) (run_subs (ru n))"
	+ show ?case
	+ using MatchF valid_init_window[of ?args l_t0 "map (su n) (collect_subfmlas r [])", simplified]
	+ by (auto simp: Let_def valid_window_matchF_def split: option.splits intro: reaches_on.intros
	+ intro!: wf_vydra.intros(12)[where ?xs="[]", OF _ _ refl refl refl])
	+qed (auto simp: Let_def intro: wf_vydra.intros reaches_on.intros)
	+
	+lemma ru_t_Some: "\<exists>e' et. ru_t e = Some (e', et)" if reaches_Suc_i: "reaches_on run_hd init_hd fs f" "length fs = Suc i"
	+ and aux: "reaches_on ru_t l_t0 es e" "length es \<le> i" for es e
	+proof -
	+ obtain fs' ft where ft_def: "reaches_on ru_t l_t0 (map fst (fs' :: ('t \<times> 'a set) list)) (Some (f, ft))"
	+ "map fst fs = map fst fs' @ [ft]" "length fs' = i"
	+ using reaches_Suc_i
	+ by (cases fs rule: rev_cases) (auto dest!: reaches_on_split_last reach_event_t0_t)
	+ show ?thesis
	+ proof (cases "length es = i")
	+ case True
	+ have e_def: "e = Some (f, ft)"
	+ using reaches_on_inj[OF aux(1) ft_def(1)]
	+ by (auto simp: True ft_def(3))
	+ then show ?thesis
	+ by (cases "run_hd f") (auto simp: e_def)
	+ next
	+ case False
	+ obtain s' s'' where split: "reaches_on ru_t l_t0 (take (length es) (map fst fs')) s'"
	+ "ru_t s' = Some (s'', map fst fs' ! (length es))"
	+ using reaches_on_split[OF ft_def(1), where ?i="length es"] False aux(2)
	+ by (auto simp: ft_def(3))
	+ show ?thesis
	+ using reaches_on_inj[OF aux(1) split(1)] aux(2)
	+ by (auto simp: ft_def(3) split(2))
	+ qed
	+qed
	+
	+lemma vydra_sound_aux:
	+ assumes "msize_fmla \<phi> \<le> n" "wf_vydra \<phi> i n v" "ru n v = Some (v', t, b)" "bounded_future_fmla \<phi>" "wf_fmla \<phi>"
	+ shows "wf_vydra \<phi> (Suc i) n v' \<and> (\<exists>es e. reaches_on run_hd init_hd es e \<and> length es = Suc i) \<and> t = \<tau> \<sigma> i \<and> b = sat \<phi> i"
	+ using assms
	+proof (induction n \<phi> arbitrary: i v v' t b rule: run_induct)
	+ case (Bool \<beta> n)
	+ then show ?case
	+ using reaches_on_run_hd reaches_on_app wf_vydra.intros(3)[OF reaches_on_app refl]
	+ by (fastforce elim!: wf_vydra.cases[of _ _ _ "v"] split: option.splits)
	+next
	+ case (Atom a n)
	+ then show ?case
	+ using reaches_on_run_hd reaches_on_app wf_vydra.intros(4)[OF reaches_on_app refl]
	+ by (fastforce elim!: wf_vydra.cases[of _ _ _ v] split: option.splits)
	+next
	+ case (Neg n x)
	+ have IH: "wf_vydra x i n v \<Longrightarrow> ru n v = Some (v', t, b) \<Longrightarrow> wf_vydra x (Suc i) n v' \<and> (\<exists>es e. reaches_on run_hd init_hd es e \<and> length es = Suc i) \<and> t = \<tau> \<sigma> i \<and> b = sat x i" for v v' t b
	+ using Neg(2,5,6)
	+ by auto
	+ show ?case
	+ apply (rule wf_vydra.cases[OF Neg(3)])
	+ using Neg(4) IH wf_vydra.intros(5)
	+ by (fastforce split: option.splits)+
	+next
	+ case (Bin n f x1 x2)
	+ have IH1: "wf_vydra x1 i n v \<Longrightarrow> ru n v = Some (v', t, b) \<Longrightarrow> wf_vydra x1 (Suc i) n v' \<and> (\<exists>es e. reaches_on run_hd init_hd es e \<and> length es = Suc i) \<and> t = \<tau> \<sigma> i \<and> b = sat x1 i" for v v' t b
	+ using Bin(2,6,7)
	+ by auto
	+ have IH2: "wf_vydra x2 i n v \<Longrightarrow> ru n v = Some (v', t, b) \<Longrightarrow> wf_vydra x2 (Suc i) n v' \<and> t = \<tau> \<sigma> i \<and> b = sat x2 i" for v v' t b
	+ using Bin(3,6,7)
	+ by auto
	+ show ?case
	+ apply (rule wf_vydra.cases[OF Bin(4)])
	+ using Bin(5) IH1 IH2 wf_vydra.intros(6)
	+ by (fastforce split: option.splits)+
	+next
	+ case (Prev n I phi)
	+ show ?case
	+ proof (cases i)
	+ case 0
	+ then show ?thesis
	+ using Prev run_hd_sound[OF reaches.intros(1)] wf_vydra.intros(7)[OF _ reaches_on.intros(2)[OF _ reaches_on.intros(1)], where ?i="Suc 0", simplified]
	+ by (fastforce split: nat.splits option.splits dest!: reaches_on_NilD elim!: wf_vydra.cases[of _ _ _ v] intro: wf_vydra.intros(1) reaches_on.intros(2)[OF _ reaches_on.intros(1)])
	+ next
	+ case (Suc j)
	+ obtain vphi es sub where v_def: "v = VYDRA_Prev I vphi sub (Some (\<tau> \<sigma> j, sat phi j))"
	+ "wf_vydra phi i n vphi" "reaches_on run_hd init_hd es sub" "length es = i"
	+ using Prev(3,4)
	+ by (auto simp: Suc elim!: wf_vydra.cases[of _ _ _ v])
	+ obtain sub' X where run_sub: "run_hd sub = Some (sub', (t, X))"
	+ using Prev(4)
	+ by (auto simp: v_def(1) Let_def split: option.splits)
	+ note reaches_sub' = reaches_on_app[OF v_def(3) run_sub]
	+ have t_def: "t = \<tau> \<sigma> (Suc j)"
	+ using reaches_on_run_hd[OF v_def(3) run_sub]
	+ by (auto simp: Suc v_def(2,4))
	+ show ?thesis
	+ proof (cases "v' = VYDRA_None")
	+ case v'_def: True
	+ show ?thesis
	+ using Prev(4) v_def(2) reaches_sub'
	+ by (auto simp: Suc Let_def v_def(1,4) v'_def run_sub t_def split: option.splits intro: wf_vydra.intros(1))
	+ next
	+ case False
	+ obtain vphi' where ru_vphi: "ru n vphi = Some (vphi', (\<tau> \<sigma> i, sat phi i))"
	+ using Prev(2)[OF v_def(2)] Prev(4,5,6) False
	+ by (auto simp: v_def(1) Let_def split: option.splits)
	+ have wf': "wf_vydra phi (Suc (Suc j)) n vphi'"
	+ using Prev(2)[OF v_def(2) ru_vphi] Prev(5,6)
	+ by (auto simp: Suc)
	+ show ?thesis
	+ using Prev(4) wf_vydra.intros(7)[OF wf' reaches_sub'] reaches_sub'
	+ by (auto simp: Let_def Suc t_def v_def(1,4) run_sub ru_vphi)
	+ qed
	+ qed
	+next
	+ case (Next n I phi)
	+ obtain w sub to es where v_def: "v = VYDRA_Next I w sub to" "wf_vydra phi (length es) n w"
	+ "reaches_on run_hd init_hd es sub" "length es = (case to of None \<Rightarrow> 0 \| _ \<Rightarrow> Suc i)"
	+ "case to of None \<Rightarrow> i = 0 \| Some told \<Rightarrow> told = \<tau> \<sigma> i"
	+ using Next(3,4)
	+ by (auto elim!: wf_vydra.cases[of _ _ _ v] split: option.splits nat.splits)
	+ obtain sub' tnew X where run_sub: "run_hd sub = Some (sub', (tnew, X))"
	+ using Next(4)
	+ by (auto simp: v_def(1) split: option.splits)
	+ have tnew_def: "tnew = \<tau> \<sigma> (length es)"
	+ using reaches_on_run_hd[OF v_def(3) run_sub]
	+ by auto
	+ have aux: ?case if aux_assms: "wf_vydra phi (Suc i) n w"
	+ "ru (Suc n) (VYDRA_Next I w sub (Some t0)) = Some (v', t, b)"
	+ "reaches_on run_hd init_hd es sub" "length es = Suc i" "t0 = \<tau> \<sigma> i" for w sub t0 es
	+ using aux_assms(1,2,5) wf_vydra.intros(2)[OF aux_assms(1)]
	+ Next(2)[where ?i="Suc i" and ?v="w"] Next(5,6) reaches_on_run_hd[OF aux_assms(3)]
	+ wf_vydra.intros(8)[OF _ reaches_on_app[OF aux_assms(3)], where ?phi=phi and ?i="Suc (Suc i)" and ?n="n"] aux_assms(3)
	+ by (auto simp: run_sub aux_assms(4,5) split: option.splits if_splits)
	+ show ?case
	+ proof (cases to)
	+ case None
	+ obtain w' z where w_def: "ru (Suc n) v = ru (Suc n) (VYDRA_Next I w' sub' (Some tnew))"
	+ "ru n w = Some (w', z)"
	+ using Next(4)
	+ by (cases "ru n w") (auto simp: v_def(1) run_sub None split: option.splits)
	+ have wf: "wf_vydra phi (Suc i) n w'"
	+ using v_def w_def(2) Next(2,5,6)
	+ by (cases z) (auto simp: None intro: wf_vydra.intros(1))
	+ show ?thesis
	+ using aux[OF wf Next(4)[unfolded w_def(1)] reaches_on_app[OF v_def(3) run_sub]] v_def(4,5) tnew_def
	+ by (auto simp: None)
	+ next
	+ case (Some z)
	+ show ?thesis
	+ using aux[OF _ _ v_def(3), where ?w="w"] v_def(2,4,5) Next(4)
	+ by (auto simp: v_def(1) Some simp del: run.simps)
	+ qed
	+next
	+ case (Since n I phi psi)
	+ obtain vphi vpsi e cphi cpsi cppsi tppsi j es where v_def:
	+ "v = VYDRA_Since I vphi vpsi e cphi cpsi cppsi tppsi"
	+ "wf_vydra phi i n vphi" "wf_vydra psi j n vpsi" "j \<le> i"
	+ "reaches_on ru_t l_t0 es e" "length es = j" "\<And>t. t \<in> set es \<Longrightarrow> memL t (\<tau> \<sigma> i) I"
	+ "cphi = i - (case last_before (\<lambda>k. \<not>sat phi k) i of None \<Rightarrow> 0 \| Some k \<Rightarrow> Suc k)" "cpsi = i - j"
	+ "cppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (i - k))"
	+ "tppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (\<tau> \<sigma> k))"
	+ using Since(5)
	+ by (auto elim: wf_vydra.cases)
	+ obtain vphi' b1 where run_vphi: "ru n vphi = Some (vphi', t, b1)"
	+ using Since(6)
	+ by (auto simp: v_def(1) Let_def split: option.splits)
	+ obtain fs f where wf_vphi': "wf_vydra phi (Suc i) n vphi'"
	+ and reaches_Suc_i: "reaches_on run_hd init_hd fs f" "length fs = Suc i"
	+ and t_def: "t = \<tau> \<sigma> i" and b1_def: "b1 = sat phi i"
	+ using Since(3)[OF v_def(2) run_vphi] Since(7,8)
	+ by auto
	+ note ru_t_Some = ru_t_Some[OF reaches_Suc_i]
	+ define loop_inv where "loop_inv = (\<lambda>(vpsi, e, cpsi :: nat, cppsi, tppsi).
	+ let j = Suc i - cpsi in cpsi \<le> Suc i \<and>
	+ wf_vydra psi j n vpsi \<and> (\<exists>es. reaches_on ru_t l_t0 es e \<and> length es = j \<and> (\<forall>t \<in> set es. memL t (\<tau> \<sigma> i) I)) \<and>
	+ cppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (Suc i - k)) \<and>
	+ tppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (\<tau> \<sigma> k)))"
	+ define loop_init where "loop_init = (vpsi, e, Suc cpsi, map_option Suc cppsi, tppsi)"
	+ obtain vpsi' e' cpsi' cppsi' tppsi' where loop_def: "while_break (while_since_cond I t) (while_since_body run_hd (ru n)) loop_init =
	+ Some (vpsi', e', cpsi', cppsi', tppsi')"
	+ using Since(6)
	+ by (auto simp: v_def(1) run_vphi loop_init_def Let_def split: option.splits)
	+ have j_def: "j = i - cpsi"
	+ using v_def(4,9)
	+ by auto
	+ have "cpsi \<le> i"
	+ using v_def(9)
	+ by auto
	+ then have loop_inv_init: "loop_inv loop_init"
	+ using v_def(3,5,6,7,10,11) last_before_Some
	+ by (fastforce simp: loop_inv_def loop_init_def Let_def j_def split: option.splits)
	+ have wf_loop: "wf {(s', s). loop_inv s \<and> while_since_cond I t s \<and> Some s' = while_since_body run_hd (ru n) s}"
	+ by (auto intro: wf_subset[OF wf_since])
	+ have step_loop: "loop_inv s'" if loop_assms: "loop_inv s" "while_since_cond I t s" "while_since_body run_hd (ru n) s = Some s'" for s s'
	+ proof -
	+ obtain vpsi e cpsi cppsi tppsi where s_def: "s = (vpsi, e, cpsi, cppsi, tppsi)"
	+ by (cases s) auto
	+ define j where "j = Suc i - cpsi"
	+ obtain es where loop_before: "cpsi \<le> Suc i" "wf_vydra psi j n vpsi"
	+ "reaches_on ru_t l_t0 es e" "length es = j" "\<And>t. t \<in> set es \<Longrightarrow> memL t (\<tau> \<sigma> i) I"
	+ "cppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (Suc i - k))"
	+ "tppsi = (case last_before (sat psi) j of None \<Rightarrow> None \| Some k \<Rightarrow> Some (\<tau> \<sigma> k))"
	+ using loop_assms(1)
	+ by (auto simp: s_def j_def loop_inv_def Let_def)
	+ obtain tt h where tt_def: "read_t e = Some tt" "memL tt t I" "e = Some (h, tt)"
	+ using ru_t_Some[OF loop_before(3)] loop_before(4) loop_assms(2)
	+ by (cases e) (fastforce simp: while_since_cond_def s_def j_def split: option.splits)+
	+ obtain e' where e'_def: "reaches_on ru_t l_t0 (es @ [tt]) e'" "ru_t e = Some (e', tt)"
	+ using reaches_on_app[OF loop_before(3)] tt_def(1)
	+ by (cases "run_hd h") (auto simp: tt_def(3))
	+ obtain vpsi' t' b' where run_vpsi: "ru n vpsi = Some (vpsi', (t', b'))"
	+ using loop_assms(3)
	+ by (auto simp: while_since_body_def s_def Let_def split: option.splits)
	+ have wf_psi': "wf_vydra psi (Suc j) n vpsi'" and t'_def: "t' = \<tau> \<sigma> j" and b'_def: "b' = sat psi j"
	+ using Since(4)[OF loop_before(2) run_vpsi] Since(7,8)
	+ by auto
	+ define j' where j'_def: "j' = Suc i - (cpsi - Suc 0)"
	+ have cpsi_pos: "cpsi > 0"
	+ using loop_assms(2)
	+ by (auto simp: while_since_cond_def s_def)
	+ have j'_j: "j' = Suc j"
	+ using loop_before(1) cpsi_pos
	+ by (auto simp: j'_def j_def)
	+ define cppsi' where "cppsi' = (if b' then Some cpsi else cppsi)"
	+ define tppsi' where "tppsi' = (if b' then Some t' else tppsi)"
	+ have cppsi': "cppsi' = (case last_before (sat psi) j' of None \<Rightarrow> None \| Some k \<Rightarrow> Some (Suc i - k))"
	+ using cpsi_pos loop_before(1)
	+ by (auto simp: cppsi'_def b'_def j'_j loop_before(6) j_def)
	+ have tppsi': "tppsi' = (case last_before (sat psi) j' of None \<Rightarrow> None \| Some k \<Rightarrow> Some (\<tau> \<sigma> k))"
	+ by (auto simp: tppsi'_def t'_def b'_def j'_j loop_before(7) split: option.splits)
	+ have s'_def: "s' = (vpsi', fst (the (ru_t e)), cpsi - Suc 0, cppsi', tppsi')"
	+ using loop_assms(3)
	+ by (auto simp: while_since_body_def s_def run_vpsi cppsi'_def tppsi'_def)
	+ show ?thesis
	+ using loop_before(1,4,5) tt_def(2) wf_psi'[folded j'_j] cppsi' tppsi' e'_def(1)
	+ by (fastforce simp: loop_inv_def s'_def j'_def[symmetric] e'_def(2) j'_j t_def)
	+ qed
	+ have loop: "loop_inv (vpsi', e', cpsi', cppsi', tppsi')" "\<not>while_since_cond I t (vpsi', e', cpsi', cppsi', tppsi')"
	+ using while_break_sound[where ?P="loop_inv" and ?Q="\<lambda>s. loop_inv s \<and> \<not>while_since_cond I t s", OF step_loop _ wf_loop loop_inv_init]
	+ by (auto simp: loop_def)
	+ define cphi' where "cphi' = (if b1 then Suc cphi else 0)"
	+ have v'_def: "v' = VYDRA_Since I vphi' vpsi' e' cphi' cpsi' cppsi' tppsi'"
	+ and b_def: "b = (case cppsi' of None \<Rightarrow> False \| Some k \<Rightarrow> k - 1 \<le> cphi' \<and> memR (the tppsi') t I)"
	+ using Since(6)
	+ by (auto simp: v_def(1) run_vphi loop_init_def[symmetric] loop_def cphi'_def Let_def split: option.splits)
	+ have read_t_e': "cpsi' > 0 \<Longrightarrow> read_t e' = None \<Longrightarrow> False"
	+ using loop(1) ru_t_Some[where ?e=e'] run_t_read
	+ by (fastforce simp: loop_inv_def Let_def)
	+ define j' where "j' = Suc i - cpsi'"
	+ have wf_vpsi': "wf_vydra psi j' n vpsi'" and cpsi'_le_Suc_i: "cpsi' \<le> Suc i"
	+ and cppsi'_def: "cppsi' = (case last_before (sat psi) j' of None \<Rightarrow> None \| Some k \<Rightarrow> Some (Suc i - k))"
	+ and tppsi'_def: "tppsi' = (case last_before (sat psi) j' of None \<Rightarrow> None \| Some k \<Rightarrow> Some (\<tau> \<sigma> k))"
	+ using loop(1)
	+ by (auto simp: loop_inv_def j'_def[symmetric])
	+ obtain es' where es'_def: "reaches_on ru_t l_t0 es' e'" "length es' = j'" "\<And>t. t \<in> set es' \<Longrightarrow> memL t (\<tau> \<sigma> i) I"
	+ using loop(1)
	+ by (auto simp: loop_inv_def j'_def[symmetric])
	+ have wf_v': "wf_vydra (Since phi I psi) (Suc i) (Suc n) v'"
	+ and cphi'_sat: "cphi' = Suc i - (case last_before (\<lambda>k. \<not>sat phi k) (Suc i) of None \<Rightarrow> 0 \| Some k \<Rightarrow> Suc k)"
	+ using cpsi'_le_Suc_i last_before_Some es'_def(3) memL_mono'[OF _ \<tau>_mono[of i "Suc i" \<sigma>]]
	+ by (force simp: v'_def cppsi'_def tppsi'_def j'_def cphi'_def b1_def v_def(8) split: option.splits
	+ intro!: wf_vydra.intros(9)[OF wf_vphi' wf_vpsi' _ es'_def(1-2)])+
	+ have "j' = Suc i \<or> \<not>memL (\<tau> \<sigma> j') (\<tau> \<sigma> i) I"
	+ using loop(2) j'_def read_t_e' ru_t_tau[OF es'_def(1)] read_t_run[where ?run_hd=run_hd]
	+ by (fastforce simp: while_since_cond_def es'_def(2) t_def split: option.splits)
	+ then have tau_k_j': "k \<le> i \<Longrightarrow> memL (\<tau> \<sigma> k) (\<tau> \<sigma> i) I \<longleftrightarrow> k < j'" for k
	+ using ru_t_tau_in[OF es'_def(1)] es'_def(3) \<tau>_mono[of j' k \<sigma>] memL_mono
	+ by (fastforce simp: es'_def(2) in_set_conv_nth)
	+ have b_sat: "b = sat (Since phi I psi) i"
	+ proof (rule iffI)
	+ assume b: "b"
	+ obtain m where m_def: "last_before (sat psi) j' = Some m" "i - m \<le> cphi'" "memR (\<tau> \<sigma> m) (\<tau> \<sigma> i) I"
	+ using b
	+ by (auto simp: b_def t_def cppsi'_def tppsi'_def split: option.splits)
	+ note aux = last_before_Some[OF m_def(1)]
	+ have mem: "mem (\<tau> \<sigma> m) (\<tau> \<sigma> i) I"
	+ using m_def(3) tau_k_j' aux
	+ by (auto simp: mem_def j'_def)
	+ have sat_phi: "sat phi x" if "m < x" "x \<le> i" for x
	+ using m_def(2) that le_neq_implies_less
	+ by (fastforce simp: cphi'_sat dest: last_before_None last_before_Some split: option.splits if_splits)
	+ show "sat (Since phi I psi) i"
	+ using aux mem sat_phi
	+ by (auto simp: j'_def intro!: exI[of _ m])
	+ next
	+ assume sat: "sat (Since phi I psi) i"
	+ then obtain k where k_def: "k \<le> i" "mem (\<tau> \<sigma> k) (\<tau> \<sigma> i) I" "sat psi k" "\<And>k'. k < k' \<and> k' \<le> i \<Longrightarrow> sat phi k'"
	+ by auto
	+ have k_j': "k < j'"
	+ using tau_k_j'[OF k_def(1)] k_def(2)
	+ by (auto simp: mem_def)
	+ obtain m where m_def: "last_before (sat psi) j' = Some m"
	+ using last_before_None[where ?P="sat psi" and ?n=j' and ?m=k] k_def(3) k_j'
	+ by (cases "last_before (sat psi) j'") auto
	+ have cppsi'_Some: "cppsi' = Some (Suc i - m)"
	+ by (auto simp: cppsi'_def m_def)
	+ have tppsi'_Some: "tppsi' = Some (\<tau> \<sigma> m)"
	+ by (auto simp: tppsi'_def m_def)
	+ have m_k: "k \<le> m"
	+ using last_before_Some[OF m_def] k_def(3) k_j'
	+ by auto
	+ have tau_i_m: "memR (\<tau> \<sigma> m) (\<tau> \<sigma> i) I"
	+ using \<tau>_mono[OF m_k, where ?s=\<sigma>] memR_mono k_def(2)
	+ by (auto simp: mem_def)
	+ have "i - m \<le> cphi'"
	+ using k_def(1) k_def(4) m_k
	+ apply (cases "k = i")
	+ apply (auto simp: cphi'_sat b1_def dest!: last_before_Some split: option.splits)
	+ apply (metis diff_le_mono2 le_neq_implies_less le_trans less_imp_le_nat nat_le_linear)
	+ done
	+ then show "b"
	+ using tau_i_m
	+ by (auto simp: b_def t_def cppsi'_Some tppsi'_Some)
	+ qed
	+ show ?case
	+ using wf_v' reaches_Suc_i
	+ by (auto simp: t_def b_sat)
	+next
	+ case (Until n I phi psi)
	+ obtain "back" vphi vpsi front c z es es' j where v_def:
	+ "v = VYDRA_Until I back vphi vpsi front c z"
	+ "wf_vydra phi j n vphi" "wf_vydra psi j n vpsi" "i \<le> j"
	+ "reaches_on ru_t l_t0 es back" "length es = i"
	+ "reaches_on ru_t l_t0 es' front" "length es' = j" "\<And>t. t \<in> set es' \<Longrightarrow> memR (\<tau> \<sigma> i) t I"
	+ "c = j - i" "z = (case j of 0 \<Rightarrow> None \| Suc k \<Rightarrow> Some (\<tau> \<sigma> k, sat phi k, sat psi k))"
	+ "\<And>k. k \<in> {i..<j - 1} \<Longrightarrow> sat phi k \<and> (memL (\<tau> \<sigma> i) (\<tau> \<sigma> k) I \<longrightarrow> \<not>sat psi k)"
	+ using Until(5)
	+ by (auto elim: wf_vydra.cases)
	+ define loop_init where "loop_init = (vphi, vpsi, front, c, z)"
	+ obtain back' vphi' vpsi' epsi' c' zo' zt zb1 zb2 where run_back: "ru_t back = Some (back', t)"
	+ and loop_def: "while_break (while_until_cond I t) (while_until_body run_hd (ru n)) loop_init = Some (vphi', vpsi', epsi', c', zo')"
	+ and v'_def: "v' = VYDRA_Until I back' vphi' vpsi' epsi' (c' - 1) zo'"
	+ and c'_pos: "\<not>c' = 0"
	+ and zo'_Some: "zo' = Some (zt, (zb1, zb2))"
	+ and b_def: "b = (zb2 \<and> memL t zt I)"
	+ using Until(6)
	+ apply (auto simp: v_def(1) Let_def loop_init_def[symmetric] split: option.splits nat.splits if_splits)
	+ done
	+ define j' where "j' = i + c'"
	+ have j_eq: "j = i + c"
	+ using v_def(4)
	+ by (auto simp: v_def(10))
	+ have t_def: "t = \<tau> \<sigma> i"
	+ using ru_t_tau[OF v_def(5) run_back]
	+ by (auto simp: v_def(6))
	+ define loop_inv where "loop_inv = (\<lambda>(vphi, vpsi, epsi, c, zo).
	+ let j = i + c in
	+ wf_vydra phi j n vphi \<and> wf_vydra psi j n vpsi \<and>
	+ (\<exists>gs. reaches_on ru_t l_t0 gs epsi \<and> length gs = j \<and> (\<forall>t. t \<in> set gs \<longrightarrow> memR (\<tau> \<sigma> i) t I)) \<and>
	+ zo = (case j of 0 \<Rightarrow> None \| Suc k \<Rightarrow> Some (\<tau> \<sigma> k, sat phi k, sat psi k)) \<and>
	+ (\<forall>k. k \<in> {i..<j - 1} \<longrightarrow> sat phi k \<and> (memL (\<tau> \<sigma> i) (\<tau> \<sigma> k) I \<longrightarrow> \<not>sat psi k)))"
	+ have loop_inv_init: "loop_inv loop_init"
	+ using v_def(2,3,7,9,12)
	+ by (auto simp: loop_inv_def loop_init_def j_eq[symmetric] v_def(8,11))
	+ have loop_step: "loop_inv s'" if loop_assms: "loop_inv s" "while_until_cond I t s" "while_until_body run_hd (ru n) s = Some s'" for s s'
	+ proof -
	+ obtain vphi_cur vpsi_cur epsi_cur c_cur zo_cur where s_def: "s = (vphi_cur, vpsi_cur, epsi_cur, c_cur, zo_cur)"
	+ by (cases s) auto
	+ define j_cur where "j_cur = i + c_cur"
	+ obtain epsi'_cur t'_cur vphi'_cur tphi_cur bphi_cur vpsi'_cur tpsi_cur bpsi_cur where
	+ run_epsi: "ru_t epsi_cur = Some (epsi'_cur, t'_cur)"
	+ and run_vphi: "ru n vphi_cur = Some (vphi'_cur, (tphi_cur, bphi_cur))"
	+ and run_vpsi: "ru n vpsi_cur = Some (vpsi'_cur, (tpsi_cur, bpsi_cur))"
	+ using loop_assms(2,3)
	+ apply (auto simp: while_until_cond_def while_until_body_def s_def split: option.splits dest: read_t_run[where ?run_hd=run_hd])
	+ done
	+ have wf: "wf_vydra phi j_cur n vphi_cur" "wf_vydra psi j_cur n vpsi_cur"
	+ and zo_cur_def: "zo_cur = (case j_cur of 0 \<Rightarrow> None \| Suc k \<Rightarrow> Some (\<tau> \<sigma> k, sat phi k, sat psi k))"
	+ using loop_assms(1)
	+ by (auto simp: loop_inv_def s_def j_cur_def[symmetric])
	+ have wf': "wf_vydra phi (Suc j_cur) n vphi'_cur" "tphi_cur = \<tau> \<sigma> j_cur" "bphi_cur = sat phi j_cur"
	+ "wf_vydra psi (Suc j_cur) n vpsi'_cur" "tpsi_cur = \<tau> \<sigma> j_cur" "bpsi_cur = sat psi j_cur"
	+ using Until(3)[OF wf(1) run_vphi] Until(4)[OF wf(2) run_vpsi] Until(7,8)
	+ apply (auto)
	+ done
	+ have s'_def: "s' = (vphi'_cur, vpsi'_cur, epsi'_cur, Suc c_cur, Some (t'_cur, (bphi_cur, bpsi_cur)))"
	+ using loop_assms(3)
	+ by (auto simp: while_until_body_def s_def run_epsi run_vphi run_vpsi)
	+ obtain gs_cur where gs_cur_def: "reaches_on ru_t l_t0 gs_cur epsi_cur"
	+ "length gs_cur = j_cur" "\<And>t. t \<in> set gs_cur \<Longrightarrow> memR (\<tau> \<sigma> i) t I"
	+ using loop_assms(1)
	+ by (auto simp: loop_inv_def s_def j_cur_def[symmetric])
	+ have t'_cur_def: "t'_cur = \<tau> \<sigma> j_cur"
	+ using ru_t_tau[OF gs_cur_def(1) run_epsi]
	+ by (auto simp: gs_cur_def(2))
	+ have t'_cur_right_I: "memR t t'_cur I"
	+ using loop_assms(2) run_t_read[OF run_epsi]
	+ by (auto simp: while_until_cond_def s_def)
	+ have c_cur_zero: "c_cur = 0 \<Longrightarrow> j_cur = i"
	+ by (auto simp: j_cur_def)
	+ have "k \<in> {i..<Suc j_cur - 1} \<Longrightarrow> sat phi k \<and> (memL (\<tau> \<sigma> i) (\<tau> \<sigma> k) I \<longrightarrow> \<not>sat psi k)" for k
	+ using loop_assms(1,2)
	+ by (cases "k = j_cur - Suc 0") (auto simp: while_until_cond_def loop_inv_def j_cur_def[symmetric] zo_cur_def s_def until_ready_def t_def split: nat.splits dest: c_cur_zero)
	+ then show ?thesis
	+ using wf' t'_cur_right_I
	+ using reaches_on_app[OF gs_cur_def(1) run_epsi] gs_cur_def(2,3)
	+ by (auto simp: loop_inv_def s'_def j_cur_def[symmetric] t_def t'_cur_def intro!: exI[of _ "gs_cur @ [t'_cur]"])
	+ qed
	+ have wf_loop: "wf {(s', s). loop_inv s \<and> while_until_cond I t s \<and> Some s' = while_until_body run_hd (ru n) s}"
	+ proof -
	+ obtain m where m_def: "\<not>\<tau> \<sigma> m \<le> \<tau> \<sigma> i + right I"
	+ using ex_lt_\<tau>[where ?x="right I" and ?s=\<sigma>] Until(7)
	+ by auto
	+ define X where "X = {(s', s). loop_inv s \<and> while_until_cond I t s \<and> Some s' = while_until_body run_hd (ru n) s}"
	+ have "memR t (\<tau> \<sigma> (i + c)) I \<Longrightarrow> i + c < m" for c
	+ using m_def order_trans[OF \<tau>_mono[where ?i=m and ?j="i + c" and ?s=\<sigma>]]
	+ by (fastforce simp: t_def dest!: memR_dest)
	+ then have "X \<subseteq> measure (\<lambda>(vphi, vpsi, epsi, c, zo). m - c)"
	+ by (fastforce simp: X_def while_until_cond_def while_until_body_def loop_inv_def Let_def split: option.splits
	+ dest!: read_t_run[where ?run_hd=run_hd] dest: ru_t_tau)
	+ then show ?thesis
	+ using wf_subset
	+ by (auto simp: X_def[symmetric])
	+ qed
	+ have loop: "loop_inv (vphi', vpsi', epsi', c', zo')" "\<not>while_until_cond I t (vphi', vpsi', epsi', c', zo')"
	+ using while_break_sound[where ?Q="\<lambda>s. loop_inv s \<and> \<not>while_until_cond I t s", OF _ _ wf_loop loop_inv_init] loop_step
	+ by (auto simp: loop_def)
	+ have tau_right_I: "k < j' \<Longrightarrow> memR (\<tau> \<sigma> i) (\<tau> \<sigma> k) I" for k
	+ using loop(1) ru_t_tau_in
	+ by (auto simp: loop_inv_def j'_def[symmetric] in_set_conv_nth)
	+ have read_t_epsi': "read_t epsi' = Some et \<Longrightarrow> et = \<tau> \<sigma> j'" for et
	+ using loop(1) ru_t_tau
	+ by (fastforce simp: loop_inv_def Let_def j'_def dest!: read_t_run[where ?run_hd=run_hd])
	+ have end_cond: "until_ready I t c' zo' \<or> \<not>(memR (\<tau> \<sigma> i) (\<tau> \<sigma> j') I)"
	+ unfolding t_def[symmetric]
	+ using Until(6) c'_pos loop(2)[unfolded while_until_cond_def]
	+ by (auto simp: until_ready_def v_def(1) run_back loop_init_def[symmetric] loop_def zo'_Some split: if_splits option.splits nat.splits dest: read_t_epsi')
	+ have Suc_i_le_j': "Suc i \<le> j'" and c'_j': "c' - Suc 0 = j' - Suc i"
	+ using end_cond c'_pos
	+ by (auto simp: until_ready_def j'_def split: nat.splits)
	+ have zo'_def: "zo' = (case j' of 0 \<Rightarrow> None \| Suc k \<Rightarrow> Some (\<tau> \<sigma> k, sat phi k, sat psi k))"
	+ and sat_phi: "k \<in> {i..<j' - 1} \<Longrightarrow> sat phi k"
	+ and not_sat_psi: "k \<in> {i..<j' - 1} \<Longrightarrow> memL (\<tau> \<sigma> i) (\<tau> \<sigma> k) I \<Longrightarrow> \<not>sat psi k" for k
	+ using loop(1)
	+ by (auto simp: loop_inv_def j'_def[symmetric])
	+ have b_sat: "b = sat (Until phi I psi) i"
	+ proof (rule iffI)
	+ assume b: "b"
	+ have mem: "mem (\<tau> \<sigma> i) (\<tau> \<sigma> (j' - Suc 0)) I"
	+ using b zo'_def tau_right_I[where ?k="j' - 1"]
	+ by (auto simp: mem_def b_def t_def zo'_Some split: nat.splits)
	+ have sat_psi: "sat psi (j' - 1)"
	+ using b zo'_def
	+ by (auto simp: b_def zo'_Some split: nat.splits)
	+ show "sat (Until phi I psi) i"
	+ using Suc_i_le_j' mem sat_psi sat_phi
	+ by (auto intro!: exI[of _ "j' - 1"])
	+ next
	+ assume "sat (Until phi I psi) i"
	+ then obtain k where k_def: "i \<le> k" "mem (\<tau> \<sigma> i) (\<tau> \<sigma> k) I" "sat psi k" "\<forall>m \<in> {i..<k}. sat phi m"
	+ by auto
	+ define X where "X = {m \<in> {i..k}. memL (\<tau> \<sigma> i) (\<tau> \<sigma> m) I \<and> sat psi m}"
	+ have fin_X: "finite X" and X_nonempty: "X \<noteq> {}" and k_X: "k \<in> X"
	+ using k_def
	+ by (auto simp: X_def mem_def)
	+ define km where "km = Min X"
	+ note aux = Min_in[OF fin_X X_nonempty, folded km_def]
	+ have km_def: "i \<le> km" "km \<le> k" "memL (\<tau> \<sigma> i) (\<tau> \<sigma> km) I" "sat psi km" "\<forall>m \<in> {i..<km}. sat phi m"
	+ "\<forall>m \<in> {i..<km}. memL (\<tau> \<sigma> i) (\<tau> \<sigma> m) I \<longrightarrow> \<not>sat psi m"
	+ using aux Min_le[OF fin_X, folded km_def] k_def(4)
	+ by (fastforce simp: X_def)+
	+ have j'_le_km: "j' - 1 \<le> km"
	+ using not_sat_psi[OF _ km_def(3)] km_def(1,4)
	+ by fastforce
	+ show "b"
	+ proof (cases "j' - 1 < km")
	+ case True
	+ have "until_ready I t c' zo'"
	+ using end_cond True km_def(2) k_def(2) memR_mono'[OF _ \<tau>_mono[where ?i=j' and ?j=k and ?s=\<sigma>]]
	+ by (auto simp: mem_def)
	+ then show ?thesis
	+ using c'_pos zo'_def km_def(5) Suc_i_le_j' True
	+ by (auto simp: until_ready_def zo'_Some b_def split: nat.splits)
	+ next
	+ case False
	+ have km_j': "km = j' - 1"
	+ using j'_le_km False
	+ by auto
	+ show ?thesis
	+ using c'_pos zo'_def km_def(3,4)
	+ by (auto simp: zo'_Some b_def km_j' t_def split: nat.splits)
	+ qed
	+ qed
	+ obtain gs where gs_def: "reaches_on ru_t l_t0 gs epsi'" "length gs = j'"
	+ "\<And>t. t \<in> set gs \<Longrightarrow> memR (\<tau> \<sigma> i) t I"
	+ using loop(1)
	+ by (auto simp: loop_inv_def j'_def[symmetric])
	+ note aux = \<tau>_mono[where ?s=\<sigma> and ?i=i and ?j="Suc i"]
	+ have wf_v': "wf_vydra (Until phi I psi) (Suc i) (Suc n) v'"
	+ unfolding v'_def
	+ apply (rule wf_vydra.intros(10)[where ?j=j' and ?es'=gs])
	+ using loop(1) reaches_on_app[OF v_def(5) run_back] Suc_i_le_j' c'_j' memL_mono[OF _ aux] memR_mono[OF _ aux] gs_def
	+ by (auto simp: loop_inv_def j'_def[symmetric] v_def(6,8))
	+ show ?case
	+ using wf_v' ru_t_event[OF v_def(5) refl run_back]
	+ by (auto simp: b_sat v_def(6))
	+next
	+ case (MatchP n I r)
	+ have IH: "x \<in> set (collect_subfmlas r []) \<Longrightarrow> wf_vydra x j n v \<Longrightarrow> ru n v = Some (v', t, b) \<Longrightarrow> wf_vydra x (Suc j) n v' \<and> t = \<tau> \<sigma> j \<and> b = sat x j" for x j v v' t b
	+ using MatchP(2,1,5,6) le_trans[OF collect_subfmlas_msize]
	+ using bf_collect_subfmlas[where ?r="r" and ?phis="[]"]
	+ by (fastforce simp: collect_subfmlas_atms[where ?phis="[]", simplified, symmetric])
	+ have "reaches_on (ru n) (su n phi) vs v \<Longrightarrow> wf_vydra phi (length vs) n v" if phi: "phi \<in> set (collect_subfmlas r [])" for phi vs v
	+ apply (induction vs arbitrary: v rule: rev_induct)
	+ using MatchP(1) wf_vydra_sub collect_subfmlas_msize[OF phi]
	+ apply (auto elim!: reaches_on.cases)[1]
	+ using IH[OF phi]
	+ apply (fastforce dest!: reaches_on_split_last)
	+ done
	+ then have wf: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) bs s \<Longrightarrow> j < length (collect_subfmlas r []) \<Longrightarrow>
	+ wf_vydra (collect_subfmlas r [] ! j) (length bs) n (s ! j)" for bs s j
	+ using reach_run_subs_run
	+ by (fastforce simp: in_set_conv_nth)
	+ let ?qf = "state_cnt r"
	+ let ?transs = "iarray_of_list (build_nfa_impl r (0, ?qf, []))"
	+ define args where "args = init_args ({0}, NFA.delta' ?transs ?qf, NFA.accept' ?transs ?qf) (ru_t, read_t) (run_subs (ru n))"
	+ interpret MDL_window \<sigma> r l_t0 "map (su n) (collect_subfmlas r [])" args
	+ using bs_sat[where ?r=r and ?n=n, OF _ wf _ reach_run_subs_len[where ?n=n]] IH run_t_read[of run_hd]
	+ read_t_run[of _ _ run_hd] ru_t_tau MatchP(5) collect_subfmlas_atms[where ?phis="[]"]
	+ unfolding args_def iarray_of_list_def
	+ by unfold_locales auto
	+ obtain w xs where w_def: "v = VYDRA_MatchP I ?transs ?qf w"
	+ "valid_window_matchP args I l_t0 (map (su n) (collect_subfmlas r [])) xs i w"
	+ using MatchP(3,4)
	+ by (auto simp: args_def elim!: wf_vydra.cases[of _ _ _ v])
	+ obtain tj' t' sj' bs where somes: "w_run_t args (w_tj w) = Some (tj', t')"
	+ "w_run_sub args (w_sj w) = Some (sj', bs)"
	+ using MatchP(4)
	+ by (auto simp: w_def(1) adv_end_def args_def Let_def split: option.splits prod.splits)
	+ obtain w' where w'_def: "eval_mP I w = Some ((\<tau> \<sigma> i, sat (MatchP I r) i), w')"
	+ "t' = \<tau> \<sigma> i" "valid_matchP I l_t0 (map (su n) (collect_subfmlas r [])) (xs @ [(t', bs)]) (Suc i) w'"
	+ using valid_eval_matchP[OF w_def(2) somes] MatchP(6)
	+ by auto
	+ have v'_def: "v' = VYDRA_MatchP I ?transs ?qf w'" "(t, b) = (\<tau> \<sigma> i, sat (MatchP I r) i)"
	+ using MatchP(4)
	+ by (auto simp: w_def(1) args_def[symmetric] w'_def(1) simp del: eval_matchP.simps init_args.simps)
	+ have len_xs: "length xs = i"
	+ using w'_def(3)
	+ by (auto simp: valid_window_matchP_def)
	+ have "\<exists>es e. reaches_on run_hd init_hd es e \<and> length es = Suc i"
	+ using ru_t_event valid_window_matchP_reach_tj[OF w_def(2)] somes(1) len_xs
	+ by (fastforce simp: args_def)
	+ then show ?case
	+ using MatchP(1) v'_def(2) w'_def(3)
	+ by (auto simp: v'_def(1) args_def[symmetric] simp del: init_args.simps intro!: wf_vydra.intros(11))
	+next
	+ case (MatchF n I r)
	+ have IH: "x \<in> set (collect_subfmlas r []) \<Longrightarrow> wf_vydra x j n v \<Longrightarrow> ru n v = Some (v', t, b) \<Longrightarrow> wf_vydra x (Suc j) n v' \<and> t = \<tau> \<sigma> j \<and> b = sat x j" for x j v v' t b
	+ using MatchF(2,1,5,6) le_trans[OF collect_subfmlas_msize]
	+ using bf_collect_subfmlas[where ?r="r" and ?phis="[]"]
	+ by (fastforce simp: collect_subfmlas_atms[where ?phis="[]", simplified, symmetric])
	+ have "reaches_on (ru n) (su n phi) vs v \<Longrightarrow> wf_vydra phi (length vs) n v" if phi: "phi \<in> set (collect_subfmlas r [])" for phi vs v
	+ apply (induction vs arbitrary: v rule: rev_induct)
	+ using MatchF(1) wf_vydra_sub collect_subfmlas_msize[OF phi]
	+ apply (auto elim!: reaches_on.cases)[1]
	+ using IH[OF phi]
	+ apply (fastforce dest!: reaches_on_split_last)
	+ done
	+ then have wf: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) bs s \<Longrightarrow> j < length (collect_subfmlas r []) \<Longrightarrow>
	+ wf_vydra (collect_subfmlas r [] ! j) (length bs) n (s ! j)" for bs s j
	+ using reach_run_subs_run
	+ by (fastforce simp: in_set_conv_nth)
	+ let ?qf = "state_cnt r"
	+ let ?transs = "iarray_of_list (build_nfa_impl r (0, ?qf, []))"
	+ define args where "args = init_args ({0}, NFA.delta' ?transs ?qf, NFA.accept' ?transs ?qf) (ru_t, read_t) (run_subs (ru n))"
	+ interpret MDL_window \<sigma> r l_t0 "map (su n) (collect_subfmlas r [])" args
	+ using bs_sat[where ?r=r and ?n=n, OF _ wf _ reach_run_subs_len[where ?n=n]] IH run_t_read[of run_hd]
	+ read_t_run[of _ _ run_hd] ru_t_tau MatchF(5) collect_subfmlas_atms[where ?phis="[]"]
	+ unfolding args_def iarray_of_list_def
	+ by unfold_locales auto
	+ obtain w xs where w_def: "v = VYDRA_MatchF I ?transs ?qf w"
	+ "valid_window_matchF args I l_t0 (map (su n) (collect_subfmlas r [])) xs i w"
	+ using MatchF(3,4)
	+ by (auto simp: args_def elim!: wf_vydra.cases[of _ _ _ v])
	+ obtain w' rho' where w'_def: "eval_mF I w = Some ((t, b), w')" "valid_matchF I l_t0 (map (su n) (collect_subfmlas r [])) rho' (Suc i) w'" "t = \<tau> \<sigma> i" "b = sat (MatchF I r) i"
	+ using valid_eval_matchF_sound[OF w_def(2)] MatchF(4,5,6)
	+ by (fastforce simp: w_def(1) args_def[symmetric] simp del: eval_matchF.simps init_args.simps split: option.splits)
	+ have v'_def: "v' = VYDRA_MatchF I ?transs ?qf w'"
	+ using MatchF(4)
	+ by (auto simp: w_def(1) args_def[symmetric] w'_def(1) simp del: eval_matchF.simps init_args.simps)
	+ obtain w_ti' ti where ru_w_ti: "ru_t (w_ti w) = Some (w_ti', ti)"
	+ using MatchF(4) read_t_run
	+ by (auto simp: w_def(1) args_def split: option.splits)
	+ have "\<exists>es e. reaches_on run_hd init_hd es e \<and> length es = Suc i"
	+ using w_def(2) ru_t_event[OF _ refl ru_w_ti, where ?ts="take (w_i w) (map fst xs)"]
	+ by (auto simp: valid_window_matchF_def args_def)
	+ then show ?case
	+ using MatchF(1) w'_def(2)
	+ by (auto simp: v'_def(1) args_def[symmetric] w'_def(3,4) simp del: init_args.simps intro!: wf_vydra.intros(12))
	+qed
	+
	+lemma reaches_ons_run_lD: "reaches_on (run_subs (ru n)) vs ws vs' \<Longrightarrow>
	+ length vs = length vs'"
	+ by (induction vs ws vs' rule: reaches_on_rev_induct)
	+ (auto simp: run_subs_def Let_def split: option.splits if_splits)
	+
	+lemma reaches_ons_run_vD: "reaches_on (run_subs (ru n)) vs ws vs' \<Longrightarrow>
	+ i < length vs \<Longrightarrow> (\<exists>ys. reaches_on (ru n) (vs ! i) ys (vs' ! i) \<and> length ys = length ws)"
	+proof (induction vs ws vs' rule: reaches_on_rev_induct)
	+ case (2 s s' bs bss s'')
	+ obtain ys where ys_def: "reaches_on (ru n) (s ! i) ys (s' ! i)"
	+ "length s = length s'" "length ys = length bss"
	+ using reaches_ons_run_lD[OF 2(1)] 2(3)[OF 2(4)]
	+ by auto
	+ obtain tb where tb_def: "ru n (s' ! i) = Some (s'' ! i, tb)"
	+ using run_subs_vD[OF 2(2) 2(4)[unfolded ys_def(2)]]
	+ by auto
	+ show ?case
	+ using reaches_on_app[OF ys_def(1) tb_def(1)] ys_def(2,3) tb_def
	+ by auto
	+qed (auto intro: reaches_on.intros)
	+
	+lemma reaches_ons_runI:
	+ assumes "\<And>phi. phi \<in> set (collect_subfmlas r []) \<Longrightarrow> \<exists>ws v. reaches_on (ru n) (su n phi) ws v \<and> length ws = i"
	+ shows "\<exists>ws v. reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) ws v \<and> length ws = i"
	+ using assms
	+proof (induction i)
	+ case 0
	+ show ?case
	+ by (fastforce intro: reaches_on.intros)
	+next
	+ case (Suc i)
	+ have IH': "\<And>phi. phi \<in> set (collect_subfmlas r []) \<Longrightarrow> \<exists>ws v. reaches_on (ru n) (su n phi) ws v \<and> length ws = i \<and> ru n v \<noteq> None"
	+ proof -
	+ fix phi
	+ assume lassm: "phi \<in> set (collect_subfmlas r [])"
	+ obtain ws v where ws_def: "reaches_on (ru n) (su n phi) ws v"
	+ "length ws = Suc i"
	+ using Suc(2)[OF lassm]
	+ by auto
	+ obtain y ys where ws_snoc: "ws = ys @ [y]"
	+ using ws_def(2)
	+ by (cases ws rule: rev_cases) auto
	+ show "\<exists>ws v. reaches_on (ru n) (su n phi) ws v \<and> length ws = i \<and> ru n v \<noteq> None"
	+ using reaches_on_split_last[OF ws_def(1)[unfolded ws_snoc]] ws_def(2) ws_snoc
	+ by fastforce
	+ qed
	+ obtain ws v where ws_def: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) ws v" "length ws = i"
	+ using Suc(1) IH'
	+ by blast
	+ have "x \<in> set v \<Longrightarrow> Option.is_none (ru n x) \<Longrightarrow> False" for x
	+ using ws_def IH'
	+ by (auto simp: in_set_conv_nth) (metis is_none_code(2) reach_run_subs_len reach_run_subs_run reaches_on_inj)
	+ then obtain v' tb where v'_def: "run_subs (ru n) v = Some (v', tb)"
	+ by (fastforce simp: run_subs_def Let_def)
	+ show ?case
	+ using reaches_on_app[OF ws_def(1) v'_def] ws_def(2)
	+ by fastforce
	+qed
	+
	+lemma reaches_on_takeWhile: "reaches_on r s vs s' \<Longrightarrow> r s' = Some (s'', v) \<Longrightarrow> \<not>f v \<Longrightarrow>
	+ vs' = takeWhile f vs \<Longrightarrow>
	+ \<exists>t' t'' v'. reaches_on r s vs' t' \<and> r t' = Some (t'', v') \<and> \<not>f v' \<and>
	+ reaches_on r t' (drop (length vs') vs) s'"
	+ by (induction s vs s' arbitrary: vs' rule: reaches_on.induct) (auto intro: reaches_on.intros)
	+
	+lemma reaches_on_suffix:
	+ assumes "reaches_on r s vs s'" "reaches_on r s vs' s''" "length vs' \<le> length vs"
	+ shows "\<exists>vs''. reaches_on r s'' vs'' s' \<and> vs = vs' @ vs''"
	+ using reaches_on_split'[where ?i="length vs'", OF assms(1,3)] assms(3) reaches_on_inj[OF assms(2)]
	+ by (metis add_diff_cancel_right' append_take_drop_id diff_diff_cancel length_append length_drop)
	+
	+lemma vydra_wf_reaches_on:
	+ assumes "\<And>j v. j < i \<Longrightarrow> wf_vydra \<phi> j n v \<Longrightarrow> ru n v = None \<Longrightarrow> False" "bounded_future_fmla \<phi>" "wf_fmla \<phi>" "msize_fmla \<phi> \<le> n"
	+ shows "\<exists>vs v. reaches_on (ru n) (su n \<phi>) vs v \<and> wf_vydra \<phi> i n v \<and> length vs = i"
	+ using assms(1)
	+proof (induction i)
	+ case (Suc i)
	+ obtain vs v where IH: "reaches_on (ru n) (su n \<phi>) vs v" "wf_vydra \<phi> i n v" "length vs = i"
	+ using Suc(1) Suc(2)[OF less_SucI]
	+ by auto
	+ show ?case
	+ using reaches_on_app[OF IH(1)] Suc(2)[OF _ IH(2)] vydra_sound_aux[OF assms(4) IH(2) _ assms(2,3)] IH(3)
	+ by fastforce
	+qed (auto intro: reaches_on.intros wf_vydra_sub[OF assms(4)])
	+
	+lemma reaches_on_Some:
	+ assumes "reaches_on r s vs s'" "reaches_on r s vs' s''" "length vs < length vs'"
	+ shows "\<exists>s''' x. r s' = Some (s''', x)"
	+ using reaches_on_split[OF assms(2,3)] reaches_on_inj[OF assms(1)] assms(3)
	+ by auto
	+
	+lemma reaches_on_progress:
	+ assumes "reaches_on run_hd init_hd vs e"
	+ shows "progress phi (map fst vs) \<le> length vs"
	+ using progress_le_ts[of "map fst vs" phi] reaches_on_run_hd \<tau>_fin
	+ by (fastforce dest!: reaches_on_setD[OF assms] reaches_on_split_last)
	+
	+lemma vydra_complete_aux:
	+ assumes prefix: "reaches_on run_hd init_hd vs e"
	+ and run: "wf_vydra \<phi> i n v" "ru n v = None" "i < progress \<phi> (map fst vs)" "bounded_future_fmla \<phi>" "wf_fmla \<phi>"
	+ and msize: "msize_fmla \<phi> \<le> n"
	+ shows "False"
	+ using msize run
	+proof (induction n \<phi> arbitrary: i v rule: run_induct)
	+ case (Bool b n)
	+ have False if v_def: "v = VYDRA_Bool b g" for g
	+ proof -
	+ obtain es where g_def: "reaches_on run_hd init_hd es g" "length es = i"
	+ using Bool(1)
	+ by (auto simp: v_def elim: wf_vydra.cases)
	+ show False
	+ using Bool(2) reaches_on_Some[OF g_def(1) prefix] Bool(3)
	+ by (auto simp: v_def g_def(2) split: option.splits)
	+ qed
	+ then show False
	+ using Bool(1)
	+ by (auto elim!: wf_vydra.cases[of _ _ _ v])
	+next
	+ case (Atom a n)
	+ have False if v_def: "v = VYDRA_Atom a g" for g
	+ proof -
	+ obtain es where g_def: "reaches_on run_hd init_hd es g" "length es = i"
	+ using Atom(1)
	+ by (auto simp: v_def elim: wf_vydra.cases)
	+ show False
	+ using Atom(2) reaches_on_Some[OF g_def(1) prefix] Atom(3)
	+ by (auto simp: v_def g_def(2) split: option.splits)
	+ qed
	+ then show False
	+ using Atom(1)
	+ by (auto elim!: wf_vydra.cases[of _ _ _ v])
	+next
	+ case (Neg n phi)
	+ show ?case
	+ apply (rule wf_vydra.cases[OF Neg(3)])
	+ using Neg
	+ by (fastforce split: option.splits)+
	+next
	+ case (Bin n f phi psi)
	+ show ?case
	+ apply (rule wf_vydra.cases[OF Bin(4)])
	+ using Bin
	+ by (fastforce split: option.splits)+
	+next
	+ case (Prev n I phi)
	+ show ?case
	+ proof (cases i)
	+ case 0
	+ obtain vphi where v_def: "v = VYDRA_Prev I vphi init_hd None"
	+ using Prev(3)
	+ by (auto simp: 0 dest: reaches_on_NilD elim!: wf_vydra.cases[of "Prev I phi"])
	+ show ?thesis
	+ using Prev(4,5) prefix
	+ by (auto simp: 0 v_def elim: reaches_on.cases split: option.splits)
	+ next
	+ case (Suc j)
	+ show ?thesis
	+ proof (cases "v = VYDRA_None")
	+ case v_def: True
	+ obtain w where w_def: "wf_vydra phi j n w" "ru n w = None"
	+ using Prev(3)
	+ by (auto simp: Suc v_def elim!: wf_vydra.cases[of "Prev I phi"])
	+ show ?thesis
	+ using Prev(2)[OF w_def(1,2)] Prev(5,6,7)
	+ by (auto simp: Suc)
	+ next
	+ case False
	+ obtain vphi tphi bphi es g where v_def: "v = VYDRA_Prev I vphi g (Some (tphi, bphi))"
	+ "wf_vydra phi (Suc j) n vphi" "reaches_on run_hd init_hd es g" "length es = Suc j"
	+ using Prev(3) False
	+ by (auto simp: Suc elim!: wf_vydra.cases[of "Prev I phi"])
	+ show ?thesis
	+ using Prev(4,5) reaches_on_Some[OF v_def(3) prefix]
	+ by (auto simp: Let_def Suc v_def(1,4) split: option.splits)
	+ qed
	+ qed
	+next
	+ case (Next n I phi)
	+ show ?case
	+ proof (cases "v = VYDRA_None")
	+ case True
	+ obtain w where w_def: "wf_vydra phi i n w" "ru n w = None"
	+ using Next(3)
	+ by (auto simp: True elim: wf_vydra.cases)
	+ show ?thesis
	+ using Next(2)[OF w_def] Next(5,6,7)
	+ by (auto split: nat.splits)
	+ next
	+ case False
	+ obtain w sub to es where v_def: "v = VYDRA_Next I w sub to" "wf_vydra phi (length es) n w"
	+ "reaches_on run_hd init_hd es sub" "length es = (case to of None \<Rightarrow> 0 \| _ \<Rightarrow> Suc i)"
	+ "case to of None \<Rightarrow> i = 0 \| Some told \<Rightarrow> told = \<tau> \<sigma> i"
	+ using Next(3) False
	+ by (auto elim!: wf_vydra.cases[of _ _ _ v] split: option.splits nat.splits)
	+ show ?thesis
	+ proof (cases to)
	+ case None
	+ obtain w' tw' bw' where w'_def: "ru n w = Some (w', (tw', bw'))"
	+ using Next(2)[OF v_def(2)] Next(5,6,7)
	+ by (fastforce simp: v_def(4) None split: nat.splits)
	+ have wf: "wf_vydra phi (Suc (length es)) n w'"
	+ using v_def(4,5) vydra_sound_aux[OF Next(1) v_def(2) w'_def] Next(6,7)
	+ by (auto simp: None)
	+ show ?thesis
	+ using Next(2)[OF wf] Next(4,5,6,7) reaches_on_Some[OF v_def(3) prefix]
	+ reaches_on_Some[OF reaches_on_app[OF v_def(3)] prefix] reaches_on_progress[OF prefix, where ?phi=phi]
	+ by (cases vs) (fastforce simp: v_def(1,4) w'_def None split: option.splits nat.splits if_splits)+
	+ next
	+ case (Some z)
	+ show ?thesis
	+ using Next(2)[OF v_def(2)] Next(4,5,6,7) reaches_on_Some[OF v_def(3) prefix] reaches_on_progress[OF prefix, where ?phi=phi]
	+ by (auto simp: v_def(1,4) Some split: option.splits nat.splits)
	+ qed
	+ qed
	+next
	+ case (Since n I phi psi)
	+ obtain vphi vpsi g cphi cpsi cppsi tppsi j gs where v_def:
	+ "v = VYDRA_Since I vphi vpsi g cphi cpsi cppsi tppsi"
	+ "wf_vydra phi i n vphi" "wf_vydra psi j n vpsi" "j \<le> i"
	+ "reaches_on ru_t l_t0 gs g" "length gs = j" "cpsi = i - j"
	+ using Since(5)
	+ by (auto elim: wf_vydra.cases)
	+ obtain vphi' t1 b1 where run_vphi: "ru n vphi = Some (vphi', t1, b1)"
	+ using Since(3)[OF v_def(2)] Since(7,8,9)
	+ by fastforce
	+ obtain cs c where wf_vphi': "wf_vydra phi (Suc i) n vphi'"
	+ and reaches_Suc_i: "reaches_on run_hd init_hd cs c" "length cs = Suc i"
	+ and t1_def: "t1 = \<tau> \<sigma> i"
	+ using vydra_sound_aux[OF Since(1) v_def(2) run_vphi] Since(8,9)
	+ by auto
	+ note ru_t_Some = ru_t_Some[OF reaches_Suc_i]
	+ define loop_inv where "loop_inv = (\<lambda>(vpsi, e, cpsi :: nat, cppsi :: nat option, tppsi :: 't option).
	+ let j = Suc i - cpsi in cpsi \<le> Suc i \<and> wf_vydra psi j n vpsi \<and> (\<exists>es. reaches_on ru_t l_t0 es e \<and> length es = j))"
	+ define loop_init where "loop_init = (vpsi, g, Suc cpsi, map_option Suc cppsi, tppsi)"
	+ have j_def: "j = i - cpsi" and cpsi_i: "cpsi \<le> i"
	+ using v_def(4,7)
	+ by auto
	+ then have loop_inv_init: "loop_inv loop_init"
	+ using v_def(3,5,6,7) last_before_Some
	+ by (fastforce simp: loop_inv_def loop_init_def Let_def j_def split: option.splits)
	+ have wf_loop: "wf {(s', s). loop_inv s \<and> while_since_cond I t1 s \<and> Some s' = while_since_body run_hd (ru n) s}"
	+ by (auto intro: wf_subset[OF wf_since])
	+ have step_loop: "pred_option' loop_inv (while_since_body run_hd (ru n) s)"
	+ if loop_assms: "loop_inv s" "while_since_cond I t1 s" for s
	+ proof -
	+ obtain vpsi d cpsi cppsi tppsi where s_def: "s = (vpsi, d, cpsi, cppsi, tppsi)"
	+ by (cases s) auto
	+ have cpsi_pos: "cpsi > 0"
	+ using loop_assms(2)
	+ by (auto simp: while_since_cond_def s_def)
	+ define j where "j = Suc i - cpsi"
	+ have j_i: "j \<le> i"
	+ using cpsi_pos
	+ by (auto simp: j_def)
	+ obtain ds where loop_before: "cpsi \<le> Suc i" "wf_vydra psi j n vpsi" "reaches_on ru_t l_t0 ds d" "length ds = j"
	+ using loop_assms(1)
	+ by (auto simp: s_def j_def loop_inv_def Let_def)
	+ obtain h tt where tt_def: "read_t d = Some tt" "d = Some (h, tt)"
	+ using ru_t_Some[OF loop_before(3)] loop_before(4) loop_assms(2)
	+ by (cases d) (fastforce simp: while_since_cond_def s_def j_def split: option.splits)+
	+ obtain d' where d'_def: "reaches_on ru_t l_t0 (ds @ [tt]) d'" "ru_t d = Some (d', tt)"
	+ using reaches_on_app[OF loop_before(3)] tt_def(1)
	+ by (cases "run_hd h") (auto simp: tt_def(2))
	+ obtain vpsi' tpsi' bpsi' where run_vpsi: "ru n vpsi = Some (vpsi', (tpsi', bpsi'))"
	+ using Since(4) j_i Since(7,8,9) loop_before(2)
	+ by fastforce
	+ have wf_psi': "wf_vydra psi (Suc j) n vpsi'" and t'_def: "tpsi' = \<tau> \<sigma> j" and b'_def: "bpsi' = sat psi j"
	+ using vydra_sound_aux[OF Since(2) loop_before(2) run_vpsi] Since(8,9)
	+ by auto
	+ define j' where j'_def: "j' = Suc i - (cpsi - Suc 0)"
	+ have j'_j: "j' = Suc j"
	+ using loop_before(1) cpsi_pos
	+ by (auto simp: j'_def j_def)
	+ show ?thesis
	+ using wf_psi'(1) loop_before(1,4) d'_def(1)
	+ by (fastforce simp: while_since_body_def s_def run_vpsi pred_option'_def loop_inv_def j'_def[symmetric] j'_j d'_def(2) t1_def)
	+ qed
	+ show ?case
	+ using while_break_complete[OF step_loop _ wf_loop loop_inv_init, where ?Q="\<lambda>_. True"] Since(6)
	+ by (auto simp: pred_option'_def v_def(1) run_vphi Let_def loop_init_def split: option.splits)
	+next
	+ case (Until n I phi psi)
	+ obtain "back" vphi vpsi front c z es es' j where v_def:
	+ "v = VYDRA_Until I back vphi vpsi front c z"
	+ "wf_vydra phi j n vphi" "wf_vydra psi j n vpsi" "i \<le> j"
	+ "reaches_on ru_t l_t0 es back" "length es = i"
	+ "reaches_on ru_t l_t0 es' front" "length es' = j" "\<And>t. t \<in> set es' \<Longrightarrow> memR (\<tau> \<sigma> i) t I"
	+ "c = j - i" "z = (case j of 0 \<Rightarrow> None \| Suc k \<Rightarrow> Some (\<tau> \<sigma> k, sat phi k, sat psi k))"
	+ "\<And>k. k \<in> {i..<j - 1} \<Longrightarrow> sat phi k \<and> (memL (\<tau> \<sigma> i) (\<tau> \<sigma> k) I \<longrightarrow> \<not>sat psi k)"
	+ using Until(5)
	+ by (auto simp: elim: wf_vydra.cases)
	+ have ru_t_Some: "reaches_on ru_t l_t0 gs g \<Longrightarrow> length gs < length vs \<Longrightarrow> \<exists>g' gt. ru_t g = Some (g', gt)" for gs g
	+ using reaches_on_Some reaches_on_run_hd_t[OF prefix]
	+ by fastforce
	+ have vs_tau: "map fst vs ! k = \<tau> \<sigma> k" if k_vs: "k < length vs" for k
	+ using reaches_on_split[OF prefix k_vs] run_hd_sound k_vs
	+ apply (cases "vs ! k")
	+ apply (auto)
	+ apply (metis fst_conv length_map nth_map prefix reaches_on_run_hd_t ru_t_tau_in)
	+ done
	+ define m where "m = min (length (map fst vs) - 1) (min (progress phi (map fst vs)) (progress psi (map fst vs)))"
	+ have m_vs: "m < length vs"
	+ using Until(7)
	+ by (cases vs) (auto simp: m_def split: if_splits)
	+ define A where "A = {j. 0 \<le> j \<and> j \<le> m \<and> memR (map fst vs ! j) (map fst vs ! m) I}"
	+ have m_A: "m \<in> A"
	+ using memR_tfin_refl[OF \<tau>_fin] vs_tau[OF m_vs]
	+ by (fastforce simp: A_def)
	+ then have A_nonempty: "A \<noteq> {}"
	+ by auto
	+ have A_finite: "finite A"
	+ by (auto simp: A_def)
	+ have p: "progress (Until phi I psi) (map fst vs) = Min A"
	+ using Until(7)
	+ unfolding progress.simps m_def[symmetric] Let_def A_def[symmetric]
	+ by auto
	+ have i_A: "i \<notin> A"
	+ using Until(7) A_finite A_nonempty
	+ by (auto simp del: progress.simps simp: p)
	+ have i_m: "i < m"
	+ using Until(7) m_A A_finite A_nonempty
	+ by (auto simp del: progress.simps simp: p)
	+ have memR_i_m: "\<not>memR (map fst vs ! i) (map fst vs ! m) I"
	+ using i_A i_m
	+ by (auto simp: A_def)
	+ have i_vs: "i < length vs"
	+ using i_m m_vs
	+ by auto
	+ have j_m: "j \<le> m"
	+ using ru_t_tau_in[OF v_def(7), of m] v_def(9)[of "\<tau> \<sigma> m"] memR_i_m
	+ unfolding vs_tau[OF i_vs] vs_tau[OF m_vs]
	+ by (force simp: in_set_conv_nth v_def(8))
	+ have j_vs: "j < length vs"
	+ using j_m m_vs
	+ by auto
	+ obtain back' t where run_back: "ru_t back = Some (back', t)" and t_def: "t = \<tau> \<sigma> i"
	+ using ru_t_Some[OF v_def(5)] v_def(4) j_vs ru_t_tau[OF v_def(5)]
	+ by (fastforce simp: v_def(6))
	+ define loop_inv where "loop_inv = (\<lambda>(vphi, vpsi, front, c, z :: ('t \<times> bool \<times> bool) option).
	+ let j = i + c in wf_vydra phi j n vphi \<and> wf_vydra psi j n vpsi \<and> j < length vs \<and>
	+ (\<exists>es'. reaches_on ru_t l_t0 es' front \<and> length es' = j) \<and>
	+ (z = None \<longrightarrow> j = 0))"
	+ define loop_init where "loop_init = (vphi, vpsi, front, c, z)"
	+ have j_eq: "j = i + c"
	+ using v_def(4)
	+ by (auto simp: v_def(10))
	+ have "j = 0 \<Longrightarrow> c = 0"
	+ by (auto simp: j_eq)
	+ then have loop_inv_init: "loop_inv loop_init"
	+ using v_def(2,3,4,7,8,9,11) j_vs
	+ by (auto simp: loop_inv_def loop_init_def j_eq[symmetric] split: nat.splits)
	+ have loop_step: "pred_option' loop_inv (while_until_body run_hd (ru n) s)" if loop_assms: "loop_inv s" "while_until_cond I t s" for s
	+ proof -
	+ obtain vphi_cur vpsi_cur epsi_cur c_cur zo_cur where s_def: "s = (vphi_cur, vpsi_cur, epsi_cur, c_cur, zo_cur)"
	+ by (cases s) auto
	+ define j_cur where "j_cur = i + c_cur"
	+ obtain gs where wf: "wf_vydra phi j_cur n vphi_cur" "wf_vydra psi j_cur n vpsi_cur"
	+ and gs_def: "reaches_on ru_t l_t0 gs epsi_cur" "length gs = j_cur"
	+ and j_cur_vs: "j_cur < length vs"
	+ using loop_assms(1)
	+ by (auto simp: loop_inv_def s_def j_cur_def[symmetric])
	+ obtain epsi'_cur t'_cur where run_epsi: "ru_t epsi_cur = Some (epsi'_cur, t'_cur)"
	+ and t'_cur_def: "t'_cur = \<tau> \<sigma> (length gs)"
	+ using ru_t_Some[OF gs_def(1)] ru_t_event[OF gs_def(1) refl] j_cur_vs
	+ by (auto simp: gs_def(2))
	+ have j_m: "j_cur < m"
	+ using loop_assms(2) memR_i_m memR_mono'[OF _ \<tau>_mono, of _ _ _ _ m]
	+ unfolding vs_tau[OF i_vs] vs_tau[OF m_vs]
	+ by (fastforce simp: gs_def(2) while_until_cond_def s_def run_t_read[OF run_epsi] t_def t'_cur_def)
	+ have j_cur_prog_phi: "j_cur < progress phi (map fst vs)"
	+ using j_m
	+ by (auto simp: m_def)
	+ have j_cur_prog_psi: "j_cur < progress psi (map fst vs)"
	+ using j_m
	+ by (auto simp: m_def)
	+ obtain vphi'_cur tphi_cur bphi_cur where run_vphi: "ru n vphi_cur = Some (vphi'_cur, (tphi_cur, bphi_cur))"
	+ using Until(3)[OF wf(1) _ j_cur_prog_phi] Until(8,9)
	+ by fastforce
	+ obtain vpsi'_cur tpsi_cur bpsi_cur where run_vpsi: "ru n vpsi_cur = Some (vpsi'_cur, (tpsi_cur, bpsi_cur))"
	+ using Until(4)[OF wf(2) _ j_cur_prog_psi] Until(8,9)
	+ by fastforce
	+ have wf': "wf_vydra phi (Suc j_cur) n vphi'_cur" "wf_vydra psi (Suc j_cur) n vpsi'_cur"
	+ using vydra_sound_aux[OF Until(1) wf(1) run_vphi] vydra_sound_aux[OF Until(2) wf(2) run_vpsi] Until(8,9)
	+ by auto
	+ show ?thesis
	+ using wf' reaches_on_app[OF gs_def(1) run_epsi] gs_def(2) j_m m_vs
	+ by (auto simp: pred_option'_def while_until_body_def s_def run_epsi run_vphi run_vpsi loop_inv_def j_cur_def[symmetric])
	+ qed
	+ have wf_loop: "wf {(s', s). loop_inv s \<and> while_until_cond I t s \<and> Some s' = while_until_body run_hd (ru n) s}"
	+ proof -
	+ obtain m where m_def: "\<not>\<tau> \<sigma> m \<le> \<tau> \<sigma> i + right I"
	+ using ex_lt_\<tau>[where ?x="right I" and ?s=\<sigma>] Until(8)
	+ by auto
	+ define X where "X = {(s', s). loop_inv s \<and> while_until_cond I t s \<and> Some s' = while_until_body run_hd (ru n) s}"
	+ have "memR t (\<tau> \<sigma> (i + c)) I \<Longrightarrow> i + c < m" for c
	+ using m_def order_trans[OF \<tau>_mono[where ?i=m and ?j="i + c" and ?s=\<sigma>]]
	+ by (fastforce simp: t_def dest!: memR_dest)
	+ then have "X \<subseteq> measure (\<lambda>(vphi, vpsi, epsi, c, zo). m - c)"
	+ by (fastforce simp: X_def while_until_cond_def while_until_body_def loop_inv_def Let_def split: option.splits
	+ dest!: read_t_run[where ?run_hd=run_hd] dest: ru_t_tau)
	+ then show ?thesis
	+ using wf_subset
	+ by (auto simp: X_def[symmetric])
	+ qed
	+ obtain vphi' vpsi' front' c' z' where loop:
	+ "while_break (while_until_cond I t) (while_until_body run_hd (ru n)) loop_init = Some (vphi', vpsi', front', c', z')"
	+ "loop_inv (vphi', vpsi', front', c', z')" "\<not>while_until_cond I t (vphi', vpsi', front', c', z')"
	+ using while_break_complete[where ?P="loop_inv", OF loop_step _ wf_loop loop_inv_init]
	+ by (cases "while_break (while_until_cond I t) (while_until_body run_hd (ru n)) loop_init") (force simp: pred_option'_def)+
	+ define j' where "j' = i + c'"
	+ obtain tf where read_front': "read_t front' = Some tf"
	+ using loop(2)
	+ by (auto simp: loop_inv_def j'_def[symmetric] dest!: ru_t_Some run_t_read[where ?run_hd=run_hd])
	+ have tf_fin: "tf \<in> tfin"
	+ using loop(2) ru_t_Some[where ?g=front'] ru_t_tau[where ?t'=front'] read_t_run[OF read_front'] \<tau>_fin[where ?\<sigma>=\<sigma>]
	+ by (fastforce simp: loop_inv_def j'_def[symmetric])
	+ have c'_pos: "c' = 0 \<Longrightarrow> False"
	+ using loop(2,3) ru_t_tau ru_t_tau[OF reaches_on.intros(1)] read_t_run[OF read_front']
	+ memR_tfin_refl[OF tf_fin]
	+ by (fastforce simp: loop_inv_def while_until_cond_def until_ready_def read_front' t_def dest!: reaches_on_NilD)
	+ have z'_Some: "z' = None \<Longrightarrow> False"
	+ using loop(2) c'_pos
	+ by (auto simp: loop_inv_def j'_def[symmetric])
	+ show ?case
	+ using Until(6) c'_pos z'_Some
	+ by (auto simp: v_def(1) run_back loop_init_def[symmetric] loop(1) read_front' split: if_splits option.splits)
	+next
	+ case (MatchP n I r)
	+ have msize_sub: "\<And>x. x \<in> set (collect_subfmlas r []) \<Longrightarrow> msize_fmla x \<le> n"
	+ using le_trans[OF collect_subfmlas_msize] MatchP(1)
	+ by auto
	+ have sound: "x \<in> set (collect_subfmlas r []) \<Longrightarrow> wf_vydra x j n v \<Longrightarrow> ru n v = Some (v', t, b) \<Longrightarrow> wf_vydra x (Suc j) n v' \<and> t = \<tau> \<sigma> j \<and> b = sat x j" for x j v v' t b
	+ using MatchP vydra_sound_aux[OF msize_sub] le_trans[OF collect_subfmlas_msize]
	+ using bf_collect_subfmlas[where ?r="r" and ?phis="[]"]
	+ by (fastforce simp: collect_subfmlas_atms[where ?phis="[]", simplified, symmetric])
	+ have "reaches_on (ru n) (su n phi) vs v \<Longrightarrow> wf_vydra phi (length vs) n v" if phi: "phi \<in> set (collect_subfmlas r [])" for phi vs v
	+ apply (induction vs arbitrary: v rule: rev_induct)
	+ using MatchP(1) wf_vydra_sub collect_subfmlas_msize[OF phi]
	+ apply (auto elim!: reaches_on.cases)[1]
	+ using sound[OF phi]
	+ apply (fastforce dest!: reaches_on_split_last)
	+ done
	+ then have wf: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) bs s \<Longrightarrow> j < length (collect_subfmlas r []) \<Longrightarrow>
	+ wf_vydra (collect_subfmlas r [] ! j) (length bs) n (s ! j)" for bs s j
	+ using reach_run_subs_run
	+ by (fastforce simp: in_set_conv_nth)
	+ let ?qf = "state_cnt r"
	+ let ?transs = "iarray_of_list (build_nfa_impl r (0, ?qf, []))"
	+ define args where "args = init_args ({0}, NFA.delta' ?transs ?qf, NFA.accept' ?transs ?qf) (ru_t, read_t) (run_subs (ru n))"
	+ interpret MDL_window \<sigma> r l_t0 "map (su n) (collect_subfmlas r [])" args
	+ using bs_sat[where ?r=r and ?n=n, OF _ wf _ reach_run_subs_len[where ?n=n]] sound run_t_read[of run_hd]
	+ read_t_run[of _ _ run_hd] ru_t_tau MatchP(5) collect_subfmlas_atms[where ?phis="[]"]
	+ unfolding args_def iarray_of_list_def
	+ by unfold_locales auto
	+ obtain w xs where w_def: "v = VYDRA_MatchP I ?transs ?qf w"
	+ "valid_window_matchP args I l_t0 (map (su n) (collect_subfmlas r [])) xs i w"
	+ using MatchP(3)
	+ by (auto simp: args_def elim!: wf_vydra.cases)
	+ note args' = args_def[unfolded init_args.simps, symmetric]
	+ have run_args: "w_run_t args = ru_t" "w_run_sub args = run_subs (ru n)"
	+ by (auto simp: args_def)
	+ have len_xs: "length xs = i"
	+ using w_def(2)
	+ by (auto simp: valid_window_matchP_def)
	+ obtain ej tj where w_tj: "ru_t (w_tj w) = Some (ej, tj)"
	+ using reaches_on_Some[OF valid_window_matchP_reach_tj[OF w_def(2)]] reaches_on_run_hd_t[OF prefix]
	+ MatchP(5) reaches_on_progress[OF prefix, where ?phi="MatchP I r"]
	+ by (fastforce simp: run_args len_xs simp del: progress.simps)
	+ have "run_subs (ru n) (w_sj w) = None"
	+ using valid_eval_matchP[OF w_def(2), unfolded run_args] w_tj MatchP(4,7)
	+ by (cases "run_subs (ru n) (w_sj w)") (auto simp: w_def(1) args' simp del: eval_matchP.simps split: option.splits)
	+ then obtain j where j_def: "j < length (w_sj w)" "ru n (w_sj w ! j) = None"
	+ by (auto simp: run_subs_def Let_def in_set_conv_nth Option.is_none_def split: if_splits)
	+ have len_w_sj: "length (w_sj w) = length (collect_subfmlas r [])"
	+ using valid_window_matchP_reach_sj[OF w_def(2)] reach_run_subs_len
	+ by (auto simp: run_args)
	+ define phi where "phi = collect_subfmlas r [] ! j"
	+ have phi_in_set: "phi \<in> set (collect_subfmlas r [])"
	+ using j_def(1)
	+ by (auto simp: phi_def in_set_conv_nth len_w_sj)
	+ have wf: "wf_vydra phi i n (w_sj w ! j)"
	+ using valid_window_matchP_reach_sj[OF w_def(2)] wf[folded len_w_sj, OF _ j_def(1)] len_xs
	+ by (fastforce simp: run_args phi_def)
	+ have "i < progress phi (map fst vs)"
	+ using MatchP(5) phi_in_set atms_nonempty[of r] atms_finite[of r] collect_subfmlas_atms[of r "[]"]
	+ by auto
	+ then show ?case
	+ using MatchP(2)[OF msize_sub[OF phi_in_set] wf j_def(2)] MatchP(6,7) phi_in_set
	+ bf_collect_subfmlas[where ?r="r" and ?phis="[]"]
	+ by (auto simp: collect_subfmlas_atms)
	+next
	+ case (MatchF n I r)
	+ have subfmla: "msize_fmla x \<le> n" "bounded_future_fmla x" "wf_fmla x" if "x \<in> set (collect_subfmlas r [])" for x
	+ using that MatchF(1,6,7) le_trans[OF collect_subfmlas_msize] bf_collect_subfmlas[where ?r="r" and ?phis="[]" and ?phi=x]
	+ collect_subfmlas_atms[where ?phis="[]" and ?r=r]
	+ by auto
	+ have sound: "x \<in> set (collect_subfmlas r []) \<Longrightarrow> wf_vydra x j n v \<Longrightarrow> ru n v = Some (v', t, b) \<Longrightarrow> wf_vydra x (Suc j) n v' \<and> t = \<tau> \<sigma> j \<and> b = sat x j" for x j v v' t b
	+ using MatchF vydra_sound_aux subfmla
	+ by fastforce
	+ have "reaches_on (ru n) (su n phi) vs v \<Longrightarrow> wf_vydra phi (length vs) n v" if phi: "phi \<in> set (collect_subfmlas r [])" for phi vs v
	+ apply (induction vs arbitrary: v rule: rev_induct)
	+ using MatchF(1) wf_vydra_sub subfmla(1)[OF phi] sound[OF phi]
	+ apply (auto elim!: reaches_on.cases)[1]
	+ using sound[OF phi]
	+ apply (fastforce dest!: reaches_on_split_last)
	+ done
	+ then have wf: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) bs s \<Longrightarrow> j < length (collect_subfmlas r []) \<Longrightarrow>
	+ wf_vydra (collect_subfmlas r [] ! j) (length bs) n (s ! j)" for bs s j
	+ using reach_run_subs_run
	+ by (fastforce simp: in_set_conv_nth)
	+ let ?qf = "state_cnt r"
	+ let ?transs = "iarray_of_list (build_nfa_impl r (0, ?qf, []))"
	+ define args where "args = init_args ({0}, NFA.delta' ?transs ?qf, NFA.accept' ?transs ?qf) (ru_t, read_t) (run_subs (ru n))"
	+ interpret MDL_window \<sigma> r l_t0 "map (su n) (collect_subfmlas r [])" args
	+ using bs_sat[where ?r=r and ?n=n, OF _ wf _ reach_run_subs_len[where ?n=n]] sound run_t_read[of run_hd]
	+ read_t_run[of _ _ run_hd] ru_t_tau MatchF(5) subfmla
	+ unfolding args_def iarray_of_list_def
	+ by unfold_locales auto
	+ obtain w xs where w_def: "v = VYDRA_MatchF I ?transs ?qf w"
	+ "valid_window_matchF args I l_t0 (map (su n) (collect_subfmlas r [])) xs i w"
	+ using MatchF(3)
	+ by (auto simp: args_def elim!: wf_vydra.cases)
	+ note args' = args_def[unfolded init_args.simps, symmetric]
	+ have run_args: "w_run_t args = ru_t" "w_read_t args = read_t" "w_run_sub args = run_subs (ru n)"
	+ by (auto simp: args_def)
	+ have vs_tau: "map fst vs ! k = \<tau> \<sigma> k" if k_vs: "k < length vs" for k
	+ using reaches_on_split[OF prefix k_vs] run_hd_sound k_vs
	+ apply (cases "vs ! k")
	+ apply (auto)
	+ apply (metis fst_conv length_map nth_map prefix reaches_on_run_hd_t ru_t_tau_in)
	+ done
	+ define m where "m = min (length (map fst vs) - 1) (Min ((\<lambda>f. progress f (map fst vs)) ` atms r))"
	+ have m_vs: "m < length vs"
	+ using MatchF(5)
	+ by (cases vs) (auto simp: m_def split: if_splits)
	+ define A where "A = {j. 0 \<le> j \<and> j \<le> m \<and> memR (map fst vs ! j) (map fst vs ! m) I}"
	+ have m_A: "m \<in> A"
	+ using memR_tfin_refl[OF \<tau>_fin] vs_tau[OF m_vs]
	+ by (fastforce simp: A_def)
	+ then have A_nonempty: "A \<noteq> {}"
	+ by auto
	+ have A_finite: "finite A"
	+ by (auto simp: A_def)
	+ have p: "progress (MatchF I r) (map fst vs) = Min A"
	+ using MatchF(5)
	+ unfolding progress.simps m_def[symmetric] Let_def A_def[symmetric]
	+ by auto
	+ have i_A: "i \<notin> A"
	+ using MatchF(5) A_finite A_nonempty
	+ by (auto simp del: progress.simps simp: p)
	+ have i_m: "i < m"
	+ using MatchF(5) m_A A_finite A_nonempty
	+ by (auto simp del: progress.simps simp: p)
	+ have memR_i_m: "\<not>memR (map fst vs ! i) (map fst vs ! m) I"
	+ using i_A i_m
	+ by (auto simp: A_def)
	+ have i_vs: "i < length vs"
	+ using i_m m_vs
	+ by auto
	+ obtain ti where read_ti: "w_read_t args (w_ti w) = Some ti"
	+ using w_def(2) reaches_on_Some[where ?r=ru_t and ?s=l_t0 and ?s'="w_ti w"]
	+ reaches_on_run_hd_t[OF prefix] i_vs run_t_read[where ?t="w_ti w"]
	+ by (fastforce simp: valid_window_matchF_def run_args)
	+ have ti_def: "ti = \<tau> \<sigma> i"
	+ using w_def(2) ru_t_tau read_t_run[OF read_ti]
	+ by (fastforce simp: valid_window_matchF_def run_args)
	+ note reach_tj = valid_window_matchF_reach_tj[OF w_def(2), unfolded run_args]
	+ note reach_sj = valid_window_matchF_reach_sj[OF w_def(2), unfolded run_args]
	+ have len_xs: "length xs = w_j w" and memR_xs: "\<And>l. l\<in>{w_i w..<w_j w} \<Longrightarrow> memR (ts_at xs i) (ts_at xs l) I"
	+ and i_def: "w_i w = i"
	+ using w_def(2)
	+ unfolding valid_window_matchF_def
	+ by (auto simp: valid_window_matchF_def run_args)
	+ have j_m: "w_j w \<le> m"
	+ using ru_t_tau_in[OF reach_tj, of i] ru_t_tau_in[OF reach_tj, of m] memR_i_m i_m memR_xs[of m]
	+ unfolding vs_tau[OF i_vs] vs_tau[OF m_vs]
	+ by (force simp: in_set_conv_nth len_xs ts_at_def i_def)
	+ obtain tm tm' where tm_def: "reaches_on ru_t l_t0 (take m (map fst vs)) tm"
	+ "ru_t tm = Some (tm', fst (vs ! m))"
	+ using reaches_on_split[where ?i=m] reaches_on_run_hd_t[OF prefix] m_vs
	+ by fastforce
	+ have reach_tj_m: "reaches_on (w_run_t args) (w_tj w) (drop (w_j w) (take m (map fst vs))) tm"
	+ using reaches_on_split'[OF tm_def(1), where ?i="w_j w"] reaches_on_inj[OF reach_tj] m_vs j_m
	+ by (auto simp: len_xs run_args)
	+ have vs_m: "fst (vs ! m) = \<tau> \<sigma> m"
	+ using vs_tau[OF m_vs] m_vs
	+ by auto
	+ have memR_ti_m: "\<not>memR ti (\<tau> \<sigma> m) I"
	+ using memR_i_m
	+ unfolding vs_tau[OF i_vs] vs_tau[OF m_vs]
	+ by (auto simp: ti_def)
	+ have m_prog: "m \<le> progress phi (map fst vs)" if "phi \<in> set (collect_subfmlas r [])" for phi
	+ using collect_subfmlas_atms[where ?r=r and ?phis="[]"] that atms_finite[of r]
	+ by (auto simp: m_def min.coboundedI2)
	+ obtain ws s where ws_def: "reaches_on (run_subs (ru n)) (map (su n) (collect_subfmlas r [])) ws s" "length ws = m"
	+ using reaches_ons_runI[where ?r=r and ?n=n and ?i=m]
	+ vydra_wf_reaches_on[where ?i=m and ?n=n] subfmla
	+ MatchF(2) m_prog
	+ by fastforce
	+ have reach_sj_m: "reaches_on (run_subs (ru n)) (w_sj w) (drop (w_j w) ws) s"
	+ using reaches_on_split'[OF ws_def(1), where ?i="w_j w"] reaches_on_inj[OF reach_sj] i_m j_m
	+ by (auto simp: ws_def(2) len_xs)
	+ define rho where "rho = zip (drop (w_j w) (take m (map fst vs))) (drop (w_j w) ws)"
	+ have map_fst_rho: "map fst rho = drop (w_j w) (take m (map fst vs))"
	+ and map_snd_rho: "map snd rho = drop (w_j w) ws"
	+ using ws_def(2) j_m m_vs
	+ by (auto simp: rho_def)
	+ show False
	+ using valid_eval_matchF_complete[OF w_def(2) reach_tj_m[folded map_fst_rho] reach_sj_m[folded map_snd_rho run_args] read_ti run_t_read[OF tm_def(2)[folded run_args], unfolded vs_m] memR_ti_m] MatchF(4,7)
	+ by (auto simp: w_def(1) args_def simp del: eval_matchF.simps)
	+qed
	+
	+definition "ru' \<phi> = ru (msize_fmla \<phi>)"
	+definition "su' \<phi> = su (msize_fmla \<phi>) \<phi>"
	+
	+lemma vydra_wf:
	+ assumes "reaches (ru n) (su n \<phi>) i v" "bounded_future_fmla \<phi>" "wf_fmla \<phi>" "msize_fmla \<phi> \<le> n"
	+ shows "wf_vydra \<phi> i n v"
	+ using assms(1)
	+proof (induction i arbitrary: v)
	+ case 0
	+ then show ?case
	+ using wf_vydra_sub[OF assms(4)]
	+ by (auto elim: reaches.cases)
	+next
	+ case (Suc i)
	+ show ?case
	+ using reaches_Suc_split_last[OF Suc(2)] Suc(1) vydra_sound_aux[OF assms(4) _ _ assms(2,3)]
	+ by fastforce
	+qed
	+
	+lemma vydra_sound':
	+ assumes "reaches (ru' \<phi>) (su' \<phi>) n v" "ru' \<phi> v = Some (v', (t, b))" "bounded_future_fmla \<phi>" "wf_fmla \<phi>"
	+ shows "(t, b) = (\<tau> \<sigma> n, sat \<phi> n)"
	+ using vydra_sound_aux[OF order.refl vydra_wf[OF assms(1)[unfolded ru'_def su'_def] assms(3,4) order.refl] assms(2)[unfolded ru'_def] assms(3,4)]
	+ by auto
	+
	+lemma vydra_complete':
	+ assumes prefix: "reaches_on run_hd init_hd vs e"
	+ and prog: "n < progress \<phi> (map fst vs)" "bounded_future_fmla \<phi>" "wf_fmla \<phi>"
	+ shows "\<exists>v v'. reaches (ru' \<phi>) (su' \<phi>) n v \<and> ru' \<phi> v = Some (v', (\<tau> \<sigma> n, sat \<phi> n))"
	+proof -
	+ have aux: "False" if aux_assms: "j \<le> n" "wf_vydra \<phi> j (msize_fmla \<phi>) v" "ru (msize_fmla \<phi>) v = None" for j v
	+ using vydra_complete_aux[OF prefix aux_assms(2,3) _ prog(2-)] aux_assms(1) prog(1)
	+ by auto
	+ obtain ws v where ws_def: "reaches_on (ru' \<phi>) (su' \<phi>) ws v" "wf_vydra \<phi> n (msize_fmla \<phi>) v" "length ws = n"
	+ using vydra_wf_reaches_on[OF _ prog(2,3)] aux[OF less_imp_le_nat]
	+ unfolding ru'_def su'_def
	+ by blast
	+ have ru_Some: "ru' \<phi> v \<noteq> None"
	+ using aux[OF order.refl ws_def(2)]
	+ by (fastforce simp: ru'_def)
	+ obtain v' t b where tb_def: "ru' \<phi> v = Some (v', (t, b))"
	+ using ru_Some
	+ by auto
	+ show ?thesis
	+ using reaches_on_n[OF ws_def(1)] tb_def vydra_sound'[OF reaches_on_n[OF ws_def(1)] tb_def prog(2,3)]
	+ by (auto simp: ws_def(3))
	+qed
	+
	+lemma map_option_apfst_idle: "map_option (apfst snd) (map_option (apfst (Pair n)) x) = x"
	+ by (cases x) auto
	+
	+lemma vydra_sound:
	+ assumes "reaches (run_vydra run_hd) (init_vydra init_hd run_hd \<phi>) n v" "run_vydra run_hd v = Some (v', (t, b))" "bounded_future_fmla \<phi>" "wf_fmla \<phi>"
	+ shows "(t, b) = (\<tau> \<sigma> n, sat \<phi> n)"
	+proof -
	+ have fst_v: "fst v = msize_fmla \<phi>"
	+ by (rule reaches_invar[OF assms(1)]) (auto simp: init_vydra_def run_vydra_def Let_def)
	+ have "reaches (ru' \<phi>) (su' \<phi>) n (snd v)"
	+ using reaches_cong[OF assms(1), where ?P="\<lambda>(m, w). m = msize_fmla \<phi>" and ?g=snd]
	+ by (auto simp: init_vydra_def run_vydra_def ru'_def su'_def map_option_apfst_idle Let_def simp del: sub.simps)
	+ then show ?thesis
	+ using vydra_sound'[OF _ _ assms(3,4)] assms(2) fst_v
	+ by (auto simp: run_vydra_def ru'_def split: prod.splits)
	+qed
	+
	+lemma vydra_complete:
	+ assumes prefix: "reaches_on run_hd init_hd vs e"
	+ and prog: "n < progress \<phi> (map fst vs)" "bounded_future_fmla \<phi>" "wf_fmla \<phi>"
	+ shows "\<exists>v v'. reaches (run_vydra run_hd) (init_vydra init_hd run_hd \<phi>) n v \<and> run_vydra run_hd v = Some (v', (\<tau> \<sigma> n, sat \<phi> n))"
	+proof -
	+ obtain v v' where wits: "reaches (ru' \<phi>) (su' \<phi>) n v" "ru' \<phi> v = Some (v', \<tau> \<sigma> n, sat \<phi> n)"
	+ using vydra_complete'[OF assms]
	+ by auto
	+ have reach: "reaches (run_vydra run_hd) (init_vydra init_hd run_hd \<phi>) n (msize_fmla \<phi>, v)"
	+ using reaches_cong[OF wits(1), where ?P="\<lambda>x. True" and ?f'="run_vydra run_hd" and ?g="Pair (msize_fmla \<phi>)"]
	+ by (auto simp: init_vydra_def run_vydra_def ru'_def su'_def Let_def simp del: sub.simps)
	+ show ?thesis
	+ apply (rule exI[of _ "(msize_fmla \<phi>, v)"])
	+ apply (rule exI[of _ "(msize_fmla \<phi>, v')"])
	+ apply (auto simp: run_vydra_def wits(2)[unfolded ru'_def] intro: reach)
	+ done
	+qed
	+
	+end
	+
	+context MDL
	+begin
	+
	+lemma reach_elem:
	+ assumes "reaches (\<lambda>i. if P i then Some (Suc i, (\<tau> \<sigma> i, \<Gamma> \<sigma> i)) else None) s n s'" "s = 0"
	+ shows "s' = n"
	+proof -
	+ obtain vs where vs_def: "reaches_on (\<lambda>i. if P i then Some (Suc i, (\<tau> \<sigma> i, \<Gamma> \<sigma> i)) else None) s vs s'" "length vs = n"
	+ using reaches_on[OF assms(1)]
	+ by auto
	+ have "s' = length vs"
	+ using vs_def(1) assms(2)
	+ by (induction s vs s' rule: reaches_on_rev_induct) (auto split: if_splits)
	+ then show ?thesis
	+ using vs_def(2)
	+ by auto
	+qed
	+
	+interpretation default_vydra: VYDRA_MDL \<sigma> 0 "\<lambda>i. Some (Suc i, (\<tau> \<sigma> i, \<Gamma> \<sigma> i))"
	+ using reach_elem[where ?P="\<lambda>_. True"]
	+ by unfold_locales auto
	+
	+end
	+
	+lemma reaches_inj: "reaches r s i t \<Longrightarrow> reaches r s i t' \<Longrightarrow> t = t'"
	+ using reaches_on_inj reaches_on
	+ by metis
	+
	+lemma progress_sound:
	+ assumes
	+ "\<And>n. n < length ts \<Longrightarrow> ts ! n = \<tau> \<sigma> n"
	+ "\<And>n. n < length ts \<Longrightarrow> \<tau> \<sigma> n = \<tau> \<sigma>' n"
	+ "\<And>n. n < length ts \<Longrightarrow> \<Gamma> \<sigma> n = \<Gamma> \<sigma>' n"
	+ "n < progress phi ts"
	+ "bounded_future_fmla phi"
	+ "wf_fmla phi"
	+ shows "MDL.sat \<sigma> phi n \<longleftrightarrow> MDL.sat \<sigma>' phi n"
	+proof -
	+ define run_hd where "run_hd = (\<lambda>i. if i < length ts then Some (Suc i, (\<tau> \<sigma> i, \<Gamma> \<sigma> i)) else None)"
	+ interpret vydra: VYDRA_MDL \<sigma> 0 run_hd
	+ using MDL.reach_elem[where ?P="\<lambda>i. i < length ts"]
	+ by unfold_locales (auto simp: run_hd_def split: if_splits)
	+ define run_hd' where "run_hd' = (\<lambda>i. if i < length ts then Some (Suc i, (\<tau> \<sigma>' i, \<Gamma> \<sigma>' i)) else None)"
	+ interpret vydra': VYDRA_MDL \<sigma>' 0 run_hd'
	+ using MDL.reach_elem[where ?P="\<lambda>i. i < length ts"]
	+ by unfold_locales (auto simp: run_hd'_def split: if_splits)
	+ have run_hd_hd': "run_hd = run_hd'"
	+ using assms(1-3)
	+ by (auto simp: run_hd_def run_hd'_def)
	+ have reaches_run_hd: "n \<le> length ts \<Longrightarrow> reaches_on run_hd 0 (map (\<lambda>i. (\<tau> \<sigma> i, \<Gamma> \<sigma> i)) [0..<n]) n" for n
	+ by (induction n) (auto simp: run_hd_def intro: reaches_on.intros(1) intro!: reaches_on_app)
	+ have ts_map: "ts = map fst (map (\<lambda>i. (\<tau> \<sigma> i, \<Gamma> \<sigma> i)) [0..<length ts])"
	+ by (subst map_nth[symmetric]) (auto simp: assms(1))
	+ obtain v v' where vv_def: "reaches (run_vydra run_hd) (init_vydra 0 run_hd phi) n v" "run_vydra run_hd v = Some (v', \<tau> \<sigma> n, vydra.sat phi n)"
	+ using vydra.vydra_complete[OF reaches_run_hd[OF order.refl] _ assms(5,6)] assms(4)
	+ unfolding ts_map[symmetric]
	+ by blast
	+ have reaches_run_hd': "n \<le> length ts \<Longrightarrow> reaches_on run_hd' 0 (map (\<lambda>i. (\<tau> \<sigma>' i, \<Gamma> \<sigma>' i)) [0..<n]) n" for n
	+ by (induction n) (auto simp: run_hd'_def intro: reaches_on.intros(1) intro!: reaches_on_app)
	+ have ts'_map: "ts = map fst (map (\<lambda>i. (\<tau> \<sigma>' i, \<Gamma> \<sigma>' i)) [0..<length ts])"
	+ by (subst map_nth[symmetric]) (auto simp: assms(1,2))
	+ obtain w w' where ww_def: "reaches (run_vydra run_hd') (init_vydra 0 run_hd' phi) n w" "run_vydra run_hd' w = Some (w', \<tau> \<sigma>' n, vydra'.sat phi n)"
	+ using vydra'.vydra_complete[OF reaches_run_hd'[OF order.refl] _ assms(5,6)] assms(4)
	+ unfolding ts'_map[symmetric]
	+ by blast
	+ note v_w = reaches_inj[OF vv_def(1) ww_def(1)[folded run_hd_hd']]
	+ show ?thesis
	+ using vv_def(2) ww_def(2)
	+ by (auto simp: run_hd_hd' v_w)
	+qed
	+
	+end
	diff --git a/thys/VYDRA_MDL/Monitor_Code.thy b/thys/VYDRA_MDL/Monitor_Code.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Monitor_Code.thy
	@@ -0,0 +1,128 @@
	+theory Monitor_Code
	+ imports "HOL-Library.Code_Target_Nat" "Containers.Containers" Monitor Preliminaries
	+begin
	+
	+derive (eq) ceq enat
	+
	+instantiation enat :: ccompare begin
	+
	+definition ccompare_enat :: "enat comparator option" where
	+ "ccompare_enat = Some (\<lambda>x y. if x = y then order.Eq else if x < y then order.Lt else order.Gt)"
	+
	+instance by intro_classes
	+ (auto simp: ccompare_enat_def split: if_splits intro!: comparator.intro)
	+
	+end
	+
	+code_printing
	+ code_module "IArray" \<rightharpoonup> (OCaml)
	+\<open>module IArray : sig
	+ val length' : 'a array -> Z.t
	+ val sub' : 'a array * Z.t -> 'a
	+end = struct
	+
	+let length' xs = Z.of_int (Array.length xs);;
	+
	+let sub' (xs, i) = Array.get xs (Z.to_int i);;
	+
	+end\<close> for type_constructor iarray constant IArray.length' IArray.sub'
	+
	+code_reserved OCaml IArray
	+
	+code_printing
	+ type_constructor iarray \<rightharpoonup> (OCaml) "_ array"
	+\| constant iarray_of_list \<rightharpoonup> (OCaml) "Array.of'_list"
	+\| constant IArray.list_of \<rightharpoonup> (OCaml) "Array.to'_list"
	+\| constant IArray.length' \<rightharpoonup> (OCaml) "IArray.length'"
	+\| constant IArray.sub' \<rightharpoonup> (OCaml) "IArray.sub'"
	+
	+lemma iarray_list_of_inj: "IArray.list_of xs = IArray.list_of ys \<Longrightarrow> xs = ys"
	+ by (cases xs; cases ys) auto
	+
	+instantiation iarray :: (ccompare) ccompare
	+begin
	+
	+definition ccompare_iarray :: "('a iarray \<Rightarrow> 'a iarray \<Rightarrow> order) option" where
	+ "ccompare_iarray = (case ID CCOMPARE('a list) of None \<Rightarrow> None
	+ \| Some c \<Rightarrow> Some (\<lambda>xs ys. c (IArray.list_of xs) (IArray.list_of ys)))"
	+
	+instance
	+ apply standard
	+ apply unfold_locales
	+ using comparator.sym[OF ID_ccompare'] comparator.weak_eq[OF ID_ccompare']
	+ comparator.comp_trans[OF ID_ccompare'] iarray_list_of_inj
	+ apply (auto simp: ccompare_iarray_def split: option.splits)
	+ apply blast+
	+ done
	+
	+end
	+
	+derive (rbt) mapping_impl iarray
	+
	+definition mk_db :: "String.literal list \<Rightarrow> String.literal set" where "mk_db = set"
	+
	+definition init_vydra_string_enat :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (String.literal, enat, 'e) vydra" where
	+ "init_vydra_string_enat = init_vydra"
	+definition run_vydra_string_enat :: " _ \<Rightarrow> (String.literal, enat, 'e) vydra \<Rightarrow> _" where
	+ "run_vydra_string_enat = run_vydra"
	+definition progress_enat :: "(String.literal, enat) formula \<Rightarrow> enat list \<Rightarrow> nat" where
	+ "progress_enat = progress"
	+definition bounded_future_fmla_enat :: "(String.literal, enat) formula \<Rightarrow> bool" where
	+ "bounded_future_fmla_enat = bounded_future_fmla"
	+definition wf_fmla_enat :: "(String.literal, enat) formula \<Rightarrow> bool" where
	+ "wf_fmla_enat = wf_fmla"
	+definition mdl2mdl'_enat :: "(String.literal, enat) formula \<Rightarrow> (String.literal, enat) Preliminaries.formula" where
	+ "mdl2mdl'_enat = mdl2mdl'"
	+definition interval_enat :: "enat \<Rightarrow> enat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> enat \<I>" where
	+ "interval_enat = interval"
	+definition rep_interval_enat :: "enat \<I> \<Rightarrow> enat \<times> enat \<times> bool \<times> bool" where
	+ "rep_interval_enat = Rep_\<I>"
	+
	+definition init_vydra_string_ereal :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (String.literal, ereal, 'e) vydra" where
	+ "init_vydra_string_ereal = init_vydra"
	+definition run_vydra_string_ereal :: " _ \<Rightarrow> (String.literal, ereal, 'e) vydra \<Rightarrow> _" where
	+ "run_vydra_string_ereal = run_vydra"
	+definition progress_ereal :: "(String.literal, ereal) formula \<Rightarrow> ereal list \<Rightarrow> real" where
	+ "progress_ereal = progress"
	+definition bounded_future_fmla_ereal :: "(String.literal, ereal) formula \<Rightarrow> bool" where
	+ "bounded_future_fmla_ereal = bounded_future_fmla"
	+definition wf_fmla_ereal :: "(String.literal, ereal) formula \<Rightarrow> bool" where
	+ "wf_fmla_ereal = wf_fmla"
	+definition mdl2mdl'_ereal :: "(String.literal, ereal) formula \<Rightarrow> (String.literal, ereal) Preliminaries.formula" where
	+ "mdl2mdl'_ereal = mdl2mdl'"
	+definition interval_ereal :: "ereal \<Rightarrow> ereal \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ereal \<I>" where
	+ "interval_ereal = interval"
	+definition rep_interval_ereal :: "ereal \<I> \<Rightarrow> ereal \<times> ereal \<times> bool \<times> bool" where
	+ "rep_interval_ereal = Rep_\<I>"
	+
	+lemma tfin_enat_code[code]: "(tfin :: enat set) = Collect_set (\<lambda>x. x \<noteq> \<infinity>)"
	+ by (auto simp: tfin_enat_def)
	+
	+lemma tfin_ereal_code[code]: "(tfin :: ereal set) = Collect_set (\<lambda>x. x \<noteq> -\<infinity> \<and> x \<noteq> \<infinity>)"
	+ by (auto simp: tfin_ereal_def)
	+
	+lemma Ball_atms[code_unfold]: "Ball (atms r) P = list_all P (collect_subfmlas r [])"
	+ using collect_subfmlas_atms[where ?phis="[]"]
	+ by (auto simp: list_all_def)
	+
	+lemma MIN_fold: "(MIN x\<in>set (z # zs). f x) = fold min (map f zs) (f z)"
	+ by (metis Min.set_eq_fold list.set_map list.simps(9))
	+
	+declare progress.simps(1-8)[code]
	+
	+lemma progress_matchP_code[code]:
	+ "progress (MatchP I r) ts = (case collect_subfmlas r [] of x # xs \<Rightarrow> fold min (map (\<lambda>f. progress f ts) xs) (progress x ts))"
	+ using collect_subfmlas_atms[where ?r=r and ?phis="[]"] atms_nonempty[of r]
	+ by (auto split: list.splits) (smt (z3) MIN_fold[where ?f="\<lambda>f. progress f ts"] list.simps(15))
	+
	+lemma progress_matchF_code[code]:
	+ "progress (MatchF I r) ts = (if length ts = 0 then 0 else
	+ (let k = min (length ts - 1) (case collect_subfmlas r [] of x # xs \<Rightarrow> fold min (map (\<lambda>f. progress f ts) xs) (progress x ts)) in
	+ Min {j \<in> {..k}. memR (ts ! j) (ts ! k) I}))"
	+ by (auto simp: progress_matchP_code[unfolded progress.simps])
	+
	+export_code init_vydra_string_enat run_vydra_string_enat progress_enat bounded_future_fmla_enat wf_fmla_enat mdl2mdl'_enat
	+ Bool Preliminaries.Bool enat interval_enat rep_interval_enat nat_of_integer integer_of_nat mk_db
	+ in OCaml module_name VYDRA file_prefix "verified"
	+
	+end
	diff --git a/thys/VYDRA_MDL/NFA.thy b/thys/VYDRA_MDL/NFA.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/NFA.thy
	@@ -0,0 +1,958 @@
	+theory NFA
	+ imports "HOL-Library.IArray"
	+begin
	+
	+type_synonym state = nat
	+
	+datatype transition = eps_trans state nat \| symb_trans state \| split_trans state state
	+
	+fun state_set :: "transition \<Rightarrow> state set" where
	+ "state_set (eps_trans s _) = {s}"
	+\| "state_set (symb_trans s) = {s}"
	+\| "state_set (split_trans s s') = {s, s'}"
	+
	+fun fmla_set :: "transition \<Rightarrow> nat set" where
	+ "fmla_set (eps_trans _ n) = {n}"
	+\| "fmla_set _ = {}"
	+
	+lemma rtranclp_closed: "rtranclp R q q' \<Longrightarrow> X = X \<union> {q'. \<exists>q \<in> X. R q q'} \<Longrightarrow>
	+ q \<in> X \<Longrightarrow> q' \<in> X"
	+ by (induction q q' rule: rtranclp.induct) auto
	+
	+lemma rtranclp_closed_sub: "rtranclp R q q' \<Longrightarrow> {q'. \<exists>q \<in> X. R q q'} \<subseteq> X \<Longrightarrow>
	+ q \<in> X \<Longrightarrow> q' \<in> X"
	+ by (induction q q' rule: rtranclp.induct) auto
	+
	+lemma rtranclp_closed_sub': "rtranclp R q q' \<Longrightarrow> q' = q \<or> (\<exists>q''. R q q'' \<and> rtranclp R q'' q')"
	+ using converse_rtranclpE by force
	+
	+lemma rtranclp_step: "rtranclp R q q'' \<Longrightarrow> (\<And>q'. R q q' \<longleftrightarrow> q' \<in> X) \<Longrightarrow>
	+ q = q'' \<or> (\<exists>q' \<in> X. R q q' \<and> rtranclp R q' q'')"
	+ by (induction q q'' rule: rtranclp.induct)
	+ (auto intro: rtranclp.rtrancl_into_rtrancl)
	+
	+lemma rtranclp_unfold: "rtranclp R x z \<Longrightarrow> x = z \<or> (\<exists>y. R x y \<and> rtranclp R y z)"
	+ by (induction x z rule: rtranclp.induct) auto
	+
	+context fixes
	+ q0 :: "state" and
	+ qf :: "state" and
	+ transs :: "transition list"
	+begin
	+
	+(* sets of states *)
	+
	+qualified definition SQ :: "state set" where
	+ "SQ = {q0..<q0 + length transs}"
	+
	+lemma q_in_SQ[code_unfold]: "q \<in> SQ \<longleftrightarrow> q0 \<le> q \<and> q < q0 + length transs"
	+ by (auto simp: SQ_def)
	+
	+lemma finite_SQ: "finite SQ"
	+ by (auto simp add: SQ_def)
	+
	+lemma transs_q_in_set: "q \<in> SQ \<Longrightarrow> transs ! (q - q0) \<in> set transs"
	+ by (auto simp add: SQ_def)
	+
	+qualified definition Q :: "state set" where
	+ "Q = SQ \<union> {qf}"
	+
	+lemma finite_Q: "finite Q"
	+ by (auto simp add: Q_def SQ_def)
	+
	+lemma SQ_sub_Q: "SQ \<subseteq> Q"
	+ by (auto simp add: SQ_def Q_def)
	+
	+(* set of formula indices *)
	+
	+qualified definition nfa_fmla_set :: "nat set" where
	+ "nfa_fmla_set = \<Union>(fmla_set ` set transs)"
	+
	+(* step relation *)
	+
	+qualified definition step_eps :: "bool list \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
	+ "step_eps bs q q' \<longleftrightarrow> q \<in> SQ \<and>
	+ (case transs ! (q - q0) of eps_trans p n \<Rightarrow> n < length bs \<and> bs ! n \<and> p = q'
	+ \| split_trans p p' \<Rightarrow> p = q' \<or> p' = q' \| _ \<Rightarrow> False)"
	+
	+lemma step_eps_dest: "step_eps bs q q' \<Longrightarrow> q \<in> SQ"
	+ by (auto simp add: step_eps_def)
	+
	+lemma step_eps_mono: "step_eps [] q q' \<Longrightarrow> step_eps bs q q'"
	+ by (auto simp: step_eps_def split: transition.splits)
	+
	+(* successors in step relation *)
	+
	+qualified definition step_eps_sucs :: "bool list \<Rightarrow> state \<Rightarrow> state set" where
	+ "step_eps_sucs bs q = (if q \<in> SQ then
	+ (case transs ! (q - q0) of eps_trans p n \<Rightarrow> if n < length bs \<and> bs ! n then {p} else {}
	+ \| split_trans p p' \<Rightarrow> {p, p'} \| _ \<Rightarrow> {}) else {})"
	+
	+lemma step_eps_sucs_sound: "q' \<in> step_eps_sucs bs q \<longleftrightarrow> step_eps bs q q'"
	+ by (auto simp add: step_eps_sucs_def step_eps_def split: transition.splits)
	+
	+qualified definition step_eps_set :: "bool list \<Rightarrow> state set \<Rightarrow> state set" where
	+ "step_eps_set bs R = \<Union>(step_eps_sucs bs ` R)"
	+
	+lemma step_eps_set_sound: "step_eps_set bs R = {q'. \<exists>q \<in> R. step_eps bs q q'}"
	+ using step_eps_sucs_sound by (auto simp add: step_eps_set_def)
	+
	+lemma step_eps_set_mono: "R \<subseteq> S \<Longrightarrow> step_eps_set bs R \<subseteq> step_eps_set bs S"
	+ by (auto simp add: step_eps_set_def)
	+
	+(* reflexive and transitive closure of step relation *)
	+
	+qualified definition step_eps_closure :: "bool list \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
	+ "step_eps_closure bs = (step_eps bs)\<^sup>\<^sup>"
	+
	+lemma step_eps_closure_dest: "step_eps_closure bs q q' \<Longrightarrow> q \<noteq> q' \<Longrightarrow> q \<in> SQ"
	+ unfolding step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct) using step_eps_dest by auto
	+
	+qualified definition step_eps_closure_set :: "state set \<Rightarrow> bool list \<Rightarrow> state set" where
	+ "step_eps_closure_set R bs = \<Union>((\<lambda>q. {q'. step_eps_closure bs q q'}) ` R)"
	+
	+lemma step_eps_closure_set_refl: "R \<subseteq> step_eps_closure_set R bs"
	+ by (auto simp add: step_eps_closure_set_def step_eps_closure_def)
	+
	+lemma step_eps_closure_set_mono: "R \<subseteq> S \<Longrightarrow> step_eps_closure_set R bs \<subseteq> step_eps_closure_set S bs"
	+ by (auto simp add: step_eps_closure_set_def)
	+
	+lemma step_eps_closure_set_empty: "step_eps_closure_set {} bs = {}"
	+ by (auto simp add: step_eps_closure_set_def)
	+
	+lemma step_eps_closure_set_mono': "step_eps_closure_set R [] \<subseteq> step_eps_closure_set R bs"
	+ by (auto simp: step_eps_closure_set_def step_eps_closure_def) (metis mono_rtranclp step_eps_mono)
	+
	+lemma step_eps_closure_set_split: "step_eps_closure_set (R \<union> S) bs =
	+ step_eps_closure_set R bs \<union> step_eps_closure_set S bs"
	+ by (auto simp add: step_eps_closure_set_def)
	+
	+lemma step_eps_closure_set_Un: "step_eps_closure_set (\<Union>x \<in> X. R x) bs =
	+ (\<Union>x \<in> X. step_eps_closure_set (R x) bs)"
	+ by (auto simp add: step_eps_closure_set_def)
	+
	+lemma step_eps_closure_set_idem: "step_eps_closure_set (step_eps_closure_set R bs) bs =
	+ step_eps_closure_set R bs"
	+ unfolding step_eps_closure_set_def step_eps_closure_def by auto
	+
	+lemma step_eps_closure_set_flip:
	+ assumes "step_eps_closure_set R bs = R \<union> S"
	+ shows "step_eps_closure_set S bs \<subseteq> R \<union> S"
	+ using step_eps_closure_set_idem[of R bs, unfolded assms, unfolded step_eps_closure_set_split]
	+ by auto
	+
	+lemma step_eps_closure_set_unfold: "(\<And>q'. step_eps bs q q' \<longleftrightarrow> q' \<in> X) \<Longrightarrow>
	+ step_eps_closure_set {q} bs = {q} \<union> step_eps_closure_set X bs"
	+ unfolding step_eps_closure_set_def step_eps_closure_def
	+ using rtranclp_step[of "step_eps bs" q]
	+ by (auto simp add: converse_rtranclp_into_rtranclp)
	+
	+lemma step_step_eps_closure: "step_eps bs q q' \<Longrightarrow> q \<in> R \<Longrightarrow> q' \<in> step_eps_closure_set R bs"
	+ unfolding step_eps_closure_set_def step_eps_closure_def by auto
	+
	+lemma step_eps_closure_set_code[code]:
	+ "step_eps_closure_set R bs =
	+ (let R' = R \<union> step_eps_set bs R in if R = R' then R else step_eps_closure_set R' bs)"
	+ using rtranclp_closed
	+ by (auto simp add: step_eps_closure_set_def step_eps_closure_def step_eps_set_sound Let_def)
	+
	+(* no step_eps *)
	+
	+lemma step_eps_closure_empty: "step_eps_closure bs q q' \<Longrightarrow> (\<And>q'. \<not>step_eps bs q q') \<Longrightarrow> q = q'"
	+ unfolding step_eps_closure_def by (induction q q' rule: rtranclp.induct) auto
	+
	+lemma step_eps_closure_set_step_id: "(\<And>q q'. q \<in> R \<Longrightarrow> \<not>step_eps bs q q') \<Longrightarrow>
	+ step_eps_closure_set R bs = R"
	+ using step_eps_closure_empty step_eps_closure_set_refl unfolding step_eps_closure_set_def by blast
	+
	+(* symbol step relation *)
	+
	+qualified definition step_symb :: "state \<Rightarrow> state \<Rightarrow> bool" where
	+ "step_symb q q' \<longleftrightarrow> q \<in> SQ \<and>
	+ (case transs ! (q - q0) of symb_trans p \<Rightarrow> p = q' \| _ \<Rightarrow> False)"
	+
	+lemma step_symb_dest: "step_symb q q' \<Longrightarrow> q \<in> SQ"
	+ by (auto simp add: step_symb_def)
	+
	+(* successors in symbol step relation *)
	+
	+qualified definition step_symb_sucs :: "state \<Rightarrow> state set" where
	+ "step_symb_sucs q = (if q \<in> SQ then
	+ (case transs ! (q - q0) of symb_trans p \<Rightarrow> {p} \| _ \<Rightarrow> {}) else {})"
	+
	+lemma step_symb_sucs_sound: "q' \<in> step_symb_sucs q \<longleftrightarrow> step_symb q q'"
	+ by (auto simp add: step_symb_sucs_def step_symb_def split: transition.splits)
	+
	+qualified definition step_symb_set :: "state set \<Rightarrow> state set" where
	+ "step_symb_set R = {q'. \<exists>q \<in> R. step_symb q q'}"
	+
	+lemma step_symb_set_mono: "R \<subseteq> S \<Longrightarrow> step_symb_set R \<subseteq> step_symb_set S"
	+ by (auto simp add: step_symb_set_def)
	+
	+lemma step_symb_set_empty: "step_symb_set {} = {}"
	+ by (auto simp add: step_symb_set_def)
	+
	+lemma step_symb_set_proj: "step_symb_set R = step_symb_set (R \<inter> SQ)"
	+ using step_symb_dest by (auto simp add: step_symb_set_def)
	+
	+lemma step_symb_set_split: "step_symb_set (R \<union> S) = step_symb_set R \<union> step_symb_set S"
	+ by (auto simp add: step_symb_set_def)
	+
	+lemma step_symb_set_Un: "step_symb_set (\<Union>x \<in> X. R x) = (\<Union>x \<in> X. step_symb_set (R x))"
	+ by (auto simp add: step_symb_set_def)
	+
	+lemma step_symb_set_code[code]: "step_symb_set R = \<Union>(step_symb_sucs ` R)"
	+ using step_symb_sucs_sound by (auto simp add: step_symb_set_def)
	+
	+(* delta function *)
	+
	+qualified definition delta :: "state set \<Rightarrow> bool list \<Rightarrow> state set" where
	+ "delta R bs = step_symb_set (step_eps_closure_set R bs)"
	+
	+lemma delta_eps: "delta (step_eps_closure_set R bs) bs = delta R bs"
	+ unfolding delta_def step_eps_closure_set_idem by (rule refl)
	+
	+lemma delta_eps_split:
	+ assumes "step_eps_closure_set R bs = R \<union> S"
	+ shows "delta R bs = step_symb_set R \<union> delta S bs"
	+ unfolding delta_def assms step_symb_set_split
	+ using step_symb_set_mono[OF step_eps_closure_set_flip[OF assms], unfolded step_symb_set_split]
	+ step_symb_set_mono[OF step_eps_closure_set_refl] by auto
	+
	+lemma delta_split: "delta (R \<union> S) bs = delta R bs \<union> delta S bs"
	+ by (auto simp add: delta_def step_symb_set_split step_eps_closure_set_split)
	+
	+lemma delta_Un: "delta (\<Union>x \<in> X. R x) bs = (\<Union>x \<in> X. delta (R x) bs)"
	+ unfolding delta_def step_eps_closure_set_Un step_symb_set_Un by simp
	+
	+lemma delta_step_symb_set_absorb: "delta R bs = delta R bs \<union> step_symb_set R"
	+ using step_eps_closure_set_refl by (auto simp add: delta_def step_symb_set_def)
	+
	+lemma delta_sub_eps_mono:
	+ assumes "S \<subseteq> step_eps_closure_set R bs"
	+ shows "delta S bs \<subseteq> delta R bs"
	+ unfolding delta_def
	+ using step_symb_set_mono[OF step_eps_closure_set_mono[OF assms, of bs,
	+ unfolded step_eps_closure_set_idem]] by simp
	+
	+(* run delta function *)
	+
	+qualified definition run :: "state set \<Rightarrow> bool list list \<Rightarrow> state set" where
	+ "run R bss = foldl delta R bss"
	+
	+lemma run_eps_split:
	+ assumes "step_eps_closure_set R bs = R \<union> S" "step_symb_set R = {}"
	+ shows "run R (bs # bss) = run S (bs # bss)"
	+ unfolding run_def foldl.simps delta_eps_split[OF assms(1), unfolded assms(2)]
	+ by auto
	+
	+lemma run_empty: "run {} bss = {}"
	+ unfolding run_def
	+ by (induction bss)
	+ (auto simp add: delta_def step_symb_set_empty step_eps_closure_set_empty)
	+
	+lemma run_Nil: "run R [] = R"
	+ by (auto simp add: run_def)
	+
	+lemma run_Cons: "run R (bs # bss) = run (delta R bs) bss"
	+ unfolding run_def by simp
	+
	+lemma run_split: "run (R \<union> S) bss = run R bss \<union> run S bss"
	+ unfolding run_def
	+ by (induction bss arbitrary: R S) (auto simp add: delta_split)
	+
	+lemma run_Un: "run (\<Union>x \<in> X. R x) bss = (\<Union>x \<in> X. run (R x) bss)"
	+ unfolding run_def
	+ by (induction bss arbitrary: R) (auto simp add: delta_Un)
	+
	+lemma run_comp: "run R (bss @ css) = run (run R bss) css"
	+ unfolding run_def by simp
	+
	+(* accept function *)
	+
	+qualified definition accept_eps :: "state set \<Rightarrow> bool list \<Rightarrow> bool" where
	+ "accept_eps R bs \<longleftrightarrow> (qf \<in> step_eps_closure_set R bs)"
	+
	+lemma step_eps_accept_eps: "step_eps bs q qf \<Longrightarrow> q \<in> R \<Longrightarrow> accept_eps R bs"
	+ unfolding accept_eps_def using step_step_eps_closure by simp
	+
	+lemma accept_eps_empty: "accept_eps {} bs \<longleftrightarrow> False"
	+ by (auto simp add: accept_eps_def step_eps_closure_set_def)
	+
	+lemma accept_eps_split: "accept_eps (R \<union> S) bs \<longleftrightarrow> accept_eps R bs \<or> accept_eps S bs"
	+ by (auto simp add: accept_eps_def step_eps_closure_set_split)
	+
	+lemma accept_eps_Un: "accept_eps (\<Union>x \<in> X. R x) bs \<longleftrightarrow> (\<exists>x \<in> X. accept_eps (R x) bs)"
	+ by (auto simp add: accept_eps_def step_eps_closure_set_def)
	+
	+qualified definition accept :: "state set \<Rightarrow> bool" where
	+ "accept R \<longleftrightarrow> accept_eps R []"
	+
	+(* is a run accepting? *)
	+
	+qualified definition run_accept_eps :: "state set \<Rightarrow> bool list list \<Rightarrow> bool list \<Rightarrow> bool" where
	+ "run_accept_eps R bss bs = accept_eps (run R bss) bs"
	+
	+lemma run_accept_eps_empty: "\<not>run_accept_eps {} bss bs"
	+ unfolding run_accept_eps_def run_empty accept_eps_empty by simp
	+
	+lemma run_accept_eps_Nil: "run_accept_eps R [] cs \<longleftrightarrow> accept_eps R cs"
	+ by (auto simp add: run_accept_eps_def run_Nil)
	+
	+lemma run_accept_eps_Cons: "run_accept_eps R (bs # bss) cs \<longleftrightarrow> run_accept_eps (delta R bs) bss cs"
	+ by (auto simp add: run_accept_eps_def run_Cons)
	+
	+lemma run_accept_eps_Cons_delta_cong: "delta R bs = delta S bs \<Longrightarrow>
	+ run_accept_eps R (bs # bss) cs \<longleftrightarrow> run_accept_eps S (bs # bss) cs"
	+ unfolding run_accept_eps_Cons by auto
	+
	+lemma run_accept_eps_Nil_eps: "run_accept_eps (step_eps_closure_set R bs) [] bs \<longleftrightarrow> run_accept_eps R [] bs"
	+ unfolding run_accept_eps_Nil accept_eps_def step_eps_closure_set_idem by (rule refl)
	+
	+lemma run_accept_eps_Cons_eps: "run_accept_eps (step_eps_closure_set R cs) (cs # css) bs \<longleftrightarrow>
	+ run_accept_eps R (cs # css) bs"
	+ unfolding run_accept_eps_Cons delta_eps by (rule refl)
	+
	+lemma run_accept_eps_Nil_eps_split:
	+ assumes "step_eps_closure_set R bs = R \<union> S" "step_symb_set R = {}" "qf \<notin> R"
	+ shows "run_accept_eps R [] bs = run_accept_eps S [] bs"
	+ unfolding Nil run_accept_eps_Nil accept_eps_def assms(1)
	+ using assms(3) step_eps_closure_set_refl step_eps_closure_set_flip[OF assms(1)] by auto
	+
	+lemma run_accept_eps_Cons_eps_split:
	+ assumes "step_eps_closure_set R cs = R \<union> S" "step_symb_set R = {}" "qf \<notin> R"
	+ shows "run_accept_eps R (cs # css) bs = run_accept_eps S (cs # css) bs"
	+ unfolding run_accept_eps_def Cons run_eps_split[OF assms(1,2)] by (rule refl)
	+
	+lemma run_accept_eps_split: "run_accept_eps (R \<union> S) bss bs \<longleftrightarrow>
	+ run_accept_eps R bss bs \<or> run_accept_eps S bss bs"
	+ unfolding run_accept_eps_def run_split accept_eps_split by auto
	+
	+lemma run_accept_eps_Un: "run_accept_eps (\<Union>x \<in> X. R x) bss bs \<longleftrightarrow>
	+ (\<exists>x \<in> X. run_accept_eps (R x) bss bs)"
	+ unfolding run_accept_eps_def run_Un accept_eps_Un by simp
	+
	+qualified definition run_accept :: "state set \<Rightarrow> bool list list \<Rightarrow> bool" where
	+ "run_accept R bss = accept (run R bss)"
	+
	+end
	+
	+definition "iarray_of_list xs = IArray xs"
	+
	+context fixes
	+ transs :: "transition iarray"
	+ and len :: nat
	+begin
	+
	+qualified definition step_eps' :: "bool iarray \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
	+ "step_eps' bs q q' \<longleftrightarrow> q < len \<and>
	+ (case transs !! q of eps_trans p n \<Rightarrow> n < IArray.length bs \<and> bs !! n \<and> p = q'
	+ \| split_trans p p' \<Rightarrow> p = q' \<or> p' = q' \| _ \<Rightarrow> False)"
	+
	+qualified definition step_eps_closure' :: "bool iarray \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
	+ "step_eps_closure' bs = (step_eps' bs)\<^sup>\<^sup>"
	+
	+qualified definition step_eps_sucs' :: "bool iarray \<Rightarrow> state \<Rightarrow> state set" where
	+ "step_eps_sucs' bs q = (if q < len then
	+ (case transs !! q of eps_trans p n \<Rightarrow> if n < IArray.length bs \<and> bs !! n then {p} else {}
	+ \| split_trans p p' \<Rightarrow> {p, p'} \| _ \<Rightarrow> {}) else {})"
	+
	+lemma step_eps_sucs'_sound: "q' \<in> step_eps_sucs' bs q \<longleftrightarrow> step_eps' bs q q'"
	+ by (auto simp add: step_eps_sucs'_def step_eps'_def split: transition.splits)
	+
	+qualified definition step_eps_set' :: "bool iarray \<Rightarrow> state set \<Rightarrow> state set" where
	+ "step_eps_set' bs R = \<Union>(step_eps_sucs' bs ` R)"
	+
	+lemma step_eps_set'_sound: "step_eps_set' bs R = {q'. \<exists>q \<in> R. step_eps' bs q q'}"
	+ using step_eps_sucs'_sound by (auto simp add: step_eps_set'_def)
	+
	+qualified definition step_eps_closure_set' :: "state set \<Rightarrow> bool iarray \<Rightarrow> state set" where
	+ "step_eps_closure_set' R bs = \<Union>((\<lambda>q. {q'. step_eps_closure' bs q q'}) ` R)"
	+
	+lemma step_eps_closure_set'_code[code]:
	+ "step_eps_closure_set' R bs =
	+ (let R' = R \<union> step_eps_set' bs R in if R = R' then R else step_eps_closure_set' R' bs)"
	+ using rtranclp_closed
	+ by (auto simp add: step_eps_closure_set'_def step_eps_closure'_def step_eps_set'_sound Let_def)
	+
	+qualified definition step_symb_sucs' :: "state \<Rightarrow> state set" where
	+ "step_symb_sucs' q = (if q < len then
	+ (case transs !! q of symb_trans p \<Rightarrow> {p} \| _ \<Rightarrow> {}) else {})"
	+
	+qualified definition step_symb_set' :: "state set \<Rightarrow> state set" where
	+ "step_symb_set' R = \<Union>(step_symb_sucs' ` R)"
	+
	+qualified definition delta' :: "state set \<Rightarrow> bool iarray \<Rightarrow> state set" where
	+ "delta' R bs = step_symb_set' (step_eps_closure_set' R bs)"
	+
	+qualified definition accept_eps' :: "state set \<Rightarrow> bool iarray \<Rightarrow> bool" where
	+ "accept_eps' R bs \<longleftrightarrow> (len \<in> step_eps_closure_set' R bs)"
	+
	+qualified definition accept' :: "state set \<Rightarrow> bool" where
	+ "accept' R \<longleftrightarrow> accept_eps' R (iarray_of_list [])"
	+
	+qualified definition run' :: "state set \<Rightarrow> bool iarray list \<Rightarrow> state set" where
	+ "run' R bss = foldl delta' R bss"
	+
	+qualified definition run_accept_eps' :: "state set \<Rightarrow> bool iarray list \<Rightarrow> bool iarray \<Rightarrow> bool" where
	+ "run_accept_eps' R bss bs = accept_eps' (run' R bss) bs"
	+
	+qualified definition run_accept' :: "state set \<Rightarrow> bool iarray list \<Rightarrow> bool" where
	+ "run_accept' R bss = accept' (run' R bss)"
	+
	+end
	+
	+locale nfa_array =
	+ fixes transs :: "transition list"
	+ and transs' :: "transition iarray"
	+ and len :: nat
	+ assumes transs_eq: "transs' = IArray transs"
	+ and len_def: "len = length transs"
	+begin
	+
	+abbreviation "step_eps \<equiv> NFA.step_eps 0 transs"
	+abbreviation "step_eps' \<equiv> NFA.step_eps' transs' len"
	+abbreviation "step_eps_closure \<equiv> NFA.step_eps_closure 0 transs"
	+abbreviation "step_eps_closure' \<equiv> NFA.step_eps_closure' transs' len"
	+abbreviation "step_eps_sucs \<equiv> NFA.step_eps_sucs 0 transs"
	+abbreviation "step_eps_sucs' \<equiv> NFA.step_eps_sucs' transs' len"
	+abbreviation "step_eps_set \<equiv> NFA.step_eps_set 0 transs"
	+abbreviation "step_eps_set' \<equiv> NFA.step_eps_set' transs' len"
	+abbreviation "step_eps_closure_set \<equiv> NFA.step_eps_closure_set 0 transs"
	+abbreviation "step_eps_closure_set' \<equiv> NFA.step_eps_closure_set' transs' len"
	+abbreviation "step_symb_sucs \<equiv> NFA.step_symb_sucs 0 transs"
	+abbreviation "step_symb_sucs' \<equiv> NFA.step_symb_sucs' transs' len"
	+abbreviation "step_symb_set \<equiv> NFA.step_symb_set 0 transs"
	+abbreviation "step_symb_set' \<equiv> NFA.step_symb_set' transs' len"
	+abbreviation "delta \<equiv> NFA.delta 0 transs"
	+abbreviation "delta' \<equiv> NFA.delta' transs' len"
	+abbreviation "accept_eps \<equiv> NFA.accept_eps 0 len transs"
	+abbreviation "accept_eps' \<equiv> NFA.accept_eps' transs' len"
	+abbreviation "accept \<equiv> NFA.accept 0 len transs"
	+abbreviation "accept' \<equiv> NFA.accept' transs' len"
	+abbreviation "run \<equiv> NFA.run 0 transs"
	+abbreviation "run' \<equiv> NFA.run' transs' len"
	+abbreviation "run_accept_eps \<equiv> NFA.run_accept_eps 0 len transs"
	+abbreviation "run_accept_eps' \<equiv> NFA.run_accept_eps' transs' len"
	+abbreviation "run_accept \<equiv> NFA.run_accept 0 len transs"
	+abbreviation "run_accept' \<equiv> NFA.run_accept' transs' len"
	+
	+lemma q_in_SQ: "q \<in> NFA.SQ 0 transs \<longleftrightarrow> q < len"
	+ using len_def
	+ by (auto simp: NFA.SQ_def)
	+
	+lemma step_eps'_eq: "bs' = IArray bs \<Longrightarrow> step_eps bs q q' \<longleftrightarrow> step_eps' bs' q q'"
	+ by (auto simp: NFA.step_eps_def NFA.step_eps'_def q_in_SQ transs_eq split: transition.splits)
	+
	+lemma step_eps_closure'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_closure bs q q' \<longleftrightarrow> step_eps_closure' bs' q q'"
	+proof -
	+ assume lassm: "bs' = IArray bs"
	+ have step_eps_eq_folded: "step_eps bs = step_eps' bs'"
	+ using step_eps'_eq[OF lassm]
	+ by auto
	+ show ?thesis
	+ by (auto simp: NFA.step_eps_closure_def NFA.step_eps_closure'_def step_eps_eq_folded)
	+qed
	+
	+lemma step_eps_sucs'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_sucs bs q = step_eps_sucs' bs' q"
	+ by (auto simp: NFA.step_eps_sucs_def NFA.step_eps_sucs'_def q_in_SQ transs_eq
	+ split: transition.splits)
	+
	+lemma step_eps_set'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_set bs R = step_eps_set' bs' R"
	+ by (auto simp: NFA.step_eps_set_def NFA.step_eps_set'_def step_eps_sucs'_eq)
	+
	+lemma step_eps_closure_set'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_closure_set R bs = step_eps_closure_set' R bs'"
	+ by (auto simp: NFA.step_eps_closure_set_def NFA.step_eps_closure_set'_def step_eps_closure'_eq)
	+
	+lemma step_symb_sucs'_eq: "bs' = IArray bs \<Longrightarrow> step_symb_sucs R = step_symb_sucs' R"
	+ by (auto simp: NFA.step_symb_sucs_def NFA.step_symb_sucs'_def q_in_SQ transs_eq
	+ split: transition.splits)
	+
	+lemma step_symb_set'_eq: "bs' = IArray bs \<Longrightarrow> step_symb_set R = step_symb_set' R"
	+ by (auto simp: step_symb_set_code NFA.step_symb_set'_def step_symb_sucs'_eq)
	+
	+lemma delta'_eq: "bs' = IArray bs \<Longrightarrow> delta R bs = delta' R bs'"
	+ by (auto simp: NFA.delta_def NFA.delta'_def step_eps_closure_set'_eq step_symb_set'_eq)
	+
	+lemma accept_eps'_eq: "bs' = IArray bs \<Longrightarrow> accept_eps R bs = accept_eps' R bs'"
	+ by (auto simp: NFA.accept_eps_def NFA.accept_eps'_def step_eps_closure_set'_eq)
	+
	+lemma accept'_eq: "accept R = accept' R"
	+ by (auto simp: NFA.accept_def NFA.accept'_def accept_eps'_eq iarray_of_list_def)
	+
	+lemma run'_eq: "bss' = map IArray bss \<Longrightarrow> run R bss = run' R bss'"
	+ by (induction bss arbitrary: R bss') (auto simp: NFA.run_def NFA.run'_def delta'_eq)
	+
	+lemma run_accept_eps'_eq: "bss' = map IArray bss \<Longrightarrow> bs' = IArray bs \<Longrightarrow>
	+ run_accept_eps R bss bs \<longleftrightarrow> run_accept_eps' R bss' bs'"
	+ by (auto simp: NFA.run_accept_eps_def NFA.run_accept_eps'_def accept_eps'_eq run'_eq)
	+
	+lemma run_accept'_eq: "bss' = map IArray bss \<Longrightarrow>
	+ run_accept R bss \<longleftrightarrow> run_accept' R bss'"
	+ by (auto simp: NFA.run_accept_def NFA.run_accept'_def run'_eq accept'_eq)
	+
	+end
	+
	+locale nfa =
	+ fixes q0 :: nat
	+ and qf :: nat
	+ and transs :: "transition list"
	+ assumes state_closed: "\<And>t. t \<in> set transs \<Longrightarrow> state_set t \<subseteq> NFA.Q q0 qf transs"
	+ and transs_not_Nil: "transs \<noteq> []"
	+ and qf_not_in_SQ: "qf \<notin> NFA.SQ q0 transs"
	+begin
	+
	+abbreviation "SQ \<equiv> NFA.SQ q0 transs"
	+abbreviation "Q \<equiv> NFA.Q q0 qf transs"
	+abbreviation "nfa_fmla_set \<equiv> NFA.nfa_fmla_set transs"
	+abbreviation "step_eps \<equiv> NFA.step_eps q0 transs"
	+abbreviation "step_eps_sucs \<equiv> NFA.step_eps_sucs q0 transs"
	+abbreviation "step_eps_set \<equiv> NFA.step_eps_set q0 transs"
	+abbreviation "step_eps_closure \<equiv> NFA.step_eps_closure q0 transs"
	+abbreviation "step_eps_closure_set \<equiv> NFA.step_eps_closure_set q0 transs"
	+abbreviation "step_symb \<equiv> NFA.step_symb q0 transs"
	+abbreviation "step_symb_sucs \<equiv> NFA.step_symb_sucs q0 transs"
	+abbreviation "step_symb_set \<equiv> NFA.step_symb_set q0 transs"
	+abbreviation "delta \<equiv> NFA.delta q0 transs"
	+abbreviation "run \<equiv> NFA.run q0 transs"
	+abbreviation "accept_eps \<equiv> NFA.accept_eps q0 qf transs"
	+abbreviation "run_accept_eps \<equiv> NFA.run_accept_eps q0 qf transs"
	+
	+lemma Q_diff_qf_SQ: "Q - {qf} = SQ"
	+ using qf_not_in_SQ by (auto simp add: NFA.Q_def)
	+
	+lemma q0_sub_SQ: "{q0} \<subseteq> SQ"
	+ using transs_not_Nil by (auto simp add: NFA.SQ_def)
	+
	+lemma q0_sub_Q: "{q0} \<subseteq> Q"
	+ using q0_sub_SQ SQ_sub_Q by auto
	+
	+lemma step_eps_closed: "step_eps bs q q' \<Longrightarrow> q' \<in> Q"
	+ using transs_q_in_set state_closed
	+ by (fastforce simp add: NFA.step_eps_def split: transition.splits)
	+
	+lemma step_eps_set_closed: "step_eps_set bs R \<subseteq> Q"
	+ using step_eps_closed by (auto simp add: step_eps_set_sound)
	+
	+lemma step_eps_closure_closed: "step_eps_closure bs q q' \<Longrightarrow> q \<noteq> q' \<Longrightarrow> q' \<in> Q"
	+ unfolding NFA.step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct) using step_eps_closed by auto
	+
	+lemma step_eps_closure_set_closed_union: "step_eps_closure_set R bs \<subseteq> R \<union> Q"
	+ using step_eps_closure_closed by (auto simp add: NFA.step_eps_closure_set_def NFA.step_eps_closure_def)
	+
	+lemma step_eps_closure_set_closed: "R \<subseteq> Q \<Longrightarrow> step_eps_closure_set R bs \<subseteq> Q"
	+ using step_eps_closure_set_closed_union by auto
	+
	+lemma step_symb_closed: "step_symb q q' \<Longrightarrow> q' \<in> Q"
	+ using transs_q_in_set state_closed
	+ by (fastforce simp add: NFA.step_symb_def split: transition.splits)
	+
	+lemma step_symb_set_closed: "step_symb_set R \<subseteq> Q"
	+ using step_symb_closed by (auto simp add: NFA.step_symb_set_def)
	+
	+lemma step_symb_set_qf: "step_symb_set {qf} = {}"
	+ using qf_not_in_SQ step_symb_set_proj[of _ _ "{qf}"] step_symb_set_empty by auto
	+
	+lemma delta_closed: "delta R bs \<subseteq> Q"
	+ using step_symb_set_closed by (auto simp add: NFA.delta_def)
	+
	+lemma run_closed_Cons: "run R (bs # bss) \<subseteq> Q"
	+ unfolding NFA.run_def
	+ using delta_closed by (induction bss arbitrary: R bs) auto
	+
	+lemma run_closed: "R \<subseteq> Q \<Longrightarrow> run R bss \<subseteq> Q"
	+ using run_Nil run_closed_Cons by (cases bss) auto
	+
	+(* transitions from accepting state *)
	+
	+lemma step_eps_qf: "step_eps bs qf q \<longleftrightarrow> False"
	+ using qf_not_in_SQ step_eps_dest by force
	+
	+lemma step_symb_qf: "step_symb qf q \<longleftrightarrow> False"
	+ using qf_not_in_SQ step_symb_dest by force
	+
	+lemma step_eps_closure_qf: "step_eps_closure bs q q' \<Longrightarrow> q = qf \<Longrightarrow> q = q'"
	+ unfolding NFA.step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct) using step_eps_qf by auto
	+
	+lemma step_eps_closure_set_qf: "step_eps_closure_set {qf} bs = {qf}"
	+ using step_eps_closure_qf unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def by auto
	+
	+lemma delta_qf: "delta {qf} bs = {}"
	+ using step_eps_closure_qf step_symb_qf
	+ by (auto simp add: NFA.delta_def NFA.step_symb_set_def NFA.step_eps_closure_set_def)
	+
	+lemma run_qf_many: "run {qf} (bs # bss) = {}"
	+ unfolding run_Cons delta_qf run_empty by (rule refl)
	+
	+lemma run_accept_eps_qf_many: "run_accept_eps {qf} (bs # bss) cs \<longleftrightarrow> False"
	+ unfolding NFA.run_accept_eps_def using run_qf_many accept_eps_empty by simp
	+
	+lemma run_accept_eps_qf_one: "run_accept_eps {qf} [] bs \<longleftrightarrow> True"
	+ unfolding NFA.run_accept_eps_def NFA.accept_eps_def using run_Nil step_eps_closure_set_refl by force
	+
	+end
	+
	+locale nfa_cong = nfa q0 qf transs + nfa': nfa q0' qf' transs'
	+ for q0 q0' qf qf' transs transs' +
	+ assumes SQ_sub: "nfa'.SQ \<subseteq> SQ" and
	+ qf_eq: "qf = qf'" and
	+ transs_eq: "\<And>q. q \<in> nfa'.SQ \<Longrightarrow> transs ! (q - q0) = transs' ! (q - q0')"
	+begin
	+
	+lemma q_Q_SQ_nfa'_SQ: "q \<in> nfa'.Q \<Longrightarrow> q \<in> SQ \<longleftrightarrow> q \<in> nfa'.SQ"
	+ using SQ_sub qf_not_in_SQ qf_eq by (auto simp add: NFA.Q_def)
	+
	+lemma step_eps_cong: "q \<in> nfa'.Q \<Longrightarrow> step_eps bs q q' \<longleftrightarrow> nfa'.step_eps bs q q'"
	+ using q_Q_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_eps_def)
	+
	+lemma eps_nfa'_step_eps_closure: "step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
	+ q' \<in> nfa'.Q \<and> nfa'.step_eps_closure bs q q'"
	+ unfolding NFA.step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct)
	+ using nfa'.step_eps_closure_closed step_eps_cong by (auto simp add: NFA.step_eps_closure_def)
	+
	+lemma nfa'_eps_step_eps_closure: "nfa'.step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
	+ q' \<in> nfa'.Q \<and> step_eps_closure bs q q'"
	+ unfolding NFA.step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct)
	+ using nfa'.step_eps_closed step_eps_cong
	+ by (auto simp add: NFA.step_eps_closure_def intro: rtranclp.intros(2))
	+
	+lemma step_eps_closure_set_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> step_eps_closure_set R bs =
	+ nfa'.step_eps_closure_set R bs"
	+ using eps_nfa'_step_eps_closure nfa'_eps_step_eps_closure
	+ by (fastforce simp add: NFA.step_eps_closure_set_def)
	+
	+lemma step_symb_cong: "q \<in> nfa'.Q \<Longrightarrow> step_symb q q' \<longleftrightarrow> nfa'.step_symb q q'"
	+ using q_Q_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_symb_def)
	+
	+lemma step_symb_set_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> step_symb_set R = nfa'.step_symb_set R"
	+ using step_symb_cong by (auto simp add: NFA.step_symb_set_def)
	+
	+lemma delta_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> delta R bs = nfa'.delta R bs"
	+ using step_symb_set_cong nfa'.step_eps_closure_set_closed
	+ by (auto simp add: NFA.delta_def step_eps_closure_set_cong)
	+
	+lemma run_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> run R bss = nfa'.run R bss"
	+ unfolding NFA.run_def
	+ using nfa'.delta_closed delta_cong by (induction bss arbitrary: R) auto
	+
	+lemma accept_eps_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> accept_eps R bs \<longleftrightarrow> nfa'.accept_eps R bs"
	+ unfolding NFA.accept_eps_def using step_eps_closure_set_cong qf_eq by auto
	+
	+lemma run_accept_eps_cong:
	+ assumes "R \<subseteq> nfa'.Q"
	+ shows "run_accept_eps R bss bs \<longleftrightarrow> nfa'.run_accept_eps R bss bs"
	+ unfolding NFA.run_accept_eps_def run_cong[OF assms]
	+ accept_eps_cong[OF nfa'.run_closed[OF assms]] by simp
	+
	+end
	+
	+fun list_split :: "'a list \<Rightarrow> ('a list \<times> 'a list) set" where
	+ "list_split [] = {}"
	+\| "list_split (x # xs) = {([], x # xs)} \<union> (\<Union>(ys, zs) \<in> list_split xs. {(x # ys, zs)})"
	+
	+lemma list_split_unfold: "(\<Union>(ys, zs) \<in> list_split (x # xs). f ys zs) =
	+ f [] (x # xs) \<union> (\<Union>(ys, zs) \<in> list_split xs. f (x # ys) zs)"
	+ by (induction xs) auto
	+
	+lemma list_split_def: "list_split xs = (\<Union>n < length xs. {(take n xs, drop n xs)})"
	+ using less_Suc_eq_0_disj by (induction xs rule: list_split.induct) auto+
	+
	+locale nfa_cong' = nfa q0 qf transs + nfa': nfa q0' qf' transs'
	+ for q0 q0' qf qf' transs transs' +
	+ assumes SQ_sub: "nfa'.SQ \<subseteq> SQ" and
	+ qf'_in_SQ: "qf' \<in> SQ" and
	+ transs_eq: "\<And>q. q \<in> nfa'.SQ \<Longrightarrow> transs ! (q - q0) = transs' ! (q - q0')"
	+begin
	+
	+lemma nfa'_Q_sub_Q: "nfa'.Q \<subseteq> Q"
	+ unfolding NFA.Q_def using SQ_sub qf'_in_SQ by auto
	+
	+lemma q_SQ_SQ_nfa'_SQ: "q \<in> nfa'.SQ \<Longrightarrow> q \<in> SQ \<longleftrightarrow> q \<in> nfa'.SQ"
	+ using SQ_sub by auto
	+
	+lemma step_eps_cong_SQ: "q \<in> nfa'.SQ \<Longrightarrow> step_eps bs q q' \<longleftrightarrow> nfa'.step_eps bs q q'"
	+ using q_SQ_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_eps_def)
	+
	+lemma step_eps_cong_Q: "q \<in> nfa'.Q \<Longrightarrow> nfa'.step_eps bs q q' \<Longrightarrow> step_eps bs q q'"
	+ using SQ_sub transs_eq by (auto simp add: NFA.step_eps_def)
	+
	+lemma nfa'_step_eps_closure_cong: "nfa'.step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
	+ step_eps_closure bs q q'"
	+ unfolding NFA.step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct)
	+ using NFA.Q_def NFA.step_eps_closure_def
	+ by (auto simp add: rtranclp.rtrancl_into_rtrancl step_eps_cong_SQ step_eps_dest)
	+
	+lemma nfa'_step_eps_closure_set_sub: "R \<subseteq> nfa'.Q \<Longrightarrow> nfa'.step_eps_closure_set R bs \<subseteq>
	+ step_eps_closure_set R bs"
	+ unfolding NFA.step_eps_closure_set_def
	+ using nfa'_step_eps_closure_cong by fastforce
	+
	+lemma eps_nfa'_step_eps_closure_cong: "step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
	+ (q' \<in> nfa'.Q \<and> nfa'.step_eps_closure bs q q') \<or>
	+ (nfa'.step_eps_closure bs q qf' \<and> step_eps_closure bs qf' q')"
	+ unfolding NFA.step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct)
	+ using nfa'.step_eps_closure_closed nfa'.step_eps_closed step_eps_cong_SQ NFA.Q_def
	+ by (auto simp add: intro: rtranclp.rtrancl_into_rtrancl) fastforce+
	+
	+lemma nfa'_eps_step_eps_closure_cong: "nfa'.step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
	+ q' \<in> nfa'.Q \<and> step_eps_closure bs q q'"
	+ unfolding NFA.step_eps_closure_def
	+ apply (induction q q' rule: rtranclp.induct)
	+ using nfa'.step_eps_closed step_eps_cong_Q
	+ by (auto intro: rtranclp.intros(2))
	+
	+lemma step_eps_closure_set_cong_reach: "R \<subseteq> nfa'.Q \<Longrightarrow> qf' \<in> nfa'.step_eps_closure_set R bs \<Longrightarrow>
	+ step_eps_closure_set R bs = nfa'.step_eps_closure_set R bs \<union> step_eps_closure_set {qf'} bs"
	+ using eps_nfa'_step_eps_closure_cong nfa'_eps_step_eps_closure_cong
	+ rtranclp_trans[of "step_eps bs"]
	+ unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
	+ by auto blast+
	+
	+lemma step_eps_closure_set_cong_unreach: "R \<subseteq> nfa'.Q \<Longrightarrow> qf' \<notin> nfa'.step_eps_closure_set R bs \<Longrightarrow>
	+ step_eps_closure_set R bs = nfa'.step_eps_closure_set R bs"
	+ using eps_nfa'_step_eps_closure_cong nfa'_eps_step_eps_closure_cong
	+ unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
	+ by auto blast+
	+
	+lemma step_symb_cong_SQ: "q \<in> nfa'.SQ \<Longrightarrow> step_symb q q' \<longleftrightarrow> nfa'.step_symb q q'"
	+ using q_SQ_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_symb_def)
	+
	+lemma step_symb_cong_Q: "nfa'.step_symb q q' \<Longrightarrow> step_symb q q'"
	+ using SQ_sub transs_eq by (auto simp add: NFA.step_symb_def)
	+
	+lemma step_symb_set_cong_SQ: "R \<subseteq> nfa'.SQ \<Longrightarrow> step_symb_set R = nfa'.step_symb_set R"
	+ using step_symb_cong_SQ by (auto simp add: NFA.step_symb_set_def)
	+
	+lemma step_symb_set_cong_Q: "nfa'.step_symb_set R \<subseteq> step_symb_set R"
	+ using step_symb_cong_Q by (auto simp add: NFA.step_symb_set_def)
	+
	+lemma delta_cong_unreach:
	+ assumes "R \<subseteq> nfa'.Q" "\<not>nfa'.accept_eps R bs"
	+ shows "delta R bs = nfa'.delta R bs"
	+proof -
	+ have "nfa'.step_eps_closure_set R bs \<subseteq> nfa'.SQ"
	+ using nfa'.step_eps_closure_set_closed[OF assms(1), unfolded NFA.Q_def]
	+ assms(2)[unfolded NFA.accept_eps_def] by auto
	+ then show ?thesis
	+ unfolding NFA.accept_eps_def NFA.delta_def using step_symb_set_cong_SQ
	+ step_eps_closure_set_cong_unreach[OF assms(1) assms(2)[unfolded NFA.accept_eps_def]]
	+ by auto
	+qed
	+
	+lemma nfa'_delta_sub_delta:
	+ assumes "R \<subseteq> nfa'.Q"
	+ shows "nfa'.delta R bs \<subseteq> delta R bs"
	+ unfolding NFA.delta_def
	+ using step_symb_set_mono[OF nfa'_step_eps_closure_set_sub[OF assms]] step_symb_set_cong_Q
	+ by fastforce
	+
	+lemma delta_cong_reach:
	+ assumes "R \<subseteq> nfa'.Q" "nfa'.accept_eps R bs"
	+ shows "delta R bs = nfa'.delta R bs \<union> delta {qf'} bs"
	+proof (rule set_eqI, rule iffI)
	+ fix q
	+ assume assm: "q \<in> delta R bs"
	+ have nfa'_eps_diff_Un: "nfa'.step_eps_closure_set R bs =
	+ nfa'.step_eps_closure_set R bs - {qf'} \<union> {qf'}"
	+ using assms(2)[unfolded NFA.accept_eps_def] by auto
	+ from assm have "q \<in> step_symb_set (nfa'.step_eps_closure_set R bs - {qf'}) \<union>
	+ step_symb_set {qf'} \<union> delta {qf'} bs"
	+ unfolding NFA.delta_def step_eps_closure_set_cong_reach[OF assms(1)
	+ assms(2)[unfolded NFA.accept_eps_def]] step_symb_set_split[symmetric]
	+ nfa'_eps_diff_Un[symmetric] by simp
	+ then have "q \<in> step_symb_set (nfa'.step_eps_closure_set R bs - {qf'}) \<union> delta {qf'} bs"
	+ using step_symb_set_mono[of "{qf'}" "step_eps_closure_set {qf'} bs",
	+ OF step_eps_closure_set_refl, unfolded NFA.delta_def[symmetric]]
	+ delta_step_symb_set_absorb by blast
	+ then show "q \<in> nfa'.delta R bs \<union> delta {qf'} bs"
	+ unfolding NFA.delta_def
	+ using nfa'.step_eps_closure_set_closed[OF assms(1), unfolded NFA.Q_def]
	+ step_symb_set_cong_SQ[of "nfa'.step_eps_closure_set R bs - {qf'}"]
	+ step_symb_set_mono by blast
	+next
	+ fix q
	+ assume "q \<in> nfa'.delta R bs \<union> delta {qf'} bs"
	+ then show "q \<in> delta R bs"
	+ using nfa'_delta_sub_delta[OF assms(1)] delta_sub_eps_mono[of "{qf'}" _ _ R bs]
	+ assms(2)[unfolded NFA.accept_eps_def] nfa'_step_eps_closure_set_sub[OF assms(1)]
	+ by fastforce
	+qed
	+
	+lemma run_cong:
	+ assumes "R \<subseteq> nfa'.Q"
	+ shows "run R bss = nfa'.run R bss \<union> (\<Union>(css, css') \<in> list_split bss.
	+ if nfa'.run_accept_eps R css (hd css') then run {qf'} css' else {})"
	+ using assms
	+proof (induction bss arbitrary: R rule: list_split.induct)
	+ case 1
	+ then show ?case
	+ using run_Nil by simp
	+next
	+ case (2 x xs)
	+ show ?case
	+ apply (cases "nfa'.accept_eps R x")
	+ unfolding run_Cons delta_cong_reach[OF 2(2)]
	+ delta_cong_unreach[OF 2(2)] run_split run_accept_eps_Nil run_accept_eps_Cons
	+ list_split_unfold[of "\<lambda>ys zs. if nfa'.run_accept_eps R ys (hd zs)
	+ then run {qf'} zs else {}" x xs] using 2(1)[of "nfa'.delta R x",
	+ OF nfa'.delta_closed, unfolded run_accept_eps_Nil] by auto
	+qed
	+
	+lemma run_cong_Cons_sub:
	+ assumes "R \<subseteq> nfa'.Q" "delta {qf'} bs \<subseteq> nfa'.delta R bs"
	+ shows "run R (bs # bss) = nfa'.run R (bs # bss) \<union>
	+ (\<Union>(css, css') \<in> list_split bss.
	+ if nfa'.run_accept_eps (nfa'.delta R bs) css (hd css') then run {qf'} css' else {})"
	+ unfolding run_Cons using run_cong[OF nfa'.delta_closed]
	+ delta_cong_reach[OF assms(1)] delta_cong_unreach[OF assms(1)]
	+ by (cases "nfa'.accept_eps R bs") (auto simp add: Un_absorb2[OF assms(2)])
	+
	+lemma accept_eps_nfa'_run:
	+ assumes "R \<subseteq> nfa'.Q"
	+ shows "accept_eps (nfa'.run R bss) bs \<longleftrightarrow>
	+ nfa'.accept_eps (nfa'.run R bss) bs \<and> accept_eps (run {qf'} []) bs"
	+ unfolding NFA.accept_eps_def run_Nil
	+ using step_eps_closure_set_cong_reach[OF nfa'.run_closed[OF assms]]
	+ step_eps_closure_set_cong_unreach[OF nfa'.run_closed[OF assms]] qf_not_in_SQ
	+ qf'_in_SQ nfa'.step_eps_closure_set_closed[OF nfa'.run_closed[OF assms],
	+ unfolded NFA.Q_def] SQ_sub
	+ by (cases "qf' \<in> nfa'.step_eps_closure_set (nfa'.run R bss) bs") fastforce+
	+
	+lemma run_accept_eps_cong:
	+ assumes "R \<subseteq> nfa'.Q"
	+ shows "run_accept_eps R bss bs \<longleftrightarrow> (nfa'.run_accept_eps R bss bs \<and> run_accept_eps {qf'} [] bs) \<or>
	+ (\<exists>(css, css') \<in> list_split bss. nfa'.run_accept_eps R css (hd css') \<and>
	+ run_accept_eps {qf'} css' bs)"
	+ unfolding NFA.run_accept_eps_def run_cong[OF assms] accept_eps_split
	+ accept_eps_Un accept_eps_nfa'_run[OF assms]
	+ using accept_eps_empty by (auto split: if_splits)+
	+
	+lemma run_accept_eps_cong_Cons_sub:
	+ assumes "R \<subseteq> nfa'.Q" "delta {qf'} bs \<subseteq> nfa'.delta R bs"
	+ shows "run_accept_eps R (bs # bss) cs \<longleftrightarrow>
	+ (nfa'.run_accept_eps R (bs # bss) cs \<and> run_accept_eps {qf'} [] cs) \<or>
	+ (\<exists>(css, css') \<in> list_split bss. nfa'.run_accept_eps (nfa'.delta R bs) css (hd css') \<and>
	+ run_accept_eps {qf'} css' cs)"
	+ unfolding NFA.run_accept_eps_def run_cong_Cons_sub[OF assms]
	+ accept_eps_split accept_eps_Un accept_eps_nfa'_run[OF assms(1)]
	+ using accept_eps_empty by (auto split: if_splits)+
	+
	+lemmas run_accept_eps_cong_Cons_sub_simp =
	+ run_accept_eps_cong_Cons_sub[unfolded list_split_def, simplified,
	+ unfolded run_accept_eps_Cons[symmetric] take_Suc_Cons[symmetric]]
	+
	+end
	+
	+locale nfa_cong_Plus = nfa_cong q0 q0' qf qf' transs transs' +
	+ right: nfa_cong q0 q0'' qf qf'' transs transs''
	+ for q0 q0' q0'' qf qf' qf'' transs transs' transs'' +
	+ assumes step_eps_q0: "step_eps bs q0 q \<longleftrightarrow> q \<in> {q0', q0''}" and
	+ step_symb_q0: "\<not>step_symb q0 q"
	+begin
	+
	+lemma step_symb_set_q0: "step_symb_set {q0} = {}"
	+ unfolding NFA.step_symb_set_def using step_symb_q0 by simp
	+
	+lemma qf_not_q0: "qf \<notin> {q0}"
	+ using qf_not_in_SQ q0_sub_SQ by auto
	+
	+lemma step_eps_closure_set_q0: "step_eps_closure_set {q0} bs = {q0} \<union>
	+ (nfa'.step_eps_closure_set {q0'} bs \<union> right.nfa'.step_eps_closure_set {q0''} bs)"
	+ using step_eps_closure_set_unfold[OF step_eps_q0]
	+ insert_is_Un[of q0' "{q0''}"]
	+ step_eps_closure_set_split[of _ _ "{q0'}" "{q0''}"]
	+ step_eps_closure_set_cong[OF nfa'.q0_sub_Q]
	+ right.step_eps_closure_set_cong[OF right.nfa'.q0_sub_Q]
	+ by auto
	+
	+lemmas run_accept_eps_Nil_cong =
	+ run_accept_eps_Nil_eps_split[OF step_eps_closure_set_q0 step_symb_set_q0 qf_not_q0,
	+ unfolded run_accept_eps_split
	+ run_accept_eps_cong[OF nfa'.step_eps_closure_set_closed[OF nfa'.q0_sub_Q]]
	+ right.run_accept_eps_cong[OF right.nfa'.step_eps_closure_set_closed[OF right.nfa'.q0_sub_Q]]
	+ run_accept_eps_Nil_eps]
	+
	+lemmas run_accept_eps_Cons_cong =
	+ run_accept_eps_Cons_eps_split[OF step_eps_closure_set_q0 step_symb_set_q0 qf_not_q0,
	+ unfolded run_accept_eps_split
	+ run_accept_eps_cong[OF nfa'.step_eps_closure_set_closed[OF nfa'.q0_sub_Q]]
	+ right.run_accept_eps_cong[OF right.nfa'.step_eps_closure_set_closed[OF right.nfa'.q0_sub_Q]]
	+ run_accept_eps_Cons_eps]
	+
	+lemma run_accept_eps_cong: "run_accept_eps {q0} bss bs \<longleftrightarrow>
	+ (nfa'.run_accept_eps {q0'} bss bs \<or> right.nfa'.run_accept_eps {q0''} bss bs)"
	+ using run_accept_eps_Nil_cong run_accept_eps_Cons_cong by (cases bss) auto
	+
	+end
	+
	+locale nfa_cong_Times = nfa_cong' q0 q0 qf q0' transs transs' +
	+ right: nfa_cong q0 q0' qf qf transs transs''
	+ for q0 q0' qf transs transs' transs''
	+begin
	+
	+lemmas run_accept_eps_cong =
	+ run_accept_eps_cong[OF nfa'.q0_sub_Q, unfolded
	+ right.run_accept_eps_cong[OF right.nfa'.q0_sub_Q], unfolded list_split_def, simplified]
	+
	+end
	+
	+locale nfa_cong_Star = nfa_cong' q0 q0' qf q0 transs transs'
	+ for q0 q0' qf transs transs' +
	+ assumes step_eps_q0: "step_eps bs q0 q \<longleftrightarrow> q \<in> {q0', qf}" and
	+ step_symb_q0: "\<not>step_symb q0 q"
	+begin
	+
	+lemma step_symb_set_q0: "step_symb_set {q0} = {}"
	+ unfolding NFA.step_symb_set_def using step_symb_q0 by simp
	+
	+lemma run_accept_eps_Nil: "run_accept_eps {q0} [] bs"
	+ unfolding NFA.run_accept_eps_def NFA.run_def using step_eps_accept_eps step_eps_q0 by fastforce
	+
	+lemma rtranclp_step_eps_q0_q0': "(step_eps bs)\<^sup>\<^sup> q q' \<Longrightarrow> q = q0 \<Longrightarrow>
	+ q' \<in> {q0, qf} \<or> (q' \<in> nfa'.SQ \<and> (nfa'.step_eps bs)\<^sup>\<^sup> q0' q')"
	+ apply (induction q q' rule: rtranclp.induct)
	+ using step_eps_q0 step_eps_dest qf_not_in_SQ step_eps_cong_SQ nfa'.q0_sub_SQ
	+ nfa'.step_eps_closed[unfolded NFA.Q_def] by fastforce+
	+
	+lemma step_eps_closure_set_q0: "step_eps_closure_set {q0} bs \<subseteq> {q0, qf} \<union>
	+ (nfa'.step_eps_closure_set {q0'} bs \<inter> nfa'.SQ)"
	+ unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
	+ using rtranclp_step_eps_q0_q0' by auto
	+
	+lemma delta_sub_nfa'_delta: "delta {q0} bs \<subseteq> nfa'.delta {q0'} bs"
	+ unfolding NFA.delta_def
	+ using step_symb_set_mono[OF step_eps_closure_set_q0, unfolded step_symb_set_q0
	+ step_symb_set_qf step_symb_set_split insert_is_Un[of q0 "{qf}"]]
	+ step_symb_set_cong_SQ
	+ by (metis boolean_algebra_cancel.sup0 inf_le2 step_symb_set_proj step_symb_set_q0
	+ step_symb_set_qf sup_commute)
	+
	+lemma step_eps_closure_set_q0_split: "step_eps_closure_set {q0} bs = {q0, qf} \<union>
	+ step_eps_closure_set {q0'} bs"
	+ unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
	+ using step_eps_qf step_eps_q0
	+ apply (auto)
	+ apply (metis rtranclp_unfold)
	+ by (metis r_into_rtranclp rtranclp.rtrancl_into_rtrancl rtranclp_idemp)
	+
	+lemma delta_q0_q0': "delta {q0} bs = delta {q0'} bs"
	+ unfolding NFA.delta_def step_eps_closure_set_q0_split step_symb_set_split
	+ unfolding NFA.delta_def[symmetric]
	+ unfolding NFA.step_symb_set_def
	+ using step_symb_q0 step_symb_dest qf_not_in_SQ
	+ by fastforce
	+
	+lemmas run_accept_eps_cong_Cons =
	+ run_accept_eps_cong_Cons_sub_simp[OF nfa'.q0_sub_Q delta_sub_nfa'_delta,
	+ unfolded run_accept_eps_Cons_delta_cong[OF delta_q0_q0', symmetric]]
	+
	+end
	+
	+end
	diff --git a/thys/VYDRA_MDL/Preliminaries.thy b/thys/VYDRA_MDL/Preliminaries.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Preliminaries.thy
	@@ -0,0 +1,123 @@
	+theory Preliminaries
	+ imports MDL
	+begin
	+
	+section \<open>Formulas and Satisfiability\<close>
	+
	+declare [[typedef_overloaded]]
	+
	+context
	+begin
	+
	+qualified datatype ('a, 't :: timestamp) formula = Bool bool \| Atom 'a \| Neg "('a, 't) formula" \|
	+ Bin "bool \<Rightarrow> bool \<Rightarrow> bool" "('a, 't) formula" "('a, 't) formula" \|
	+ Prev "'t \<I>" "('a, 't) formula" \| Next "'t \<I>" "('a, 't) formula" \|
	+ Since "('a, 't) formula" "'t \<I>" "('a, 't) formula" \|
	+ Until "('a, 't) formula" "'t \<I>" "('a, 't) formula" \|
	+ MatchP "'t \<I>" "('a, 't) regex" \| MatchF "'t \<I>" "('a, 't) regex"
	+ and ('a, 't) regex = Test "('a, 't) formula" \| Wild \|
	+ Plus "('a, 't) regex" "('a, 't) regex" \| Times "('a, 't) regex" "('a, 't) regex" \|
	+ Star "('a, 't) regex"
	+
	+end
	+
	+fun mdl2mdl :: "('a, 't :: timestamp) Preliminaries.formula \<Rightarrow> ('a, 't) formula"
	+ and embed :: "('a, 't) Preliminaries.regex \<Rightarrow> ('a, 't) regex" where
	+ "mdl2mdl (Preliminaries.Bool b) = Bool b"
	+\| "mdl2mdl (Preliminaries.Atom a) = Atom a"
	+\| "mdl2mdl (Preliminaries.Neg phi) = Neg (mdl2mdl phi)"
	+\| "mdl2mdl (Preliminaries.Bin f phi psi) = Bin f (mdl2mdl phi) (mdl2mdl psi)"
	+\| "mdl2mdl (Preliminaries.Prev I phi) = Prev I (mdl2mdl phi)"
	+\| "mdl2mdl (Preliminaries.Next I phi) = Next I (mdl2mdl phi)"
	+\| "mdl2mdl (Preliminaries.Since phi I psi) = Since (mdl2mdl phi) I (mdl2mdl psi)"
	+\| "mdl2mdl (Preliminaries.Until phi I psi) = Until (mdl2mdl phi) I (mdl2mdl psi)"
	+\| "mdl2mdl (Preliminaries.MatchP I r) = MatchP I (Times (embed r) (Symbol (Bool True)))"
	+\| "mdl2mdl (Preliminaries.MatchF I r) = MatchF I (Times (embed r) (Symbol (Bool True)))"
	+\| "embed (Preliminaries.Test phi) = Lookahead (mdl2mdl phi)"
	+\| "embed Preliminaries.Wild = Symbol (Bool True)"
	+\| "embed (Preliminaries.Plus r s) = Plus (embed r) (embed s)"
	+\| "embed (Preliminaries.Times r s) = Times (embed r) (embed s)"
	+\| "embed (Preliminaries.Star r) = Star (embed r)"
	+
	+lemma mdl2mdl_wf:
	+ fixes phi :: "('a, 't :: timestamp) Preliminaries.formula"
	+ shows "wf_fmla (mdl2mdl phi)"
	+ by (induction phi rule: mdl2mdl_embed.induct(1)[where ?Q="\<lambda>r. wf_regex (Times (embed r) (Symbol (Bool True))) \<and> (\<forall>phi \<in> atms (embed r). wf_fmla phi)"]) auto
	+
	+fun embed' :: "(('a, 't :: timestamp) formula \<Rightarrow> ('a, 't) Preliminaries.formula) \<Rightarrow> ('a, 't) regex \<Rightarrow> ('a, 't) Preliminaries.regex" where
	+ "embed' f (Lookahead phi) = Preliminaries.Test (f phi)"
	+\| "embed' f (Symbol phi) = Preliminaries.Times (Preliminaries.Test (f phi)) Preliminaries.Wild"
	+\| "embed' f (Plus r s) = Preliminaries.Plus (embed' f r) (embed' f s)"
	+\| "embed' f (Times r s) = Preliminaries.Times (embed' f r) (embed' f s)"
	+\| "embed' f (Star r) = Preliminaries.Star (embed' f r)"
	+
	+lemma embed'_cong[fundef_cong]: "(\<And>phi. phi \<in> atms r \<Longrightarrow> f phi = f' phi) \<Longrightarrow> embed' f r = embed' f' r"
	+ by (induction r) auto
	+
	+fun mdl2mdl' :: "('a, 't :: timestamp) formula \<Rightarrow> ('a, 't) Preliminaries.formula" where
	+ "mdl2mdl' (Bool b) = Preliminaries.Bool b"
	+\| "mdl2mdl' (Atom a) = Preliminaries.Atom a"
	+\| "mdl2mdl' (Neg phi) = Preliminaries.Neg (mdl2mdl' phi)"
	+\| "mdl2mdl' (Bin f phi psi) = Preliminaries.Bin f (mdl2mdl' phi) (mdl2mdl' psi)"
	+\| "mdl2mdl' (Prev I phi) = Preliminaries.Prev I (mdl2mdl' phi)"
	+\| "mdl2mdl' (Next I phi) = Preliminaries.Next I (mdl2mdl' phi)"
	+\| "mdl2mdl' (Since phi I psi) = Preliminaries.Since (mdl2mdl' phi) I (mdl2mdl' psi)"
	+\| "mdl2mdl' (Until phi I psi) = Preliminaries.Until (mdl2mdl' phi) I (mdl2mdl' psi)"
	+\| "mdl2mdl' (MatchP I r) = Preliminaries.MatchP I (embed' mdl2mdl' (rderive r))"
	+\| "mdl2mdl' (MatchF I r) = Preliminaries.MatchF I (embed' mdl2mdl' (rderive r))"
	+
	+context MDL
	+begin
	+
	+fun rvsat :: "('a, 't) Preliminaries.formula \<Rightarrow> nat \<Rightarrow> bool"
	+ and rvmatch :: "('a, 't) Preliminaries.regex \<Rightarrow> (nat \<times> nat) set" where
	+ "rvsat (Preliminaries.Bool b) i = b"
	+\| "rvsat (Preliminaries.Atom a) i = (a \<in> \<Gamma> \<sigma> i)"
	+\| "rvsat (Preliminaries.Neg \<phi>) i = (\<not> rvsat \<phi> i)"
	+\| "rvsat (Preliminaries.Bin f \<phi> \<psi>) i = (f (rvsat \<phi> i) (rvsat \<psi> i))"
	+\| "rvsat (Preliminaries.Prev I \<phi>) i = (case i of 0 \<Rightarrow> False \| Suc j \<Rightarrow> mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> rvsat \<phi> j)"
	+\| "rvsat (Preliminaries.Next I \<phi>) i = (mem (\<tau> \<sigma> i) (\<tau> \<sigma> (Suc i)) I \<and> rvsat \<phi> (Suc i))"
	+\| "rvsat (Preliminaries.Since \<phi> I \<psi>) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> rvsat \<psi> j \<and> (\<forall>k \<in> {j<..i}. rvsat \<phi> k))"
	+\| "rvsat (Preliminaries.Until \<phi> I \<psi>) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> rvsat \<psi> j \<and> (\<forall>k \<in> {i..<j}. rvsat \<phi> k))"
	+\| "rvsat (Preliminaries.MatchP I r) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> (j, i) \<in> rvmatch r)"
	+\| "rvsat (Preliminaries.MatchF I r) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> (i, j) \<in> rvmatch r)"
	+\| "rvmatch (Preliminaries.Test \<phi>) = {(i, i) \| i. rvsat \<phi> i}"
	+\| "rvmatch Preliminaries.Wild = {(i, i + 1) \| i. True}"
	+\| "rvmatch (Preliminaries.Plus r s) = rvmatch r \<union> rvmatch s"
	+\| "rvmatch (Preliminaries.Times r s) = rvmatch r O rvmatch s"
	+\| "rvmatch (Preliminaries.Star r) = rtrancl (rvmatch r)"
	+
	+lemma mdl2mdl_equivalent:
	+ fixes phi :: "('a, 't :: timestamp) Preliminaries.formula"
	+ shows "\<And>i. sat (mdl2mdl phi) i \<longleftrightarrow> rvsat phi i"
	+ by (induction phi rule: mdl2mdl_embed.induct(1)[where ?Q="\<lambda>r. match (embed r) = rvmatch r"]) (auto split: nat.splits)
	+
	+lemma mdlstar2mdl:
	+ fixes phi :: "('a, 't :: timestamp) Preliminaries.formula"
	+ shows "wf_fmla (mdl2mdl phi)" "\<And>i. sat (mdl2mdl phi) i \<longleftrightarrow> rvsat phi i"
	+ apply (rule mdl2mdl_wf)
	+ apply (rule mdl2mdl_equivalent)
	+ done
	+
	+lemma rvmatch_embed':
	+ assumes "\<And>phi i. phi \<in> atms r \<Longrightarrow> rvsat (mdl2mdl' phi) i \<longleftrightarrow> sat phi i"
	+ shows "rvmatch (embed' mdl2mdl' r) = match r"
	+ using assms
	+ by (induction r) auto
	+
	+lemma mdl2mdlstar:
	+ fixes phi :: "('a, 't :: timestamp) formula"
	+ assumes "wf_fmla phi"
	+ shows "\<And>i. rvsat (mdl2mdl' phi) i \<longleftrightarrow> sat phi i"
	+ using assms
	+ apply (induction phi rule: mdl2mdl'.induct)
	+ apply (auto split: nat.splits)[8]
	+ subgoal for I r i
	+ by auto (metis atms_rderive match_rderive rvmatch_embed' wf_fmla.simps(1))+
	+ subgoal for I r i
	+ by auto (metis atms_rderive match_rderive rvmatch_embed' wf_fmla.simps(1))+
	+ done
	+
	+end
	+
	+end
	diff --git a/thys/VYDRA_MDL/ROOT b/thys/VYDRA_MDL/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/ROOT
	@@ -0,0 +1,23 @@
	+chapter AFP
	+
	+session VYDRA_MDL (AFP) = Containers +
	+ options [timeout=600]
	+ theories
	+ Interval
	+ MDL
	+ Metric_Point_Structure
	+ Monitor_Code
	+ Monitor
	+ NFA
	+ Preliminaries
	+ Temporal
	+ Timestamp_Lex
	+ Timestamp_Prod
	+ Timestamp
	+ Trace
	+ Window
	+ document_files
	+ "root.tex"
	+ "root.bib"
	+export_files (in ".") [2]
	+ "VYDRA_MDL.Monitor_Code:code/**"
	diff --git a/thys/VYDRA_MDL/Temporal.thy b/thys/VYDRA_MDL/Temporal.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Temporal.thy
	@@ -0,0 +1,2012 @@
	+theory Temporal
	+ imports MDL NFA Window
	+begin
	+
	+fun state_cnt :: "('a, 'b :: timestamp) regex \<Rightarrow> nat" where
	+ "state_cnt (Lookahead phi) = 1"
	+\| "state_cnt (Symbol phi) = 2"
	+\| "state_cnt (Plus r s) = 1 + state_cnt r + state_cnt s"
	+\| "state_cnt (Times r s) = state_cnt r + state_cnt s"
	+\| "state_cnt (Star r) = 1 + state_cnt r"
	+
	+lemma state_cnt_pos: "state_cnt r > 0"
	+ by (induction r rule: state_cnt.induct) auto
	+
	+fun collect_subfmlas :: "('a, 'b :: timestamp) regex \<Rightarrow> ('a, 'b) formula list \<Rightarrow>
	+ ('a, 'b) formula list" where
	+ "collect_subfmlas (Lookahead \<phi>) phis = (if \<phi> \<in> set phis then phis else phis @ [\<phi>])"
	+\| "collect_subfmlas (Symbol \<phi>) phis = (if \<phi> \<in> set phis then phis else phis @ [\<phi>])"
	+\| "collect_subfmlas (Plus r s) phis = collect_subfmlas s (collect_subfmlas r phis)"
	+\| "collect_subfmlas (Times r s) phis = collect_subfmlas s (collect_subfmlas r phis)"
	+\| "collect_subfmlas (Star r) phis = collect_subfmlas r phis"
	+
	+lemma bf_collect_subfmlas: "bounded_future_regex r \<Longrightarrow> phi \<in> set (collect_subfmlas r phis) \<Longrightarrow>
	+ phi \<in> set phis \<or> bounded_future_fmla phi"
	+ by (induction r phis rule: collect_subfmlas.induct) (auto split: if_splits)
	+
	+lemma collect_subfmlas_atms: "set (collect_subfmlas r phis) = set phis \<union> atms r"
	+ by (induction r phis rule: collect_subfmlas.induct) (auto split: if_splits)
	+
	+lemma collect_subfmlas_set: "set (collect_subfmlas r phis) = set (collect_subfmlas r []) \<union> set phis"
	+proof (induction r arbitrary: phis)
	+ case (Plus r1 r2)
	+ show ?case
	+ using Plus(1)[of phis] Plus(2)[of "collect_subfmlas r1 phis"]
	+ Plus(2)[of "collect_subfmlas r1 []"]
	+ by auto
	+next
	+ case (Times r1 r2)
	+ show ?case
	+ using Times(1)[of phis] Times(2)[of "collect_subfmlas r1 phis"]
	+ Times(2)[of "collect_subfmlas r1 []"]
	+ by auto
	+next
	+ case (Star r)
	+ show ?case
	+ using Star[of phis]
	+ by auto
	+qed auto
	+
	+lemma collect_subfmlas_size: "x \<in> set (collect_subfmlas r []) \<Longrightarrow> size x < size r"
	+proof (induction r)
	+ case (Plus r1 r2)
	+ then show ?case
	+ by (auto simp: collect_subfmlas_set[of r2 "collect_subfmlas r1 []"])
	+next
	+ case (Times r1 r2)
	+ then show ?case
	+ by (auto simp: collect_subfmlas_set[of r2 "collect_subfmlas r1 []"])
	+next
	+ case (Star r)
	+ then show ?case
	+ by fastforce
	+qed (auto split: if_splits)
	+
	+lemma collect_subfmlas_app: "\<exists>phis'. collect_subfmlas r phis = phis @ phis'"
	+ by (induction r phis rule: collect_subfmlas.induct) auto
	+
	+lemma length_collect_subfmlas: "length (collect_subfmlas r phis) \<ge> length phis"
	+ by (induction r phis rule: collect_subfmlas.induct) auto
	+
	+fun pos :: "'a \<Rightarrow> 'a list \<Rightarrow> nat option" where
	+ "pos a [] = None"
	+\| "pos a (x # xs) =
	+ (if a = x then Some 0 else (case pos a xs of Some n \<Rightarrow> Some (Suc n) \| _ \<Rightarrow> None))"
	+
	+lemma pos_sound: "pos a xs = Some i \<Longrightarrow> i < length xs \<and> xs ! i = a"
	+ by (induction a xs arbitrary: i rule: pos.induct) (auto split: if_splits option.splits)
	+
	+lemma pos_complete: "pos a xs = None \<Longrightarrow> a \<notin> set xs"
	+ by (induction a xs rule: pos.induct) (auto split: if_splits option.splits)
	+
	+fun build_nfa_impl :: "('a, 'b :: timestamp) regex \<Rightarrow> (state \<times> state \<times> ('a, 'b) formula list) \<Rightarrow>
	+ transition list" where
	+ "build_nfa_impl (Lookahead \<phi>) (q0, qf, phis) = (case pos \<phi> phis of
	+ Some n \<Rightarrow> [eps_trans qf n]
	+ \| None \<Rightarrow> [eps_trans qf (length phis)])"
	+\| "build_nfa_impl (Symbol \<phi>) (q0, qf, phis) = (case pos \<phi> phis of
	+ Some n \<Rightarrow> [eps_trans (Suc q0) n, symb_trans qf]
	+ \| None \<Rightarrow> [eps_trans (Suc q0) (length phis), symb_trans qf])"
	+\| "build_nfa_impl (Plus r s) (q0, qf, phis) = (
	+ let ts_r = build_nfa_impl r (q0 + 1, qf, phis);
	+ ts_s = build_nfa_impl s (q0 + 1 + state_cnt r, qf, collect_subfmlas r phis) in
	+ split_trans (q0 + 1) (q0 + 1 + state_cnt r) # ts_r @ ts_s)"
	+\| "build_nfa_impl (Times r s) (q0, qf, phis) = (
	+ let ts_r = build_nfa_impl r (q0, q0 + state_cnt r, phis);
	+ ts_s = build_nfa_impl s (q0 + state_cnt r, qf, collect_subfmlas r phis) in
	+ ts_r @ ts_s)"
	+\| "build_nfa_impl (Star r) (q0, qf, phis) = (
	+ let ts_r = build_nfa_impl r (q0 + 1, q0, phis) in
	+ split_trans (q0 + 1) qf # ts_r)"
	+
	+lemma build_nfa_impl_state_cnt: "length (build_nfa_impl r (q0, qf, phis)) = state_cnt r"
	+ by (induction r "(q0, qf, phis)" arbitrary: q0 qf phis rule: build_nfa_impl.induct)
	+ (auto split: option.splits)
	+
	+lemma build_nfa_impl_not_Nil: "build_nfa_impl r (q0, qf, phis) \<noteq> []"
	+ by (induction r "(q0, qf, phis)" arbitrary: q0 qf phis rule: build_nfa_impl.induct)
	+ (auto split: option.splits)
	+
	+lemma build_nfa_impl_state_set: "t \<in> set (build_nfa_impl r (q0, qf, phis)) \<Longrightarrow>
	+ state_set t \<subseteq> {q0..<q0 + length (build_nfa_impl r (q0, qf, phis))} \<union> {qf}"
	+ by (induction r "(q0, qf, phis)" arbitrary: q0 qf phis t rule: build_nfa_impl.induct)
	+ (fastforce simp add: build_nfa_impl_state_cnt state_cnt_pos build_nfa_impl_not_Nil
	+ split: option.splits)+
	+
	+lemma build_nfa_impl_fmla_set: "t \<in> set (build_nfa_impl r (q0, qf, phis)) \<Longrightarrow>
	+ n \<in> fmla_set t \<Longrightarrow> n < length (collect_subfmlas r phis)"
	+proof (induction r "(q0, qf, phis)" arbitrary: q0 qf phis t rule: build_nfa_impl.induct)
	+ case (1 \<phi> q0 qf phis)
	+ then show ?case
	+ using pos_sound pos_complete by (force split: option.splits)
	+next
	+ case (2 \<phi> q0 qf phis)
	+ then show ?case
	+ using pos_sound pos_complete by (force split: option.splits)
	+next
	+ case (3 r s q0 qf phis)
	+ then show ?case
	+ using length_collect_subfmlas dual_order.strict_trans1 by fastforce
	+next
	+ case (4 r s q0 qf phis)
	+ then show ?case
	+ using length_collect_subfmlas dual_order.strict_trans1 by fastforce
	+next
	+ case (5 r q0 qf phis)
	+ then show ?case
	+ using length_collect_subfmlas dual_order.strict_trans1 by fastforce
	+qed
	+
	+context MDL
	+begin
	+
	+definition "IH r q0 qf phis transs bss bs i \<equiv>
	+ let n = length (collect_subfmlas r phis) in
	+ transs = build_nfa_impl r (q0, qf, phis) \<and> (\<forall>cs \<in> set bss. length cs \<ge> n) \<and> length bs \<ge> n \<and>
	+ qf \<notin> NFA.SQ q0 (build_nfa_impl r (q0, qf, phis)) \<and>
	+ (\<forall>k < n. (bs ! k \<longleftrightarrow> sat (collect_subfmlas r phis ! k) (i + length bss))) \<and>
	+ (\<forall>j < length bss. \<forall>k < n. ((bss ! j) ! k \<longleftrightarrow> sat (collect_subfmlas r phis ! k) (i + j)))"
	+
	+lemma nfa_correct: "IH r q0 qf phis transs bss bs i \<Longrightarrow>
	+ NFA.run_accept_eps q0 qf transs {q0} bss bs \<longleftrightarrow> (i, i + length bss) \<in> match r"
	+proof (induct r arbitrary: q0 qf phis transs bss bs i rule: regex_induct)
	+case (Lookahead \<phi>)
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 transs"
	+ using Lookahead unfolding IH_def by (auto simp: Let_def)
	+ have qf_not_q0_Suc_q0: "qf \<notin> {q0}"
	+ using Lookahead unfolding IH_def
	+ by (auto simp: NFA.SQ_def split: option.splits)
	+ have transs_def: "transs = build_nfa_impl (Lookahead \<phi>) (q0, qf, phis)"
	+ using Lookahead(1)
	+ by (auto simp: Let_def IH_def)
	+ interpret base: nfa q0 qf transs
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding IH_def NFA.Q_def NFA.SQ_def transs_def
	+ by (auto split: option.splits)
	+ define n where "n \<equiv> case pos \<phi> phis of Some n \<Rightarrow> n \| _ \<Rightarrow> length phis"
	+ then have collect: "n < length (collect_subfmlas (Lookahead \<phi>) phis)"
	+ "(collect_subfmlas (Lookahead \<phi>) phis) ! n = \<phi>"
	+ using pos_sound pos_complete by (force split: option.splits)+
	+ have "\<And>cs q. base.step_eps cs q0 q \<longleftrightarrow> n < length cs \<and> cs ! n \<and> q = qf" "\<And>cs q. \<not>base.step_eps cs qf q"
	+ using base.q0_sub_SQ qf_not_in_SQ
	+ by (auto simp: NFA.step_eps_def transs_def n_def split: option.splits)
	+ then have base_eps: "base.step_eps_closure_set {q0} cs = (if n < length cs \<and> cs ! n then {q0, qf} else {q0})" for cs
	+ using NFA.step_eps_closure_set_unfold[where ?X="{qf}"]
	+ using NFA.step_eps_closure_set_step_id[where ?R="{q0}"]
	+ using NFA.step_eps_closure_set_step_id[where ?R="{qf}"]
	+ by auto
	+ have base_delta: "base.delta {q0} cs = {}" for cs
	+ unfolding NFA.delta_def NFA.step_symb_set_def base_eps
	+ by (auto simp: NFA.step_symb_def NFA.SQ_def transs_def split: option.splits)
	+ show ?case
	+ proof (cases bss)
	+ case Nil
	+ have sat: "n < length bs \<and> bs ! n \<longleftrightarrow> sat \<phi> i"
	+ using Lookahead(1) collect
	+ by (auto simp: Let_def IH_def Nil)
	+ show ?thesis
	+ using qf_not_q0_Suc_q0
	+ unfolding NFA.run_accept_eps_def NFA.run_def NFA.accept_eps_def Nil
	+ by (auto simp: base_eps sat)
	+ next
	+ case bss_def: (Cons cs css)
	+ show ?thesis
	+ using NFA.run_accept_eps_empty
	+ unfolding NFA.run_accept_eps_def NFA.run_def NFA.accept_eps_def bss_def
	+ by (auto simp: bss_def base_delta)
	+ qed
	+next
	+ case (Symbol \<phi>)
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 transs"
	+ using Symbol unfolding IH_def by (auto simp: Let_def)
	+ have qf_not_q0_Suc_q0: "qf \<notin> {q0, Suc q0}"
	+ using Symbol unfolding IH_def
	+ by (auto simp: NFA.SQ_def split: option.splits)
	+ have transs_def: "transs = build_nfa_impl (Symbol \<phi>) (q0, qf, phis)"
	+ using Symbol(1)
	+ by (auto simp: Let_def IH_def)
	+ interpret base: nfa q0 qf transs
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding IH_def NFA.Q_def NFA.SQ_def transs_def
	+ by (auto split: option.splits)
	+ define n where "n \<equiv> case pos \<phi> phis of Some n \<Rightarrow> n \| _ \<Rightarrow> length phis"
	+ then have collect: "n < length (collect_subfmlas (Symbol \<phi>) phis)"
	+ "(collect_subfmlas (Symbol \<phi>) phis) ! n = \<phi>"
	+ using pos_sound pos_complete by (force split: option.splits)+
	+ have "\<And>cs q. base.step_eps cs q0 q \<longleftrightarrow> n < length cs \<and> cs ! n \<and> q = Suc q0" "\<And>cs q. \<not>base.step_eps cs (Suc q0) q"
	+ using base.q0_sub_SQ
	+ by (auto simp: NFA.step_eps_def transs_def n_def split: option.splits)
	+ then have base_eps: "base.step_eps_closure_set {q0} cs = (if n < length cs \<and> cs ! n then {q0, Suc q0} else {q0})" for cs
	+ using NFA.step_eps_closure_set_unfold[where ?X="{Suc q0}"]
	+ using NFA.step_eps_closure_set_step_id[where ?R="{q0}"]
	+ using NFA.step_eps_closure_set_step_id[where ?R="{Suc q0}"]
	+ by auto
	+ have base_delta: "base.delta {q0} cs = (if n < length cs \<and> cs ! n then {qf} else {})" for cs
	+ unfolding NFA.delta_def NFA.step_symb_set_def base_eps
	+ by (auto simp: NFA.step_symb_def NFA.SQ_def transs_def split: option.splits)
	+ show ?case
	+ proof (cases bss)
	+ case Nil
	+ show ?thesis
	+ using qf_not_q0_Suc_q0
	+ unfolding NFA.run_accept_eps_def NFA.run_def NFA.accept_eps_def Nil
	+ by (auto simp: base_eps)
	+ next
	+ case bss_def: (Cons cs css)
	+ have sat: "n < length cs \<and> cs ! n \<longleftrightarrow> sat \<phi> i"
	+ using Symbol(1) collect
	+ by (auto simp: Let_def IH_def bss_def)
	+ show ?thesis
	+ proof (cases css)
	+ case Nil
	+ show ?thesis
	+ unfolding NFA.run_accept_eps_def NFA.run_def NFA.accept_eps_def bss_def Nil
	+ by (auto simp: base_delta sat NFA.step_eps_closure_set_def NFA.step_eps_closure_def)
	+ next
	+ case css_def: (Cons ds dss)
	+ have "base.delta {} ds = {}" "base.delta {qf} ds = {}"
	+ using base.step_eps_closure_qf qf_not_in_SQ step_symb_dest
	+ by (fastforce simp: NFA.delta_def NFA.step_eps_closure_set_def NFA.step_symb_set_def)+
	+ then show ?thesis
	+ using NFA.run_accept_eps_empty
	+ unfolding NFA.run_accept_eps_def NFA.run_def NFA.accept_eps_def bss_def css_def
	+ by (auto simp: base_delta)
	+ qed
	+ qed
	+next
	+ case (Plus r s)
	+ obtain phis' where collect: "collect_subfmlas (Plus r s) phis =
	+ collect_subfmlas r phis @ phis'"
	+ using collect_subfmlas_app by auto
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 (build_nfa_impl (Plus r s) (q0, qf, phis))"
	+ using Plus unfolding IH_def by auto
	+ interpret base: nfa q0 qf "build_nfa_impl (Plus r s) (q0, qf, phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt by fast+
	+ interpret left: nfa "q0 + 1" qf "build_nfa_impl r (q0 + 1, qf, phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt
	+ by fastforce+
	+ interpret right: nfa "q0 + 1 + state_cnt r" qf
	+ "build_nfa_impl s (q0 + 1 + state_cnt r, qf, collect_subfmlas r phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt
	+ by fastforce+
	+ from Plus(3) have "IH r (q0 + 1) qf phis (build_nfa_impl r (q0 + 1, qf, phis)) bss bs i"
	+ unfolding Let_def IH_def collect
	+ using left.qf_not_in_SQ
	+ by (auto simp: nth_append)
	+ then have left_IH: "left.run_accept_eps {q0 + 1} bss bs \<longleftrightarrow>
	+ (i, i + length bss) \<in> match r"
	+ using Plus(1) build_nfa_impl_state_cnt
	+ by auto
	+ have "IH s (q0 + 1 + state_cnt r) qf (collect_subfmlas r phis)
	+ (build_nfa_impl s (q0 + 1 + state_cnt r, qf, collect_subfmlas r phis)) bss bs i"
	+ using right.qf_not_in_SQ IH_def Plus
	+ by (auto simp: Let_def)
	+ then have right_IH: "right.run_accept_eps {q0 + 1 + state_cnt r} bss bs \<longleftrightarrow>
	+ (i, i + length bss) \<in> match s"
	+ using Plus(2) build_nfa_impl_state_cnt
	+ by auto
	+ interpret cong: nfa_cong_Plus q0 "q0 + 1" "q0 + 1 + state_cnt r" qf qf qf
	+ "build_nfa_impl (Plus r s) (q0, qf, phis)" "build_nfa_impl r (q0 + 1, qf, phis)"
	+ "build_nfa_impl s (q0 + 1 + state_cnt r, qf, collect_subfmlas r phis)"
	+ apply unfold_locales
	+ unfolding NFA.SQ_def build_nfa_impl_state_cnt
	+ NFA.step_eps_def NFA.step_symb_def
	+ by (auto simp add: nth_append build_nfa_impl_state_cnt)
	+ show ?case
	+ using cong.run_accept_eps_cong left_IH right_IH Plus
	+ by (auto simp: Let_def IH_def)
	+next
	+ case (Times r s)
	+ obtain phis' where collect: "collect_subfmlas (Times r s) phis =
	+ collect_subfmlas r phis @ phis'"
	+ using collect_subfmlas_app by auto
	+ have transs_def: "transs = build_nfa_impl (Times r s) (q0, qf, phis)"
	+ using Times unfolding IH_def by (auto simp: Let_def)
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 (build_nfa_impl (Times r s) (q0, qf, phis))"
	+ using Times unfolding IH_def by auto
	+ interpret base: nfa q0 qf "build_nfa_impl (Times r s) (q0, qf, phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt by fast+
	+ interpret left: nfa "q0" "q0 + state_cnt r" "build_nfa_impl r (q0, q0 + state_cnt r, phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt
	+ by fastforce+
	+ interpret right: nfa "q0 + state_cnt r" qf
	+ "build_nfa_impl s (q0 + state_cnt r, qf, collect_subfmlas r phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt
	+ by fastforce+
	+ from Times(3) have left_IH: "IH r q0 (q0 + state_cnt r) phis
	+ (build_nfa_impl r (q0 , q0 + state_cnt r, phis)) bss bs i"
	+ unfolding Let_def IH_def collect
	+ using left.qf_not_in_SQ
	+ by (auto simp: nth_append)
	+ from Times(3) have left_IH_take: "\<And>n. n < length bss \<Longrightarrow>
	+ IH r q0 (q0 + state_cnt r) phis
	+ (build_nfa_impl r (q0, q0 + state_cnt r, phis)) (take n bss) (hd (drop n bss)) i"
	+ unfolding Let_def IH_def collect
	+ using left.qf_not_in_SQ
	+ apply (auto simp: nth_append min_absorb2 hd_drop_conv_nth)
	+ apply (meson in_set_takeD le_add1 le_trans)
	+ by (meson le_add1 le_trans nth_mem)
	+ have left_IH_match: "left.run_accept_eps {q0} bss bs \<longleftrightarrow>
	+ (i, i + length bss) \<in> match r"
	+ using Times(1) build_nfa_impl_state_cnt left_IH
	+ by auto
	+ have left_IH_match_take: "\<And>n. n < length bss \<Longrightarrow>
	+ left.run_accept_eps {q0} (take n bss) (hd (drop n bss)) \<longleftrightarrow> (i, i + n) \<in> match r"
	+ using Times(1) build_nfa_impl_state_cnt left_IH_take
	+ by (fastforce simp add: nth_append min_absorb2)
	+ have "IH s (q0 + state_cnt r) qf (collect_subfmlas r phis)
	+ (build_nfa_impl s (q0 + state_cnt r, qf, collect_subfmlas r phis)) bss bs i"
	+ using right.qf_not_in_SQ IH_def Times
	+ by (auto simp: Let_def)
	+ then have right_IH: "\<And>n. n \<le> length bss \<Longrightarrow> IH s (q0 + state_cnt r) qf (collect_subfmlas r phis)
	+ (build_nfa_impl s (q0 + state_cnt r, qf, collect_subfmlas r phis)) (drop n bss) bs (i + n)"
	+ unfolding Let_def IH_def
	+ by (auto simp: nth_append add.assoc) (meson in_set_dropD)
	+ have right_IH_match: "\<And>n. n \<le> length bss \<Longrightarrow>
	+ right.run_accept_eps {q0 + state_cnt r} (drop n bss) bs \<longleftrightarrow> (i + n, i + length bss) \<in> match s"
	+ using Times(2)[OF right_IH] build_nfa_impl_state_cnt
	+ by (auto simp: IH_def)
	+ interpret cong: nfa_cong_Times q0 "q0 + state_cnt r" qf
	+ "build_nfa_impl (Times r s) (q0, qf, phis)"
	+ "build_nfa_impl r (q0, q0 + state_cnt r, phis)"
	+ "build_nfa_impl s (q0 + state_cnt r, qf, collect_subfmlas r phis)"
	+ apply unfold_locales
	+ using NFA.Q_def NFA.SQ_def NFA.step_eps_def NFA.step_symb_def build_nfa_impl_state_set
	+ by (fastforce simp add: nth_append build_nfa_impl_state_cnt build_nfa_impl_not_Nil
	+ state_cnt_pos)+
	+ have right_IH_Nil: "right.run_accept_eps {q0 + state_cnt r} [] bs \<longleftrightarrow>
	+ (i + length bss, i + length bss) \<in> match s"
	+ using right_IH_match
	+ by fastforce
	+ show ?case
	+ unfolding match_Times transs_def cong.run_accept_eps_cong left_IH_match right_IH_Nil
	+ using left_IH_match_take right_IH_match less_imp_le_nat le_eq_less_or_eq
	+ by auto
	+next
	+ case (Star r)
	+ then show ?case
	+ proof (induction "length bss" arbitrary: bss bs i rule: nat_less_induct)
	+ case 1
	+ have transs_def: "transs = build_nfa_impl (Star r) (q0, qf, phis)"
	+ using 1 unfolding IH_def by (auto simp: Let_def)
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 (build_nfa_impl (Star r) (q0, qf, phis))"
	+ using 1 unfolding IH_def by auto
	+ interpret base: nfa q0 qf "build_nfa_impl (Star r) (q0, qf, phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt
	+ by fast+
	+ interpret left: nfa "q0 + 1" q0 "build_nfa_impl r (q0 + 1, q0, phis)"
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt
	+ by fastforce+
	+ from 1(3) have left_IH: "IH r (q0 + 1) q0 phis (build_nfa_impl r (q0 + 1, q0, phis)) bss bs i"
	+ using left.qf_not_in_SQ
	+ unfolding Let_def IH_def
	+ by (auto simp add: nth_append)
	+ from 1(3) have left_IH_take: "\<And>n. n < length bss \<Longrightarrow>
	+ IH r (q0 + 1) q0 phis (build_nfa_impl r (q0 + 1, q0, phis)) (take n bss) (hd (drop n bss)) i"
	+ using left.qf_not_in_SQ
	+ unfolding Let_def IH_def
	+ by (auto simp add: nth_append min_absorb2 hd_drop_conv_nth) (meson in_set_takeD)
	+ have left_IH_match: "left.run_accept_eps {q0 + 1} bss bs \<longleftrightarrow>
	+ (i, i + length bss) \<in> match r"
	+ using 1(2) left_IH
	+ unfolding build_nfa_impl_state_cnt NFA.SQ_def
	+ by auto
	+ have left_IH_match_take: "\<And>n. n < length bss \<Longrightarrow>
	+ left.run_accept_eps {q0 + 1} (take n bss) (hd (drop n bss)) \<longleftrightarrow>
	+ (i, i + n) \<in> match r"
	+ using 1(2) left_IH_take
	+ unfolding build_nfa_impl_state_cnt NFA.SQ_def
	+ by (fastforce simp add: nth_append min_absorb2)
	+ interpret cong: nfa_cong_Star q0 "q0 + 1" qf
	+ "build_nfa_impl (Star r) (q0, qf, phis)"
	+ "build_nfa_impl r (q0 + 1, q0, phis)"
	+ apply unfold_locales
	+ unfolding NFA.SQ_def build_nfa_impl_state_cnt NFA.step_eps_def NFA.step_symb_def
	+ by (auto simp add: nth_append build_nfa_impl_state_cnt)
	+ show ?case
	+ using cong.run_accept_eps_Nil
	+ proof (cases bss)
	+ case Nil
	+ show ?thesis
	+ unfolding transs_def Nil
	+ using cong.run_accept_eps_Nil run_Nil run_accept_eps_Nil
	+ by auto
	+ next
	+ case (Cons cs css)
	+ have aux: "\<And>n j x P. n < x \<Longrightarrow> j < x - n \<Longrightarrow> (\<forall>j < Suc x. P j) \<Longrightarrow> P (Suc (n + j))"
	+ by auto
	+ from 1(3) have star_IH: "\<And>n. n < length css \<Longrightarrow>
	+ IH (Star r) q0 qf phis transs (drop n css) bs (i + n + 1)"
	+ unfolding Cons Let_def IH_def
	+ using aux[of _ _ _ "\<lambda>j. \<forall>k<length (collect_subfmlas r phis).
	+ (cs # css) ! j ! k = sat (collect_subfmlas r phis ! k) (i + j)"]
	+ by (auto simp add: nth_append add.assoc dest: in_set_dropD)
	+ have IH_inst: "\<And>xs i. length xs \<le> length css \<Longrightarrow> IH (Star r) q0 qf phis transs xs bs i \<longrightarrow>
	+ (base.run_accept_eps {q0} xs bs \<longleftrightarrow> (i, i + length xs) \<in> match (Star r))"
	+ using 1
	+ unfolding Cons
	+ by (auto simp add: nth_append less_Suc_eq_le transs_def)
	+ have "\<And>n. n < length css \<Longrightarrow> base.run_accept_eps {q0} (drop n css) bs \<longleftrightarrow>
	+ (i + n + 1, i + length (cs # css)) \<in> match (Star r)"
	+ proof -
	+ fix n
	+ assume assm: "n < length css"
	+ then show "base.run_accept_eps {q0} (drop n css) bs \<longleftrightarrow>
	+ (i + n + 1, i + length (cs # css)) \<in> match (Star r)"
	+ using IH_inst[of "drop n css" "i + n + 1"] star_IH
	+ by (auto simp add: nth_append)
	+ qed
	+ then show ?thesis
	+ using match_Star length_Cons Cons cong.run_accept_eps_cong_Cons
	+ using cong.run_accept_eps_Nil left_IH_match left_IH_match_take
	+ apply (auto simp add: Cons transs_def)
	+ apply (metis Suc_less_eq add_Suc_right drop_Suc_Cons less_imp_le_nat take_Suc_Cons)
	+ apply (metis Suc_less_eq add_Suc_right drop_Suc_Cons le_eq_less_or_eq lessThan_iff
	+ take_Suc_Cons)
	+ done
	+ qed
	+ qed
	+qed
	+
	+lemma step_eps_closure_set_empty_list:
	+ assumes "wf_regex r" "IH r q0 qf phis transs bss bs i" "NFA.step_eps_closure q0 transs bs q qf"
	+ shows "NFA.step_eps_closure q0 transs [] q qf"
	+ using assms
	+proof (induction r arbitrary: q0 qf phis transs q)
	+ case (Symbol \<phi>)
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 transs"
	+ using Symbol unfolding IH_def by (auto simp: Let_def)
	+ have qf_not_q0_Suc_q0: "qf \<notin> {q0, Suc q0}"
	+ using Symbol unfolding IH_def
	+ by (auto simp: NFA.SQ_def split: option.splits)
	+ have transs_def: "transs = build_nfa_impl (Symbol \<phi>) (q0, qf, phis)"
	+ using Symbol(2)
	+ by (auto simp: Let_def IH_def)
	+ interpret base: nfa q0 qf transs
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding IH_def NFA.Q_def NFA.SQ_def transs_def
	+ by (auto split: option.splits)
	+ define n where "n \<equiv> case pos \<phi> phis of Some n \<Rightarrow> n \| _ \<Rightarrow> length phis"
	+ then have collect: "n < length (collect_subfmlas (Symbol \<phi>) phis)"
	+ "(collect_subfmlas (Symbol \<phi>) phis) ! n = \<phi>"
	+ using pos_sound pos_complete by (force split: option.splits)+
	+ have SQD: "q \<in> NFA.SQ q0 transs \<Longrightarrow> q = q0 \<or> q = Suc q0" for q
	+ by (auto simp: NFA.SQ_def transs_def split: option.splits)
	+ have "\<not>base.step_eps cs q qf" if "q \<in> NFA.SQ q0 transs" for cs q
	+ using SQD[OF that] qf_not_q0_Suc_q0
	+ by (auto simp: NFA.step_eps_def transs_def split: option.splits transition.splits)
	+ then show ?case
	+ using Symbol(3)
	+ by (auto simp: NFA.step_eps_closure_def) (metis rtranclp.simps step_eps_dest)
	+next
	+ case (Plus r s)
	+ have transs_def: "transs = build_nfa_impl (Plus r s) (q0, qf, phis)"
	+ using Plus(4)
	+ by (auto simp: IH_def Let_def)
	+ define ts_l where "ts_l = build_nfa_impl r (q0 + 1, qf, phis)"
	+ define ts_r where "ts_r = build_nfa_impl s (q0 + 1 + state_cnt r, qf, collect_subfmlas r phis)"
	+ have len_ts: "length ts_l = state_cnt r" "length ts_r = state_cnt s" "length transs = Suc (state_cnt r + state_cnt s)"
	+ by (auto simp: ts_l_def ts_r_def transs_def build_nfa_impl_state_cnt)
	+ have transs_eq: "transs = split_trans (q0 + 1) (q0 + 1 + state_cnt r) # ts_l @ ts_r"
	+ by (auto simp: transs_def ts_l_def ts_r_def)
	+ have ts_nonempty: "ts_l = [] \<Longrightarrow> False" "ts_r = [] \<Longrightarrow> False"
	+ by (auto simp: ts_l_def ts_r_def build_nfa_impl_not_Nil)
	+ obtain phis' where collect: "collect_subfmlas (Plus r s) phis = collect_subfmlas r phis @ phis'"
	+ using collect_subfmlas_app by auto
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 (build_nfa_impl (Plus r s) (q0, qf, phis))"
	+ using Plus unfolding IH_def by auto
	+ interpret base: nfa q0 qf transs
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt transs_def by fast+
	+ interpret left: nfa "Suc q0" qf ts_l
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt ts_l_def
	+ by fastforce+
	+ interpret right: nfa "Suc (q0 + state_cnt r)" qf ts_r
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt ts_r_def
	+ by fastforce+
	+ interpret cong: nfa_cong_Plus q0 "Suc q0" "Suc (q0 + state_cnt r)" qf qf qf transs ts_l ts_r
	+ apply unfold_locales
	+ unfolding NFA.SQ_def build_nfa_impl_state_cnt
	+ NFA.step_eps_def NFA.step_symb_def transs_def ts_l_def ts_r_def
	+ by (auto simp add: nth_append build_nfa_impl_state_cnt)
	+ have "IH s (Suc (q0 + state_cnt r)) qf (collect_subfmlas r phis) ts_r bss bs i"
	+ using right.qf_not_in_SQ IH_def Plus
	+ by (auto simp: Let_def ts_r_def)
	+ then have case_right: "base.step_eps_closure [] q qf" if "base.step_eps_closure bs q qf" "q \<in> right.Q" for q
	+ using cong.right.eps_nfa'_step_eps_closure[OF that] Plus(2,3) cong.right.nfa'_eps_step_eps_closure[OF _ that(2)]
	+ by auto
	+ from Plus(4) have "IH r (Suc q0) qf phis ts_l bss bs i"
	+ using left.qf_not_in_SQ
	+ unfolding Let_def IH_def collect ts_l_def
	+ by (auto simp: nth_append)
	+ then have case_left: "base.step_eps_closure [] q qf" if "base.step_eps_closure bs q qf" "q \<in> left.Q" for q
	+ using cong.eps_nfa'_step_eps_closure[OF that] Plus(1,3) cong.nfa'_eps_step_eps_closure[OF _ that(2)]
	+ by auto
	+ have "q = q0 \<or> q \<in> left.Q \<or> q \<in> right.Q"
	+ using Plus(5)
	+ by (auto simp: NFA.Q_def NFA.SQ_def len_ts dest!: NFA.step_eps_closure_dest)
	+ moreover have ?case if q_q0: "q = q0"
	+ proof -
	+ have "q0 \<noteq> qf"
	+ using qf_not_in_SQ
	+ by (auto simp: NFA.SQ_def)
	+ then obtain q' where q'_def: "base.step_eps bs q q'" "base.step_eps_closure bs q' qf"
	+ using Plus(5)
	+ by (auto simp: q_q0 NFA.step_eps_closure_def elim: converse_rtranclpE)
	+ have fst_step_eps: "base.step_eps [] q q'"
	+ using q'_def(1)
	+ by (auto simp: q_q0 NFA.step_eps_def transs_eq)
	+ have "q' \<in> left.Q \<or> q' \<in> right.Q"
	+ using q'_def(1)
	+ by (auto simp: NFA.step_eps_def NFA.Q_def NFA.SQ_def q_q0 transs_eq dest: ts_nonempty split: transition.splits)
	+ then show ?case
	+ using fst_step_eps case_left[OF q'_def(2)] case_right[OF q'_def(2)]
	+ by (auto simp: NFA.step_eps_closure_def)
	+ qed
	+ ultimately show ?case
	+ using Plus(5) case_left case_right
	+ by auto
	+next
	+ case (Times r s)
	+ obtain phis' where collect: "collect_subfmlas (Times r s) phis =
	+ collect_subfmlas r phis @ phis'"
	+ using collect_subfmlas_app by auto
	+ have transs_def: "transs = build_nfa_impl (Times r s) (q0, qf, phis)"
	+ using Times unfolding IH_def by (auto simp: Let_def)
	+ define ts_l where "ts_l = build_nfa_impl r (q0, q0 + state_cnt r, phis)"
	+ define ts_r where "ts_r = build_nfa_impl s (q0 + state_cnt r, qf, collect_subfmlas r phis)"
	+ have len_ts: "length ts_l = state_cnt r" "length ts_r = state_cnt s" "length transs = state_cnt r + state_cnt s"
	+ by (auto simp: ts_l_def ts_r_def transs_def build_nfa_impl_state_cnt)
	+ have transs_eq: "transs = ts_l @ ts_r"
	+ by (auto simp: transs_def ts_l_def ts_r_def)
	+ have ts_nonempty: "ts_l = [] \<Longrightarrow> False" "ts_r = [] \<Longrightarrow> False"
	+ by (auto simp: ts_l_def ts_r_def build_nfa_impl_not_Nil)
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 (build_nfa_impl (Times r s) (q0, qf, phis))"
	+ using Times unfolding IH_def by auto
	+ interpret base: nfa q0 qf transs
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt transs_def by fast+
	+ interpret left: nfa "q0" "q0 + state_cnt r" ts_l
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt ts_l_def
	+ by fastforce+
	+ interpret right: nfa "q0 + state_cnt r" qf ts_r
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt ts_r_def
	+ by fastforce+
	+ interpret cong: nfa_cong_Times q0 "q0 + state_cnt r" qf transs ts_l ts_r
	+ apply unfold_locales
	+ using NFA.Q_def NFA.SQ_def NFA.step_eps_def NFA.step_symb_def build_nfa_impl_state_set
	+ by (auto simp add: nth_append build_nfa_impl_state_cnt build_nfa_impl_not_Nil
	+ state_cnt_pos len_ts transs_eq)
	+ have "qf \<notin> base.SQ"
	+ using Times(4)
	+ by (auto simp: IH_def Let_def)
	+ then have qf_left_Q: "qf \<in> left.Q \<Longrightarrow> False"
	+ by (auto simp: NFA.Q_def NFA.SQ_def len_ts state_cnt_pos)
	+ have left_IH: "IH r q0 (q0 + state_cnt r) phis ts_l bss bs i"
	+ using left.qf_not_in_SQ Times
	+ unfolding Let_def IH_def collect
	+ by (auto simp: nth_append ts_l_def)
	+ have case_left: "base.step_eps_closure [] q (q0 + state_cnt r)" if "left.step_eps_closure bs q (q0 + state_cnt r)" "q \<in> left.Q" and wf: "wf_regex r" for q
	+ using that(1) Times(1)[OF wf left_IH] cong.nfa'_step_eps_closure_cong[OF _ that(2)]
	+ by auto
	+ have left_IH: "IH s (q0 + state_cnt r) qf (collect_subfmlas r phis) ts_r bss bs i"
	+ using right.qf_not_in_SQ IH_def Times
	+ by (auto simp: Let_def ts_r_def)
	+ then have case_right: "base.step_eps_closure [] q qf" if "base.step_eps_closure bs q qf" "q \<in> right.Q" for q
	+ using cong.right.eps_nfa'_step_eps_closure[OF that] Times(2,3) cong.right.nfa'_eps_step_eps_closure[OF _ that(2)]
	+ by auto
	+ have init_right: "q0 + state_cnt r \<in> right.Q"
	+ by (auto simp: NFA.Q_def NFA.SQ_def dest: ts_nonempty)
	+ {
	+ assume q_left_Q: "q \<in> left.Q"
	+ then have split: "left.step_eps_closure bs q (q0 + state_cnt r)" "base.step_eps_closure bs (q0 + state_cnt r) qf"
	+ using cong.eps_nfa'_step_eps_closure_cong[OF Times(5)]
	+ by (auto dest: qf_left_Q)
	+ have empty_IH: "IH s (q0 + state_cnt r) qf (collect_subfmlas r phis) ts_r [] bs (i + length bss)"
	+ using left_IH
	+ by (auto simp: IH_def Let_def ts_r_def)
	+ have "right.step_eps_closure bs (q0 + state_cnt r) qf"
	+ using cong.right.eps_nfa'_step_eps_closure[OF split(2) init_right]
	+ by auto
	+ then have "right.run_accept_eps {q0 + state_cnt r} [] bs"
	+ by (auto simp: NFA.run_accept_eps_def NFA.accept_eps_def NFA.step_eps_closure_set_def NFA.run_def)
	+ then have wf: "wf_regex r"
	+ using nfa_correct[OF empty_IH] Times(3) match_refl_eps
	+ by auto
	+ have ?case
	+ using case_left[OF split(1) q_left_Q wf] case_right[OF split(2) init_right]
	+ by (auto simp: NFA.step_eps_closure_def)
	+ }
	+ moreover have "q \<in> left.Q \<or> q \<in> right.Q"
	+ using Times(5)
	+ by (auto simp: NFA.Q_def NFA.SQ_def transs_eq len_ts dest!: NFA.step_eps_closure_dest)
	+ ultimately show ?case
	+ using case_right[OF Times(5)]
	+ by auto
	+next
	+ case (Star r)
	+ have transs_def: "transs = build_nfa_impl (Star r) (q0, qf, phis)"
	+ using Star unfolding IH_def by (auto simp: Let_def)
	+ obtain ts_r where ts_r: "transs = split_trans (q0 + 1) qf # ts_r" "ts_r = build_nfa_impl r (Suc q0, q0, phis)"
	+ using Star(3)
	+ by (auto simp: Let_def IH_def)
	+ have qf_not_in_SQ: "qf \<notin> NFA.SQ q0 transs"
	+ using Star unfolding IH_def transs_def by auto
	+ interpret base: nfa q0 qf transs
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt transs_def
	+ by fast+
	+ interpret left: nfa "Suc q0" q0 ts_r
	+ apply unfold_locales
	+ using build_nfa_impl_state_set build_nfa_impl_not_Nil qf_not_in_SQ
	+ unfolding NFA.Q_def NFA.SQ_def build_nfa_impl_state_cnt ts_r(2)
	+ by fastforce+
	+ interpret cong: nfa_cong_Star q0 "Suc q0" qf transs ts_r
	+ apply unfold_locales
	+ unfolding NFA.SQ_def build_nfa_impl_state_cnt NFA.step_eps_def NFA.step_symb_def
	+ by (auto simp add: nth_append build_nfa_impl_state_cnt ts_r(1))
	+ have IH: "wf_regex r" "IH r (Suc q0) q0 phis ts_r bss bs i"
	+ using Star(2,3)
	+ by (auto simp: Let_def IH_def NFA.SQ_def ts_r(2))
	+ have step_eps_q'_qf: "q' = q0" if "base.step_eps bs q' qf" for q'
	+ proof (rule ccontr)
	+ assume "q' \<noteq> q0"
	+ then have "q' \<in> left.SQ"
	+ using that
	+ by (auto simp: NFA.step_eps_def NFA.SQ_def ts_r(1))
	+ then have "left.step_eps bs q' qf"
	+ using cong.step_eps_cong_SQ that
	+ by simp
	+ then show "False"
	+ using qf_not_in_SQ
	+ by (metis NFA.Q_def UnE base.q0_sub_SQ cong.SQ_sub left.step_eps_closed subset_eq)
	+ qed
	+ show ?case
	+ proof (cases "q = qf")
	+ case False
	+ then have base_q_q0: "base.step_eps_closure bs q q0" "base.step_eps bs q0 qf"
	+ using Star(4) step_eps_q'_qf
	+ by (auto simp: NFA.step_eps_closure_def) (metis rtranclp.cases)+
	+ have base_Nil_q0_qf: "base.step_eps [] q0 qf"
	+ by (auto simp: NFA.step_eps_def NFA.SQ_def ts_r(1))
	+ have q_left_Q: "q \<in> left.Q"
	+ using base_q_q0
	+ by (auto simp: NFA.Q_def NFA.SQ_def ts_r(1) dest: step_eps_closure_dest)
	+ have "left.step_eps_closure [] q q0"
	+ using cong.eps_nfa'_step_eps_closure_cong[OF base_q_q0(1) q_left_Q] Star(1)[OF IH]
	+ by auto
	+ then show ?thesis
	+ using cong.nfa'_step_eps_closure_cong[OF _ q_left_Q] base_Nil_q0_qf
	+ by (auto simp: NFA.step_eps_closure_def) (meson rtranclp.rtrancl_into_rtrancl)
	+ qed (auto simp: NFA.step_eps_closure_def)
	+qed auto
	+
	+lemma accept_eps_iff_accept:
	+ assumes "wf_regex r" "IH r q0 qf phis transs bss bs i"
	+ shows "NFA.accept_eps q0 qf transs R bs = NFA.accept q0 qf transs R"
	+ using step_eps_closure_set_empty_list[OF assms] step_eps_closure_set_mono'
	+ unfolding NFA.accept_eps_def NFA.accept_def
	+ by (fastforce simp: NFA.accept_eps_def NFA.accept_def NFA.step_eps_closure_set_def)
	+
	+lemma run_accept_eps_iff_run_accept:
	+ assumes "wf_regex r" "IH r q0 qf phis transs bss bs i"
	+ shows "NFA.run_accept_eps q0 qf transs {q0} bss bs \<longleftrightarrow> NFA.run_accept q0 qf transs {q0} bss"
	+ unfolding NFA.run_accept_eps_def NFA.run_accept_def accept_eps_iff_accept[OF assms] ..
	+
	+end
	+
	+definition pred_option' :: "('a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> bool" where
	+ "pred_option' P z = (case z of Some z' \<Rightarrow> P z' \| None \<Rightarrow> False)"
	+
	+definition map_option' :: "('b \<Rightarrow> 'c option) \<Rightarrow> 'b option \<Rightarrow> 'c option" where
	+ "map_option' f z = (case z of Some z' \<Rightarrow> f z' \| None \<Rightarrow> None)"
	+
	+definition while_break :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> 'a \<Rightarrow> 'a option" where
	+ "while_break P f x = while (pred_option' P) (map_option' f) (Some x)"
	+
	+lemma wf_while_break:
	+ assumes "wf {(t, s). P s \<and> b s \<and> Some t = c s}"
	+ shows "wf {(t, s). pred_option P s \<and> pred_option' b s \<and> t = map_option' c s}"
	+proof -
	+ have sub: "{(t, s). pred_option P s \<and> pred_option' b s \<and> t = map_option' c s} \<subseteq>
	+ map_prod Some Some ` {(t, s). P s \<and> b s \<and> Some t = c s} \<union> ({None} \<times> (Some ` UNIV))"
	+ by (auto simp: pred_option'_def map_option'_def split: option.splits)
	+ (smt (z3) case_prodI map_prod_imageI mem_Collect_eq not_Some_eq)
	+ show ?thesis
	+ apply (rule wf_subset[OF _ sub])
	+ apply (rule wf_union_compatible)
	+ apply (rule wf_map_prod_image)
	+ apply (fastforce simp: wf_def intro: assms)+
	+ done
	+qed
	+
	+lemma wf_while_break':
	+ assumes "wf {(t, s). P s \<and> b s \<and> Some t = c s}"
	+ shows "wf {(t, s). pred_option' P s \<and> pred_option' b s \<and> t = map_option' c s}"
	+ by (rule wf_subset[OF wf_while_break[OF assms]]) (auto simp: pred_option'_def split: option.splits)
	+
	+lemma while_break_sound:
	+ assumes "\<And>s s'. P s \<Longrightarrow> b s \<Longrightarrow> c s = Some s' \<Longrightarrow> P s'" "\<And>s. P s \<Longrightarrow> \<not> b s \<Longrightarrow> Q s" "wf {(t, s). P s \<and> b s \<and> Some t = c s}" "P s"
	+ shows "pred_option Q (while_break b c s)"
	+proof -
	+ have aux: "P t \<Longrightarrow> b t \<Longrightarrow> pred_option P (c t)" for t
	+ using assms(1)
	+ by (cases "c t") auto
	+ show ?thesis
	+ using assms aux
	+ by (auto simp: while_break_def pred_option'_def map_option'_def split: option.splits
	+ intro!: while_rule_lemma[where ?P="pred_option P" and ?Q="pred_option Q" and ?b="pred_option' b" and ?c="map_option' c", OF _ _ wf_while_break])
	+qed
	+
	+lemma while_break_complete: "(\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> pred_option' P (c s)) \<Longrightarrow> (\<And>s. P s \<Longrightarrow> \<not> b s \<Longrightarrow> Q s) \<Longrightarrow> wf {(t, s). P s \<and> b s \<and> Some t = c s} \<Longrightarrow> P s \<Longrightarrow>
	+ pred_option' Q (while_break b c s)"
	+ unfolding while_break_def
	+ by (rule while_rule_lemma[where ?P="pred_option' P" and ?Q="pred_option' Q" and ?b="pred_option' b" and ?c="map_option' c", OF _ _ wf_while_break'])
	+ (force simp: pred_option'_def map_option'_def split: option.splits elim!: case_optionE)+
	+
	+context
	+ fixes args :: "(bool iarray, nat set, 'd :: timestamp, 't, 'e) args"
	+begin
	+
	+abbreviation "reach_w \<equiv> reach_window args"
	+
	+qualified definition "in_win = init_window args"
	+
	+definition valid_window_matchP :: "'d \<I> \<Rightarrow> 't \<Rightarrow> 'e \<Rightarrow>
	+ ('d \<times> bool iarray) list \<Rightarrow> nat \<Rightarrow> (bool iarray, nat set, 'd, 't, 'e) window \<Rightarrow> bool" where
	+ "valid_window_matchP I t0 sub rho j w \<longleftrightarrow> j = w_j w \<and>
	+ valid_window args t0 sub rho w \<and>
	+ reach_w t0 sub rho (w_i w, w_ti w, w_si w, w_j w, w_tj w, w_sj w) \<and>
	+ (case w_read_t args (w_tj w) of None \<Rightarrow> True
	+ \| Some t \<Rightarrow> (\<forall>l < w_i w. memL (ts_at rho l) t I))"
	+
	+lemma valid_window_matchP_reach_tj: "valid_window_matchP I t0 sub rho i w \<Longrightarrow>
	+ reaches_on (w_run_t args) t0 (map fst rho) (w_tj w)"
	+ using reach_window_run_tj
	+ by (fastforce simp: valid_window_matchP_def simp del: reach_window.simps)
	+
	+lemma valid_window_matchP_reach_sj: "valid_window_matchP I t0 sub rho i w \<Longrightarrow>
	+ reaches_on (w_run_sub args) sub (map snd rho) (w_sj w)"
	+ using reach_window_run_sj
	+ by (fastforce simp: valid_window_matchP_def simp del: reach_window.simps)
	+
	+lemma valid_window_matchP_len_rho: "valid_window_matchP I t0 sub rho i w \<Longrightarrow> length rho = i"
	+ by (auto simp: valid_window_matchP_def)
	+
	+definition "matchP_loop_cond I t = (\<lambda>w. w_i w < w_j w \<and> memL (the (w_read_t args (w_ti w))) t I)"
	+
	+definition "matchP_loop_inv I t0 sub rho j0 tj0 sj0 t =
	+ (\<lambda>w. valid_window args t0 sub rho w \<and>
	+ w_j w = j0 \<and> w_tj w = tj0 \<and> w_sj w = sj0 \<and> (\<forall>l < w_i w. memL (ts_at rho l) t I))"
	+
	+fun ex_key :: "('c, 'd) mmap \<Rightarrow> ('d \<Rightarrow> bool) \<Rightarrow>
	+ ('c \<Rightarrow> bool) \<Rightarrow> ('c, bool) mapping \<Rightarrow> (bool \<times> ('c, bool) mapping)" where
	+ "ex_key [] time accept ac = (False, ac)"
	+\| "ex_key ((q, t) # qts) time accept ac = (if time t then
	+ (case cac accept ac q of (\<beta>, ac') \<Rightarrow>
	+ if \<beta> then (True, ac') else ex_key qts time accept ac')
	+ else ex_key qts time accept ac)"
	+
	+lemma ex_key_sound:
	+ assumes inv: "\<And>q. case Mapping.lookup ac q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v"
	+ and distinct: "distinct (map fst qts)"
	+ and eval: "ex_key qts time accept ac = (b, ac')"
	+ shows "b = (\<exists>q \<in> mmap_keys qts. time (the (mmap_lookup qts q)) \<and> accept q) \<and>
	+ (\<forall>q. case Mapping.lookup ac' q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v)"
	+ using assms
	+proof (induction qts arbitrary: ac)
	+ case (Cons a qts)
	+ obtain q t where qt_def: "a = (q, t)"
	+ by fastforce
	+ show ?case
	+ proof (cases "time t")
	+ case True
	+ note time_t = True
	+ obtain \<beta> ac'' where ac''_def: "cac accept ac q = (\<beta>, ac'')"
	+ by fastforce
	+ have accept: "\<beta> = accept q" "\<And>q. case Mapping.lookup ac'' q of None \<Rightarrow> True
	+ \| Some v \<Rightarrow> accept q = v"
	+ using ac''_def Cons(2)
	+ by (fastforce simp: cac_def Let_def Mapping.lookup_update' split: option.splits if_splits)+
	+ show ?thesis
	+ proof (cases \<beta>)
	+ case True
	+ then show ?thesis
	+ using accept(2) time_t Cons(4)
	+ by (auto simp: qt_def mmap_keys_def accept(1) mmap_lookup_def ac''_def)
	+ next
	+ case False
	+ have ex_key: "ex_key qts time accept ac'' = (b, ac')"
	+ using Cons(4) time_t False
	+ by (auto simp: qt_def ac''_def)
	+ show ?thesis
	+ using Cons(1)[OF accept(2) _ ex_key] False[unfolded accept(1)] Cons(3)
	+ by (auto simp: mmap_keys_def mmap_lookup_def qt_def)
	+ qed
	+ next
	+ case False
	+ have ex_key: "ex_key qts time accept ac = (b, ac')"
	+ using Cons(4) False
	+ by (auto simp: qt_def)
	+ show ?thesis
	+ using Cons(1)[OF Cons(2) _ ex_key] False Cons(3)
	+ by (auto simp: mmap_keys_def mmap_lookup_def qt_def)
	+ qed
	+qed (auto simp: mmap_keys_def)
	+
	+fun eval_matchP :: "'d \<I> \<Rightarrow> (bool iarray, nat set, 'd, 't, 'e) window \<Rightarrow>
	+ (('d \<times> bool) \<times> (bool iarray, nat set, 'd, 't, 'e) window) option" where
	+ "eval_matchP I w =
	+ (case w_read_t args (w_tj w) of None \<Rightarrow> None \| Some t \<Rightarrow>
	+ (case adv_end args w of None \<Rightarrow> None \| Some w' \<Rightarrow>
	+ let w'' = while (matchP_loop_cond I t) (adv_start args) w';
	+ (\<beta>, ac') = ex_key (w_e w'') (\<lambda>t'. memR t' t I) (w_accept args) (w_ac w'') in
	+ Some ((t, \<beta>), w''\<lparr>w_ac := ac'\<rparr>)))"
	+
	+definition valid_window_matchF :: "'d \<I> \<Rightarrow> 't \<Rightarrow> 'e \<Rightarrow> ('d \<times> bool iarray) list \<Rightarrow> nat \<Rightarrow>
	+ (bool iarray, nat set, 'd, 't, 'e) window \<Rightarrow> bool" where
	+ "valid_window_matchF I t0 sub rho i w \<longleftrightarrow> i = w_i w \<and>
	+ valid_window args t0 sub rho w \<and>
	+ reach_w t0 sub rho (w_i w, w_ti w, w_si w, w_j w, w_tj w, w_sj w) \<and>
	+ (\<forall>l \<in> {w_i w..<w_j w}. memR (ts_at rho i) (ts_at rho l) I)"
	+
	+lemma valid_window_matchF_reach_tj: "valid_window_matchF I t0 sub rho i w \<Longrightarrow>
	+ reaches_on (w_run_t args) t0 (map fst rho) (w_tj w)"
	+ using reach_window_run_tj
	+ by (fastforce simp: valid_window_matchF_def simp del: reach_window.simps)
	+
	+lemma valid_window_matchF_reach_sj: "valid_window_matchF I t0 sub rho i w \<Longrightarrow>
	+ reaches_on (w_run_sub args) sub (map snd rho) (w_sj w)"
	+ using reach_window_run_sj
	+ by (fastforce simp: valid_window_matchF_def simp del: reach_window.simps)
	+
	+definition "matchF_loop_cond I t =
	+ (\<lambda>w. case w_read_t args (w_tj w) of None \<Rightarrow> False \| Some t' \<Rightarrow> memR t t' I)"
	+
	+definition "matchF_loop_inv I t0 sub rho i ti si tjm sjm =
	+ (\<lambda>w. valid_window args t0 sub (take (w_j w) rho) w \<and>
	+ w_i w = i \<and> w_ti w = ti \<and> w_si w = si \<and>
	+ reach_window args t0 sub rho (w_j w, w_tj w, w_sj w, length rho, tjm, sjm) \<and>
	+ (\<forall>l \<in> {w_i w..<w_j w}. memR (ts_at rho i) (ts_at rho l) I))"
	+
	+definition "matchF_loop_inv' t0 sub rho i ti si j tj sj =
	+ (\<lambda>w. w_i w = i \<and> w_ti w = ti \<and> w_si w = si \<and>
	+ (\<exists>rho'. valid_window args t0 sub (rho @ rho') w \<and>
	+ reach_window args t0 sub (rho @ rho') (j, tj, sj, w_j w, w_tj w, w_sj w)))"
	+
	+fun eval_matchF :: "'d \<I> \<Rightarrow> (bool iarray, nat set, 'd, 't, 'e) window \<Rightarrow>
	+ (('d \<times> bool) \<times> (bool iarray, nat set, 'd, 't, 'e) window) option" where
	+ "eval_matchF I w =
	+ (case w_read_t args (w_ti w) of None \<Rightarrow> None \| Some t \<Rightarrow>
	+ (case while_break (matchF_loop_cond I t) (adv_end args) w of None \<Rightarrow> None \| Some w' \<Rightarrow>
	+ (case w_read_t args (w_tj w') of None \<Rightarrow> None \| Some t' \<Rightarrow>
	+ let \<beta> = (case snd (the (mmap_lookup (w_s w') {0})) of None \<Rightarrow> False
	+ \| Some tstp \<Rightarrow> memL t (fst tstp) I) in
	+ Some ((t, \<beta>), adv_start args w'))))"
	+
	+end
	+
	+locale MDL_window = MDL \<sigma>
	+ for \<sigma> :: "('a, 'd :: timestamp) trace" +
	+ fixes r :: "('a, 'd :: timestamp) regex"
	+ and t0 :: 't
	+ and sub :: 'e
	+ and args :: "(bool iarray, nat set, 'd, 't, 'e) args"
	+ assumes init_def: "w_init args = {0 :: nat}"
	+ and step_def: "w_step args =
	+ NFA.delta' (IArray (build_nfa_impl r (0, state_cnt r, []))) (state_cnt r)"
	+ and accept_def: "w_accept args = NFA.accept' (IArray (build_nfa_impl r (0, state_cnt r, []))) (state_cnt r)"
	+ and run_t_sound: "reaches_on (w_run_t args) t0 ts t \<Longrightarrow>
	+ w_run_t args t = Some (t', x) \<Longrightarrow> x = \<tau> \<sigma> (length ts)"
	+ and run_sub_sound: "reaches_on (w_run_sub args) sub bs s \<Longrightarrow>
	+ w_run_sub args s = Some (s', b) \<Longrightarrow>
	+ b = IArray (map (\<lambda>phi. sat phi (length bs)) (collect_subfmlas r []))"
	+ and run_t_read: "w_run_t args t = Some (t', x) \<Longrightarrow> w_read_t args t = Some x"
	+ and read_t_run: "w_read_t args t = Some x \<Longrightarrow> \<exists>t'. w_run_t args t = Some (t', x)"
	+begin
	+
	+definition "qf = state_cnt r"
	+definition "transs = build_nfa_impl r (0, qf, [])"
	+
	+abbreviation "init \<equiv> w_init args"
	+abbreviation "step \<equiv> w_step args"
	+abbreviation "accept \<equiv> w_accept args"
	+abbreviation "run \<equiv> NFA.run' (IArray transs) qf"
	+abbreviation "wacc \<equiv> Window.acc (w_step args) (w_accept args)"
	+abbreviation "rw \<equiv> reach_window args"
	+
	+abbreviation "valid_matchP \<equiv> valid_window_matchP args"
	+abbreviation "eval_mP \<equiv> eval_matchP args"
	+abbreviation "matchP_inv \<equiv> matchP_loop_inv args"
	+abbreviation "matchP_cond \<equiv> matchP_loop_cond args"
	+
	+abbreviation "valid_matchF \<equiv> valid_window_matchF args"
	+abbreviation "eval_mF \<equiv> eval_matchF args"
	+abbreviation "matchF_inv \<equiv> matchF_loop_inv args"
	+abbreviation "matchF_inv' \<equiv> matchF_loop_inv' args"
	+abbreviation "matchF_cond \<equiv> matchF_loop_cond args"
	+
	+lemma run_t_sound':
	+ assumes "reaches_on (w_run_t args) t0 ts t" "i < length ts"
	+ shows "ts ! i = \<tau> \<sigma> i"
	+proof -
	+ obtain t' t'' where t'_def: "reaches_on (w_run_t args) t0 (take i ts) t'"
	+ "w_run_t args t' = Some (t'', ts ! i)"
	+ using reaches_on_split[OF assms]
	+ by auto
	+ show ?thesis
	+ using run_t_sound[OF t'_def] assms(2)
	+ by simp
	+qed
	+
	+lemma run_sub_sound':
	+ assumes "reaches_on (w_run_sub args) sub bs s" "i < length bs"
	+ shows "bs ! i = IArray (map (\<lambda>phi. sat phi i) (collect_subfmlas r []))"
	+proof -
	+ obtain s' s'' where s'_def: "reaches_on (w_run_sub args) sub (take i bs) s'"
	+ "w_run_sub args s' = Some (s'', bs ! i)"
	+ using reaches_on_split[OF assms]
	+ by auto
	+ show ?thesis
	+ using run_sub_sound[OF s'_def] assms(2)
	+ by simp
	+qed
	+
	+lemma run_ts: "reaches_on (w_run_t args) t ts t' \<Longrightarrow> t = t0 \<Longrightarrow> chain_le ts"
	+proof (induction t ts t' rule: reaches_on_rev_induct)
	+ case (2 s s' v vs s'')
	+ show ?case
	+ proof (cases vs rule: rev_cases)
	+ case (snoc zs z)
	+ show ?thesis
	+ using 2(3)[OF 2(4)]
	+ using chain_le_app[OF _ \<tau>_mono[of "length zs" "Suc (length zs)" \<sigma>]]
	+ run_t_sound'[OF reaches_on_app[OF 2(1,2), unfolded 2(4)], of "length zs"]
	+ run_t_sound'[OF reaches_on_app[OF 2(1,2), unfolded 2(4)], of "Suc (length zs)"]
	+ unfolding snoc
	+ by (auto simp: nth_append)
	+ qed (auto intro: chain_le.intros)
	+qed (auto intro: chain_le.intros)
	+
	+lemma ts_at_tau: "reaches_on (w_run_t args) t0 (map fst rho) t \<Longrightarrow> i < length rho \<Longrightarrow>
	+ ts_at rho i = \<tau> \<sigma> i"
	+ using run_t_sound'
	+ unfolding ts_at_def
	+ by fastforce
	+
	+lemma length_bs_at: "reaches_on (w_run_sub args) sub (map snd rho) s \<Longrightarrow> i < length rho \<Longrightarrow>
	+ IArray.length (bs_at rho i) = length (collect_subfmlas r [])"
	+ using run_sub_sound'
	+ unfolding bs_at_def
	+ by fastforce
	+
	+lemma bs_at_nth: "reaches_on (w_run_sub args) sub (map snd rho) s \<Longrightarrow> i < length rho \<Longrightarrow>
	+ n < IArray.length (bs_at rho i) \<Longrightarrow>
	+ IArray.sub (bs_at rho i) n \<longleftrightarrow> sat (collect_subfmlas r [] ! n) i"
	+ using run_sub_sound'
	+ unfolding bs_at_def
	+ by fastforce
	+
	+lemma ts_at_mono: "\<And>i j. reaches_on (w_run_t args) t0 (map fst rho) t \<Longrightarrow>
	+ i \<le> j \<Longrightarrow> j < length rho \<Longrightarrow> ts_at rho i \<le> ts_at rho j"
	+ using ts_at_tau
	+ by fastforce
	+
	+lemma steps_is_run: "steps (w_step args) rho q ij = run q (sub_bs rho ij)"
	+ unfolding NFA.run'_def steps_def step_def transs_def qf_def ..
	+
	+lemma acc_is_accept: "wacc rho q (i, j) = w_accept args (run q (sub_bs rho (i, j)))"
	+ unfolding acc_def steps_is_run by auto
	+
	+lemma iarray_list_of: "IArray (IArray.list_of xs) = xs"
	+ by (cases xs) auto
	+
	+lemma map_iarray_list_of: "map IArray (map IArray.list_of bss) = bss"
	+ using iarray_list_of
	+ by (induction bss) auto
	+
	+lemma acc_match:
	+ fixes ts :: "'d list"
	+ assumes "reaches_on (w_run_sub args) sub (map snd rho) s" "i \<le> j" "j \<le> length rho" "wf_regex r"
	+ shows "wacc rho {0} (i, j) \<longleftrightarrow> (i, j) \<in> match r"
	+proof -
	+ have j_eq: "j = i + length (sub_bs rho (i, j))"
	+ using assms by auto
	+ define bs where "bs = map (\<lambda>phi. sat phi j) (collect_subfmlas r [])"
	+ have IH: "IH r 0 qf [] transs (map IArray.list_of (sub_bs rho (i, j))) bs i"
	+ unfolding IH_def transs_def qf_def NFA.SQ_def build_nfa_impl_state_cnt bs_def
	+ using assms run_sub_sound bs_at_nth length_bs_at by fastforce
	+ interpret NFA_array: nfa_array transs "IArray transs" qf
	+ by unfold_locales (auto simp: qf_def transs_def build_nfa_impl_state_cnt)
	+ have run_run': "NFA_array.run R (map IArray.list_of (sub_bs rho (i, j))) = NFA_array.run' R (sub_bs rho (i, j))" for R
	+ using NFA_array.run'_eq[of "sub_bs rho (i, j)" "map IArray.list_of (sub_bs rho (i, j))"]
	+ unfolding map_iarray_list_of
	+ by auto
	+ show ?thesis
	+ using nfa_correct[OF IH, unfolded NFA.run_accept_def]
	+ unfolding run_accept_eps_iff_run_accept[OF assms(4) IH] acc_is_accept NFA.run_accept_def run_run' NFA_array.accept'_eq
	+ by (simp add: j_eq[symmetric] accept_def assms(2) qf_def transs_def)
	+qed
	+
	+lemma accept_match:
	+ fixes ts :: "'d list"
	+ shows "reaches_on (w_run_sub args) sub (map snd rho) s \<Longrightarrow> i \<le> j \<Longrightarrow> j \<le> length rho \<Longrightarrow> wf_regex r \<Longrightarrow>
	+ w_accept args (steps (w_step args) rho {0} (i, j)) \<longleftrightarrow> (i, j) \<in> match r"
	+ using acc_match acc_is_accept steps_is_run
	+ by metis
	+
	+lemma drop_take_drop: "i \<le> j \<Longrightarrow> j \<le> length rho \<Longrightarrow> drop i (take j rho) @ drop j rho = drop i rho"
	+ apply (induction i arbitrary: j rho)
	+ by auto (metis append_take_drop_id diff_add drop_drop drop_take)
	+
	+lemma take_Suc: "drop n xs = y # ys \<Longrightarrow> take n xs @ [y] = take (Suc n) xs"
	+ by (metis drop_all list.distinct(1) list.sel(1) not_less take_hd_drop)
	+
	+lemma valid_init_matchP: "valid_matchP I t0 sub [] 0 (init_window args t0 sub)"
	+ using valid_init_window
	+ by (fastforce simp: valid_window_matchP_def Let_def intro: reaches_on.intros split: option.splits)
	+
	+lemma valid_init_matchF: "valid_matchF I t0 sub [] 0 (init_window args t0 sub)"
	+ using valid_init_window
	+ by (fastforce simp: valid_window_matchF_def Let_def intro: reaches_on.intros split: option.splits)
	+
	+lemma valid_eval_matchP:
	+ assumes valid_before': "valid_matchP I t0 sub rho j w"
	+ and before_end: "w_run_t args (w_tj w) = Some (tj''', t)" "w_run_sub args (w_sj w) = Some (sj''', b)"
	+ and wf: "wf_regex r"
	+ shows "\<exists>w'. eval_mP I w = Some ((\<tau> \<sigma> j, sat (MatchP I r) j), w') \<and>
	+ t = \<tau> \<sigma> j \<and> valid_matchP I t0 sub (rho @ [(t, b)]) (Suc j) w'"
	+proof -
	+ obtain w' where w'_def: "adv_end args w = Some w'"
	+ using before_end
	+ by (fastforce simp: adv_end_def Let_def split: prod.splits)
	+ define st where "st = w_st w'"
	+ define i where "i = w_i w'"
	+ define ti where "ti = w_ti w'"
	+ define si where "si = w_si w'"
	+ define tj where "tj = w_tj w'"
	+ define sj where "sj = w_sj w'"
	+ define s where "s = w_s w'"
	+ define e where "e = w_e w'"
	+ define rho' where "rho' = rho @ [(t, b)]"
	+ have reaches_on': "reaches_on (w_run_t args) t0 (map fst rho') tj'''"
	+ using valid_before' reach_window_run_tj[OF reach_window_app[OF _ before_end]]
	+ by (auto simp: valid_window_matchP_def rho'_def)
	+ have rho_mono: "\<And>t'. t' \<in> set (map fst rho) \<Longrightarrow> t' \<le> t"
	+ using ts_at_mono[OF reaches_on'] nat_less_le
	+ by (fastforce simp: rho'_def ts_at_def nth_append in_set_conv_nth split: list.splits)
	+ have valid_adv_end_w: "valid_window args t0 sub rho' w'"
	+ using valid_before' valid_adv_end[OF _ before_end rho_mono]
	+ by (auto simp: valid_window_matchP_def rho'_def w'_def)
	+ have w_ij_adv_end: "w_i w' = w_i w" "w_j w' = Suc j"
	+ using valid_before' w'_def
	+ by (auto simp: valid_window_matchP_def adv_end_def Let_def before_end split: prod.splits)
	+ have valid_before: "rw t0 sub rho' (i, ti, si, Suc j, tj, sj)"
	+ "\<And>i j. i \<le> j \<Longrightarrow> j < length rho' \<Longrightarrow> ts_at rho' i \<le> ts_at rho' j"
	+ "\<forall>q. mmap_lookup e q = sup_leadsto init step rho' i (Suc j) q"
	+ "valid_s init step st accept rho' i i (Suc j) s"
	+ "w_j w' = Suc j" "i \<le> Suc j"
	+ using valid_adv_end_w
	+ unfolding valid_window_def Let_def ti_def si_def i_def tj_def sj_def s_def e_def w_ij_adv_end st_def
	+ by auto
	+ note read_t_def = run_t_read[OF before_end(1)]
	+ have t_props: "\<forall>l < i. memL (ts_at rho' l) t I"
	+ using valid_before'
	+ by (auto simp: valid_window_matchP_def i_def w_ij_adv_end read_t_def rho'_def ts_at_def nth_append)
	+
	+ note reaches_on_tj = reach_window_run_tj[OF valid_before(1)]
	+ note reaches_on_sj = reach_window_run_sj[OF valid_before(1)]
	+ have length_rho': "length rho' = Suc j" "length rho = j"
	+ using valid_before
	+ by (auto simp: rho'_def)
	+ have j_len_rho': "j < length rho'"
	+ by (auto simp: length_rho')
	+ have tj_eq: "t = \<tau> \<sigma> j" "t = ts_at rho' j"
	+ using run_t_sound'[OF reaches_on_tj, of j]
	+ by (auto simp: rho'_def length_rho' nth_append ts_at_def)
	+ have bj_def: "b = bs_at rho' j"
	+ using run_sub_sound'[OF reaches_on_sj, of j]
	+ by (auto simp: rho'_def length_rho' nth_append bs_at_def)
	+ define w'' where loop_def: "w'' = while (matchP_cond I t) (adv_start args) w'"
	+ have inv_before: "matchP_inv I t0 sub rho' (Suc j) tj sj t w'"
	+ using valid_adv_end_w valid_before t_props
	+ unfolding matchP_loop_inv_def
	+ by (auto simp: tj_def sj_def i_def)
	+ have loop: "matchP_inv I t0 sub rho' (Suc j) tj sj t w'' \<and> \<not>matchP_cond I t w''"
	+ unfolding loop_def
	+ proof (rule while_rule_lemma[of "matchP_inv I t0 sub rho' (Suc j) tj sj t"])
	+ fix w_cur :: "(bool iarray, nat set, 'd, 't, 'e) window"
	+ assume assms: "matchP_inv I t0 sub rho' (Suc j) tj sj t w_cur" "matchP_cond I t w_cur"
	+ define st_cur where "st_cur = w_st w_cur"
	+ define i_cur where "i_cur = w_i w_cur"
	+ define ti_cur where "ti_cur = w_ti w_cur"
	+ define si_cur where "si_cur = w_si w_cur"
	+ define s_cur where "s_cur = w_s w_cur"
	+ define e_cur where "e_cur = w_e w_cur"
	+ have valid_loop: "rw t0 sub rho' (i_cur, ti_cur, si_cur, Suc j, tj, sj)"
	+ "\<And>i j. i \<le> j \<Longrightarrow> j < length rho' \<Longrightarrow> ts_at rho' i \<le> ts_at rho' j"
	+ "\<forall>q. mmap_lookup e_cur q = sup_leadsto init step rho' i_cur (Suc j) q"
	+ "valid_s init step st_cur accept rho' i_cur i_cur (Suc j) s_cur"
	+ "w_j w_cur = Suc j"
	+ using assms(1)[unfolded matchP_loop_inv_def valid_window_matchP_def] valid_before(6)
	+ ti_cur_def si_cur_def i_cur_def s_cur_def e_cur_def
	+ by (auto simp: valid_window_def Let_def init_def step_def st_cur_def accept_def
	+ split: option.splits)
	+ obtain ti'_cur si'_cur t_cur b_cur where run_si_cur:
	+ "w_run_t args ti_cur = Some (ti'_cur, t_cur)" "w_run_sub args si_cur = Some (si'_cur, b_cur)"
	+ "t_cur = ts_at rho' i_cur" "b_cur = bs_at rho' i_cur"
	+ using assms(2) reach_window_run_si[OF valid_loop(1)] reach_window_run_ti[OF valid_loop(1)]
	+ unfolding matchP_loop_cond_def valid_loop(5) i_cur_def
	+ by auto
	+ have "\<And>l. l < i_cur \<Longrightarrow> memL (ts_at rho' l) t I"
	+ using assms(1)
	+ unfolding matchP_loop_inv_def i_cur_def
	+ by auto
	+ then have "\<And>l. l < Suc (i_cur) \<Longrightarrow> memL (ts_at rho' l) t I"
	+ using assms(2) run_t_read[OF run_si_cur(1), unfolded run_si_cur(3)]
	+ unfolding matchP_loop_cond_def i_cur_def ti_cur_def
	+ by (auto simp: less_Suc_eq)
	+ then show "matchP_inv I t0 sub rho' (Suc j) tj sj t (adv_start args w_cur)"
	+ using assms i_cur_def valid_adv_start valid_adv_start_bounds
	+ unfolding matchP_loop_inv_def matchP_loop_cond_def
	+ by fastforce
	+ next
	+ {
	+ fix w1 w2
	+ assume lassms: "matchP_inv I t0 sub rho' (Suc j) tj sj t w1" "matchP_cond I t w1"
	+ "w2 = adv_start args w1"
	+ define i_cur where "i_cur = w_i w1"
	+ define ti_cur where "ti_cur = w_ti w1"
	+ define si_cur where "si_cur = w_si w1"
	+ have valid_loop: "rw t0 sub rho' (i_cur, ti_cur, si_cur, Suc j, tj, sj)" "w_j w1 = Suc j"
	+ using lassms(1)[unfolded matchP_loop_inv_def valid_window_matchP_def] valid_before(6)
	+ ti_cur_def si_cur_def i_cur_def
	+ by (auto simp: valid_window_def Let_def)
	+ obtain ti'_cur si'_cur t_cur b_cur where run_si_cur:
	+ "w_run_t args ti_cur = Some (ti'_cur, t_cur)"
	+ "w_run_sub args si_cur = Some (si'_cur, b_cur)"
	+ using lassms(2) reach_window_run_si[OF valid_loop(1)] reach_window_run_ti[OF valid_loop(1)]
	+ unfolding matchP_loop_cond_def valid_loop i_cur_def
	+ by auto
	+ have w1_ij: "w_i w1 < Suc j" "w_j w1 = Suc j"
	+ using lassms
	+ unfolding matchP_loop_inv_def matchP_loop_cond_def
	+ by auto
	+ have w2_ij: "w_i w2 = Suc (w_i w1)" "w_j w2 = Suc j"
	+ using w1_ij lassms(3) run_si_cur(1,2)
	+ unfolding ti_cur_def si_cur_def
	+ by (auto simp: adv_start_def Let_def split: option.splits prod.splits if_splits)
	+ have "w_j w2 - w_i w2 < w_j w1 - w_i w1"
	+ using w1_ij w2_ij
	+ by auto
	+ }
	+ then have "{(s', s). matchP_inv I t0 sub rho' (Suc j) tj sj t s \<and> matchP_cond I t s \<and>
	+ s' = adv_start args s} \<subseteq> measure (\<lambda>w. w_j w - w_i w)"
	+ by auto
	+ then show "wf {(s', s). matchP_inv I t0 sub rho' (Suc j) tj sj t s \<and> matchP_cond I t s \<and>
	+ s' = adv_start args s}"
	+ using wf_measure wf_subset by auto
	+ qed (auto simp: inv_before)
	+ have valid_w': "valid_window args t0 sub rho' w''"
	+ using conjunct1[OF loop]
	+ unfolding matchP_loop_inv_def
	+ by auto
	+ have w_tsj_w': "w_tj w'' = tj" "w_sj w'' = sj" "w_j w'' = Suc j"
	+ using loop
	+ by (auto simp: matchP_loop_inv_def)
	+ define st' where "st' = w_st w''"
	+ define ac where "ac = w_ac w''"
	+ define i' where "i' = w_i w''"
	+ define ti' where "ti' = w_ti w''"
	+ define si' where "si' = w_si w''"
	+ define s' where "s' = w_s w''"
	+ define e' where "e' = w_e w''"
	+ define tj' where "tj' = w_tj w''"
	+ define sj' where "sj' = w_sj w''"
	+ have i'_le_Suc_j: "i' \<le> Suc j"
	+ using loop
	+ unfolding matchP_loop_inv_def
	+ by (auto simp: valid_window_def Let_def i'_def)
	+ have valid_after: "rw t0 sub rho' (i', ti', si', Suc j, tj', sj')"
	+ "\<And>i j. i \<le> j \<Longrightarrow> j < length rho' \<Longrightarrow> ts_at rho' i \<le> ts_at rho' j"
	+ "distinct (map fst e')"
	+ "\<forall>q. mmap_lookup e' q = sup_leadsto init step rho' i' (Suc j) q"
	+ "\<And>q. case Mapping.lookup ac q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v"
	+ "valid_s init step st' accept rho' i' i' (Suc j) s'" "i' \<le> Suc j" "Suc j \<le> length rho'"
	+ using valid_w' i'_le_Suc_j
	+ unfolding valid_window_def Let_def i'_def ti'_def si'_def s'_def e'_def tj'_def sj'_def ac_def st'_def w_tsj_w'
	+ by auto
	+ note lookup_e' = valid_after(3,4,5,6)
	+ obtain \<beta> ac' where ac'_def: "ex_key e' (\<lambda>t'. memR t' t I)
	+ (w_accept args) ac = (\<beta>, ac')"
	+ by fastforce
	+ have \<beta>_def: "\<beta> = (\<exists>q\<in>mmap_keys e'. memR (the (mmap_lookup e' q)) t I \<and> accept q)"
	+ "\<And>q. case Mapping.lookup ac' q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v"
	+ using ex_key_sound[OF valid_after(5) valid_after(3) ac'_def]
	+ by auto
	+ have i'_set: "\<And>l. l < w_i w'' \<Longrightarrow> memL (ts_at rho' l) (ts_at rho' j) I"
	+ using loop length_rho' i'_le_Suc_j
	+ unfolding matchP_loop_inv_def
	+ by (auto simp: ts_at_def rho'_def nth_append i'_def)
	+ have b_alt: "(\<exists>q \<in> mmap_keys e'. memR (the (mmap_lookup e' q)) t I \<and> accept q) \<longleftrightarrow> sat (MatchP I r) j"
	+ proof (rule iffI)
	+ assume "\<exists>q \<in> mmap_keys e'. memR (the (mmap_lookup e' q)) t I \<and> accept q"
	+ then obtain q where q_def: "q \<in> mmap_keys e'"
	+ "memR (the (mmap_lookup e' q)) t I" "accept q"
	+ by auto
	+ then obtain ts' where ts_def: "mmap_lookup e' q = Some ts'"
	+ by (auto dest: Mapping_keys_dest)
	+ have "sup_leadsto init step rho' i' (Suc j) q = Some ts'"
	+ using lookup_e' ts_def q_def valid_after(4,7,8)
	+ by (auto simp: rho'_def sup_leadsto_app_cong)
	+ then obtain l where l_def: "l < i'" "steps step rho' init (l, Suc j) = q"
	+ "ts_at rho' l = ts'"
	+ using sup_leadsto_SomeE[OF i'_le_Suc_j]
	+ unfolding i'_def
	+ by fastforce
	+ have l_le_j: "l \<le> j" and l_le_Suc_j: "l \<le> Suc j"
	+ using l_def(1) i'_le_Suc_j
	+ by (auto simp: i'_def)
	+ have tau_l: "l < j \<Longrightarrow> fst (rho ! l) = \<tau> \<sigma> l"
	+ using run_t_sound'[OF reaches_on_tj, of l] length_rho'
	+ by (auto simp: rho'_def nth_append)
	+ have tau_l_left: "memL ts' t I"
	+ unfolding l_def(3)[symmetric] tj_eq(2)
	+ using i'_set l_def(1)
	+ by (auto simp: i'_def)
	+ have "(l, Suc j) \<in> match r"
	+ using accept_match[OF reaches_on_sj l_le_Suc_j _ wf] q_def(3) length_rho' init_def l_def(2)
	+ rho'_def
	+ by auto
	+ then show "sat (MatchP I r) j"
	+ using l_le_j q_def(2) ts_at_tau[OF reaches_on_tj] tau_l_left
	+ by (auto simp: mem_def tj_eq rho'_def ts_def l_def(3)[symmetric] tau_l tj_def ts_at_def
	+ nth_append length_rho' intro: exI[of _ l] split: if_splits)
	+ next
	+ assume "sat (MatchP I r) j"
	+ then obtain l where l_def: "l \<le> j" "l \<le> Suc j" "mem (\<tau> \<sigma> l) (\<tau> \<sigma> j) I" "(l, Suc j) \<in> match r"
	+ by auto
	+ show "(\<exists>q\<in>mmap_keys e'. memR (the (mmap_lookup e' q)) t I \<and> accept q)"
	+ proof -
	+ have l_lt_j: "l < Suc j"
	+ using l_def(1) by auto
	+ then have ts_at_l_j: "ts_at rho' l \<le> ts_at rho' j"
	+ using ts_at_mono[OF reaches_on' _ j_len_rho']
	+ by (auto simp: rho'_def length_rho')
	+ have ts_j_l: "memL (ts_at rho' l) (ts_at rho' j) I"
	+ using l_def(3) ts_at_tau[OF reaches_on_tj] l_lt_j length_rho' tj_eq
	+ unfolding rho'_def mem_def
	+ by auto
	+ have "i' = Suc j \<or> \<not>memL (ts_at rho' i') (ts_at rho' j) I"
	+ proof (rule Meson.disj_comm, rule disjCI)
	+ assume "i' \<noteq> Suc j"
	+ then have i'_j: "i' < Suc j"
	+ using valid_after
	+ by auto
	+ obtain t' b' where tbi_cur_def: "w_read_t args ti' = Some t'"
	+ "t' = ts_at rho' i'" "b' = bs_at rho' i'"
	+ using reach_window_run_ti[OF valid_after(1) i'_j]
	+ reach_window_run_si[OF valid_after(1) i'_j] run_t_read
	+ by auto
	+ show "\<not>memL (ts_at rho' i') (ts_at rho' j) I"
	+ using loop tbi_cur_def(1) i'_j length_rho'
	+ unfolding matchP_loop_inv_def matchP_loop_cond_def tj_eq(2) ti'_def[symmetric]
	+ by (auto simp: i'_def tbi_cur_def)
	+ qed
	+ then have l_lt_i': "l < i'"
	+ proof (rule disjE)
	+ assume assm: "\<not>memL (ts_at rho' i') (ts_at rho' j) I"
	+ show "l < i'"
	+ proof (rule ccontr)
	+ assume "\<not>l < i'"
	+ then have ts_at_i'_l: "ts_at rho' i' \<le> ts_at rho' l"
	+ using ts_at_mono[OF reaches_on'] l_lt_j length_rho'
	+ by (auto simp: rho'_def length_rho')
	+ show False
	+ using assm memL_mono[OF ts_j_l ts_at_i'_l]
	+ by auto
	+ qed
	+ qed (auto simp add: l_lt_j)
	+ define q where q_def: "q = steps step rho' init (l, Suc j)"
	+ then obtain l' where l'_def: "sup_leadsto init step rho' i' (Suc j) q = Some (ts_at rho' l')"
	+ "l \<le> l'" "l' < i'"
	+ using sup_leadsto_SomeI[OF l_lt_i'] by fastforce
	+ have ts_j_l': "memR (ts_at rho' l') (ts_at rho' j) I"
	+ proof -
	+ have ts_at_l_l': "ts_at rho' l \<le> ts_at rho' l'"
	+ using ts_at_mono[OF reaches_on' l'_def(2)] l'_def(3) valid_after(4,7,8)
	+ by (auto simp add: rho'_def length_rho' dual_order.order_iff_strict)
	+ show ?thesis
	+ using l_def(3) memR_mono[OF _ ts_at_l_l']
	+ ts_at_tau[OF reaches_on_tj] l'_def(2,3) valid_after(4,7,8)
	+ by (auto simp: mem_def rho'_def length_rho')
	+ qed
	+ have lookup_e'_q: "mmap_lookup e' q = Some (ts_at rho' l')"
	+ using lookup_e' l'_def(1) valid_after(4,7,8)
	+ by (auto simp: rho'_def sup_leadsto_app_cong)
	+ show ?thesis
	+ using accept_match[OF reaches_on_sj l_def(2) _ wf] l_def(4) ts_j_l' lookup_e'_q tj_eq(2)
	+ by (auto simp: bs_at_def nth_append init_def length_rho'(1) q_def intro!: bexI[of _ q] Mapping_keys_intro)
	+ qed
	+ qed
	+ have read_tj_Some: "\<And>t' l. w_read_t args tj = Some t' \<Longrightarrow> l < i' \<Longrightarrow> memL (ts_at rho' l) t' I"
	+ proof -
	+ fix t' l
	+ assume lassms: "(w_read_t args) tj = Some t'" "l < i'"
	+ obtain tj'''' where reaches_on_tj'''':
	+ "reaches_on (w_run_t args) t0 (map fst (rho' @ [(t', undefined)])) tj''''"
	+ using reaches_on_app[OF reaches_on_tj] read_t_run[OF lassms(1)]
	+ by auto
	+ have "t \<le> t'"
	+ using ts_at_mono[OF reaches_on_tj'''', of "length rho" "length rho'"]
	+ by (auto simp: ts_at_def nth_append rho'_def)
	+ then show "memL (ts_at rho' l) t' I"
	+ using memL_mono' lassms(2) loop
	+ unfolding matchP_loop_inv_def
	+ by (fastforce simp: i'_def)
	+ qed
	+ define w''' where "w''' = w''\<lparr>w_ac := ac'\<rparr>"
	+ have "rw t0 sub rho' (w_i w''', w_ti w''', w_si w''', w_j w''', w_tj w''', w_sj w''')"
	+ using valid_after(1)
	+ by (auto simp del: reach_window.simps simp: w'''_def i'_def ti'_def si'_def tj'_def sj'_def w_tsj_w')
	+ moreover have "valid_window args t0 sub rho' w'''"
	+ using valid_w'
	+ by (auto simp: w'''_def valid_window_def Let_def \<beta>_def(2))
	+ ultimately have "valid_matchP I t0 sub rho' (Suc j) w'''"
	+ using i'_set read_tj_Some
	+ by (auto simp: valid_window_matchP_def w'''_def w_tsj_w' i'_def split: option.splits)
	+ moreover have "eval_mP I w = Some ((t, sat (MatchP I r) j), w''')"
	+ by (simp add: read_t_def Let_def loop_def[symmetric] ac'_def[unfolded e'_def ac_def] w'''_def w'_def trans[OF \<beta>_def(1) b_alt])
	+ ultimately show ?thesis
	+ by (auto simp: tj_eq rho'_def)
	+qed
	+
	+lemma valid_eval_matchF_Some:
	+ assumes valid_before': "valid_matchF I t0 sub rho i w"
	+ and eval: "eval_mF I w = Some ((t, b), w'')"
	+ and bounded: "right I \<in> tfin"
	+ shows "\<exists>rho' tm. reaches_on (w_run_t args) (w_tj w) (map fst rho') (w_tj w'') \<and>
	+ reaches_on (w_run_sub args) (w_sj w) (map snd rho') (w_sj w'') \<and>
	+ (w_read_t args) (w_ti w) = Some t \<and>
	+ (w_read_t args) (w_tj w'') = Some tm \<and>
	+ \<not>memR t tm I"
	+proof -
	+ define st where "st = w_st w"
	+ define ti where "ti = w_ti w"
	+ define si where "si = w_si w"
	+ define j where "j = w_j w"
	+ define tj where "tj = w_tj w"
	+ define sj where "sj = w_sj w"
	+ define s where "s = w_s w"
	+ define e where "e = w_e w"
	+ have valid_before: "rw t0 sub rho (i, ti, si, j, tj, sj)"
	+ "\<And>i j. i \<le> j \<Longrightarrow> j < length rho \<Longrightarrow> ts_at rho i \<le> ts_at rho j"
	+ "\<forall>q. mmap_lookup e q = sup_leadsto init step rho i j q"
	+ "valid_s init step st accept rho i i j s"
	+ "i = w_i w" "i \<le> j" "length rho = j"
	+ using valid_before'[unfolded valid_window_matchF_def] ti_def
	+ si_def j_def tj_def sj_def s_def e_def
	+ by (auto simp: valid_window_def Let_def init_def step_def st_def accept_def)
	+ obtain ti''' where tbi_def: "w_run_t args ti = Some (ti''', t)"
	+ using eval read_t_run
	+ by (fastforce simp: Let_def ti_def si_def split: option.splits if_splits)
	+ have t_tau: "t = \<tau> \<sigma> i"
	+ using run_t_sound[OF _ tbi_def] valid_before(1)
	+ by auto
	+ note t_def = run_t_read[OF tbi_def(1)]
	+ obtain w' where loop_def: "while_break (matchF_cond I t) (adv_end args) w = Some w'"
	+ using eval
	+ by (auto simp: ti_def[symmetric] t_def split: option.splits)
	+ have adv_start_last:
	+ "adv_start args w' = w''"
	+ using eval loop_def[symmetric] run_t_read[OF tbi_def(1)]
	+ by (auto simp: ti_def split: option.splits prod.splits if_splits)
	+ have inv_before: "matchF_inv' t0 sub rho i ti si j tj sj w"
	+ using valid_before(1) valid_before'
	+ unfolding matchF_loop_inv'_def valid_before(6) valid_window_matchF_def
	+ by (auto simp add: ti_def si_def j_def tj_def sj_def simp del: reach_window.simps
	+ dest: reach_window_shift_all intro!: exI[of _ "[]"])
	+ have i_j: "i \<le> j" "length rho = j"
	+ using valid_before by auto
	+ define j'' where "j'' = w_j w''"
	+ define tj'' where "tj'' = w_tj w''"
	+ define sj'' where "sj'' = w_sj w''"
	+ have loop: "matchF_inv' t0 sub rho i ti si j tj sj w' \<and> \<not> matchF_cond I t w'"
	+ proof (rule while_break_sound[of "matchF_inv' t0 sub rho i ti si j tj sj" "matchF_cond I t" "adv_end args" "\<lambda>w'. matchF_inv' t0 sub rho i ti si j tj sj w' \<and> \<not> matchF_cond I t w'" w, unfolded loop_def, simplified])
	+ fix w_cur w_cur' :: "(bool iarray, nat set, 'd, 't, 'e) window"
	+ assume assms: "matchF_inv' t0 sub rho i ti si j tj sj w_cur" "matchF_cond I t w_cur" "adv_end args w_cur = Some w_cur'"
	+ define j_cur where "j_cur = w_j w_cur"
	+ define tj_cur where "tj_cur = w_tj w_cur"
	+ define sj_cur where "sj_cur = w_sj w_cur"
	+ obtain rho' where rho'_def: "valid_window args t0 sub (rho @ rho') w_cur"
	+ "rw t0 sub (rho @ rho') (j, tj, sj, w_j w_cur, w_tj w_cur, w_sj w_cur)"
	+ using assms(1)[unfolded matchF_loop_inv'_def valid_window_matchF_def]
	+ by auto
	+ obtain tj' x sj' y where append: "w_run_t args tj_cur = Some (tj', x)"
	+ "w_run_sub args sj_cur = Some (sj', y)"
	+ using assms(3)
	+ unfolding tj_cur_def sj_cur_def
	+ by (auto simp: adv_end_def Let_def split: option.splits)
	+ note append' = append[unfolded tj_cur_def sj_cur_def]
	+ define rho'' where "rho'' = rho @ rho'"
	+ have reach: "reaches_on (w_run_t args) t0 (map fst (rho'' @ [(x, undefined)])) tj'"
	+ using reaches_on_app[OF reach_window_run_tj[OF rho'_def(2)] append'(1)]
	+ by (auto simp: rho''_def)
	+ have mono: "\<And>t'. t' \<in> set (map fst rho'') \<Longrightarrow> t' \<le> x"
	+ using ts_at_mono[OF reach, of _ "length rho''"] nat_less_le
	+ by (fastforce simp: ts_at_def nth_append in_set_conv_nth split: list.splits)
	+ show "matchF_inv' t0 sub rho i ti si j tj sj w_cur'"
	+ using assms(1,3) reach_window_app[OF rho'_def(2) append[unfolded tj_cur_def sj_cur_def]]
	+ valid_adv_end[OF rho'_def(1) append' mono] adv_end_bounds[OF append']
	+ unfolding matchF_loop_inv'_def matchF_loop_cond_def rho''_def
	+ by auto
	+ next
	+ obtain l where l_def: "\<not>\<tau> \<sigma> l \<le> t + right I"
	+ unfolding t_tau
	+ using ex_lt_\<tau>[OF bounded]
	+ by auto
	+ {
	+ fix w1 w2
	+ assume lassms: "matchF_inv' t0 sub rho i ti si j tj sj w1" "matchF_cond I t w1"
	+ "Some w2 = adv_end args w1"
	+ define j_cur where "j_cur = w_j w1"
	+ define tj_cur where "tj_cur = w_tj w1"
	+ define sj_cur where "sj_cur = w_sj w1"
	+ obtain rho' where rho'_def: "valid_window args t0 sub (rho @ rho') w1"
	+ "rw t0 sub (rho @ rho') (j, tj, sj, w_j w1, w_tj w1, w_sj w1)"
	+ using lassms(1)[unfolded matchF_loop_inv'_def valid_window_matchF_def]
	+ by auto
	+ obtain tj' x sj' y where append: "w_run_t args tj_cur = Some (tj', x)"
	+ "w_run_sub args sj_cur = Some (sj', y)"
	+ using lassms(3)
	+ unfolding tj_cur_def sj_cur_def
	+ by (auto simp: adv_end_def Let_def split: option.splits)
	+ note append' = append[unfolded tj_cur_def sj_cur_def]
	+ define rho'' where "rho'' = rho @ rho'"
	+ have reach: "reaches_on (w_run_t args) t0 (map fst (rho'' @ [(x, undefined)])) tj'"
	+ using reaches_on_app[OF reach_window_run_tj[OF rho'_def(2)] append'(1)]
	+ by (auto simp: rho''_def)
	+ have mono: "\<And>t'. t' \<in> set (map fst rho'') \<Longrightarrow> t' \<le> x"
	+ using ts_at_mono[OF reach, of _ "length rho''"] nat_less_le
	+ by (fastforce simp: ts_at_def nth_append in_set_conv_nth split: list.splits)
	+ have t_cur_tau: "x = \<tau> \<sigma> j_cur"
	+ using ts_at_tau[OF reach, of "length rho''"] rho'_def(2)
	+ by (auto simp: ts_at_def j_cur_def rho''_def)
	+ have "j_cur < l"
	+ using lassms(2)[unfolded matchF_loop_cond_def] l_def memR_mono'[OF _ \<tau>_mono[of l j_cur \<sigma>]]
	+ unfolding run_t_read[OF append(1), unfolded t_cur_tau tj_cur_def]
	+ by (fastforce dest: memR_dest)
	+ moreover have "w_j w2 = Suc j_cur"
	+ using adv_end_bounds[OF append']
	+ unfolding lassms(3)[symmetric] j_cur_def
	+ by auto
	+ ultimately have "l - w_j w2 < l - w_j w1"
	+ unfolding j_cur_def
	+ by auto
	+ }
	+ then have "{(ta, s). matchF_inv' t0 sub rho i ti si j tj sj s \<and> matchF_cond I t s \<and>
	+ Some ta = adv_end args s} \<subseteq> measure (\<lambda>w. l - w_j w)"
	+ by auto
	+ then show "wf {(ta, s). matchF_inv' t0 sub rho i ti si j tj sj s \<and> matchF_cond I t s \<and>
	+ Some ta = adv_end args s}"
	+ using wf_measure wf_subset
	+ by auto
	+ qed (auto simp: inv_before)
	+ define i' where "i' = w_i w'"
	+ define ti' where "ti' = w_ti w'"
	+ define si' where "si' = w_si w'"
	+ define j' where "j' = w_j w'"
	+ define tj' where "tj' = w_tj w'"
	+ define sj' where "sj' = w_sj w'"
	+ obtain rho' where rho'_def: "valid_window args t0 sub (rho @ rho') w'"
	+ "rw t0 sub (rho @ rho') (j, tj, sj, j', tj', sj')"
	+ "i = i'" "j \<le> j'"
	+ using loop
	+ unfolding matchF_loop_inv'_def i'_def j'_def tj'_def sj'_def
	+ by auto
	+ obtain tje tm where tm_def: "w_read_t args tj' = Some tm" "w_run_t args tj' = Some (tje, tm)"
	+ using eval read_t_run loop_def t_def ti_def
	+ by (auto simp: t_def Let_def tj'_def split: option.splits if_splits)
	+ have drop_j_rho: "drop j (map fst (rho @ rho')) = map fst rho'"
	+ using i_j
	+ by auto
	+ have "reaches_on (w_run_t args) ti (drop i (map fst rho)) tj"
	+ using valid_before(1)
	+ by auto
	+ then have "reaches_on (w_run_t args) ti
	+ (drop i (map fst rho) @ (drop j (map fst (rho @ rho')))) tj'"
	+ using rho'_def reaches_on_trans
	+ by fastforce
	+ then have "reaches_on (w_run_t args) ti (drop i (map fst (rho @ rho'))) tj'"
	+ unfolding drop_j_rho
	+ by (auto simp: i_j)
	+ then have reach_tm: "reaches_on (w_run_t args) ti (drop i (map fst (rho @ rho')) @ [tm]) tje"
	+ using reaches_on_app tm_def(2)
	+ by fastforce
	+ have run_tsi': "w_run_t args ti' \<noteq> None"
	+ using tbi_def loop
	+ by (auto simp: matchF_loop_inv'_def ti'_def si'_def)
	+ have memR_t_tm: "\<not> memR t tm I"
	+ using loop tm_def
	+ by (auto simp: tj'_def matchF_loop_cond_def)
	+ have i_le_rho: "i \<le> length rho"
	+ using valid_before
	+ by auto
	+ define rho'' where "rho'' = rho @ rho'"
	+ have t_tfin: "t \<in> tfin"
	+ using \<tau>_fin
	+ by (auto simp: t_tau)
	+ have i'_lt_j': "i' < j'"
	+ using rho'_def(1,2,3)[folded rho''_def] i_j reach_tm[folded rho''_def] memR_t_tm tbi_def memR_tfin_refl[OF t_tfin]
	+ by (cases "i' = j'") (auto dest!: reaches_on_NilD elim!: reaches_on.cases[of _ _ "[tm]"])
	+ have adv_last_bounds: "j'' = j'" "tj'' = tj'" "sj'' = sj'"
	+ using valid_adv_start_bounds[OF rho'_def(1) i'_lt_j'[unfolded i'_def j'_def]]
	+ unfolding adv_start_last j'_def j''_def tj'_def tj''_def sj'_def sj''_def
	+ by auto
	+ show ?thesis
	+ using eval rho'_def run_tsi' i_j(2) adv_last_bounds tj''_def tj_def sj''_def sj_def
	+ loop_def t_def ti_def tj'_def tm_def memR_t_tm
	+ by (auto simp: drop_map run_t_read[OF tbi_def(1)] Let_def
	+ split: option.splits prod.splits if_splits intro!: exI[of _ rho'])
	+qed
	+
	+lemma valid_eval_matchF_complete:
	+ assumes valid_before': "valid_matchF I t0 sub rho i w"
	+ and before_end: "reaches_on (w_run_t args) (w_tj w) (map fst rho') tj'''"
	+ "reaches_on (w_run_sub args) (w_sj w) (map snd rho') sj'''"
	+ "w_read_t args (w_ti w) = Some t" "w_read_t args tj''' = Some tm" "\<not>memR t tm I"
	+ and wf: "wf_regex r"
	+ shows "\<exists>w'. eval_mF I w = Some ((\<tau> \<sigma> i, sat (MatchF I r) i), w') \<and>
	+ valid_matchF I t0 sub (take (w_j w') (rho @ rho')) (Suc i) w'"
	+proof -
	+ define st where "st = w_st w"
	+ define ti where "ti = w_ti w"
	+ define si where "si = w_si w"
	+ define j where "j = w_j w"
	+ define tj where "tj = w_tj w"
	+ define sj where "sj = w_sj w"
	+ define s where "s = w_s w"
	+ define e where "e = w_e w"
	+ have valid_before: "rw t0 sub rho (i, ti, si, j, tj, sj)"
	+ "\<And>i j. i \<le> j \<Longrightarrow> j < length rho \<Longrightarrow> ts_at rho i \<le> ts_at rho j"
	+ "\<forall>q. mmap_lookup e q = sup_leadsto init step rho i j q"
	+ "valid_s init step st accept rho i i j s"
	+ "i = w_i w" "i \<le> j" "length rho = j"
	+ using valid_before'[unfolded valid_window_matchF_def] ti_def
	+ si_def j_def tj_def sj_def s_def e_def
	+ by (auto simp: valid_window_def Let_def init_def step_def st_def accept_def)
	+ define rho'' where "rho'' = rho @ rho'"
	+ have ij_le: "i \<le> j" "j = length rho"
	+ using valid_before
	+ by auto
	+ have reach_tj: "reaches_on (w_run_t args) t0 (take j (map fst rho'')) tj"
	+ using valid_before(1) ij_le
	+ by (auto simp: take_map rho''_def simp del: reach_window.simps dest!: reach_window_run_tj)
	+ have reach_ti: "reaches_on (w_run_t args) t0 (take i (map fst rho'')) ti"
	+ using valid_before(1) ij_le
	+ by (auto simp: take_map rho''_def)
	+ have reach_si: "reaches_on (w_run_sub args) sub (take i (map snd rho'')) si"
	+ using valid_before(1) ij_le
	+ by (auto simp: take_map rho''_def)
	+ have reach_sj: "reaches_on (w_run_sub args) sub (take j (map snd rho'')) sj"
	+ using valid_before(1) ij_le
	+ by (auto simp: take_map rho''_def simp del: reach_window.simps dest!: reach_window_run_sj)
	+ have reach_tj''': "reaches_on (w_run_t args) t0 (map fst rho'') tj'''"
	+ using reaches_on_trans[OF reach_tj before_end(1)[folded tj_def]] ij_le(2)
	+ by (auto simp del: map_append simp: rho''_def take_map drop_map map_append[symmetric])
	+ have rho''_mono: "\<And>i j. i \<le> j \<Longrightarrow> j < length rho'' \<Longrightarrow> ts_at rho'' i \<le> ts_at rho'' j"
	+ using ts_at_mono[OF reach_tj'''] .
	+ obtain tm' where reach_tm: "reaches_on (w_run_t args) t0
	+ (map fst (rho'' @ [(tm, undefined)])) tm'"
	+ using reaches_on_app[OF reach_tj'''] read_t_run[OF before_end(4)]
	+ by auto
	+ have tj'''_eq: "\<And>tj_cur. reaches_on (w_run_t args) t0 (map fst rho'') tj_cur \<Longrightarrow>
	+ tj_cur = tj'''"
	+ using reaches_on_inj[OF reach_tj''']
	+ by blast
	+ have reach_sj''': "reaches_on (w_run_sub args) sub (map snd rho'') sj'''"
	+ using reaches_on_trans[OF reach_sj before_end(2)[folded sj_def]] ij_le(2)
	+ by (auto simp del: map_append simp: rho''_def take_map drop_map map_append[symmetric])
	+ have sj'''_eq: "\<And>sj_cur. reaches_on (w_run_sub args) sub (map snd rho'') sj_cur \<Longrightarrow>
	+ sj_cur = sj'''"
	+ using reaches_on_inj[OF reach_sj''']
	+ by blast
	+ have reach_window_i: "rw t0 sub rho'' (i, ti, si, length rho'', tj''', sj''')"
	+ using reach_windowI[OF reach_ti reach_si reach_tj''' reach_sj''' _ refl] ij_le
	+ by (auto simp: rho''_def)
	+ have reach_window_j: "rw t0 sub rho'' (j, tj, sj, length rho'', tj''', sj''')"
	+ using reach_windowI[OF reach_tj reach_sj reach_tj''' reach_sj''' _ refl] ij_le
	+ by (auto simp: rho''_def)
	+ have t_def: "t = \<tau> \<sigma> i"
	+ using valid_before(6) read_t_run[OF before_end(3)] reaches_on_app[OF reach_ti]
	+ ts_at_tau[where ?rho="take i rho'' @ [(t, undefined)]"]
	+ by (fastforce simp: ti_def rho''_def valid_before(5,7) take_map ts_at_def nth_append)
	+ have t_tfin: "t \<in> tfin"
	+ using \<tau>_fin
	+ by (auto simp: t_def)
	+ have i_lt_rho'': "i < length rho''"
	+ using ij_le before_end(3,4,5) reach_window_i memR_tfin_refl[OF t_tfin]
	+ by (cases "i = length rho''") (auto simp: rho''_def ti_def dest!: reaches_on_NilD)
	+ obtain ti''' si''' b where tbi_def: "w_run_t args ti = Some (ti''', t)"
	+ "w_run_sub args si = Some (si''', b)" "t = ts_at rho'' i" "b = bs_at rho'' i"
	+ using reach_window_run_ti[OF reach_window_i i_lt_rho'']
	+ reach_window_run_si[OF reach_window_i i_lt_rho'']
	+ read_t_run[OF before_end(3), folded ti_def]
	+ by auto
	+ note before_end' = before_end(5)
	+ have read_ti: "w_read_t args ti = Some t"
	+ using run_t_read[OF tbi_def(1)] .
	+ have inv_before: "matchF_inv I t0 sub rho'' i ti si tj''' sj''' w"
	+ using valid_before' before_end(1,2,3) reach_window_j ij_le ti_def si_def j_def tj_def sj_def
	+ unfolding matchF_loop_inv_def valid_window_matchF_def
	+ by (auto simp: rho''_def ts_at_def nth_append)
	+ have i_j: "i \<le> j"
	+ using valid_before by auto
	+ have loop: "pred_option' (\<lambda>w'. matchF_inv I t0 sub rho'' i ti si tj''' sj''' w' \<and> \<not> matchF_cond I t w') (while_break (matchF_cond I t) (adv_end args) w)"
	+ proof (rule while_break_complete[of "matchF_inv I t0 sub rho'' i ti si tj''' sj'''", OF _ _ _ inv_before])
	+ fix w_cur :: "(bool iarray, nat set, 'd, 't, 'e) window"
	+ assume assms: "matchF_inv I t0 sub rho'' i ti si tj''' sj''' w_cur" "matchF_cond I t w_cur"
	+ define j_cur where "j_cur = w_j w_cur"
	+ define tj_cur where "tj_cur = w_tj w_cur"
	+ define sj_cur where "sj_cur = w_sj w_cur"
	+ define s_cur where "s_cur = w_s w_cur"
	+ define e_cur where "e_cur = w_e w_cur"
	+ have loop: "valid_window args t0 sub (take (w_j w_cur) rho'') w_cur"
	+ "rw t0 sub rho'' (j_cur, tj_cur, sj_cur, length rho'', tj''', sj''')"
	+ "\<And>l. l\<in>{w_i w_cur..<w_j w_cur} \<Longrightarrow> memR (ts_at rho'' i) (ts_at rho'' l) I"
	+ using j_cur_def tj_cur_def sj_cur_def s_cur_def e_cur_def
	+ assms(1)[unfolded matchF_loop_inv_def]
	+ by auto
	+ have j_cur_lt_rho'': "j_cur < length rho''"
	+ using assms tj'''_eq before_end(4,5)
	+ unfolding matchF_loop_inv_def matchF_loop_cond_def
	+ by (cases "j_cur = length rho''") (auto simp: j_cur_def split: option.splits)
	+ obtain tj_cur' sj_cur' x b_cur where tbi_cur_def: "w_run_t args tj_cur = Some (tj_cur', x)"
	+ "w_run_sub args sj_cur = Some (sj_cur', b_cur)"
	+ "x = ts_at rho'' j_cur" "b_cur = bs_at rho'' j_cur"
	+ using reach_window_run_ti[OF loop(2) j_cur_lt_rho'']
	+ reach_window_run_si[OF loop(2) j_cur_lt_rho'']
	+ by auto
	+ note reach_window_j'_cur = reach_window_shift[OF loop(2) j_cur_lt_rho'' tbi_cur_def(1,2)]
	+ note tbi_cur_def' = tbi_cur_def(1,2)[unfolded tj_cur_def sj_cur_def]
	+ have mono: "\<And>t'. t' \<in> set (map fst (take (w_j w_cur) rho'')) \<Longrightarrow> t' \<le> x"
	+ using rho''_mono[of _ j_cur] j_cur_lt_rho'' nat_less_le
	+ by (fastforce simp: tbi_cur_def(3) j_cur_def ts_at_def nth_append in_set_conv_nth
	+ split: list.splits)
	+ have take_unfold: "take (w_j w_cur) rho'' @ [(x, b_cur)] = (take (Suc (w_j w_cur)) rho'')"
	+ using j_cur_lt_rho''
	+ unfolding tbi_cur_def(3,4)
	+ by (auto simp: ts_at_def bs_at_def j_cur_def take_Suc_conv_app_nth)
	+ obtain w_cur' where w_cur'_def: "adv_end args w_cur = Some w_cur'"
	+ by (fastforce simp: adv_end_def Let_def tj_cur_def[symmetric] sj_cur_def[symmetric] tbi_cur_def(1,2) split: prod.splits)
	+ have "\<And>l. l \<in>{w_i w_cur'..<w_j w_cur'} \<Longrightarrow>
	+ memR (ts_at rho'' i) (ts_at rho'' l) I"
	+ using loop(3) assms(2) w_cur'_def
	+ unfolding adv_end_bounds[OF tbi_cur_def' w_cur'_def] matchF_loop_cond_def
	+ run_t_read[OF tbi_cur_def(1)[unfolded tj_cur_def]] tbi_cur_def(3) tbi_def(3)
	+ by (auto simp: j_cur_def elim: less_SucE)
	+ then show "pred_option' (matchF_inv I t0 sub rho'' i ti si tj''' sj''') (adv_end args w_cur)"
	+ using assms(1) reach_window_j'_cur valid_adv_end[OF loop(1) tbi_cur_def' mono]
	+ w_cur'_def adv_end_bounds[OF tbi_cur_def' w_cur'_def]
	+ unfolding matchF_loop_inv_def j_cur_def take_unfold
	+ by (auto simp: pred_option'_def)
	+ next
	+ {
	+ fix w1 w2
	+ assume lassms: "matchF_inv I t0 sub rho'' i ti si tj''' sj''' w1" "matchF_cond I t w1"
	+ "Some w2 = adv_end args w1"
	+ define j_cur where "j_cur = w_j w1"
	+ define tj_cur where "tj_cur = w_tj w1"
	+ define sj_cur where "sj_cur = w_sj w1"
	+ define s_cur where "s_cur = w_s w1"
	+ define e_cur where "e_cur = w_e w1"
	+ have loop: "valid_window args t0 sub (take (w_j w1) rho'') w1"
	+ "rw t0 sub rho'' (j_cur, tj_cur, sj_cur, length rho'', tj''', sj''')"
	+ "\<And>l. l\<in>{w_i w1..<w_j w1} \<Longrightarrow> memR (ts_at rho'' i) (ts_at rho'' l) I"
	+ using j_cur_def tj_cur_def sj_cur_def s_cur_def e_cur_def
	+ lassms(1)[unfolded matchF_loop_inv_def]
	+ by auto
	+ have j_cur_lt_rho'': "j_cur < length rho''"
	+ using lassms tj'''_eq ij_le before_end(4,5)
	+ unfolding matchF_loop_inv_def matchF_loop_cond_def
	+ by (cases "j_cur = length rho''") (auto simp: j_cur_def split: option.splits)
	+ obtain tj_cur' sj_cur' x b_cur where tbi_cur_def: "w_run_t args tj_cur = Some (tj_cur', x)"
	+ "w_run_sub args sj_cur = Some (sj_cur', b_cur)"
	+ "x = ts_at rho'' j_cur" "b_cur = bs_at rho'' j_cur"
	+ using reach_window_run_ti[OF loop(2) j_cur_lt_rho'']
	+ reach_window_run_si[OF loop(2) j_cur_lt_rho'']
	+ by auto
	+ note tbi_cur_def' = tbi_cur_def(1,2)[unfolded tj_cur_def sj_cur_def]
	+ have "length rho'' - w_j w2 < length rho'' - w_j w1"
	+ using j_cur_lt_rho'' adv_end_bounds[OF tbi_cur_def', folded lassms(3)]
	+ unfolding j_cur_def
	+ by auto
	+ }
	+ then have "{(ta, s). matchF_inv I t0 sub rho'' i ti si tj''' sj''' s \<and> matchF_cond I t s \<and>
	+ Some ta = adv_end args s} \<subseteq> measure (\<lambda>w. length rho'' - w_j w)"
	+ by auto
	+ then show "wf {(ta, s). matchF_inv I t0 sub rho'' i ti si tj''' sj''' s \<and> matchF_cond I t s \<and>
	+ Some ta = adv_end args s}"
	+ using wf_measure wf_subset
	+ by auto
	+ qed (auto simp add: inv_before)
	+ obtain w' where w'_def: "while_break (matchF_cond I t) (adv_end args) w = Some w'"
	+ using loop
	+ by (auto simp: pred_option'_def split: option.splits)
	+ define w'' where adv_start_last: "w'' = adv_start args w'"
	+ define st' where "st' = w_st w'"
	+ define i' where "i' = w_i w'"
	+ define ti' where "ti' = w_ti w'"
	+ define si' where "si' = w_si w'"
	+ define j' where "j' = w_j w'"
	+ define tj' where "tj' = w_tj w'"
	+ define sj' where "sj' = w_sj w'"
	+ define s' where "s' = w_s w'"
	+ define e' where "e' = w_e w'"
	+ have valid_after: "valid_window args t0 sub (take (w_j w') rho'') w'"
	+ "rw t0 sub rho'' (j', tj', sj', length rho'', tj''', sj''')"
	+ "\<And>l. l\<in>{i..<j'} \<Longrightarrow> memR (ts_at rho'' i) (ts_at rho'' l) I"
	+ "i' = i" "ti' = ti" "si' = si"
	+ using loop
	+ unfolding matchF_loop_inv_def w'_def i'_def ti'_def si'_def j'_def tj'_def sj'_def
	+ by (auto simp: pred_option'_def)
	+ define i'' where "i'' = w_i w''"
	+ define j'' where "j'' = w_j w''"
	+ define tj'' where "tj'' = w_tj w''"
	+ define sj'' where "sj'' = w_sj w''"
	+ have j'_le_rho'': "j' \<le> length rho''"
	+ using loop
	+ unfolding matchF_loop_inv_def valid_window_matchF_def w'_def j'_def
	+ by (auto simp: pred_option'_def)
	+ obtain te where tbj'_def: "w_read_t args tj' = Some te"
	+ "te = ts_at (rho'' @ [(tm, undefined)]) j'"
	+ proof (cases "j' < length rho''")
	+ case True
	+ show ?thesis
	+ using reach_window_run_ti[OF valid_after(2) True] that True
	+ by (auto simp: ts_at_def nth_append dest!: run_t_read)
	+ next
	+ case False
	+ then have "tj' = tj'''" "j' = length rho''"
	+ using valid_after(2) j'_le_rho'' tj'''_eq
	+ by auto
	+ then show ?thesis
	+ using that before_end(4)
	+ by (auto simp: ts_at_def nth_append)
	+ qed
	+ have not_ets_te: "\<not>memR (ts_at rho'' i) te I"
	+ using loop
	+ unfolding w'_def
	+ by (auto simp: pred_option'_def matchF_loop_cond_def tj'_def[symmetric] tbj'_def(1) tbi_def(3) split: option.splits)
	+ have i'_set: "\<And>l. l \<in> {i..<j'} \<Longrightarrow> memR (ts_at rho'' i) (ts_at rho'' l) I"
	+ "\<not>memR (ts_at rho'' i) (ts_at (rho'' @ [(tm, undefined)]) j') I"
	+ using loop tbj'_def not_ets_te valid_after atLeastLessThan_iff
	+ unfolding matchF_loop_inv_def matchF_loop_cond_def tbi_def(3)
	+ by (auto simp: tbi_def tj'_def split: option.splits)
	+ have i_le_j': "i \<le> j'"
	+ using valid_after(1)
	+ unfolding valid_after(4)[symmetric]
	+ by (auto simp: valid_window_def Let_def i'_def j'_def)
	+ have i_lt_j': "i < j'"
	+ using i_le_j' i'_set(2) i_lt_rho''
	+ using memR_tfin_refl[OF \<tau>_fin] ts_at_tau[OF reach_tj''', of j']
	+ by (cases "i = j'") (auto simp: ts_at_def nth_append)
	+ then have i'_lt_j': "i' < j'"
	+ unfolding valid_after
	+ by auto
	+ have adv_last_bounds: "i'' = Suc i'" "w_ti w'' = ti'''" "w_si w'' = si'''" "j'' = j'"
	+ "tj'' = tj'" "sj'' = sj'"
	+ using valid_adv_start_bounds[OF valid_after(1) i'_lt_j'[unfolded i'_def j'_def]]
	+ valid_adv_start_bounds'[OF valid_after(1) tbi_def(1,2)[folded valid_after(5,6),
	+ unfolded ti'_def si'_def]]
	+ unfolding adv_start_last i'_def i''_def j'_def j''_def tj'_def tj''_def sj'_def sj''_def
	+ by auto
	+ have i''_i: "i'' = i + 1"
	+ using valid_after adv_last_bounds by auto
	+ have i_le_j': "i \<le> j'"
	+ using valid_after i'_lt_j'
	+ by auto
	+ then have i_le_rho: "i \<le> length rho''"
	+ using valid_after(2)
	+ by auto
	+ have "valid_s init step st' accept (take j' rho'') i i j' s'"
	+ using valid_after(1,4) i'_def
	+ by (auto simp: valid_window_def Let_def init_def step_def st'_def accept_def j'_def s'_def)
	+ note valid_s' = this[unfolded valid_s_def]
	+ have q0_in_keys: "{0} \<in> mmap_keys s'"
	+ using valid_s' init_def steps_refl by auto
	+ then obtain q' tstp where lookup_s': "mmap_lookup s' {0} = Some (q', tstp)"
	+ by (auto dest: Mapping_keys_dest)
	+ have lookup_sup_acc: "snd (the (mmap_lookup s' {0})) =
	+ sup_acc step accept (take j' rho'') {0} i j'"
	+ using conjunct2[OF valid_s'] lookup_s'
	+ by auto (smt case_prodD option.simps(5))
	+ have b_alt: "(case snd (the (mmap_lookup s' {0})) of None \<Rightarrow> False
	+ \| Some tstp \<Rightarrow> memL t (fst tstp) I) \<longleftrightarrow> sat (MatchF I r) i"
	+ proof (rule iffI)
	+ assume assm: "case snd (the (mmap_lookup s' {0})) of None \<Rightarrow> False
	+ \| Some tstp \<Rightarrow> memL t (fst tstp) I"
	+ then obtain ts tp where tstp_def:
	+ "sup_acc step accept (take j' rho'') {0} i j' = Some (ts, tp)"
	+ "memL (ts_at rho'' i) ts I"
	+ unfolding lookup_sup_acc
	+ by (auto simp: tbi_def split: option.splits)
	+ then have sup_acc_rho'': "sup_acc step accept rho'' {0} i j' = Some (ts, tp)"
	+ using sup_acc_concat_cong[of j' "take j' rho''" step accept "drop j' rho''"] j'_le_rho''
	+ by auto
	+ have tp_props: "tp \<in> {i..<j'}" "acc step accept rho'' {0} (i, Suc tp)"
	+ using sup_acc_SomeE[OF sup_acc_rho''] by auto
	+ have ts_ts_at: "ts = ts_at rho'' tp"
	+ using sup_acc_Some_ts[OF sup_acc_rho''] .
	+ have i_le_tp: "i \<le> Suc tp"
	+ using tp_props by auto
	+ have "memR (ts_at rho'' i) (ts_at rho'' tp) I"
	+ using i'_set(1)[OF tp_props(1)] .
	+ then have "mem (ts_at rho'' i) (ts_at rho'' tp) I"
	+ using tstp_def(2) unfolding ts_ts_at mem_def by auto
	+ then show "sat (MatchF I r) i"
	+ using i_le_tp acc_match[OF reach_sj''' i_le_tp _ wf] tp_props(2) ts_at_tau[OF reach_tj''']
	+ tp_props(1) j'_le_rho''
	+ by auto
	+ next
	+ assume "sat (MatchF I r) i"
	+ then obtain l where l_def: "l \<ge> i" "mem (\<tau> \<sigma> i) (\<tau> \<sigma> l) I" "(i, Suc l) \<in> match r"
	+ by auto
	+ have l_lt_rho: "l < length rho''"
	+ proof (rule ccontr)
	+ assume contr: "\<not>l < length rho''"
	+ have "tm = ts_at (rho'' @ [(tm, undefined)]) (length rho'')"
	+ using i_le_rho
	+ by (auto simp add: ts_at_def rho''_def)
	+ moreover have "\<dots> \<le> \<tau> \<sigma> l"
	+ using \<tau>_mono ts_at_tau[OF reach_tm] i_le_rho contr
	+ by (metis One_nat_def Suc_eq_plus1 length_append lessI list.size(3)
	+ list.size(4) not_le_imp_less)
	+ moreover have "memR (\<tau> \<sigma> i) (\<tau> \<sigma> l) I"
	+ using l_def(2)
	+ unfolding mem_def
	+ by auto
	+ ultimately have "memR (\<tau> \<sigma> i) tm I"
	+ using memR_mono'
	+ by auto
	+ then show "False"
	+ using before_end' ts_at_tau[OF reach_tj''' i_lt_rho''] tbi_def(3)
	+ by (auto simp: rho''_def)
	+ qed
	+ have l_lt_j': "l < j'"
	+ proof (rule ccontr)
	+ assume contr: "\<not>l < j'"
	+ then have ts_at_j'_l: "ts_at rho'' j' \<le> ts_at rho'' l"
	+ using ts_at_mono[OF reach_tj'''] l_lt_rho
	+ by (auto simp add: order.not_eq_order_implies_strict)
	+ have ts_at_l_iu: "memR (ts_at rho'' i) (ts_at rho'' l) I"
	+ using l_def(2) ts_at_tau[OF reach_tj''' l_lt_rho] ts_at_tau[OF reach_tj''' i_lt_rho'']
	+ unfolding mem_def
	+ by auto
	+ show "False"
	+ using i'_set(2) ts_at_j'_l ts_at_l_iu contr l_lt_rho memR_mono'
	+ by (auto simp: ts_at_def nth_append split: if_splits)
	+ qed
	+ have i_le_Suc_l: "i \<le> Suc l"
	+ using l_def(1)
	+ by auto
	+ obtain tp where tstp_def: "sup_acc step accept rho'' {0} i j' = Some (ts_at rho'' tp, tp)"
	+ "l \<le> tp" "tp < j'"
	+ using l_def(1,3) l_lt_j' l_lt_rho
	+ by (meson accept_match[OF reach_sj''' i_le_Suc_l _ wf, unfolded steps_is_run] sup_acc_SomeI[unfolded acc_is_accept, of step accept] acc_is_accept atLeastLessThan_iff less_eq_Suc_le)
	+ have "memL (ts_at rho'' i) (ts_at rho'' l) I"
	+ using l_def(2)
	+ unfolding ts_at_tau[OF reach_tj''' i_lt_rho'', symmetric]
	+ ts_at_tau[OF reach_tj''' l_lt_rho, symmetric] mem_def
	+ by auto
	+ then have "memL (ts_at rho'' i) (ts_at rho'' tp) I"
	+ using ts_at_mono[OF reach_tj''' tstp_def(2)] tstp_def(3) j'_le_rho'' memL_mono'
	+ by auto
	+ then show "case snd (the (mmap_lookup s' {0})) of None \<Rightarrow> False
	+ \| Some tstp \<Rightarrow> memL t (fst tstp) I"
	+ using lookup_sup_acc tstp_def j'_le_rho''
	+ sup_acc_concat_cong[of j' "take j' rho''" step accept "drop j' rho''"]
	+ by (auto simp: tbi_def split: option.splits)
	+ qed
	+ have "valid_matchF I t0 sub (take j'' rho'') i'' (adv_start args w')"
	+ proof -
	+ have "\<forall>l \<in> {i'..<j'}. memR (ts_at rho'' i') (ts_at rho'' l) I"
	+ using loop i'_def j'_def valid_after
	+ unfolding matchF_loop_inv_def
	+ by auto
	+ then have "\<forall>l \<in> {i''..<j''}. memR (ts_at rho'' i'') ( ts_at rho'' l) I"
	+ unfolding i''_i valid_after adv_last_bounds
	+ apply safe
	+ subgoal for l
	+ apply (drule ballE[of _ _ l])
	+ using ts_at_mono[OF reach_tj''', of i "Suc i"] j'_le_rho'' memR_mono
	+ apply auto
	+ done
	+ done
	+ moreover have "rw t0 sub (take j'' rho'') (i'', ti''', si''', j'', tj'', sj'')"
	+ proof -
	+ have rw: "rw t0 sub (take j' rho'') (i', ti', si', j', tj', sj')"
	+ using valid_after(1)
	+ by (auto simp: valid_window_def Let_def i'_def ti'_def si'_def j'_def tj'_def sj'_def)
	+ show ?thesis
	+ using reach_window_shift[OF rw i'_lt_j'
	+ tbi_def(1,2)[unfolded valid_after(5,6)[symmetric]]] adv_last_bounds
	+ by auto
	+ qed
	+ moreover have "valid_window args t0 sub (take j' rho'') w''"
	+ using valid_adv_start[OF valid_after(1) i'_lt_j'[unfolded i'_def j'_def]]
	+ unfolding adv_start_last j'_def .
	+ ultimately show "valid_matchF I t0 sub (take j'' rho'') i'' (adv_start args w')"
	+ using j'_le_rho''
	+ unfolding valid_window_matchF_def adv_last_bounds adv_start_last[symmetric] i''_def[symmetric]
	+ j'_def j''_def[symmetric] tj'_def tj''_def[symmetric] sj'_def sj''_def[symmetric]
	+ by (auto simp: ts_at_def)
	+ qed
	+ moreover have "eval_mF I w = Some ((\<tau> \<sigma> i, sat (MatchF I r) i), w'')"
	+ unfolding j''_def adv_start_last[symmetric] adv_last_bounds valid_after rho''_def
	+ eval_matchF.simps run_t_read[OF tbi_def(1)[unfolded ti_def]]
	+ using tbj'_def[unfolded tj'_def] not_ets_te[folded tbi_def(3)]
	+ b_alt[unfolded s'_def] t_def adv_start_last w'_def
	+ by (auto simp only: Let_def split: option.splits if_splits)
	+ ultimately show ?thesis
	+ unfolding j''_def adv_start_last[symmetric] adv_last_bounds valid_after rho''_def
	+ by auto
	+qed
	+
	+lemma valid_eval_matchF_sound:
	+ assumes valid_before: "valid_matchF I t0 sub rho i w"
	+ and eval: "eval_mF I w = Some ((t, b), w'')"
	+ and bounded: "right I \<in> tfin"
	+ and wf: "wf_regex r"
	+shows "t = \<tau> \<sigma> i \<and> b = sat (MatchF I r) i \<and> (\<exists>rho'. valid_matchF I t0 sub rho' (Suc i) w'')"
	+proof -
	+ obtain rho' t tm where rho'_def: "reaches_on (w_run_t args) (w_tj w) (map fst rho') (w_tj w'')"
	+ "reaches_on (w_run_sub args) (w_sj w) (map snd rho') (w_sj w'')"
	+ "w_read_t args (w_ti w) = Some t"
	+ "w_read_t args (w_tj w'') = Some tm"
	+ "\<not>memR t tm I"
	+ using valid_eval_matchF_Some[OF assms(1-3)]
	+ by auto
	+ show ?thesis
	+ using valid_eval_matchF_complete[OF assms(1) rho'_def wf]
	+ unfolding eval
	+ by blast
	+qed
	+
	+thm valid_eval_matchP
	+thm valid_eval_matchF_sound
	+thm valid_eval_matchF_complete
	+
	+end
	+
	+end
	diff --git a/thys/VYDRA_MDL/Timestamp.thy b/thys/VYDRA_MDL/Timestamp.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Timestamp.thy
	@@ -0,0 +1,178 @@
	+theory Timestamp
	+ imports "HOL-Library.Extended_Nat" "HOL-Library.Extended_Real"
	+begin
	+
	+class embed_nat =
	+ fixes \<iota> :: "nat \<Rightarrow> 'a"
	+
	+class tfin =
	+ fixes tfin :: "'a set"
	+
	+class timestamp = comm_monoid_add + semilattice_sup + embed_nat + tfin +
	+ assumes \<iota>_mono: "\<And>i j. i \<le> j \<Longrightarrow> \<iota> i \<le> \<iota> j"
	+ and \<iota>_tfin: "\<And>i. \<iota> i \<in> tfin"
	+ and \<iota>_progressing: "x \<in> tfin \<Longrightarrow> \<exists>j. \<not>\<iota> j \<le> \<iota> i + x"
	+ and zero_tfin: "0 \<in> tfin"
	+ and tfin_closed: "c \<in> tfin \<Longrightarrow> d \<in> tfin \<Longrightarrow> c + d \<in> tfin"
	+ and add_mono: "c \<le> d \<Longrightarrow> a + c \<le> a + d"
	+ and add_pos: "a \<in> tfin \<Longrightarrow> 0 < c \<Longrightarrow> a < a + c"
	+begin
	+
	+lemma add_mono_comm:
	+ fixes a :: 'a
	+ shows "c \<le> d \<Longrightarrow> c + a \<le> d + a"
	+ by (auto simp: add.commute add_mono)
	+
	+end
	+
	+(* Extending time domain with infinity (None). *)
	+
	+instantiation option :: (timestamp) timestamp
	+begin
	+
	+definition tfin_option :: "'a option set" where
	+ "tfin_option = Some ` tfin"
	+
	+definition \<iota>_option :: "nat \<Rightarrow> 'a option" where
	+ "\<iota>_option = Some \<circ> \<iota>"
	+
	+definition zero_option :: "'a option" where
	+ "zero_option = Some 0"
	+
	+definition plus_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
	+ "plus_option x y = (case x of None \<Rightarrow> None \| Some x' \<Rightarrow> (case y of None \<Rightarrow> None \| Some y' \<Rightarrow> Some (x' + y')))"
	+
	+definition sup_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
	+ "sup_option x y = (case x of None \<Rightarrow> None \| Some x' \<Rightarrow> (case y of None \<Rightarrow> None \| Some y' \<Rightarrow> Some (sup x' y')))"
	+
	+definition less_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
	+ "less_option x y = (case x of None \<Rightarrow> False \| Some x' \<Rightarrow> (case y of None \<Rightarrow> True \| Some y' \<Rightarrow> x' < y'))"
	+
	+definition less_eq_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
	+ "less_eq_option x y = (case x of None \<Rightarrow> x = y \| Some x' \<Rightarrow> (case y of None \<Rightarrow> True \| Some y' \<Rightarrow> x' \<le> y'))"
	+
	+instance
	+ apply standard
	+ apply (auto simp: plus_option_def add.assoc split: option.splits)[1]
	+ apply (auto simp: plus_option_def add.commute split: option.splits)[1]
	+ apply (auto simp: zero_option_def plus_option_def split: option.splits)[1]
	+ apply (auto simp: less_option_def less_eq_option_def split: option.splits)[1]
	+ apply (auto simp: less_eq_option_def split: option.splits)[3]
	+ apply (auto simp: sup_option_def less_eq_option_def split: option.splits)[3]
	+ apply (auto simp: \<iota>_option_def less_eq_option_def intro: \<iota>_mono)[1]
	+ apply (auto simp: tfin_option_def \<iota>_option_def intro: \<iota>_tfin)[1]
	+ apply (auto simp: tfin_option_def \<iota>_option_def plus_option_def less_eq_option_def intro: \<iota>_progressing)[1]
	+ apply (auto simp: tfin_option_def zero_option_def intro: zero_tfin)[1]
	+ apply (auto simp: tfin_option_def plus_option_def intro: tfin_closed)[1]
	+ apply (auto simp: plus_option_def less_eq_option_def intro: add_mono split: option.splits)[1]
	+ apply (auto simp: tfin_option_def zero_option_def plus_option_def less_option_def intro: add_pos split: option.splits)
	+ done
	+
	+end
	+
	+instantiation enat :: timestamp
	+begin
	+
	+definition tfin_enat :: "enat set" where
	+ "tfin_enat = UNIV - {\<infinity>}"
	+
	+definition \<iota>_enat :: "nat \<Rightarrow> enat" where
	+ "\<iota>_enat n = n"
	+
	+instance
	+ by standard (auto simp add: \<iota>_enat_def tfin_enat_def dest!: leD)
	+
	+end
	+
	+instantiation ereal :: timestamp
	+begin
	+
	+definition \<iota>_ereal :: "nat \<Rightarrow> ereal" where
	+ "\<iota>_ereal n = ereal n"
	+
	+definition tfin_ereal :: "ereal set" where
	+ "tfin_ereal = UNIV - {-\<infinity>, \<infinity>}"
	+
	+lemma ereal_add_pos:
	+ fixes a :: ereal
	+ shows "a \<in> tfin \<Longrightarrow> 0 < c \<Longrightarrow> a < a + c"
	+ by (auto simp: tfin_ereal_def) (metis add.right_neutral ereal_add_cancel_left ereal_le_add_self order_less_le)
	+
	+instance
	+ by standard (auto simp add: \<iota>_ereal_def tfin_ereal_def add.commute ereal_add_le_add_iff2 not_le
	+ less_PInf_Ex_of_nat ereal_less_ereal_Ex reals_Archimedean2 intro: ereal_add_pos)
	+
	+end
	+
	+class timestamp_total = timestamp +
	+ assumes timestamp_total: "a \<le> b \<or> b \<le> a"
	+ assumes timestamp_tfin_le_not_tfin: "0 \<le> a \<Longrightarrow> a \<in> tfin \<Longrightarrow> 0 \<le> b \<Longrightarrow> b \<notin> tfin \<Longrightarrow> a \<le> b"
	+begin
	+
	+lemma add_not_tfin: "0 \<le> a \<Longrightarrow> a \<in> tfin \<Longrightarrow> a \<le> c \<Longrightarrow> c \<in> tfin \<Longrightarrow> 0 \<le> b \<Longrightarrow> b \<notin> tfin \<Longrightarrow> c < a + b"
	+ by (metis add_0_left local.add_mono_comm timestamp_tfin_le_not_tfin dual_order.order_iff_strict dual_order.strict_trans1)
	+
	+end
	+
	+instantiation enat :: timestamp_total
	+begin
	+
	+instance
	+ by standard (auto simp: tfin_enat_def)
	+
	+end
	+
	+instantiation ereal :: timestamp_total
	+begin
	+
	+instance
	+ by standard (auto simp: tfin_ereal_def)
	+
	+end
	+
	+class timestamp_strict = timestamp +
	+ assumes add_mono_strict: "c < d \<Longrightarrow> a + c < a + d"
	+
	+class timestamp_total_strict = timestamp_total + timestamp_strict
	+
	+instantiation nat :: timestamp_total_strict
	+begin
	+
	+definition tfin_nat :: "nat set" where
	+ "tfin_nat = UNIV"
	+
	+definition \<iota>_nat :: "nat \<Rightarrow> nat" where
	+ "\<iota>_nat n = n"
	+
	+instance
	+ by standard (auto simp: tfin_nat_def \<iota>_nat_def dest!: leD)
	+
	+end
	+
	+instantiation real :: timestamp_total_strict
	+begin
	+
	+definition tfin_real :: "real set" where "tfin_real = UNIV"
	+
	+definition \<iota>_real :: "nat \<Rightarrow> real" where "\<iota>_real n = real n"
	+
	+instance
	+ by standard (auto simp: tfin_real_def \<iota>_real_def not_le reals_Archimedean2)
	+
	+end
	+
	+instantiation prod :: (comm_monoid_add, comm_monoid_add) comm_monoid_add
	+begin
	+
	+definition zero_prod :: "'a \<times> 'b" where
	+ "zero_prod = (0, 0)"
	+
	+fun plus_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b" where
	+ "(a, b) + (c, d) = (a + c, b + d)"
	+
	+instance
	+ by standard (auto simp: zero_prod_def ac_simps)
	+
	+end
	+
	+end
	diff --git a/thys/VYDRA_MDL/Timestamp_Lex.thy b/thys/VYDRA_MDL/Timestamp_Lex.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Timestamp_Lex.thy
	@@ -0,0 +1,84 @@
	+theory Timestamp_Lex
	+ imports Timestamp
	+begin
	+
	+instantiation prod :: (timestamp_total_strict, timestamp_total_strict) timestamp_total_strict
	+begin
	+
	+definition tfin_prod :: "('a \<times> 'b) set" where
	+ "tfin_prod = tfin \<times> UNIV"
	+
	+definition \<iota>_prod :: "nat \<Rightarrow> 'a \<times> 'b" where
	+ "\<iota>_prod n = (\<iota> n, \<iota> n)"
	+
	+fun sup_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b" where
	+ "sup_prod (a, b) (c, d) = (if a < c then (c, d) else if c < a then (a, b) else (a, sup b d))"
	+
	+fun less_eq_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
	+ "less_eq_prod (a, b) (c, d) \<longleftrightarrow> a < c \<or> (a = c \<and> b \<le> d)"
	+
	+definition less_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
	+ "less_prod x y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
	+
	+instance
	+ apply standard
	+ apply (auto simp: zero_prod_def less_prod_def)[2]
	+ subgoal for x y z
	+ using order.strict_trans
	+ by (cases x; cases y; cases z) auto
	+ subgoal for x y
	+ by (cases x; cases y) auto
	+ subgoal for x y
	+ by (cases x; cases y) (auto simp add: sup.commute sup.strict_order_iff)
	+ subgoal for x y
	+ apply (cases x; cases y)
	+ apply (auto simp add: sup.commute sup.strict_order_iff)
	+ apply (metis sup.absorb_iff2 sup.order_iff timestamp_total)
	+ done
	+ subgoal for y x z
	+ by (cases x; cases y; cases z) auto
	+ subgoal for i j
	+ using \<iota>_mono less_le
	+ apply (auto simp: \<iota>_prod_def less_prod_def)
	+ by (simp add: \<iota>_mono)
	+ subgoal for i
	+ by (auto simp: \<iota>_prod_def tfin_prod_def intro: \<iota>_tfin)
	+ subgoal for x i
	+ apply (cases x)
	+ apply (auto simp: \<iota>_prod_def tfin_prod_def)
	+ apply (metis \<iota>_progressing dual_order.refl order_less_le)
	+ done
	+ apply (auto simp: tfin_prod_def tfin_closed)[1]
	+ apply (auto simp: zero_prod_def tfin_prod_def intro: zero_tfin)[1]
	+ subgoal for c d
	+ by (cases c; cases d) (auto simp: tfin_prod_def intro: tfin_closed)
	+ subgoal for c d a
	+ by (cases c; cases d; cases a) (auto simp: add_mono add_mono_strict)
	+ subgoal for a c
	+ apply (cases a; cases c)
	+ apply (auto simp: tfin_prod_def zero_prod_def)
	+ apply (metis less_eq_prod.simps add.right_neutral add_mono_strict less_prod_def order_le_less order_less_le prod.inject)
	+ done
	+ subgoal for c d a
	+ apply (cases c; cases d; cases a)
	+ apply (auto simp add: add_mono_strict less_prod_def order.strict_implies_order)
	+ apply (metis add_mono_strict sup.strict_order_iff)
	+ apply (metis add_mono_strict sup.strict_order_iff)
	+ by (metis add_mono_strict dual_order.order_iff_strict less_le_not_le)
	+ subgoal for a b
	+ apply (cases a; cases b)
	+ apply (auto)
	+ apply (metis antisym_conv1 timestamp_total)
	+ apply (metis antisym_conv1 timestamp_total)
	+ apply (metis antisym_conv1 timestamp_total)
	+ apply (metis timestamp_total)
	+ done
	+ subgoal for a b
	+ apply (cases a; cases b)
	+ apply (auto simp: zero_prod_def tfin_prod_def order_less_le timestamp_tfin_le_not_tfin)
	+ done
	+ done
	+
	+end
	+
	+end
	\ No newline at end of file
	diff --git a/thys/VYDRA_MDL/Timestamp_Prod.thy b/thys/VYDRA_MDL/Timestamp_Prod.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Timestamp_Prod.thy
	@@ -0,0 +1,49 @@
	+theory Timestamp_Prod
	+ imports Timestamp
	+begin
	+
	+instantiation prod :: (timestamp, timestamp) timestamp
	+begin
	+
	+definition tfin_prod :: "('a \<times> 'b) set" where
	+ "tfin_prod = tfin \<times> tfin"
	+
	+definition \<iota>_prod :: "nat \<Rightarrow> 'a \<times> 'b" where
	+ "\<iota>_prod n = (\<iota> n, \<iota> n)"
	+
	+fun sup_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b" where
	+ "sup_prod (a, b) (c, d) = (sup a c, sup b d)"
	+
	+fun less_eq_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
	+ "less_eq_prod (a, b) (c, d) \<longleftrightarrow> a \<le> c \<and> b \<le> d"
	+
	+definition less_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
	+ "less_prod x y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
	+
	+instance
	+ apply standard
	+ apply (auto simp: add.commute zero_prod_def less_prod_def)[7]
	+ subgoal for i j
	+ using \<iota>_mono \<iota>_mono less_le
	+ by (fastforce simp: \<iota>_prod_def less_prod_def)
	+ subgoal for i
	+ by (auto simp: \<iota>_prod_def tfin_prod_def intro: \<iota>_tfin)
	+ subgoal for x i
	+ apply (cases x)
	+ using \<iota>_progressing
	+ by (auto simp: tfin_prod_def \<iota>_prod_def)
	+ apply (auto simp: zero_prod_def tfin_prod_def intro: zero_tfin)[1]
	+ subgoal for c d
	+ by (cases c; cases d) (auto simp: tfin_prod_def intro: tfin_closed)
	+ subgoal for c d a
	+ by (cases c; cases d; cases a) (auto simp add: add_mono)
	+ subgoal for a c
	+ apply (cases a; cases c)
	+ apply (auto simp: tfin_prod_def zero_prod_def)
	+ apply (metis add.right_neutral add_pos less_eq_prod.simps less_prod_def order_less_le prod.inject timestamp_class.add_mono)
	+ done
	+ done
	+
	+end
	+
	+end
	diff --git a/thys/VYDRA_MDL/Trace.thy b/thys/VYDRA_MDL/Trace.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Trace.thy
	@@ -0,0 +1,112 @@
	+(<)
	+theory Trace
	+ imports "HOL-Library.Stream" Timestamp
	+begin
	+(>)
	+
	+section \<open>Infinite Traces\<close>
	+
	+inductive sorted_list :: "'a :: order list \<Rightarrow> bool" where
	+ [intro]: "sorted_list []"
	+\| [intro]: "sorted_list [x]"
	+\| [intro]: "x \<le> y \<Longrightarrow> sorted_list (y # ys) \<Longrightarrow> sorted_list (x # y # ys)"
	+
	+lemma sorted_list_app: "sorted_list xs \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> x \<le> y) \<Longrightarrow> sorted_list (xs @ [y])"
	+ by (induction xs rule: sorted_list.induct) auto
	+
	+lemma sorted_list_drop: "sorted_list xs \<Longrightarrow> sorted_list (drop n xs)"
	+proof (induction xs arbitrary: n rule: sorted_list.induct)
	+ case (2 x n)
	+ then show ?case
	+ by (cases n) auto
	+next
	+ case (3 x y ys n)
	+ then show ?case
	+ by (cases n) auto
	+qed auto
	+
	+lemma sorted_list_ConsD: "sorted_list (x # xs) \<Longrightarrow> sorted_list xs"
	+ by (auto elim: sorted_list.cases)
	+
	+lemma sorted_list_Cons_nth: "sorted_list (x # xs) \<Longrightarrow> j < length xs \<Longrightarrow> x \<le> xs ! j"
	+ by (induction "x # xs" arbitrary: x xs j rule: sorted_list.induct)
	+ (fastforce simp: nth_Cons split: nat.splits)+
	+
	+lemma sorted_list_atD: "sorted_list xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs ! i \<le> xs ! j"
	+proof (induction xs arbitrary: i j rule: sorted_list.induct)
	+ case (2 x i j)
	+ then show ?case
	+ by (cases i) auto
	+next
	+ case (3 x y ys i j)
	+ have "x \<le> (x # y # ys) ! j"
	+ using 3(5) sorted_list_Cons_nth[OF sorted_list.intros(3)[OF 3(1,2)]]
	+ by (auto simp: nth_Cons split: nat.splits)
	+ then show ?case
	+ using 3
	+ by (cases i) auto
	+qed auto
	+
	+coinductive ssorted :: "'a :: order stream \<Rightarrow> bool" where
	+ "shd s \<le> shd (stl s) \<Longrightarrow> ssorted (stl s) \<Longrightarrow> ssorted s"
	+
	+lemma ssorted_siterate[simp]: "(\<And>n. n \<le> f n) \<Longrightarrow> ssorted (siterate f n)"
	+ by (coinduction arbitrary: n) auto
	+
	+lemma ssortedD: "ssorted s \<Longrightarrow> s !! i \<le> stl s !! i"
	+ by (induct i arbitrary: s) (auto elim: ssorted.cases)
	+
	+lemma ssorted_sdrop: "ssorted s \<Longrightarrow> ssorted (sdrop i s)"
	+ by (coinduction arbitrary: i s) (auto elim: ssorted.cases ssortedD)
	+
	+lemma ssorted_monoD: "ssorted s \<Longrightarrow> i \<le> j \<Longrightarrow> s !! i \<le> s !! j"
	+proof (induct "j - i" arbitrary: j)
	+ case (Suc x)
	+ from Suc(1)[of "j - 1"] Suc(2-4) ssortedD[of s "j - 1"]
	+ show ?case by (cases j) (auto simp: le_Suc_eq Suc_diff_le)
	+qed simp
	+
	+lemma sorted_stake: "ssorted s \<Longrightarrow> sorted_list (stake i s)"
	+proof (induct i arbitrary: s)
	+ case (Suc i)
	+ then show ?case
	+ by (cases i) (auto elim: ssorted.cases)
	+qed auto
	+
	+lemma ssorted_monoI: "\<forall>i j. i \<le> j \<longrightarrow> s !! i \<le> s !! j \<Longrightarrow> ssorted s"
	+ by (coinduction arbitrary: s)
	+ (auto dest: spec2[of _ "Suc _" "Suc _"] spec2[of _ 0 "Suc 0"])
	+
	+lemma ssorted_iff_mono: "ssorted s \<longleftrightarrow> (\<forall>i j. i \<le> j \<longrightarrow> s !! i \<le> s !! j)"
	+ using ssorted_monoI ssorted_monoD by metis
	+
	+typedef (overloaded) ('a, 'b :: timestamp) trace = "{s :: ('a set \<times> 'b) stream.
	+ ssorted (smap snd s) \<and> (\<forall>x. x \<in> snd ` sset s \<longrightarrow> x \<in> tfin) \<and> (\<forall>i x. x \<in> tfin \<longrightarrow> (\<exists>j. \<not>snd (s !! j) \<le> snd (s !! i) + x))}"
	+ by (auto simp: \<iota>_mono \<iota>_tfin \<iota>_progressing stream.set_map
	+ intro!: exI[of _ "smap (\<lambda>n. ({}, \<iota> n)) nats"] ssorted_monoI)
	+
	+setup_lifting type_definition_trace
	+
	+lift_definition \<Gamma> :: "('a, 'b :: timestamp) trace \<Rightarrow> nat \<Rightarrow> 'a set" is
	+ "\<lambda>s i. fst (s !! i)" .
	+lift_definition \<tau> :: "('a, 'b :: timestamp) trace \<Rightarrow> nat \<Rightarrow> 'b" is
	+ "\<lambda>s i. snd (s !! i)" .
	+
	+lemma \<tau>_mono[simp]: "i \<le> j \<Longrightarrow> \<tau> s i \<le> \<tau> s j"
	+ by transfer (auto simp: ssorted_iff_mono)
	+
	+lemma \<tau>_fin: "\<tau> \<sigma> i \<in> tfin"
	+ by transfer auto
	+
	+lemma ex_lt_\<tau>: "x \<in> tfin \<Longrightarrow> \<exists>j. \<not>\<tau> s j \<le> \<tau> s i + x"
	+ by transfer auto
	+
	+lemma le_\<tau>_less: "\<tau> \<sigma> i \<le> \<tau> \<sigma> j \<Longrightarrow> j < i \<Longrightarrow> \<tau> \<sigma> i = \<tau> \<sigma> j"
	+ by (simp add: antisym)
	+
	+lemma less_\<tau>D: "\<tau> \<sigma> i < \<tau> \<sigma> j \<Longrightarrow> i < j"
	+ by (meson \<tau>_mono less_le_not_le not_le_imp_less)
	+
	+(<)
	+end
	+(>)
	diff --git a/thys/VYDRA_MDL/Window.thy b/thys/VYDRA_MDL/Window.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/Window.thy
	@@ -0,0 +1,1817 @@
	+theory Window
	+ imports "HOL-Library.AList" "HOL-Library.Mapping" "HOL-Library.While_Combinator" Timestamp
	+begin
	+
	+type_synonym ('a, 'b) mmap = "('a \<times> 'b) list"
	+
	+(* 'b is a polymorphic input symbol; 'c is a polymorphic DFA state;
	+ 'd is a timestamp; 'e is a submonitor state *)
	+
	+inductive chain_le :: "'d :: timestamp list \<Rightarrow> bool" where
	+ chain_le_Nil: "chain_le []"
	+\| chain_le_singleton: "chain_le [x]"
	+\| chain_le_cons: "chain_le (y # xs) \<Longrightarrow> x \<le> y \<Longrightarrow> chain_le (x # y # xs)"
	+
	+lemma chain_le_app: "chain_le (zs @ [z]) \<Longrightarrow> z \<le> w \<Longrightarrow> chain_le ((zs @ [z]) @ [w])"
	+ apply (induction "zs @ [z]" arbitrary: zs rule: chain_le.induct)
	+ apply (auto intro: chain_le.intros)[2]
	+ subgoal for y xs x zs
	+ apply (cases zs)
	+ apply (auto)
	+ apply (metis append.assoc append_Cons append_Nil chain_le_cons)
	+ done
	+ done
	+
	+inductive reaches_on :: "('e \<Rightarrow> ('e \<times> 'f) option) \<Rightarrow> 'e \<Rightarrow> 'f list \<Rightarrow> 'e \<Rightarrow> bool"
	+ for run :: "'e \<Rightarrow> ('e \<times> 'f) option" where
	+ "reaches_on run s [] s"
	+ \| "run s = Some (s', v) \<Longrightarrow> reaches_on run s' vs s'' \<Longrightarrow> reaches_on run s (v # vs) s''"
	+
	+lemma reaches_on_init_Some: "reaches_on r s xs s' \<Longrightarrow> r s' \<noteq> None \<Longrightarrow> r s \<noteq> None"
	+ by (auto elim: reaches_on.cases)
	+
	+lemma reaches_on_split: "reaches_on run s vs s' \<Longrightarrow> i < length vs \<Longrightarrow>
	+ \<exists>s'' s'''. reaches_on run s (take i vs) s'' \<and> run s'' = Some (s''', vs ! i) \<and> reaches_on run s''' (drop (Suc i) vs) s'"
	+proof (induction s vs s' arbitrary: i rule: reaches_on.induct)
	+ case (2 s s' v vs s'')
	+ show ?case
	+ using 2(1,2)
	+ proof (cases i)
	+ case (Suc n)
	+ show ?thesis
	+ using 2
	+ by (fastforce simp: Suc intro: reaches_on.intros)
	+ qed (auto intro: reaches_on.intros)
	+qed auto
	+
	+lemma reaches_on_split': "reaches_on run s vs s' \<Longrightarrow> i \<le> length vs \<Longrightarrow>
	+ \<exists>s'' . reaches_on run s (take i vs) s'' \<and> reaches_on run s'' (drop i vs) s'"
	+proof (induction s vs s' arbitrary: i rule: reaches_on.induct)
	+ case (2 s s' v vs s'')
	+ show ?case
	+ using 2(1,2)
	+ proof (cases i)
	+ case (Suc n)
	+ show ?thesis
	+ using 2
	+ by (fastforce simp: Suc intro: reaches_on.intros)
	+ qed (auto intro: reaches_on.intros)
	+qed (auto intro: reaches_on.intros)
	+
	+lemma reaches_on_split_app: "reaches_on run s (vs @ vs') s' \<Longrightarrow>
	+ \<exists>s''. reaches_on run s vs s'' \<and> reaches_on run s'' vs' s'"
	+ using reaches_on_split'[where i="length vs", of run s "vs @ vs'" s']
	+ by auto
	+
	+lemma reaches_on_inj: "reaches_on run s vs t \<Longrightarrow> reaches_on run s vs' t' \<Longrightarrow>
	+ length vs = length vs' \<Longrightarrow> vs = vs' \<and> t = t'"
	+ apply (induction s vs t arbitrary: vs' t' rule: reaches_on.induct)
	+ apply (auto elim: reaches_on.cases)[1]
	+ subgoal for s s' v vs s'' vs' t'
	+ apply (rule reaches_on.cases[of run s' vs s'']; rule reaches_on.cases[of run s vs' t'])
	+ apply assumption+
	+ apply auto[2]
	+ apply fastforce
	+ apply (metis length_0_conv list.discI)
	+ apply (metis Pair_inject length_Cons nat.inject option.inject)
	+ done
	+ done
	+
	+lemma reaches_on_split_last: "reaches_on run s (xs @ [x]) s'' \<Longrightarrow>
	+ \<exists>s'. reaches_on run s xs s' \<and> run s' = Some (s'', x)"
	+ apply (induction s "xs @ [x]" s'' arbitrary: xs x rule: reaches_on.induct)
	+ apply simp
	+ subgoal for s s' v vs s'' xs x
	+ by (cases vs rule: rev_cases) (fastforce elim: reaches_on.cases intro: reaches_on.intros)+
	+ done
	+
	+lemma reaches_on_rev_induct[consumes 1]: "reaches_on run s vs s' \<Longrightarrow>
	+ (\<And>s. P s [] s) \<Longrightarrow>
	+ (\<And>s s' v vs s''. reaches_on run s vs s' \<Longrightarrow> P s vs s' \<Longrightarrow> run s' = Some (s'', v) \<Longrightarrow>
	+ P s (vs @ [v]) s'') \<Longrightarrow>
	+ P s vs s'"
	+proof (induction vs arbitrary: s s' rule: rev_induct)
	+ case (snoc x xs)
	+ from snoc(2) obtain s'' where s''_def: "reaches_on run s xs s''" "run s'' = Some (s', x)"
	+ using reaches_on_split_last
	+ by fast
	+ show ?case
	+ using snoc(4)[OF s''_def(1) _ s''_def(2)] snoc(1)[OF s''_def(1) snoc(3,4)]
	+ by auto
	+qed (auto elim: reaches_on.cases)
	+
	+lemma reaches_on_app: "reaches_on run s vs s' \<Longrightarrow> run s' = Some (s'', v) \<Longrightarrow>
	+ reaches_on run s (vs @ [v]) s''"
	+ by (induction s vs s' rule: reaches_on.induct) (auto intro: reaches_on.intros)
	+
	+lemma reaches_on_trans: "reaches_on run s vs s' \<Longrightarrow> reaches_on run s' vs' s'' \<Longrightarrow>
	+ reaches_on run s (vs @ vs') s''"
	+ by (induction s vs s' rule: reaches_on.induct) (auto intro: reaches_on.intros)
	+
	+lemma reaches_onD: "reaches_on run s ((t, b) # vs) s' \<Longrightarrow>
	+ \<exists>s''. run s = Some (s'', (t, b)) \<and> reaches_on run s'' vs s'"
	+ by (auto elim: reaches_on.cases)
	+
	+lemma reaches_on_setD: "reaches_on run s vs s' \<Longrightarrow> x \<in> set vs \<Longrightarrow>
	+ \<exists>vs' vs'' s''. reaches_on run s (vs' @ [x]) s'' \<and> reaches_on run s'' vs'' s' \<and> vs = vs' @ x # vs''"
	+proof (induction s vs s' rule: reaches_on_rev_induct)
	+ case (2 s s' v vs s'')
	+ show ?case
	+ proof (cases "x \<in> set vs")
	+ case True
	+ obtain vs' vs'' s''' where split_def: "reaches_on run s (vs' @ [x]) s'''"
	+ "reaches_on run s''' vs'' s'" "vs = vs' @ x # vs''"
	+ using 2(3)[OF True]
	+ by auto
	+ show ?thesis
	+ using split_def(1,3) reaches_on_app[OF split_def(2) 2(2)]
	+ by auto
	+ next
	+ case False
	+ have x_v: "x = v"
	+ using 2(4) False
	+ by auto
	+ show ?thesis
	+ unfolding x_v
	+ using reaches_on_app[OF 2(1,2)] reaches_on.intros(1)[of run s'']
	+ by auto
	+ qed
	+qed auto
	+
	+lemma reaches_on_len: "\<exists>vs s'. reaches_on run s vs s' \<and> (length vs = n \<or> run s' = None)"
	+proof (induction n arbitrary: s)
	+ case (Suc n)
	+ show ?case
	+ proof (cases "run s")
	+ case (Some x)
	+ obtain s' v where x_def: "x = (s', v)"
	+ by (cases x) auto
	+ obtain vs s'' where s''_def: "reaches_on run s' vs s''" "length vs = n \<or> run s'' = None"
	+ using Suc[of s']
	+ by auto
	+ show ?thesis
	+ using reaches_on.intros(2)[OF Some[unfolded x_def] s''_def(1)] s''_def(2)
	+ by fastforce
	+ qed (auto intro: reaches_on.intros)
	+qed (auto intro: reaches_on.intros)
	+
	+lemma reaches_on_NilD: "reaches_on run q [] q' \<Longrightarrow> q = q'"
	+ by (auto elim: reaches_on.cases)
	+
	+lemma reaches_on_ConsD: "reaches_on run q (x # xs) q' \<Longrightarrow> \<exists>q''. run q = Some (q'', x) \<and> reaches_on run q'' xs q'"
	+ by (auto elim: reaches_on.cases)
	+
	+inductive reaches :: "('e \<Rightarrow> ('e \<times> 'f) option) \<Rightarrow> 'e \<Rightarrow> nat \<Rightarrow> 'e \<Rightarrow> bool"
	+ for run :: "'e \<Rightarrow> ('e \<times> 'f) option" where
	+ "reaches run s 0 s"
	+ \| "run s = Some (s', v) \<Longrightarrow> reaches run s' n s'' \<Longrightarrow> reaches run s (Suc n) s''"
	+
	+lemma reaches_Suc_split_last: "reaches run s (Suc n) s' \<Longrightarrow> \<exists>s'' x. reaches run s n s'' \<and> run s'' = Some (s', x)"
	+proof (induction n arbitrary: s)
	+ case (Suc n)
	+ obtain s'' x where s''_def: "run s = Some (s'', x)" "reaches run s'' (Suc n) s'"
	+ using Suc(2)
	+ by (auto elim: reaches.cases)
	+ show ?case
	+ using s''_def(1) Suc(1)[OF s''_def(2)]
	+ by (auto intro: reaches.intros)
	+qed (auto elim!: reaches.cases intro: reaches.intros)
	+
	+lemma reaches_invar: "reaches f x n y \<Longrightarrow> P x \<Longrightarrow> (\<And>z z' v. P z \<Longrightarrow> f z = Some (z', v) \<Longrightarrow> P z') \<Longrightarrow> P y"
	+ by (induction x n y rule: reaches.induct) auto
	+
	+lemma reaches_cong: "reaches f x n y \<Longrightarrow> P x \<Longrightarrow> (\<And>z z' v. P z \<Longrightarrow> f z = Some (z', v) \<Longrightarrow> P z') \<Longrightarrow> (\<And>z. P z \<Longrightarrow> f' (g z) = map_option (apfst g) (f z)) \<Longrightarrow> reaches f' (g x) n (g y)"
	+ by (induction x n y rule: reaches.induct) (auto intro: reaches.intros)
	+
	+lemma reaches_on_n: "reaches_on run s vs s' \<Longrightarrow> reaches run s (length vs) s'"
	+ by (induction s vs s' rule: reaches_on.induct) (auto intro: reaches.intros)
	+
	+lemma reaches_on: "reaches run s n s' \<Longrightarrow> \<exists>vs. reaches_on run s vs s' \<and> length vs = n"
	+ by (induction s n s' rule: reaches.induct) (auto intro: reaches_on.intros)
	+
	+definition ts_at :: "('d \<times> 'b) list \<Rightarrow> nat \<Rightarrow> 'd" where
	+ "ts_at rho i = fst (rho ! i)"
	+
	+definition bs_at :: "('d \<times> 'b) list \<Rightarrow> nat \<Rightarrow> 'b" where
	+ "bs_at rho i = snd (rho ! i)"
	+
	+fun sub_bs :: "('d \<times> 'b) list \<Rightarrow> nat \<times> nat \<Rightarrow> 'b list" where
	+ "sub_bs rho (i, j) = map (bs_at rho) [i..<j]"
	+
	+definition steps :: "('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('d \<times> 'b) list \<Rightarrow> 'c \<Rightarrow> nat \<times> nat \<Rightarrow> 'c" where
	+ "steps step rho q ij = foldl step q (sub_bs rho ij)"
	+
	+definition acc :: "('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('c \<Rightarrow> bool) \<Rightarrow> ('d \<times> 'b) list \<Rightarrow>
	+ 'c \<Rightarrow> nat \<times> nat \<Rightarrow> bool" where
	+ "acc step accept rho q ij = accept (steps step rho q ij)"
	+
	+definition sup_acc :: "('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('c \<Rightarrow> bool) \<Rightarrow> ('d \<times> 'b) list \<Rightarrow>
	+ 'c \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('d \<times> nat) option" where
	+ "sup_acc step accept rho q i j =
	+ (let L' = {l \<in> {i..<j}. acc step accept rho q (i, Suc l)}; m = Max L' in
	+ if L' = {} then None else Some (ts_at rho m, m))"
	+
	+definition sup_leadsto :: "'c \<Rightarrow> ('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('d \<times> 'b) list \<Rightarrow>
	+ nat \<Rightarrow> nat \<Rightarrow> 'c \<Rightarrow> 'd option" where
	+ "sup_leadsto init step rho i j q =
	+ (let L' = {l. l < i \<and> steps step rho init (l, j) = q}; m = Max L' in
	+ if L' = {} then None else Some (ts_at rho m))"
	+
	+definition mmap_keys :: "('a, 'b) mmap \<Rightarrow> 'a set" where
	+ "mmap_keys kvs = set (map fst kvs)"
	+
	+definition mmap_lookup :: "('a, 'b) mmap \<Rightarrow> 'a \<Rightarrow> 'b option" where
	+ "mmap_lookup = map_of"
	+
	+definition valid_s :: "'c \<Rightarrow> ('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('c \<times> 'b, 'c) mapping \<Rightarrow> ('c \<Rightarrow> bool) \<Rightarrow>
	+ ('d \<times> 'b) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('c, 'c \<times> ('d \<times> nat) option) mmap \<Rightarrow> bool" where
	+ "valid_s init step st accept rho u i j s \<equiv>
	+ (\<forall>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v) \<and>
	+ (mmap_keys s = {q. (\<exists>l \<le> u. steps step rho init (l, i) = q)} \<and> distinct (map fst s) \<and>
	+ (\<forall>q. case mmap_lookup s q of None \<Rightarrow> True
	+ \| Some (q', tstp) \<Rightarrow> steps step rho q (i, j) = q' \<and> tstp = sup_acc step accept rho q i j))"
	+
	+record ('b, 'c, 'd, 't, 'e) args =
	+ w_init :: 'c
	+ w_step :: "'c \<Rightarrow> 'b \<Rightarrow> 'c"
	+ w_accept :: "'c \<Rightarrow> bool"
	+ w_run_t :: "'t \<Rightarrow> ('t \<times> 'd) option"
	+ w_read_t :: "'t \<Rightarrow> 'd option"
	+ w_run_sub :: "'e \<Rightarrow> ('e \<times> 'b) option"
	+
	+record ('b, 'c, 'd, 't, 'e) window =
	+ w_st :: "('c \<times> 'b, 'c) mapping"
	+ w_ac :: "('c, bool) mapping"
	+ w_i :: nat
	+ w_ti :: 't
	+ w_si :: 'e
	+ w_j :: nat
	+ w_tj :: 't
	+ w_sj :: 'e
	+ w_s :: "('c, 'c \<times> ('d \<times> nat) option) mmap"
	+ w_e :: "('c, 'd) mmap"
	+
	+copy_bnf (dead 'b, dead 'c, dead 'd, dead 't, 'e, dead 'ext) window_ext
	+
	+fun reach_window :: "('b, 'c, 'd, 't, 'e) args \<Rightarrow> 't \<Rightarrow> 'e \<Rightarrow>
	+ ('d \<times> 'b) list \<Rightarrow> nat \<times> 't \<times> 'e \<times> nat \<times> 't \<times> 'e \<Rightarrow> bool" where
	+ "reach_window args t0 sub rho (i, ti, si, j, tj, sj) \<longleftrightarrow> i \<le> j \<and> length rho = j \<and>
	+ reaches_on (w_run_t args) t0 (take i (map fst rho)) ti \<and>
	+ reaches_on (w_run_t args) ti (drop i (map fst rho)) tj \<and>
	+ reaches_on (w_run_sub args) sub (take i (map snd rho)) si \<and>
	+ reaches_on (w_run_sub args) si (drop i (map snd rho)) sj"
	+
	+lemma reach_windowI: "reaches_on (w_run_t args) t0 (take i (map fst rho)) ti \<Longrightarrow>
	+ reaches_on (w_run_sub args) sub (take i (map snd rho)) si \<Longrightarrow>
	+ reaches_on (w_run_t args) t0 (map fst rho) tj \<Longrightarrow>
	+ reaches_on (w_run_sub args) sub (map snd rho) sj \<Longrightarrow>
	+ i \<le> length rho \<Longrightarrow> length rho = j \<Longrightarrow>
	+ reach_window args t0 sub rho (i, ti, si, j, tj, sj)"
	+ by auto (metis reaches_on_split'[of _ _ _ _ i] length_map reaches_on_inj)+
	+
	+lemma reach_window_shift:
	+ assumes "reach_window args t0 sub rho (i, ti, si, j, tj, sj)" "i < j"
	+ "w_run_t args ti = Some (ti', t)" "w_run_sub args si = Some (si', s)"
	+ shows "reach_window args t0 sub rho (Suc i, ti', si', j, tj, sj)"
	+ using reaches_on_app[of "w_run_t args" t0 "take i (map fst rho)" ti ti' t]
	+ reaches_on_app[of "w_run_sub args" sub "take i (map snd rho)" si si' s] assms
	+ apply (auto)
	+ apply (smt append_take_drop_id id_take_nth_drop length_map list.discI list.inject
	+ option.inject reaches_on.cases same_append_eq snd_conv take_Suc_conv_app_nth)
	+ apply (smt Cons_nth_drop_Suc fst_conv length_map list.discI list.inject option.inject
	+ reaches_on.cases)
	+ apply (smt append_take_drop_id id_take_nth_drop length_map list.discI list.inject
	+ option.inject reaches_on.cases same_append_eq snd_conv take_Suc_conv_app_nth)
	+ apply (smt Cons_nth_drop_Suc fst_conv length_map list.discI list.inject option.inject
	+ reaches_on.cases)
	+ done
	+
	+lemma reach_window_run_ti: "reach_window args t0 sub rho (i, ti, si, j, tj, sj) \<Longrightarrow>
	+ i < j \<Longrightarrow> \<exists>ti'. reaches_on (w_run_t args) t0 (take i (map fst rho)) ti \<and>
	+ w_run_t args ti = Some (ti', ts_at rho i) \<and>
	+ reaches_on (w_run_t args) ti' (drop (Suc i) (map fst rho)) tj"
	+ apply (auto simp: ts_at_def elim!: reaches_on.cases[of "w_run_t args" ti "drop i (map fst rho)"])
	+ using nth_via_drop apply fastforce
	+ by (metis Cons_nth_drop_Suc length_map list.inject)
	+
	+lemma reach_window_run_si: "reach_window args t0 sub rho (i, ti, si, j, tj, sj) \<Longrightarrow>
	+ i < j \<Longrightarrow> \<exists>si'. reaches_on (w_run_sub args) sub (take i (map snd rho)) si \<and>
	+ w_run_sub args si = Some (si', bs_at rho i) \<and>
	+ reaches_on (w_run_sub args) si' (drop (Suc i) (map snd rho)) sj"
	+ apply (auto simp: bs_at_def elim!: reaches_on.cases[of "w_run_sub args" si "drop i (map snd rho)"])
	+ using nth_via_drop apply fastforce
	+ by (metis Cons_nth_drop_Suc length_map list.inject)
	+
	+lemma reach_window_run_tj: "reach_window args t0 sub rho (i, ti, si, j, tj, sj) \<Longrightarrow>
	+ reaches_on (w_run_t args) t0 (map fst rho) tj"
	+ using reaches_on_trans
	+ by fastforce
	+
	+lemma reach_window_run_sj: "reach_window args t0 sub rho (i, ti, si, j, tj, sj) \<Longrightarrow>
	+ reaches_on (w_run_sub args) sub (map snd rho) sj"
	+ using reaches_on_trans
	+ by fastforce
	+
	+lemma reach_window_shift_all: "reach_window args t0 sub rho (i, si, ti, j, sj, tj) \<Longrightarrow>
	+ reach_window args t0 sub rho (j, sj, tj, j, sj, tj)"
	+ using reach_window_run_tj[of args t0 sub rho] reach_window_run_sj[of args t0 sub rho]
	+ by (auto intro: reaches_on.intros)
	+
	+lemma reach_window_app: "reach_window args t0 sub rho (i, si, ti, j, tj, sj) \<Longrightarrow>
	+ w_run_t args tj = Some (tj', x) \<Longrightarrow> w_run_sub args sj = Some (sj', y) \<Longrightarrow>
	+ reach_window args t0 sub (rho @ [(x, y)]) (i, si, ti, Suc j, tj', sj')"
	+ by (fastforce simp add: reaches_on_app)
	+
	+fun init_args :: "('c \<times> ('c \<Rightarrow> 'b \<Rightarrow> 'c) \<times> ('c \<Rightarrow> bool)) \<Rightarrow>
	+ (('t \<Rightarrow> ('t \<times> 'd) option) \<times> ('t \<Rightarrow> 'd option)) \<Rightarrow>
	+ ('e \<Rightarrow> ('e \<times> 'b) option) \<Rightarrow> ('b, 'c, 'd, 't, 'e) args" where
	+ "init_args (init, step, accept) (run_t, read_t) run_sub =
	+ \<lparr>w_init = init, w_step = step, w_accept = accept, w_run_t = run_t, w_read_t = read_t, w_run_sub = run_sub\<rparr>"
	+
	+fun init_window :: "('b, 'c, 'd, 't, 'e) args \<Rightarrow> 't \<Rightarrow> 'e \<Rightarrow> ('b, 'c, 'd, 't, 'e) window" where
	+ "init_window args t0 sub = \<lparr>w_st = Mapping.empty, w_ac = Mapping.empty,
	+ w_i = 0, w_ti = t0, w_si = sub, w_j = 0, w_tj = t0, w_sj = sub,
	+ w_s =[(w_init args, (w_init args, None))], w_e = []\<rparr>"
	+
	+definition valid_window :: "('b, 'c, 'd :: timestamp, 't, 'e) args \<Rightarrow> 't \<Rightarrow> 'e \<Rightarrow> ('d \<times> 'b) list \<Rightarrow>
	+ ('b, 'c, 'd, 't, 'e) window \<Rightarrow> bool" where
	+ "valid_window args t0 sub rho w \<longleftrightarrow>
	+ (let init = w_init args; step = w_step args; accept = w_accept args;
	+ run_t = w_run_t args; run_sub = w_run_sub args;
	+ st = w_st w; ac = w_ac w;
	+ i = w_i w; ti = w_ti w; si = w_si w; j = w_j w; tj = w_tj w; sj = w_sj w;
	+ s = w_s w; e = w_e w in
	+ (reach_window args t0 sub rho (i, ti, si, j, tj, sj) \<and>
	+ (\<forall>i j. i \<le> j \<and> j < length rho \<longrightarrow> ts_at rho i \<le> ts_at rho j) \<and>
	+ (\<forall>q. case Mapping.lookup ac q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v) \<and>
	+ (\<forall>q. mmap_lookup e q = sup_leadsto init step rho i j q) \<and> distinct (map fst e) \<and>
	+ valid_s init step st accept rho i i j s))"
	+
	+lemma valid_init_window: "valid_window args t0 sub [] (init_window args t0 sub)"
	+ by (auto simp: valid_window_def mmap_keys_def mmap_lookup_def sup_leadsto_def
	+ valid_s_def steps_def sup_acc_def intro: reaches_on.intros split: option.splits)
	+
	+lemma steps_app_cong: "j \<le> length rho \<Longrightarrow> steps step (rho @ [x]) q (i, j) =
	+ steps step rho q (i, j)"
	+proof -
	+ assume "j \<le> length rho"
	+ then have map_cong: "map (bs_at (rho @ [x])) [i..<j] = map (bs_at rho) [i..<j]"
	+ by (auto simp: bs_at_def nth_append)
	+ show ?thesis
	+ by (auto simp: steps_def map_cong)
	+qed
	+
	+lemma acc_app_cong: "j < length rho \<Longrightarrow> acc step accept (rho @ [x]) q (i, j) =
	+ acc step accept rho q (i, j)"
	+ by (auto simp: acc_def bs_at_def nth_append steps_app_cong)
	+
	+lemma sup_acc_app_cong: "j \<le> length rho \<Longrightarrow> sup_acc step accept (rho @ [x]) q i j =
	+ sup_acc step accept rho q i j"
	+ apply (auto simp: sup_acc_def Let_def ts_at_def nth_append acc_def)
	+ apply (metis (mono_tags, opaque_lifting) less_eq_Suc_le order_less_le_trans steps_app_cong)+
	+ done
	+
	+lemma sup_acc_concat_cong: "j \<le> length rho \<Longrightarrow> sup_acc step accept (rho @ rho') q i j =
	+ sup_acc step accept rho q i j"
	+ apply (induction rho' rule: rev_induct)
	+ apply auto
	+ apply (smt append.assoc le_add1 le_trans length_append sup_acc_app_cong)
	+ done
	+
	+lemma sup_leadsto_app_cong: "i \<le> j \<Longrightarrow> j \<le> length rho \<Longrightarrow>
	+ sup_leadsto init step (rho @ [x]) i j q = sup_leadsto init step rho i j q"
	+proof -
	+ assume assms: "i \<le> j" "j \<le> length rho"
	+ define L' where "L' = {l. l < i \<and> steps step rho init (l, j) = q}"
	+ define L'' where "L'' = {l. l < i \<and> steps step (rho @ [x]) init (l, j) = q}"
	+ show ?thesis
	+ using assms
	+ by (cases "L' = {}")
	+ (auto simp: sup_leadsto_def L'_def L''_def ts_at_def nth_append steps_app_cong)
	+qed
	+
	+lemma chain_le:
	+ fixes xs :: "'d :: timestamp list"
	+ shows "chain_le xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs ! i \<le> xs ! j"
	+proof (induction xs arbitrary: i j rule: chain_le.induct)
	+ case (chain_le_cons y xs x)
	+ then show ?case
	+ proof (cases i)
	+ case 0
	+ then show ?thesis
	+ using chain_le_cons
	+ apply (cases j)
	+ apply auto
	+ apply (metis (no_types, lifting) le_add1 le_add_same_cancel1 le_less less_le_trans nth_Cons_0)
	+ done
	+ qed auto
	+qed auto
	+
	+lemma steps_refl[simp]: "steps step rho q (i, i) = q"
	+ unfolding steps_def by auto
	+
	+lemma steps_split: "i < j \<Longrightarrow> steps step rho q (i, j) =
	+ steps step rho (step q (bs_at rho i)) (Suc i, j)"
	+ unfolding steps_def by (simp add: upt_rec)
	+
	+lemma steps_app: "i \<le> j \<Longrightarrow> steps step rho q (i, j + 1) =
	+ step (steps step rho q (i, j)) (bs_at rho j)"
	+ unfolding steps_def by auto
	+
	+lemma steps_appE: "i \<le> j \<Longrightarrow> steps step rho q (i, Suc j) = q' \<Longrightarrow>
	+ \<exists>q''. steps step rho q (i, j) = q'' \<and> q' = step q'' (bs_at rho j)"
	+ unfolding steps_def sub_bs.simps by auto
	+
	+lemma steps_comp: "i \<le> l \<Longrightarrow> l \<le> j \<Longrightarrow> steps step rho q (i, l) = q' \<Longrightarrow>
	+ steps step rho q' (l, j) = q'' \<Longrightarrow> steps step rho q (i, j) = q''"
	+proof -
	+ assume assms: "i \<le> l" "l \<le> j" "steps step rho q (i, l) = q'" "steps step rho q' (l, j) = q''"
	+ have range_app: "[i..<l] @ [l..<j] = [i..<j]"
	+ using assms(1,2)
	+ by (metis le_Suc_ex upt_add_eq_append)
	+ have "q' = foldl step q (map (bs_at rho) [i..<l])"
	+ using assms(3) unfolding steps_def by auto
	+ moreover have "q'' = foldl step q' (map (bs_at rho) [l..<j])"
	+ using assms(4) unfolding steps_def by auto
	+ ultimately have "q'' = foldl step q (map (bs_at rho) ([i..<l] @ [l..<j]))"
	+ by auto
	+ then show ?thesis
	+ unfolding steps_def range_app by auto
	+qed
	+
	+lemma sup_acc_SomeI: "acc step accept rho q (i, Suc l) \<Longrightarrow> l \<in> {i..<j} \<Longrightarrow>
	+ \<exists>tp. sup_acc step accept rho q i j = Some (ts_at rho tp, tp) \<and> l \<le> tp \<and> tp < j"
	+proof -
	+ assume assms: "acc step accept rho q (i, Suc l)" "l \<in> {i..<j}"
	+ define L where "L = {l \<in> {i..<j}. acc step accept rho q (i, Suc l)}"
	+ have L_props: "finite L" "L \<noteq> {}" "l \<in> L"
	+ using assms unfolding L_def by auto
	+ then show "\<exists>tp. sup_acc step accept rho q i j = Some (ts_at rho tp, tp) \<and> l \<le> tp \<and> tp < j"
	+ using L_def L_props
	+ by (auto simp add: sup_acc_def)
	+ (smt L_props(1) L_props(2) Max_ge Max_in mem_Collect_eq)
	+qed
	+
	+lemma sup_acc_Some_ts: "sup_acc step accept rho q i j = Some (ts, tp) \<Longrightarrow> ts = ts_at rho tp"
	+ by (auto simp add: sup_acc_def Let_def split: if_splits)
	+
	+lemma sup_acc_SomeE: "sup_acc step accept rho q i j = Some (ts, tp) \<Longrightarrow>
	+ tp \<in> {i..<j} \<and> acc step accept rho q (i, Suc tp)"
	+proof -
	+ assume assms: "sup_acc step accept rho q i j = Some (ts, tp)"
	+ define L where "L = {l \<in> {i..<j}. acc step accept rho q (i, Suc l)}"
	+ have L_props: "finite L" "L \<noteq> {}" "Max L = tp"
	+ unfolding L_def using assms
	+ by (auto simp add: sup_acc_def Let_def split: if_splits)
	+ show ?thesis
	+ using Max_in[OF L_props(1,2)] unfolding L_props(3) unfolding L_def by auto
	+qed
	+
	+lemma sup_acc_NoneE: "l \<in> {i..<j} \<Longrightarrow> sup_acc step accept rho q i j = None \<Longrightarrow>
	+ \<not>acc step accept rho q (i, Suc l)"
	+ by (auto simp add: sup_acc_def Let_def split: if_splits)
	+
	+lemma sup_acc_same: "sup_acc step accept rho q i i = None"
	+ by (auto simp add: sup_acc_def)
	+
	+lemma sup_acc_None_restrict: "i \<le> j \<Longrightarrow> sup_acc step accept rho q i j = None \<Longrightarrow>
	+ sup_acc step accept rho (step q (bs_at rho i)) (Suc i) j = None"
	+ using steps_split
	+ apply (auto simp add: sup_acc_def Let_def acc_def split: if_splits)
	+ apply (smt (z3) lessI less_imp_le_nat order_less_le_trans steps_split)
	+ done
	+
	+lemma sup_acc_ext_idle: "i \<le> j \<Longrightarrow> \<not>acc step accept rho q (i, Suc j) \<Longrightarrow>
	+ sup_acc step accept rho q i (Suc j) = sup_acc step accept rho q i j"
	+proof -
	+ assume assms: "i \<le> j" "\<not>acc step accept rho q (i, Suc j)"
	+ define L where "L = {l \<in> {i..<j}. acc step accept rho q (i, Suc l)}"
	+ define L' where "L' = {l \<in> {i..<Suc j}. acc step accept rho q (i, Suc l)}"
	+ have L_L': "L = L'"
	+ unfolding L_def L'_def using assms(2) less_antisym by fastforce
	+ show "sup_acc step accept rho q i (Suc j) = sup_acc step accept rho q i j"
	+ using L_def L'_def L_L' by (auto simp add: sup_acc_def)
	+qed
	+
	+lemma sup_acc_comp_Some_ge: "i \<le> l \<Longrightarrow> l \<le> j \<Longrightarrow> tp \<ge> l \<Longrightarrow>
	+ sup_acc step accept rho (steps step rho q (i, l)) l j = Some (ts, tp) \<Longrightarrow>
	+ sup_acc step accept rho q i j = sup_acc step accept rho (steps step rho q (i, l)) l j"
	+proof -
	+ assume assms: "i \<le> l" "l \<le> j" "sup_acc step accept rho (steps step rho q (i, l)) l j =
	+ Some (ts, tp)" "tp \<ge> l"
	+ define L where "L = {l \<in> {i..<j}. acc step accept rho q (i, Suc l)}"
	+ define L' where "L' = {l' \<in> {l..<j}. acc step accept rho (steps step rho q (i, l)) (l, Suc l')}"
	+ have L'_props: "finite L'" "L' \<noteq> {}" "tp = Max L'" "ts = ts_at rho tp"
	+ using assms(3) unfolding L'_def
	+ by (auto simp add: sup_acc_def Let_def split: if_splits)
	+ have tp_in_L': "tp \<in> L'"
	+ using Max_in[OF L'_props(1,2)] unfolding L'_props(3) .
	+ then have tp_in_L: "tp \<in> L"
	+ unfolding L_def L'_def using assms(1) steps_comp[OF assms(1,2), of step rho]
	+ apply (auto simp add: acc_def)
	+ using steps_comp
	+ by (metis le_SucI)
	+ have L_props: "finite L" "L \<noteq> {}"
	+ using L_def tp_in_L by auto
	+ have "\<And>l'. l' \<in> L \<Longrightarrow> l' \<le> tp"
	+ proof -
	+ fix l'
	+ assume assm: "l' \<in> L"
	+ show "l' \<le> tp"
	+ proof (cases "l' < l")
	+ case True
	+ then show ?thesis
	+ using assms(4) by auto
	+ next
	+ case False
	+ then have "l' \<in> L'"
	+ using assm
	+ unfolding L_def L'_def
	+ by (auto simp add: acc_def) (metis assms(1) less_imp_le_nat not_less_eq steps_comp)
	+ then show ?thesis
	+ using Max_eq_iff[OF L'_props(1,2)] L'_props(3) by auto
	+ qed
	+ qed
	+ then have "Max L = tp"
	+ using Max_eq_iff[OF L_props] tp_in_L by auto
	+ then have "sup_acc step accept rho q i j = Some (ts, tp)"
	+ using L_def L_props(2) unfolding L'_props(4)
	+ by (auto simp add: sup_acc_def)
	+ then show "sup_acc step accept rho q i j = sup_acc step accept rho (steps step rho q (i, l)) l j"
	+ using assms(3) by auto
	+qed
	+
	+lemma sup_acc_comp_None: "i \<le> l \<Longrightarrow> l \<le> j \<Longrightarrow>
	+ sup_acc step accept rho (steps step rho q (i, l)) l j = None \<Longrightarrow>
	+ sup_acc step accept rho q i j = sup_acc step accept rho q i l"
	+proof (induction "j - l" arbitrary: l)
	+ case (Suc n)
	+ have i_lt_j: "i < j"
	+ using Suc by auto
	+ have l_lt_j: "l < j"
	+ using Suc by auto
	+ have "\<not>acc step accept rho q (i, Suc l)"
	+ using sup_acc_NoneE[of l l j step accept rho "steps step rho q (i, l)"] Suc(2-)
	+ by (auto simp add: acc_def steps_def)
	+ then have "sup_acc step accept rho q i (l + 1) = sup_acc step accept rho q i l"
	+ using sup_acc_ext_idle[OF Suc(3)] by auto
	+ moreover have "sup_acc step accept rho (steps step rho q (i, l + 1)) (l + 1) j = None"
	+ using sup_acc_None_restrict[OF Suc(4,5)] steps_app[OF Suc(3), of step rho]
	+ by auto
	+ ultimately show ?case
	+ using Suc(1)[of "l + 1"] Suc(2,3,4,5)
	+ by auto
	+qed (auto simp add: sup_acc_same)
	+
	+lemma sup_acc_ext: "i \<le> j \<Longrightarrow> acc step accept rho q (i, Suc j) \<Longrightarrow>
	+ sup_acc step accept rho q i (Suc j) = Some (ts_at rho j, j)"
	+proof -
	+ assume assms: "i \<le> j" "acc step accept rho q (i, Suc j)"
	+ define L' where "L' = {l \<in> {i..<j + 1}. acc step accept rho q (i, Suc l)}"
	+ have j_in_L': "finite L'" "L' \<noteq> {}" "j \<in> L'"
	+ using assms unfolding L'_def by auto
	+ have j_is_Max: "Max L' = j"
	+ using Max_eq_iff[OF j_in_L'(1,2)] j_in_L'(3)
	+ by (auto simp add: L'_def)
	+ show "sup_acc step accept rho q i (Suc j) = Some (ts_at rho j, j)"
	+ using L'_def j_is_Max j_in_L'(2)
	+ by (auto simp add: sup_acc_def)
	+qed
	+
	+lemma sup_acc_None: "i < j \<Longrightarrow> sup_acc step accept rho q i j = None \<Longrightarrow>
	+ sup_acc step accept rho (step q (bs_at rho i)) (i + 1) j = None"
	+ using steps_split[of _ _ step rho]
	+ by (auto simp add: sup_acc_def Let_def acc_def split: if_splits)
	+
	+lemma sup_acc_i: "i < j \<Longrightarrow> sup_acc step accept rho q i j = Some (ts, i) \<Longrightarrow>
	+ sup_acc step accept rho (step q (bs_at rho i)) (Suc i) j = None"
	+proof (rule ccontr)
	+ assume assms: "i < j" "sup_acc step accept rho q i j = Some (ts, i)"
	+ "sup_acc step accept rho (step q (bs_at rho i)) (Suc i) j \<noteq> None"
	+ from assms(3) obtain l where l_def: "l \<in> {Suc i..<j}"
	+ "acc step accept rho (step q (bs_at rho i)) (Suc i, Suc l)"
	+ by (auto simp add: sup_acc_def Let_def split: if_splits)
	+ define L' where "L' = {l \<in> {i..<j}. acc step accept rho q (i, Suc l)}"
	+ from assms(2) have L'_props: "finite L'" "L' \<noteq> {}" "Max L' = i"
	+ by (auto simp add: sup_acc_def L'_def Let_def split: if_splits)
	+ have i_lt_l: "i < l"
	+ using l_def(1) by auto
	+ from l_def have "l \<in> L'"
	+ unfolding L'_def acc_def using steps_split[OF i_lt_l, of step rho] by (auto simp: steps_def)
	+ then show "False"
	+ using l_def(1) L'_props Max_ge i_lt_l not_le by auto
	+qed
	+
	+lemma sup_acc_l: "i < j \<Longrightarrow> i \<noteq> l \<Longrightarrow> sup_acc step accept rho q i j = Some (ts, l) \<Longrightarrow>
	+ sup_acc step accept rho q i j = sup_acc step accept rho (step q (bs_at rho i)) (Suc i) j"
	+proof -
	+ assume assms: "i < j" "i \<noteq> l" "sup_acc step accept rho q i j = Some (ts, l)"
	+ define L where "L = {l \<in> {i..<j}. acc step accept rho q (i, Suc l)}"
	+ define L' where "L' = {l \<in> {Suc i..<j}. acc step accept rho (step q (bs_at rho i)) (Suc i, Suc l)}"
	+ from assms(3) have L_props: "finite L" "L \<noteq> {}" "l = Max L"
	+ "sup_acc step accept rho q i j = Some (ts_at rho l, l)"
	+ by (auto simp add: sup_acc_def L_def Let_def split: if_splits)
	+ have l_in_L: "l \<in> L"
	+ using Max_in[OF L_props(1,2)] L_props(3) by auto
	+ then have i_lt_l: "i < l"
	+ unfolding L_def using assms(2) by auto
	+ have l_in_L': "finite L'" "L' \<noteq> {}" "l \<in> L'"
	+ using steps_split[OF i_lt_l, of step rho q] l_in_L assms(2)
	+ unfolding L_def L'_def acc_def by (auto simp: steps_def)
	+ have "\<And>l'. l' \<in> L' \<Longrightarrow> l' \<le> l"
	+ proof -
	+ fix l'
	+ assume assms: "l' \<in> L'"
	+ have i_lt_l': "i < l'"
	+ using assms unfolding L'_def by auto
	+ have "l' \<in> L"
	+ using steps_split[OF i_lt_l', of step rho] assms unfolding L_def L'_def acc_def by (auto simp: steps_def)
	+ then show "l' \<le> l"
	+ using L_props by simp
	+ qed
	+ then have l_sup_L': "Max L' = l"
	+ using Max_eq_iff[OF l_in_L'(1,2)] l_in_L'(3) by auto
	+ then show "sup_acc step accept rho q i j =
	+ sup_acc step accept rho (step q (bs_at rho i)) (Suc i) j"
	+ unfolding L_props(4)
	+ unfolding sup_acc_def Let_def
	+ using L'_def l_in_L'(2,3) L_props
	+ unfolding Suc_eq_plus1 by auto
	+qed
	+
	+lemma sup_leadsto_idle: "i < j \<Longrightarrow> steps step rho init (i, j) \<noteq> q \<Longrightarrow>
	+ sup_leadsto init step rho i j q = sup_leadsto init step rho (i + 1) j q"
	+proof -
	+ assume assms: "i < j" "steps step rho init (i, j) \<noteq> q"
	+ define L where "L = {l. l < i \<and> steps step rho init (l, j) = q}"
	+ define L' where "L' = {l. l < i + 1 \<and> steps step rho init (l, j) = q}"
	+ have L_L': "L = L'"
	+ unfolding L_def L'_def using assms(2) less_antisym
	+ by fastforce
	+ show "sup_leadsto init step rho i j q = sup_leadsto init step rho (i + 1) j q"
	+ using L_def L'_def L_L'
	+ by (auto simp add: sup_leadsto_def)
	+qed
	+
	+lemma sup_leadsto_SomeI: "l < i \<Longrightarrow> steps step rho init (l, j) = q \<Longrightarrow>
	+ \<exists>l'. sup_leadsto init step rho i j q = Some (ts_at rho l') \<and> l \<le> l' \<and> l' < i"
	+proof -
	+ assume assms: "l < i" "steps step rho init (l, j) = q"
	+ define L' where "L' = {l. l < i \<and> steps step rho init (l, j) = q}"
	+ have fin_L': "finite L'"
	+ unfolding L'_def by auto
	+ moreover have L_nonempty: "L' \<noteq> {}"
	+ using assms unfolding L'_def
	+ by (auto simp add: sup_leadsto_def split: if_splits)
	+ ultimately have "Max L' \<in> L'"
	+ using Max_in by auto
	+ then show "\<exists>l'. sup_leadsto init step rho i j q = Some (ts_at rho l') \<and> l \<le> l' \<and> l' < i"
	+ using L'_def L_nonempty assms
	+ by (fastforce simp add: sup_leadsto_def split: if_splits)
	+qed
	+
	+lemma sup_leadsto_SomeE: "i \<le> j \<Longrightarrow> sup_leadsto init step rho i j q = Some ts \<Longrightarrow>
	+ \<exists>l < i. steps step rho init (l, j) = q \<and> ts_at rho l = ts"
	+proof -
	+ assume assms: "i \<le> j" "sup_leadsto init step rho i j q = Some ts"
	+ define L' where "L' = {l. l < i \<and> steps step rho init (l, j) = q}"
	+ have fin_L': "finite L'"
	+ unfolding L'_def by auto
	+ moreover have L_nonempty: "L' \<noteq> {}"
	+ using assms(2) unfolding L'_def
	+ by (auto simp add: sup_leadsto_def split: if_splits)
	+ ultimately have "Max L' \<in> L'"
	+ using Max_in by auto
	+ then show "\<exists>l < i. steps step rho init (l, j) = q \<and> ts_at rho l = ts"
	+ using assms(2) L'_def
	+ apply (auto simp add: sup_leadsto_def split: if_splits)
	+ using \<open>Max L' \<in> L'\<close> by blast
	+qed
	+
	+lemma Mapping_keys_dest: "x \<in> mmap_keys f \<Longrightarrow> \<exists>y. mmap_lookup f x = Some y"
	+ by (auto simp add: mmap_keys_def mmap_lookup_def weak_map_of_SomeI)
	+
	+lemma Mapping_keys_intro: "mmap_lookup f x \<noteq> None \<Longrightarrow> x \<in> mmap_keys f"
	+ by (auto simp add: mmap_keys_def mmap_lookup_def)
	+ (metis map_of_eq_None_iff option.distinct(1))
	+
	+lemma Mapping_not_keys_intro: "mmap_lookup f x = None \<Longrightarrow> x \<notin> mmap_keys f"
	+ unfolding mmap_lookup_def mmap_keys_def
	+ using weak_map_of_SomeI by force
	+
	+lemma Mapping_lookup_None_intro: "x \<notin> mmap_keys f \<Longrightarrow> mmap_lookup f x = None"
	+ unfolding mmap_lookup_def mmap_keys_def
	+ by (simp add: map_of_eq_None_iff)
	+
	+primrec mmap_combine :: "'key \<Rightarrow> 'val \<Rightarrow> ('val \<Rightarrow> 'val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow>
	+ ('key \<times> 'val) list"
	+ where
	+ "mmap_combine k v c [] = [(k, v)]"
	+\| "mmap_combine k v c (p # ps) = (case p of (k', v') \<Rightarrow>
	+ if k = k' then (k, c v' v) # ps else p # mmap_combine k v c ps)"
	+
	+lemma mmap_combine_distinct_set: "distinct (map fst r) \<Longrightarrow>
	+ distinct (map fst (mmap_combine k v c r)) \<and>
	+ set (map fst (mmap_combine k v c r)) = set (map fst r) \<union> {k}"
	+ by (induction r) force+
	+
	+lemma mmap_combine_lookup: "distinct (map fst r) \<Longrightarrow> mmap_lookup (mmap_combine k v c r) z =
	+ (if k = z then (case mmap_lookup r k of None \<Rightarrow> Some v \| Some v' \<Rightarrow> Some (c v' v))
	+ else mmap_lookup r z)"
	+ using eq_key_imp_eq_value
	+ by (induction r) (fastforce simp: mmap_lookup_def split: option.splits)+
	+
	+definition mmap_fold :: "('c, 'd) mmap \<Rightarrow> (('c \<times> 'd) \<Rightarrow> ('c \<times> 'd)) \<Rightarrow> ('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow>
	+ ('c, 'd) mmap \<Rightarrow> ('c, 'd) mmap" where
	+ "mmap_fold m f c r = foldl (\<lambda>r p. case f p of (k, v) \<Rightarrow> mmap_combine k v c r) r m"
	+
	+definition mmap_fold' :: "('c, 'd) mmap \<Rightarrow> 'e \<Rightarrow> (('c \<times> 'd) \<times> 'e \<Rightarrow> ('c \<times> 'd) \<times> 'e) \<Rightarrow>
	+ ('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow> ('c, 'd) mmap \<Rightarrow> ('c, 'd) mmap \<times> 'e" where
	+ "mmap_fold' m e f c r = foldl (\<lambda>(r, e) p. case f (p, e) of ((k, v), e') \<Rightarrow>
	+ (mmap_combine k v c r, e')) (r, e) m"
	+
	+lemma mmap_fold'_eq: "mmap_fold' m e f' c r = (m', e') \<Longrightarrow> P e \<Longrightarrow>
	+ (\<And>p e p' e'. P e \<Longrightarrow> f' (p, e) = (p', e') \<Longrightarrow> p' = f p \<and> P e') \<Longrightarrow>
	+ m' = mmap_fold m f c r \<and> P e'"
	+proof (induction m arbitrary: e r m' e')
	+ case (Cons p m)
	+ obtain k v e'' where kv_def: "f' (p, e) = ((k, v), e'')" "P e''"
	+ using Cons
	+ by (cases "f' (p, e)") fastforce
	+ have mmap_fold: "mmap_fold m f c (mmap_combine k v c r) = mmap_fold (p # m) f c r"
	+ using Cons(1)[OF _ kv_def(2), where ?r="mmap_combine k v c r"] Cons(2,3,4)
	+ by (simp add: mmap_fold_def mmap_fold'_def kv_def(1))
	+ have mmap_fold': "mmap_fold' m e'' f' c (mmap_combine k v c r) = (m', e')"
	+ using Cons(2)
	+ by (auto simp: mmap_fold'_def kv_def)
	+ show ?case
	+ using Cons(1)[OF mmap_fold' kv_def(2) Cons(4)]
	+ unfolding mmap_fold
	+ by auto
	+qed (auto simp: mmap_fold_def mmap_fold'_def)
	+
	+lemma foldl_mmap_combine_distinct_set: "distinct (map fst r) \<Longrightarrow>
	+ distinct (map fst (mmap_fold m f c r)) \<and>
	+ set (map fst (mmap_fold m f c r)) = set (map fst r) \<union> set (map (fst \<circ> f) m)"
	+ apply (induction m arbitrary: r)
	+ using mmap_combine_distinct_set
	+ apply (auto simp: mmap_fold_def split: prod.splits)
	+ apply force
	+ apply (smt Un_iff fst_conv imageI insert_iff)
	+ using mk_disjoint_insert
	+ apply fastforce+
	+ done
	+
	+lemma mmap_fold_lookup_rec: "distinct (map fst r) \<Longrightarrow> mmap_lookup (mmap_fold m f c r) z =
	+ (case map (snd \<circ> f) (filter (\<lambda>(k, v). fst (f (k, v)) = z) m) of [] \<Rightarrow> mmap_lookup r z
	+ \| v # vs \<Rightarrow> (case mmap_lookup r z of None \<Rightarrow> Some (foldl c v vs)
	+ \| Some w \<Rightarrow> Some (foldl c w (v # vs))))"
	+proof (induction m arbitrary: r)
	+ case (Cons p ps)
	+ obtain k v where kv_def: "f p = (k, v)"
	+ by fastforce
	+ have distinct: "distinct (map fst (mmap_combine k v c r))"
	+ using mmap_combine_distinct_set[OF Cons(2)]
	+ by auto
	+ show ?case
	+ using Cons(1)[OF distinct, unfolded mmap_combine_lookup[OF Cons(2)]]
	+ by (auto simp: mmap_lookup_def kv_def mmap_fold_def split: list.splits option.splits)
	+qed (auto simp: mmap_fold_def)
	+
	+lemma mmap_fold_distinct: "distinct (map fst m) \<Longrightarrow> distinct (map fst (mmap_fold m f c []))"
	+ using foldl_mmap_combine_distinct_set[of "[]"]
	+ by auto
	+
	+lemma mmap_fold_set: "distinct (map fst m) \<Longrightarrow>
	+ set (map fst (mmap_fold m f c [])) = (fst \<circ> f) ` set m"
	+ using foldl_mmap_combine_distinct_set[of "[]"]
	+ by force
	+
	+lemma mmap_lookup_empty: "mmap_lookup [] z = None"
	+ by (auto simp: mmap_lookup_def)
	+
	+lemma mmap_fold_lookup: "distinct (map fst m) \<Longrightarrow> mmap_lookup (mmap_fold m f c []) z =
	+ (case map (snd \<circ> f) (filter (\<lambda>(k, v). fst (f (k, v)) = z) m) of [] \<Rightarrow> None
	+ \| v # vs \<Rightarrow> Some (foldl c v vs))"
	+ using mmap_fold_lookup_rec[of "[]" _ f c]
	+ by (auto simp: mmap_lookup_empty split: list.splits)
	+
	+definition fold_sup :: "('c, 'd :: timestamp) mmap \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> ('c, 'd) mmap" where
	+ "fold_sup m f = mmap_fold m (\<lambda>(x, y). (f x, y)) sup []"
	+
	+lemma mmap_lookup_distinct: "distinct (map fst m) \<Longrightarrow> (k, v) \<in> set m \<Longrightarrow>
	+ mmap_lookup m k = Some v"
	+ by (auto simp: mmap_lookup_def)
	+
	+lemma fold_sup_distinct: "distinct (map fst m) \<Longrightarrow> distinct (map fst (fold_sup m f))"
	+ using mmap_fold_distinct
	+ by (auto simp: fold_sup_def)
	+
	+lemma fold_sup:
	+ fixes v :: "'d :: timestamp"
	+ shows "foldl sup v vs = fold sup vs v"
	+ by (induction vs arbitrary: v) (auto simp: sup.commute)
	+
	+lemma lookup_fold_sup:
	+ assumes distinct: "distinct (map fst m)"
	+ shows "mmap_lookup (fold_sup m f) z =
	+ (let Z = {x \<in> mmap_keys m. f x = z} in
	+ if Z = {} then None else Some (Sup_fin ((the \<circ> mmap_lookup m) ` Z)))"
	+proof (cases "{x \<in> mmap_keys m. f x = z} = {}")
	+ case True
	+ have "z \<notin> mmap_keys (mmap_fold m (\<lambda>(x, y). (f x, y)) sup [])"
	+ using True[unfolded mmap_keys_def] mmap_fold_set[OF distinct]
	+ by (auto simp: mmap_keys_def)
	+ then have "mmap_lookup (fold_sup m f) z = None"
	+ unfolding fold_sup_def
	+ by (meson Mapping_keys_intro)
	+ then show ?thesis
	+ unfolding True
	+ by auto
	+next
	+ case False
	+ have z_in_keys: "z \<in> mmap_keys (mmap_fold m (\<lambda>(x, y). (f x, y)) sup [])"
	+ using False[unfolded mmap_keys_def] mmap_fold_set[OF distinct]
	+ by (force simp: mmap_keys_def)
	+ obtain v vs where vs_def: "mmap_lookup (fold_sup m f) z = Some (foldl sup v vs)"
	+ "v # vs = map snd (filter (\<lambda>(k, v). f k = z) m)"
	+ using mmap_fold_lookup[OF distinct, of "(\<lambda>(x, y). (f x, y))" sup z]
	+ Mapping_keys_dest[OF z_in_keys]
	+ by (force simp: fold_sup_def mmap_keys_def comp_def split: list.splits prod.splits)
	+ have "set (v # vs) = (the \<circ> mmap_lookup m) ` {x \<in> mmap_keys m. f x = z}"
	+ proof (rule set_eqI, rule iffI)
	+ fix w
	+ assume "w \<in> set (v # vs)"
	+ then obtain x where x_def: "x \<in> mmap_keys m" "f x = z" "(x, w) \<in> set m"
	+ using vs_def(2)
	+ by (auto simp add: mmap_keys_def rev_image_eqI)
	+ show "w \<in> (the \<circ> mmap_lookup m) ` {x \<in> mmap_keys m. f x = z}"
	+ using x_def(1,2) mmap_lookup_distinct[OF distinct x_def(3)]
	+ by force
	+ next
	+ fix w
	+ assume "w \<in> (the \<circ> mmap_lookup m) ` {x \<in> mmap_keys m. f x = z}"
	+ then obtain x where x_def: "x \<in> mmap_keys m" "f x = z" "(x, w) \<in> set m"
	+ using mmap_lookup_distinct[OF distinct]
	+ by (auto simp add: Mapping_keys_intro distinct mmap_lookup_def dest: Mapping_keys_dest)
	+ show "w \<in> set (v # vs)"
	+ using x_def
	+ by (force simp: vs_def(2))
	+ qed
	+ then have "foldl sup v vs = Sup_fin ((the \<circ> mmap_lookup m) ` {x \<in> mmap_keys m. f x = z})"
	+ unfolding fold_sup
	+ by (metis Sup_fin.set_eq_fold)
	+ then show ?thesis
	+ using False
	+ by (auto simp: vs_def(1))
	+qed
	+
	+definition mmap_map :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) mmap \<Rightarrow> ('a, 'c) mmap" where
	+ "mmap_map f m = map (\<lambda>(k, v). (k, f k v)) m"
	+
	+lemma mmap_map_keys: "mmap_keys (mmap_map f m) = mmap_keys m"
	+ by (force simp: mmap_map_def mmap_keys_def)
	+
	+lemma mmap_map_fst: "map fst (mmap_map f m) = map fst m"
	+ by (auto simp: mmap_map_def)
	+
	+definition cstep :: "('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('c \<times> 'b, 'c) mapping \<Rightarrow>
	+ 'c \<Rightarrow> 'b \<Rightarrow> ('c \<times> ('c \<times> 'b, 'c) mapping)" where
	+ "cstep step st q bs = (case Mapping.lookup st (q, bs) of None \<Rightarrow> (let res = step q bs in
	+ (res, Mapping.update (q, bs) res st)) \| Some v \<Rightarrow> (v, st))"
	+
	+definition cac :: "('c \<Rightarrow> bool) \<Rightarrow> ('c, bool) mapping \<Rightarrow> 'c \<Rightarrow> (bool \<times> ('c, bool) mapping)" where
	+ "cac accept ac q = (case Mapping.lookup ac q of None \<Rightarrow> (let res = accept q in
	+ (res, Mapping.update q res ac)) \| Some v \<Rightarrow> (v, ac))"
	+
	+fun mmap_fold_s :: "('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('c \<times> 'b, 'c) mapping \<Rightarrow>
	+ ('c \<Rightarrow> bool) \<Rightarrow> ('c, bool) mapping \<Rightarrow>
	+ 'b \<Rightarrow> 'd \<Rightarrow> nat \<Rightarrow> ('c, 'c \<times> ('d \<times> nat) option) mmap \<Rightarrow>
	+ (('c, 'c \<times> ('d \<times> nat) option) mmap \<times> ('c \<times> 'b, 'c) mapping \<times> ('c, bool) mapping)" where
	+ "mmap_fold_s step st accept ac bs t j [] = ([], st, ac)"
	+\| "mmap_fold_s step st accept ac bs t j ((q, (q', tstp)) # qbss) =
	+ (let (q'', st') = cstep step st q' bs;
	+ (\<beta>, ac') = cac accept ac q'';
	+ (qbss', st'', ac'') = mmap_fold_s step st' accept ac' bs t j qbss in
	+ ((q, (q'', if \<beta> then Some (t, j) else tstp)) # qbss', st'', ac''))"
	+
	+lemma mmap_fold_s_sound: "mmap_fold_s step st accept ac bs t j qbss = (qbss', st', ac') \<Longrightarrow>
	+ (\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v) \<Longrightarrow>
	+ (\<And>q bs. case Mapping.lookup ac q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v) \<Longrightarrow>
	+ qbss' = mmap_map (\<lambda>q (q', tstp). (step q' bs, if accept (step q' bs) then Some (t, j) else tstp)) qbss \<and>
	+ (\<forall>q bs. case Mapping.lookup st' (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v) \<and>
	+ (\<forall>q bs. case Mapping.lookup ac' q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v)"
	+proof (induction qbss arbitrary: st ac qbss')
	+ case (Cons a qbss)
	+ obtain q q' tstp where a_def: "a = (q, (q', tstp))"
	+ by (cases a) auto
	+ obtain q'' st'' where q''_def: "cstep step st q' bs = (q'', st'')"
	+ "q'' = step q' bs"
	+ using Cons(3)
	+ by (cases "cstep step st q' bs")
	+ (auto simp: cstep_def Let_def option.case_eq_if split: option.splits if_splits)
	+ obtain b ac'' where b_def: "cac accept ac q'' = (b, ac'')"
	+ "b = accept q''"
	+ using Cons(4)
	+ by (cases "cac accept ac q''")
	+ (auto simp: cac_def Let_def option.case_eq_if split: option.splits if_splits)
	+ obtain qbss'' where qbss''_def: "mmap_fold_s step st'' accept ac'' bs t j qbss =
	+ (qbss'', st', ac')" "qbss' = (q, q'', if b then Some (t, j) else tstp) # qbss''"
	+ using Cons(2)[unfolded a_def mmap_fold_s.simps q''_def(1) b_def(1)]
	+ unfolding Let_def
	+ by (auto simp: b_def(1) split: prod.splits)
	+ have ih: "\<And>q bs. case Mapping.lookup st'' (q, bs) of None \<Rightarrow> True \| Some a \<Rightarrow> step q bs = a"
	+ "\<And>q bs. case Mapping.lookup ac'' q of None \<Rightarrow> True \| Some a \<Rightarrow> accept q = a"
	+ using q''_def b_def Cons(3,4)
	+ by (auto simp: cstep_def cac_def Let_def Mapping.lookup_update' option.case_eq_if
	+ split: option.splits if_splits)
	+ show ?case
	+ using Cons(1)[OF qbss''_def(1) ih]
	+ unfolding a_def q''_def(2) b_def(2) qbss''_def(2)
	+ by (auto simp: mmap_map_def)
	+qed (auto simp: mmap_map_def)
	+
	+definition adv_end :: "('b, 'c, 'd :: timestamp, 't, 'e) args \<Rightarrow>
	+ ('b, 'c, 'd, 't, 'e) window \<Rightarrow> ('b, 'c, 'd, 't, 'e) window option" where
	+ "adv_end args w = (let step = w_step args; accept = w_accept args;
	+ run_t = w_run_t args; run_sub = w_run_sub args; st = w_st w; ac = w_ac w;
	+ j = w_j w; tj = w_tj w; sj = w_sj w; s = w_s w; e = w_e w in
	+ (case run_t tj of None \<Rightarrow> None \| Some (tj', t) \<Rightarrow> (case run_sub sj of None \<Rightarrow> None \| Some (sj', bs) \<Rightarrow>
	+ let (s', st', ac') = mmap_fold_s step st accept ac bs t j s;
	+ (e', st'') = mmap_fold' e st' (\<lambda>((x, y), st). let (q', st') = cstep step st x bs in ((q', y), st')) sup [] in
	+ Some (w\<lparr>w_st := st'', w_ac := ac', w_j := Suc j, w_tj := tj', w_sj := sj', w_s := s', w_e := e'\<rparr>))))"
	+
	+lemma map_values_lookup: "mmap_lookup (mmap_map f m) z = Some v' \<Longrightarrow>
	+ \<exists>v. mmap_lookup m z = Some v \<and> v' = f z v"
	+ by (induction m) (auto simp: mmap_lookup_def mmap_map_def)
	+
	+lemma acc_app:
	+ assumes "i \<le> j" "steps step rho q (i, Suc j) = q'" "accept q'"
	+ shows "sup_acc step accept rho q i (Suc j) = Some (ts_at rho j, j)"
	+proof -
	+ define L where "L = {l \<in> {i..<Suc j}. accept (steps step rho q (i, Suc l))}"
	+ have nonempty: "finite L" "L \<noteq> {}"
	+ using assms unfolding L_def by auto
	+ moreover have "Max {l \<in> {i..<Suc j}. accept (steps step rho q (i, Suc l))} = j"
	+ unfolding L_def[symmetric] Max_eq_iff[OF nonempty, of j]
	+ unfolding L_def using assms by auto
	+ ultimately show ?thesis
	+ by (auto simp add: sup_acc_def acc_def L_def)
	+qed
	+
	+lemma acc_app_idle:
	+ assumes "i \<le> j" "steps step rho q (i, Suc j) = q'" "\<not>accept q'"
	+ shows "sup_acc step accept rho q i (Suc j) = sup_acc step accept rho q i j"
	+ using assms
	+ by (auto simp add: sup_acc_def Let_def acc_def elim: less_SucE) (metis less_Suc_eq)+
	+
	+lemma sup_fin_closed: "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
	+ (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> sup x y \<in> {x, y}) \<Longrightarrow> \<Squnion>\<^sub>f\<^sub>i\<^sub>n A \<in> A"
	+ apply (induct A rule: finite.induct)
	+ using Sup_fin.insert
	+ by auto fastforce
	+
	+lemma valid_adv_end:
	+ assumes "valid_window args t0 sub rho w" "w_run_t args (w_tj w) = Some (tj', t)"
	+ "w_run_sub args (w_sj w) = Some (sj', bs)"
	+ "\<And>t'. t' \<in> set (map fst rho) \<Longrightarrow> t' \<le> t"
	+ shows "case adv_end args w of None \<Rightarrow> False \| Some w' \<Rightarrow> valid_window args t0 sub (rho @ [(t, bs)]) w'"
	+proof -
	+ define init where "init = w_init args"
	+ define step where "step = w_step args"
	+ define accept where "accept = w_accept args"
	+ define run_t where "run_t = w_run_t args"
	+ define run_sub where "run_sub = w_run_sub args"
	+ define st where "st = w_st w"
	+ define ac where "ac = w_ac w"
	+ define i where "i = w_i w"
	+ define ti where "ti = w_ti w"
	+ define si where "si = w_si w"
	+ define j where "j = w_j w"
	+ define tj where "tj = w_tj w"
	+ define sj where "sj = w_sj w"
	+ define s where "s = w_s w"
	+ define e where "e = w_e w"
	+ have valid_before: "reach_window args t0 sub rho (i, ti, si, j, tj, sj)"
	+ "\<And>i j. i \<le> j \<Longrightarrow> j < length rho \<Longrightarrow> ts_at rho i \<le> ts_at rho j"
	+ "(\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v)"
	+ "(\<And>q bs. case Mapping.lookup ac q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v)"
	+ "\<forall>q. mmap_lookup e q = sup_leadsto init step rho i j q" "distinct (map fst e)"
	+ "valid_s init step st accept rho i i j s"
	+ using assms(1)
	+ unfolding valid_window_def valid_s_def Let_def init_def step_def accept_def run_t_def
	+ run_sub_def st_def ac_def i_def ti_def si_def j_def tj_def sj_def s_def e_def
	+ by auto
	+ have i_j: "i \<le> j"
	+ using valid_before(1)
	+ by auto
	+ have distinct_before: "distinct (map fst s)" "distinct (map fst e)"
	+ using valid_before
	+ by (auto simp: valid_s_def)
	+ note run_tj = assms(2)[folded run_t_def tj_def]
	+ note run_sj = assms(3)[folded run_sub_def sj_def]
	+ define rho' where "rho' = rho @ [(t, bs)]"
	+ have ts_at_mono: "\<And>i j. i \<le> j \<Longrightarrow> j < length rho' \<Longrightarrow> ts_at rho' i \<le> ts_at rho' j"
	+ using valid_before(2) assms(4)
	+ by (auto simp: rho'_def ts_at_def nth_append split: option.splits list.splits if_splits)
	+ obtain s' st' ac' where s'_def: "mmap_fold_s step st accept ac bs t j s = (s', st', ac')"
	+ apply (cases "mmap_fold_s step st accept ac bs t j s")
	+ apply (auto)
	+ done
	+ have s'_mmap_map: "s' = mmap_map (\<lambda>q (q', tstp).
	+ (step q' bs, if accept (step q' bs) then Some (t, j) else tstp)) s"
	+ "(\<And>q bs. case Mapping.lookup st' (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v)"
	+ "(\<And>q bs. case Mapping.lookup ac' q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v)"
	+ using mmap_fold_s_sound[OF s'_def valid_before(3,4)]
	+ by auto
	+ obtain e' st'' where e'_def: "mmap_fold' e st' (\<lambda>((x, y), st).
	+ let (q', st') = cstep step st x bs in ((q', y), st')) sup [] = (e', st'')"
	+ by (metis old.prod.exhaust)
	+ define inv where "inv \<equiv> \<lambda>st'. \<forall>q bs. case Mapping.lookup st' (q, bs) of None \<Rightarrow> True
	+ \| Some v \<Rightarrow> step q bs = v"
	+ have inv_st': "inv st'"
	+ using s'_mmap_map(2)
	+ by (auto simp: inv_def)
	+ have "\<And>p e p' e'. inv e \<Longrightarrow> (case (p, e) of (x, xa) \<Rightarrow> (case x of (x, y) \<Rightarrow>
	+ \<lambda>st. let (q', st') = cstep step st x bs in ((q', y), st')) xa) = (p', e') \<Longrightarrow>
	+ p' = (case p of (x, y) \<Rightarrow> (step x bs, y)) \<and> inv e'"
	+ by (auto simp: inv_def cstep_def Let_def Mapping.lookup_update' split: option.splits if_splits)
	+ then have e'_fold_sup_st'': "e' = fold_sup e (\<lambda>q. step q bs)"
	+ "(\<And>q bs. case Mapping.lookup st'' (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v)"
	+ using mmap_fold'_eq[OF e'_def, of inv "\<lambda>(x, y). (step x bs, y)", OF inv_st']
	+ by (fastforce simp: fold_sup_def inv_def)+
	+ have adv_end: "adv_end args w = Some (w\<lparr>w_st := st'', w_ac := ac',
	+ w_j := Suc j, w_tj := tj', w_sj := sj', w_s := s', w_e := e'\<rparr>)"
	+ using run_tj run_sj e'_def[unfolded st_def]
	+ unfolding adv_end_def init_def step_def accept_def run_t_def run_sub_def
	+ i_def ti_def si_def j_def tj_def sj_def s_def e_def s'_def e'_def
	+ by (auto simp: Let_def s'_def[unfolded step_def st_def accept_def ac_def j_def s_def])
	+ have keys_s': "mmap_keys s' = mmap_keys s"
	+ by (force simp: mmap_keys_def mmap_map_def s'_mmap_map(1))
	+ have lookup_s: "\<And>q q' tstp. mmap_lookup s q = Some (q', tstp) \<Longrightarrow>
	+ steps step rho' q (i, j) = q' \<and> tstp = sup_acc step accept rho' q i j"
	+ using valid_before Mapping_keys_intro
	+ by (force simp add: Let_def rho'_def valid_s_def steps_app_cong sup_acc_app_cong
	+ split: option.splits)
	+ have bs_at_rho'_j: "bs_at rho' j = bs"
	+ using valid_before
	+ by (auto simp: rho'_def bs_at_def nth_append)
	+ have ts_at_rho'_j: "ts_at rho' j = t"
	+ using valid_before
	+ by (auto simp: rho'_def ts_at_def nth_append)
	+ have lookup_s': "\<And>q q' tstp. mmap_lookup s' q = Some (q', tstp) \<Longrightarrow>
	+ steps step rho' q (i, Suc j) = q' \<and> tstp = sup_acc step accept rho' q i (Suc j)"
	+ proof -
	+ fix q q'' tstp'
	+ assume assm: "mmap_lookup s' q = Some (q'', tstp')"
	+ obtain q' tstp where "mmap_lookup s q = Some (q', tstp)" "q'' = step q' bs"
	+ "tstp' = (if accept (step q' bs) then Some (t, j) else tstp)"
	+ using map_values_lookup[OF assm[unfolded s'_mmap_map]] by auto
	+ then show "steps step rho' q (i, Suc j) = q'' \<and> tstp' = sup_acc step accept rho' q i (Suc j)"
	+ using lookup_s
	+ apply (auto simp: bs_at_rho'_j ts_at_rho'_j)
	+ apply (metis Suc_eq_plus1 bs_at_rho'_j i_j steps_app)
	+ apply (metis acc_app bs_at_rho'_j i_j steps_appE ts_at_rho'_j)
	+ apply (metis Suc_eq_plus1 bs_at_rho'_j i_j steps_app)
	+ apply (metis (no_types, lifting) acc_app_idle bs_at_rho'_j i_j steps_appE)
	+ done
	+ qed
	+ have lookup_e: "\<And>q. mmap_lookup e q = sup_leadsto init step rho' i j q"
	+ using valid_before sup_leadsto_app_cong[of _ _ rho init step]
	+ by (auto simp: rho'_def)
	+ have keys_e_alt: "mmap_keys e = {q. \<exists>l < i. steps step rho' init (l, j) = q}"
	+ using valid_before
	+ apply (auto simp add: sup_leadsto_def rho'_def)
	+ apply (metis (no_types, lifting) Mapping_keys_dest lookup_e rho'_def sup_leadsto_SomeE)
	+ apply (metis (no_types, lifting) Mapping_keys_intro option.simps(3) order_refl steps_app_cong)
	+ done
	+ have finite_keys_e: "finite (mmap_keys e)"
	+ unfolding keys_e_alt
	+ by (rule finite_surj[of "{l. l < i}"]) auto
	+ have "reaches_on run_sub sub (map snd rho) sj"
	+ using valid_before reaches_on_trans
	+ unfolding run_sub_def sub_def
	+ by fastforce
	+ then have reaches_on': "reaches_on run_sub sub (map snd rho @ [bs]) sj'"
	+ using reaches_on_app run_sj
	+ by fast
	+ have "reaches_on run_t t0 (map fst rho) tj"
	+ using valid_before reaches_on_trans
	+ unfolding run_t_def
	+ by fastforce
	+ then have reach_t': "reaches_on run_t t0 (map fst rho') tj'"
	+ using reaches_on_app run_tj
	+ unfolding rho'_def
	+ by fastforce
	+ have lookup_e': "\<And>q. mmap_lookup e' q = sup_leadsto init step rho' i (Suc j) q"
	+ proof -
	+ fix q
	+ define Z where "Z = {x \<in> mmap_keys e. step x bs = q}"
	+ show "mmap_lookup e' q = sup_leadsto init step rho' i (Suc j) q"
	+ proof (cases "Z = {}")
	+ case True
	+ then have "mmap_lookup e' q = None"
	+ using Z_def lookup_fold_sup[OF distinct_before(2)]
	+ unfolding e'_fold_sup_st''
	+ by (auto simp: Let_def)
	+ moreover have "sup_leadsto init step rho' i (Suc j) q = None"
	+ proof (rule ccontr)
	+ assume assm: "sup_leadsto init step rho' i (Suc j) q \<noteq> None"
	+ obtain l where l_def: "l < i" "steps step rho' init (l, Suc j) = q"
	+ using i_j sup_leadsto_SomeE[of i "Suc j"] assm
	+ by force
	+ have l_j: "l \<le> j"
	+ using less_le_trans[OF l_def(1) i_j] by auto
	+ obtain q'' where q''_def: "steps step rho' init (l, j) = q''" "step q'' bs = q"
	+ using steps_appE[OF _ l_def(2)] l_j
	+ by (auto simp: bs_at_rho'_j)
	+ then have "q'' \<in> mmap_keys e"
	+ using keys_e_alt l_def(1)
	+ by auto
	+ then show "False"
	+ using Z_def q''_def(2) True
	+ by auto
	+ qed
	+ ultimately show ?thesis
	+ by auto
	+ next
	+ case False
	+ then have lookup_e': "mmap_lookup e' q = Some (Sup_fin ((the \<circ> mmap_lookup e) ` Z))"
	+ using Z_def lookup_fold_sup[OF distinct_before(2)]
	+ unfolding e'_fold_sup_st''
	+ by (auto simp: Let_def)
	+ define L where "L = {l. l < i \<and> steps step rho' init (l, Suc j) = q}"
	+ have fin_L: "finite L"
	+ unfolding L_def by auto
	+ have Z_alt: "Z = {x. \<exists>l < i. steps step rho' init (l, j) = x \<and> step x bs = q}"
	+ using Z_def[unfolded keys_e_alt] by auto
	+ have fin_Z: "finite Z"
	+ unfolding Z_alt by auto
	+ have L_nonempty: "L \<noteq> {}"
	+ using L_def Z_alt False i_j steps_app[of _ _ step rho q]
	+ by (auto simp: bs_at_rho'_j)
	+ (smt Suc_eq_plus1 bs_at_rho'_j less_irrefl_nat less_le_trans nat_le_linear steps_app)
	+ have sup_leadsto: "sup_leadsto init step rho' i (Suc j) q = Some (ts_at rho' (Max L))"
	+ using L_nonempty L_def
	+ by (auto simp add: sup_leadsto_def)
	+ have j_lt_rho': "j < length rho'"
	+ using valid_before
	+ by (auto simp: rho'_def)
	+ have "Sup_fin ((the \<circ> mmap_lookup e) ` Z) = ts_at rho' (Max L)"
	+ proof (rule antisym)
	+ obtain z ts where zts_def: "z \<in> Z" "(the \<circ> mmap_lookup e) z = ts"
	+ "Sup_fin ((the \<circ> mmap_lookup e) ` Z) = ts"
	+ proof -
	+ assume lassm: "\<And>z ts. z \<in> Z \<Longrightarrow> (the \<circ> mmap_lookup e) z = ts \<Longrightarrow>
	+ \<Squnion>\<^sub>f\<^sub>i\<^sub>n ((the \<circ> mmap_lookup e) ` Z) = ts \<Longrightarrow> thesis"
	+ define T where "T = (the \<circ> mmap_lookup e) ` Z"
	+ have T_sub: "T \<subseteq> ts_at rho' ` {..j}"
	+ using lookup_e keys_e_alt i_j
	+ by (auto simp add: T_def Z_def sup_leadsto_def)
	+ have "finite T" "T \<noteq> {}"
	+ using fin_Z False
	+ by (auto simp add: T_def)
	+ then have sup_in: "\<Squnion>\<^sub>f\<^sub>i\<^sub>n T \<in> T"
	+ proof (rule sup_fin_closed)
	+ fix x y
	+ assume xy: "x \<in> T" "y \<in> T"
	+ then obtain a c where "x = ts_at rho' a" "y = ts_at rho' c" "a \<le> j" "c \<le> j"
	+ using T_sub
	+ by (meson atMost_iff imageE subsetD)
	+ then show "sup x y \<in> {x, y}"
	+ using ts_at_mono j_lt_rho'
	+ by (cases "a \<le> c") (auto simp add: sup.absorb1 sup.absorb2)
	+ qed
	+ then show ?thesis
	+ using lassm
	+ by (auto simp add: T_def)
	+ qed
	+ from zts_def(2) have lookup_e_z: "mmap_lookup e z = Some ts"
	+ using zts_def(1) Z_def by (auto dest: Mapping_keys_dest)
	+ have "sup_leadsto init step rho' i j z = Some ts"
	+ using lookup_e_z lookup_e
	+ by auto
	+ then obtain l where l_def: "l < i" "steps step rho' init (l, j) = z" "ts_at rho' l = ts"
	+ using sup_leadsto_SomeE[OF i_j]
	+ by (fastforce simp: rho'_def ts_at_def nth_append)
	+ have l_j: "l \<le> j"
	+ using less_le_trans[OF l_def(1) i_j] by auto
	+ have "l \<in> L"
	+ unfolding L_def using l_def zts_def(1) Z_alt
	+ by auto (metis (no_types, lifting) Suc_eq_plus1 bs_at_rho'_j l_j steps_app)
	+ then have "l \<le> Max L" "Max L < i"
	+ using L_nonempty fin_L
	+ by (auto simp add: L_def)
	+ then show "Sup_fin ((the \<circ> mmap_lookup e) ` Z) \<le> ts_at rho' (Max L)"
	+ unfolding zts_def(3) l_def(3)[symmetric]
	+ using ts_at_mono i_j j_lt_rho'
	+ by (auto simp: rho'_def)
	+ next
	+ obtain l where l_def: "Max L = l" "l < i" "steps step rho' init (l, Suc j) = q"
	+ using Max_in[OF fin_L L_nonempty] L_def by auto
	+ obtain z where z_def: "steps step rho' init (l, j) = z" "step z bs = q"
	+ using l_def(2,3) i_j bs_at_rho'_j
	+ by (metis less_imp_le_nat less_le_trans steps_appE)
	+ have z_in_Z: "z \<in> Z"
	+ unfolding Z_alt
	+ using l_def(2) z_def i_j
	+ by fastforce
	+ have lookup_e_z: "mmap_lookup e z = sup_leadsto init step rho' i j z"
	+ using lookup_e z_in_Z Z_alt
	+ by auto
	+ obtain l' where l'_def: "sup_leadsto init step rho' i j z = Some (ts_at rho' l')"
	+ "l \<le> l'" "l' < i"
	+ using sup_leadsto_SomeI[OF l_def(2) z_def(1)] by auto
	+ have "ts_at rho' l' \<in> (the \<circ> mmap_lookup e) ` Z"
	+ using lookup_e_z l'_def(1) z_in_Z
	+ by force
	+ then have "ts_at rho' l' \<le> Sup_fin ((the \<circ> mmap_lookup e) ` Z)"
	+ using Inf_fin_le_Sup_fin fin_Z z_in_Z
	+ by (simp add: Sup_fin.coboundedI)
	+ then show "ts_at rho' (Max L) \<le> Sup_fin ((the \<circ> mmap_lookup e) ` Z)"
	+ unfolding l_def(1)
	+ using ts_at_mono l'_def(2,3) i_j j_lt_rho'
	+ by (fastforce simp: rho'_def)
	+ qed
	+ then show ?thesis
	+ unfolding lookup_e' sup_leadsto by auto
	+ qed
	+ qed
	+ have "distinct (map fst s')" "distinct (map fst e')"
	+ using distinct_before mmap_fold_distinct
	+ unfolding s'_mmap_map mmap_map_fst e'_fold_sup_st'' fold_sup_def
	+ by auto
	+ moreover have "mmap_keys s' = {q. \<exists>l\<le>i. steps step rho' init (l, i) = q}"
	+ unfolding keys_s' rho'_def
	+ using valid_before(1,7) valid_s_def[of init step st accept rho i i j s]
	+ by (auto simp: steps_app_cong[of _ rho step])
	+ moreover have "reaches_on run_t ti (drop i (map fst rho')) tj'"
	+ "reaches_on run_sub si (drop i (map snd rho')) sj'"
	+ using valid_before reaches_on_app run_tj run_sj
	+ by (auto simp: rho'_def run_t_def run_sub_def)
	+ ultimately show ?thesis
	+ unfolding adv_end
	+ using valid_before lookup_e' lookup_s' ts_at_mono s'_mmap_map(3) e'_fold_sup_st''(2)
	+ by (fastforce simp: valid_window_def Let_def init_def step_def accept_def run_t_def
	+ run_sub_def i_def ti_def si_def j_def tj_def sj_def s_def e'_def
	+ rho'_def valid_s_def intro!: exI[of _ rho'] split: option.splits)
	+qed
	+
	+lemma adv_end_bounds:
	+ assumes "w_run_t args (w_tj w) = Some (tj', t)"
	+ "w_run_sub args (w_sj w) = Some (sj', bs)"
	+ "adv_end args w = Some w'"
	+ shows "w_i w' = w_i w" "w_ti w' = w_ti w" "w_si w' = w_si w"
	+ "w_j w' = Suc (w_j w)" "w_tj w' = tj'" "w_sj w' = sj'"
	+ using assms
	+ by (auto simp: adv_end_def Let_def split: prod.splits)
	+
	+definition drop_cur :: "nat \<Rightarrow> ('c \<times> ('d \<times> nat) option) \<Rightarrow> ('c \<times> ('d \<times> nat) option)" where
	+ "drop_cur i = (\<lambda>(q', tstp). (q', case tstp of Some (ts, tp) \<Rightarrow>
	+ if tp = i then None else tstp \| None \<Rightarrow> tstp))"
	+
	+definition adv_d :: "('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('c \<times> 'b, 'c) mapping \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow>
	+ ('c, 'c \<times> ('d \<times> nat) option) mmap \<Rightarrow>
	+ (('c, 'c \<times> ('d \<times> nat) option) mmap \<times> ('c \<times> 'b, 'c) mapping)" where
	+ "adv_d step st i b s = (mmap_fold' s st (\<lambda>((x, v), st). case cstep step st x b of (x', st') \<Rightarrow>
	+ ((x', drop_cur i v), st')) (\<lambda>x y. x) [])"
	+
	+lemma adv_d_mmap_fold:
	+ assumes inv: "\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v"
	+ and fold': "mmap_fold' s st (\<lambda>((x, v), st). case cstep step st x bs of (x', st') \<Rightarrow>
	+ ((x', drop_cur i v), st')) (\<lambda>x y. x) r = (s', st')"
	+ shows "s' = mmap_fold s (\<lambda>(x, v). (step x bs, drop_cur i v)) (\<lambda>x y. x) r \<and>
	+ (\<forall>q bs. case Mapping.lookup st' (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v)"
	+proof -
	+ define inv where "inv \<equiv> \<lambda>st. \<forall>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True
	+ \| Some v \<Rightarrow> step q bs = v"
	+ have inv_st: "inv st"
	+ using inv
	+ by (auto simp: inv_def)
	+ show ?thesis
	+ by (rule mmap_fold'_eq[OF fold', of inv "\<lambda>(x, v). (step x bs, drop_cur i v)",
	+ OF inv_st, unfolded inv_def])
	+ (auto simp: cstep_def Let_def Mapping.lookup_update'
	+ split: prod.splits option.splits if_splits)
	+qed
	+
	+definition keys_idem :: "('c \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow>
	+ ('c, 'c \<times> ('d \<times> nat) option) mmap \<Rightarrow> bool" where
	+ "keys_idem step i b s = (\<forall>x \<in> mmap_keys s. \<forall>x' \<in> mmap_keys s.
	+ step x b = step x' b \<longrightarrow> drop_cur i (the (mmap_lookup s x)) =
	+ drop_cur i (the (mmap_lookup s x')))"
	+
	+lemma adv_d_keys:
	+ assumes inv: "\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v"
	+ and distinct: "distinct (map fst s)"
	+ and adv_d: "adv_d step st i bs s = (s', st')"
	+shows "mmap_keys s' = (\<lambda>q. step q bs) ` (mmap_keys s)"
	+ using adv_d_mmap_fold[OF inv adv_d[unfolded adv_d_def]]
	+ mmap_fold_set[OF distinct]
	+ unfolding mmap_keys_def
	+ by fastforce
	+
	+lemma lookup_adv_d_None:
	+ assumes inv: "\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v"
	+ and distinct: "distinct (map fst s)"
	+ and adv_d: "adv_d step st i bs s = (s', st')"
	+ and Z_empty: "{x \<in> mmap_keys s. step x bs = z} = {}"
	+ shows "mmap_lookup s' z = None"
	+proof -
	+ have "z \<notin> mmap_keys (mmap_fold s (\<lambda>(x, v). (step x bs, drop_cur i v)) (\<lambda>x y. x) [])"
	+ using Z_empty[unfolded mmap_keys_def] mmap_fold_set[OF distinct]
	+ by (auto simp: mmap_keys_def)
	+ then show ?thesis
	+ using adv_d adv_d_mmap_fold[OF inv adv_d[unfolded adv_d_def]]
	+ unfolding adv_d_def
	+ by (simp add: Mapping_lookup_None_intro)
	+qed
	+
	+lemma lookup_adv_d_Some:
	+ assumes inv: "\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v"
	+ and distinct: "distinct (map fst s)" and idem: "keys_idem step i bs s"
	+ and wit: "x \<in> mmap_keys s" "step x bs = z"
	+ and adv_d: "adv_d step st i bs s = (s', st')"
	+ shows "mmap_lookup s' z = Some (drop_cur i (the (mmap_lookup s x)))"
	+proof -
	+ have z_in_keys: "z \<in> mmap_keys (mmap_fold s (\<lambda>(x, v). (step x bs, drop_cur i v)) (\<lambda>x y. x) [])"
	+ using wit(1,2)[unfolded mmap_keys_def] mmap_fold_set[OF distinct]
	+ by (force simp: mmap_keys_def)
	+ obtain v vs where vs_def: "mmap_lookup s' z = Some (foldl (\<lambda>x y. x) v vs)"
	+ "v # vs = map (\<lambda>(x, v). drop_cur i v) (filter (\<lambda>(k, v). step k bs = z) s)"
	+ using adv_d adv_d_mmap_fold[OF inv adv_d[unfolded adv_d_def]]
	+ unfolding adv_d_def
	+ using mmap_fold_lookup[OF distinct, of "(\<lambda>(x, v). (step x bs, drop_cur i v))" "\<lambda>x y. x" z]
	+ Mapping_keys_dest[OF z_in_keys]
	+ by (force simp: adv_d_def mmap_keys_def split: list.splits)
	+ have "set (v # vs) = drop_cur i ` (the \<circ> mmap_lookup s) ` {x \<in> mmap_keys s. step x bs = z}"
	+ proof (rule set_eqI, rule iffI)
	+ fix w
	+ assume "w \<in> set (v # vs)"
	+ then obtain x y where xy_def: "x \<in> mmap_keys s" "step x bs = z" "(x, y) \<in> set s"
	+ "w = drop_cur i y"
	+ using vs_def(2)
	+ by (auto simp add: mmap_keys_def rev_image_eqI)
	+ show "w \<in> drop_cur i ` (the \<circ> mmap_lookup s) ` {x \<in> mmap_keys s. step x bs = z}"
	+ using xy_def(1,2,4) mmap_lookup_distinct[OF distinct xy_def(3)]
	+ by force
	+ next
	+ fix w
	+ assume "w \<in> drop_cur i ` (the \<circ> mmap_lookup s) ` {x \<in> mmap_keys s. step x bs = z}"
	+ then obtain x y where xy_def: "x \<in> mmap_keys s" "step x bs = z" "(x, y) \<in> set s"
	+ "w = drop_cur i y"
	+ using mmap_lookup_distinct[OF distinct]
	+ by (auto simp add: Mapping_keys_intro distinct mmap_lookup_def dest: Mapping_keys_dest)
	+ show "w \<in> set (v # vs)"
	+ using xy_def
	+ by (force simp: vs_def(2))
	+ qed
	+ then have "foldl (\<lambda>x y. x) v vs = drop_cur i (the (mmap_lookup s x))"
	+ using wit
	+ apply (induction vs arbitrary: v)
	+ apply (auto)
	+ apply (smt empty_is_image idem imageE insert_not_empty keys_idem_def mem_Collect_eq
	+ the_elem_eq the_elem_image_unique)
	+ apply (smt Collect_cong idem imageE insert_compr keys_idem_def mem_Collect_eq)
	+ done
	+ then show ?thesis
	+ using wit
	+ by (auto simp: vs_def(1))
	+qed
	+
	+definition "loop_cond j = (\<lambda>(st, ac, i, ti, si, q, s, tstp). i < j \<and> q \<notin> mmap_keys s)"
	+definition "loop_body step accept run_t run_sub =
	+ (\<lambda>(st, ac, i, ti, si, q, s, tstp). case run_t ti of Some (ti', t) \<Rightarrow>
	+ case run_sub si of Some (si', b) \<Rightarrow> case adv_d step st i b s of (s', st') \<Rightarrow>
	+ case cstep step st' q b of (q', st'') \<Rightarrow> case cac accept ac q' of (\<beta>, ac') \<Rightarrow>
	+ (st'', ac', Suc i, ti', si', q', s', if \<beta> then Some (t, i) else tstp))"
	+definition "loop_inv init step accept args t0 sub rho u j tj sj =
	+ (\<lambda>(st, ac, i, ti, si, q, s, tstp). u + 1 \<le> i \<and>
	+ reach_window args t0 sub rho (i, ti, si, j, tj, sj) \<and>
	+ steps step rho init (u + 1, i) = q \<and>
	+ (\<forall>q. case Mapping.lookup ac q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v) \<and>
	+ valid_s init step st accept rho u i j s \<and> tstp = sup_acc step accept rho init (u + 1) i)"
	+
	+definition mmap_update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mmap \<Rightarrow> ('a, 'b) mmap" where
	+ "mmap_update = AList.update"
	+
	+lemma mmap_update_distinct: "distinct (map fst m) \<Longrightarrow> distinct (map fst (mmap_update k v m))"
	+ by (auto simp: mmap_update_def distinct_update)
	+
	+definition adv_start :: "('b, 'c, 'd :: timestamp, 't, 'e) args \<Rightarrow>
	+ ('b, 'c, 'd, 't, 'e) window \<Rightarrow> ('b, 'c, 'd, 't, 'e) window" where
	+ "adv_start args w = (let init = w_init args; step = w_step args; accept = w_accept args;
	+ run_t = w_run_t args; run_sub = w_run_sub args; st = w_st w; ac = w_ac w;
	+ i = w_i w; ti = w_ti w; si = w_si w; j = w_j w;
	+ s = w_s w; e = w_e w in
	+ (case run_t ti of Some (ti', t) \<Rightarrow> (case run_sub si of Some (si', bs) \<Rightarrow>
	+ let (s', st') = adv_d step st i bs s;
	+ e' = mmap_update (fst (the (mmap_lookup s init))) t e;
	+ (st_cur, ac_cur, i_cur, ti_cur, si_cur, q_cur, s_cur, tstp_cur) =
	+ while (loop_cond j) (loop_body step accept run_t run_sub)
	+ (st', ac, Suc i, ti', si', init, s', None);
	+ s'' = mmap_update init (case mmap_lookup s_cur q_cur of Some (q', tstp') \<Rightarrow>
	+ (case tstp' of Some (ts, tp) \<Rightarrow> (q', tstp') \| None \<Rightarrow> (q', tstp_cur))
	+ \| None \<Rightarrow> (q_cur, tstp_cur)) s' in
	+ w\<lparr>w_st := st_cur, w_ac := ac_cur, w_i := Suc i, w_ti := ti', w_si := si',
	+ w_s := s'', w_e := e'\<rparr>)))"
	+
	+lemma valid_adv_d:
	+ assumes valid_before: "valid_s init step st accept rho u i j s"
	+ and u_le_i: "u \<le> i" and i_lt_j: "i < j" and b_def: "b = bs_at rho i"
	+ and adv_d: "adv_d step st i b s = (s', st')"
	+ shows "valid_s init step st' accept rho u (i + 1) j s'"
	+proof -
	+ have inv_st: "\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v"
	+ using valid_before by (auto simp add: valid_s_def)
	+ have keys_s: "mmap_keys s = {q. (\<exists>l \<le> u. steps step rho init (l, i) = q)}"
	+ using valid_before by (auto simp add: valid_s_def)
	+ have fin_keys_s: "finite (mmap_keys s)"
	+ using valid_before by (auto simp add: valid_s_def)
	+ have lookup_s: "\<And>q q' tstp. mmap_lookup s q = Some (q', tstp) \<Longrightarrow>
	+ steps step rho q (i, j) = q' \<and> tstp = sup_acc step accept rho q i j"
	+ using valid_before Mapping_keys_intro
	+ by (auto simp add: valid_s_def) (smt case_prodD option.simps(5))+
	+ have drop_cur_i: "\<And>x. x \<in> mmap_keys s \<Longrightarrow> drop_cur i (the (mmap_lookup s x)) =
	+ (steps step rho (step x (bs_at rho i)) (i + 1, j),
	+ sup_acc step accept rho (step x (bs_at rho i)) (i + 1) j)"
	+ proof -
	+ fix x
	+ assume assms: "x \<in> mmap_keys s"
	+ obtain q tstp where q_def: "mmap_lookup s x = Some (q, tstp)"
	+ using assms(1) by (auto dest: Mapping_keys_dest)
	+ have q_q': "q = steps step rho (step x (bs_at rho i)) (i + 1, j)"
	+ "tstp = sup_acc step accept rho x i j"
	+ using lookup_s[OF q_def] steps_split[OF i_lt_j] assms(1) by auto
	+ show "drop_cur i (the (mmap_lookup s x)) =
	+ (steps step rho (step x (bs_at rho i)) (i + 1, j),
	+ sup_acc step accept rho (step x (bs_at rho i)) (i + 1) j)"
	+ using q_def sup_acc_None[OF i_lt_j, of step accept rho]
	+ sup_acc_i[OF i_lt_j, of step accept rho] sup_acc_l[OF i_lt_j, of _ step accept rho]
	+ unfolding q_q'
	+ by (auto simp add: drop_cur_def split: option.splits)
	+ qed
	+ have valid_drop_cur: "\<And>x x'. x \<in> mmap_keys s \<Longrightarrow> x' \<in> mmap_keys s \<Longrightarrow>
	+ step x (bs_at rho i) = step x' (bs_at rho i) \<Longrightarrow> drop_cur i (the (mmap_lookup s x)) =
	+ drop_cur i (the (mmap_lookup s x'))"
	+ using drop_cur_i by auto
	+ then have keys_idem: "keys_idem step i b s"
	+ unfolding keys_idem_def b_def
	+ by blast
	+ have distinct: "distinct (map fst s)"
	+ using valid_before
	+ by (auto simp: valid_s_def)
	+ have "(\<lambda>q. step q (bs_at rho i)) ` {q. \<exists>l\<le>u. steps step rho init (l, i) = q} =
	+ {q. \<exists>l\<le>u. steps step rho init (l, i + 1) = q}"
	+ using steps_app[of _ i step rho init] u_le_i
	+ by auto
	+ then have keys_s': "mmap_keys s' = {q. \<exists>l\<le>u. steps step rho init (l, i + 1) = q}"
	+ using adv_d_keys[OF _ distinct adv_d] inv_st
	+ unfolding keys_s b_def
	+ by auto
	+ have lookup_s': "\<And>q q' tstp. mmap_lookup s' q = Some (q', tstp) \<Longrightarrow>
	+ steps step rho q (i + 1, j) = q' \<and> tstp = sup_acc step accept rho q (i + 1) j"
	+ proof -
	+ fix q q' tstp
	+ assume assm: "mmap_lookup s' q = Some (q', tstp)"
	+ obtain x where wit: "x \<in> mmap_keys s" "step x (bs_at rho i) = q"
	+ using assm lookup_adv_d_None[OF _ distinct adv_d] inv_st
	+ by (fastforce simp: b_def)
	+ have lookup_s'_q: "mmap_lookup s' q = Some (drop_cur i (the (mmap_lookup s x)))"
	+ using lookup_adv_d_Some[OF _ distinct keys_idem wit[folded b_def] adv_d] inv_st
	+ by auto
	+ then show "steps step rho q (i + 1, j) = q' \<and> tstp = sup_acc step accept rho q (i + 1) j"
	+ using assm
	+ by (simp add: drop_cur_i wit)
	+ qed
	+ have "distinct (map fst s')"
	+ using mmap_fold_distinct[OF distinct] adv_d_mmap_fold[OF inv_st adv_d[unfolded adv_d_def]]
	+ unfolding adv_d_def mmap_map_fst
	+ by auto
	+ then show "valid_s init step st' accept rho u (i + 1) j s'"
	+ unfolding valid_s_def
	+ using keys_s' lookup_s' u_le_i inv_st adv_d[unfolded adv_d_def]
	+ adv_d_mmap_fold[OF inv_st adv_d[unfolded adv_d_def]]
	+ by (auto split: option.splits dest: Mapping_keys_dest)
	+qed
	+
	+lemma mmap_lookup_update':
	+ "mmap_lookup (mmap_update k v kvs) z = (if k = z then Some v else mmap_lookup kvs z)"
	+ unfolding mmap_lookup_def mmap_update_def
	+ by (auto simp add: update_conv')
	+
	+lemma mmap_keys_update: "mmap_keys (mmap_update k v kvs) = mmap_keys kvs \<union> {k}"
	+ by (induction kvs) (auto simp: mmap_keys_def mmap_update_def)
	+
	+lemma valid_adv_start:
	+ assumes "valid_window args t0 sub rho w" "w_i w < w_j w"
	+ shows "valid_window args t0 sub rho (adv_start args w)"
	+proof -
	+ define init where "init = w_init args"
	+ define step where "step = w_step args"
	+ define accept where "accept = w_accept args"
	+ define run_t where "run_t = w_run_t args"
	+ define run_sub where "run_sub = w_run_sub args"
	+ define st where "st = w_st w"
	+ define ac where "ac = w_ac w"
	+ define i where "i = w_i w"
	+ define ti where "ti = w_ti w"
	+ define si where "si = w_si w"
	+ define j where "j = w_j w"
	+ define tj where "tj = w_tj w"
	+ define sj where "sj = w_sj w"
	+ define s where "s = w_s w"
	+ define e where "e = w_e w"
	+ have valid_before: "reach_window args t0 sub rho (i, ti, si, j, tj, sj)"
	+ "\<And>i j. i \<le> j \<Longrightarrow> j < length rho \<Longrightarrow> ts_at rho i \<le> ts_at rho j"
	+ "(\<And>q bs. case Mapping.lookup st (q, bs) of None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v)"
	+ "(\<And>q bs. case Mapping.lookup ac q of None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v)"
	+ "\<forall>q. mmap_lookup e q = sup_leadsto init step rho i j q" "distinct (map fst e)"
	+ "valid_s init step st accept rho i i j s"
	+ using assms(1)
	+ unfolding valid_window_def valid_s_def Let_def init_def step_def accept_def run_t_def
	+ run_sub_def st_def ac_def i_def ti_def si_def j_def tj_def sj_def s_def e_def
	+ by auto
	+ have distinct_before: "distinct (map fst s)" "distinct (map fst e)"
	+ using valid_before
	+ by (auto simp: valid_s_def)
	+ note i_lt_j = assms(2)[folded i_def j_def]
	+ obtain ti' si' t b where tb_def: "run_t ti = Some (ti', t)"
	+ "run_sub si = Some (si', b)"
	+ "reaches_on run_t ti' (drop (Suc i) (map fst rho)) tj"
	+ "reaches_on run_sub si' (drop (Suc i) (map snd rho)) sj"
	+ "t = ts_at rho i" "b = bs_at rho i"
	+ using valid_before i_lt_j
	+ apply (auto simp: ts_at_def bs_at_def run_t_def[symmetric] run_sub_def[symmetric]
	+ elim!: reaches_on.cases[of run_t ti "drop i (map fst rho)" tj]
	+ reaches_on.cases[of run_sub si "drop i (map snd rho)" sj])
	+ by (metis Cons_nth_drop_Suc length_map list.inject nth_map)
	+ have reaches_on_si': "reaches_on run_sub sub (take (Suc i) (map snd rho)) si'"
	+ using valid_before tb_def(2,3,4) i_lt_j reaches_on_app tb_def(1)
	+ by (auto simp: run_sub_def sub_def bs_at_def take_Suc_conv_app_nth reaches_on_app tb_def(6))
	+ have reaches_on_ti': "reaches_on run_t t0 (take (Suc i) (map fst rho)) ti'"
	+ using valid_before tb_def(2,3,4) i_lt_j reaches_on_app tb_def(1)
	+ by (auto simp: run_t_def ts_at_def take_Suc_conv_app_nth reaches_on_app tb_def(5))
	+ define e' where "e' = mmap_update (fst (the (mmap_lookup s init))) t e"
	+ obtain st' s' where s'_def: "adv_d step st i b s = (s', st')"
	+ by (metis old.prod.exhaust)
	+ obtain st_cur ac_cur i_cur ti_cur si_cur q_cur s_cur tstp_cur where loop_def:
	+ "(st_cur, ac_cur, i_cur, ti_cur, si_cur, q_cur, s_cur, tstp_cur) =
	+ while (loop_cond j) (loop_body step accept run_t run_sub)
	+ (st', ac, Suc i, ti', si', init, s', None)"
	+ by (cases "while (loop_cond j) (loop_body step accept run_t run_sub)
	+ (st', ac, Suc i, ti', si', init, s', None)") auto
	+ define s'' where "s'' = mmap_update init (case mmap_lookup s_cur q_cur of
	+ Some (q', tstp') \<Rightarrow> (case tstp' of Some (ts, tp) \<Rightarrow> (q', tstp') \| None \<Rightarrow> (q', tstp_cur))
	+ \| None \<Rightarrow> (q_cur, tstp_cur)) s'"
	+ have i_le_j: "i \<le> j"
	+ using i_lt_j by auto
	+ have length_rho: "length rho = j"
	+ using valid_before by auto
	+ have lookup_s: "\<And>q q' tstp. mmap_lookup s q = Some (q', tstp) \<Longrightarrow>
	+ steps step rho q (i, j) = q' \<and> tstp = sup_acc step accept rho q i j"
	+ using valid_before Mapping_keys_intro
	+ by (auto simp: valid_s_def) (smt case_prodD option.simps(5))+
	+ have init_in_keys_s: "init \<in> mmap_keys s"
	+ using valid_before by (auto simp add: valid_s_def)
	+ then have run_init_i_j: "steps step rho init (i, j) = fst (the (mmap_lookup s init))"
	+ using lookup_s by (auto dest: Mapping_keys_dest)
	+ have lookup_e: "\<And>q. mmap_lookup e q = sup_leadsto init step rho i j q"
	+ using valid_before by auto
	+ have lookup_e': "\<And>q. mmap_lookup e' q = sup_leadsto init step rho (i + 1) j q"
	+ proof -
	+ fix q
	+ show "mmap_lookup e' q = sup_leadsto init step rho (i + 1) j q"
	+ proof (cases "steps step rho init (i, j) = q")
	+ case True
	+ have "Max {l. l < Suc i \<and> steps step rho init (l, j) = steps step rho init (i, j)} = i"
	+ by (rule iffD2[OF Max_eq_iff]) auto
	+ then have "sup_leadsto init step rho (i + 1) j q = Some (ts_at rho i)"
	+ by (auto simp add: sup_leadsto_def True)
	+ then show ?thesis
	+ unfolding e'_def using run_init_i_j tb_def
	+ by (auto simp add: mmap_lookup_update' True)
	+ next
	+ case False
	+ show ?thesis
	+ using run_init_i_j sup_leadsto_idle[OF i_lt_j False] lookup_e[of q] False
	+ by (auto simp add: e'_def mmap_lookup_update')
	+ qed
	+ qed
	+ have reach_split: "{q. \<exists>l\<le>i + 1. steps step rho init (l, i + 1) = q} =
	+ {q. \<exists>l\<le>i. steps step rho init (l, i + 1) = q} \<union> {init}"
	+ using le_Suc_eq by auto
	+ have valid_s_i: "valid_s init step st accept rho i i j s"
	+ using valid_before by auto
	+ have valid_s'_Suc_i: "valid_s init step st' accept rho i (i + 1) j s'"
	+ using valid_adv_d[OF valid_s_i order.refl i_lt_j, OF tb_def(6) s'_def] unfolding s'_def .
	+ have loop: "loop_inv init step accept args t0 sub rho i j tj sj
	+ (st_cur, ac_cur, i_cur, ti_cur, si_cur, q_cur, s_cur, tstp_cur) \<and>
	+ \<not>loop_cond j (st_cur, ac_cur, i_cur, ti_cur, si_cur, q_cur, s_cur, tstp_cur)"
	+ unfolding loop_def
	+ proof (rule while_rule_lemma[of "loop_inv init step accept args t0 sub rho i j tj sj"
	+ "loop_cond j" "loop_body step accept run_t run_sub"
	+ "\<lambda>s. loop_inv init step accept args t0 sub rho i j tj sj s \<and> \<not> loop_cond j s"])
	+ show "loop_inv init step accept args t0 sub rho i j tj sj
	+ (st', ac, Suc i, ti', si', init, s', None)"
	+ unfolding loop_inv_def
	+ using i_lt_j valid_s'_Suc_i sup_acc_same[of step accept rho]
	+ length_rho reaches_on_si' reaches_on_ti' tb_def(3,4) valid_before(4)
	+ by (auto simp: run_t_def run_sub_def split: prod.splits)
	+ next
	+ have "{(t, s). loop_inv init step accept args t0 sub rho i j tj sj s \<and>
	+ loop_cond j s \<and> t = loop_body step accept run_t run_sub s} \<subseteq>
	+ measure (\<lambda>(st, ac, i_cur, ti, si, q, s, tstp). j - i_cur)"
	+ unfolding loop_inv_def loop_cond_def loop_body_def
	+ apply (auto simp: run_t_def run_sub_def split: option.splits)
	+ apply (metis drop_eq_Nil length_map not_less option.distinct(1) reaches_on.simps)
	+ apply (metis (no_types, lifting) drop_eq_Nil length_map not_less option.distinct(1)
	+ reaches_on.simps)
	+ apply (auto split: prod.splits)
	+ done
	+ then show "wf {(t, s). loop_inv init step accept args t0 sub rho i j tj sj s \<and>
	+ loop_cond j s \<and> t = loop_body step accept run_t run_sub s}"
	+ using wf_measure wf_subset by auto
	+ next
	+ fix state
	+ assume assms: "loop_inv init step accept args t0 sub rho i j tj sj state"
	+ "loop_cond j state"
	+ obtain st_cur ac_cur i_cur ti_cur si_cur q_cur s_cur tstp_cur
	+ where state_def: "state = (st_cur, ac_cur, i_cur, ti_cur, si_cur, q_cur, s_cur, tstp_cur)"
	+ by (cases state) auto
	+ obtain ti'_cur si'_cur t_cur b_cur where tb_cur_def: "run_t ti_cur = Some (ti'_cur, t_cur)"
	+ "run_sub si_cur = Some (si'_cur, b_cur)"
	+ "reaches_on run_t ti'_cur (drop (Suc i_cur) (map fst rho)) tj"
	+ "reaches_on run_sub si'_cur (drop (Suc i_cur) (map snd rho)) sj"
	+ "t_cur = ts_at rho i_cur" "b_cur = bs_at rho i_cur"
	+ using assms
	+ unfolding loop_inv_def loop_cond_def state_def
	+ apply (auto simp: ts_at_def bs_at_def run_t_def[symmetric] run_sub_def[symmetric]
	+ elim!: reaches_on.cases[of run_t ti_cur "drop i_cur (map fst rho)" tj]
	+ reaches_on.cases[of run_sub si_cur "drop i_cur (map snd rho)" sj])
	+ by (metis Cons_nth_drop_Suc length_map list.inject nth_map)
	+ obtain s'_cur st'_cur where s'_cur_def: "adv_d step st_cur i_cur b_cur s_cur =
	+ (s'_cur, st'_cur)"
	+ by fastforce
	+ have valid_s'_cur: "valid_s init step st'_cur accept rho i (i_cur + 1) j s'_cur"
	+ using assms valid_adv_d[of init step st_cur accept rho] tb_cur_def(6) s'_cur_def
	+ unfolding loop_inv_def loop_cond_def state_def
	+ by auto
	+ obtain q' st''_cur where q'_def: "cstep step st'_cur q_cur b_cur = (q', st''_cur)"
	+ by fastforce
	+ obtain \<beta> ac'_cur where b_def: "cac accept ac_cur q' = (\<beta>, ac'_cur)"
	+ by fastforce
	+ have step: "q' = step q_cur b_cur" "\<And>q bs. case Mapping.lookup st''_cur (q, bs) of
	+ None \<Rightarrow> True \| Some v \<Rightarrow> step q bs = v"
	+ using valid_s'_cur q'_def
	+ unfolding valid_s_def
	+ by (auto simp: cstep_def Let_def Mapping.lookup_update' split: option.splits if_splits)
	+ have accept: "\<beta> = accept q'" "\<And>q. case Mapping.lookup ac'_cur q of
	+ None \<Rightarrow> True \| Some v \<Rightarrow> accept q = v"
	+ using assms b_def
	+ unfolding loop_inv_def state_def
	+ by (auto simp: cac_def Let_def Mapping.lookup_update' split: option.splits if_splits)
	+ have steps_q': "steps step rho init (i + 1, Suc i_cur) = q'"
	+ using assms
	+ unfolding loop_inv_def state_def
	+ by auto (metis local.step(1) steps_appE tb_cur_def(6))
	+ have b_acc: "\<beta> = acc step accept rho init (i + 1, Suc i_cur)"
	+ unfolding accept(1) acc_def steps_q'
	+ by (auto simp: tb_cur_def)
	+ have valid_s''_cur: "valid_s init step st''_cur accept rho i (i_cur + 1) j s'_cur"
	+ using valid_s'_cur step(2)
	+ unfolding valid_s_def
	+ by auto
	+ have reaches_on_si': "reaches_on run_sub sub (take (Suc i_cur) (map snd rho)) si'_cur"
	+ using assms
	+ unfolding loop_inv_def loop_cond_def state_def
	+ by (auto simp: run_sub_def sub_def bs_at_def take_Suc_conv_app_nth reaches_on_app
	+ tb_cur_def(2,4,6))
	+ (metis bs_at_def reaches_on_app run_sub_def tb_cur_def(2) tb_cur_def(6))
	+ have reaches_on_ti': "reaches_on run_t t0 (take (Suc i_cur) (map fst rho)) ti'_cur"
	+ using assms
	+ unfolding loop_inv_def loop_cond_def state_def
	+ by (auto simp: run_t_def ts_at_def take_Suc_conv_app_nth reaches_on_app tb_cur_def(1,3,5))
	+ (metis reaches_on_app run_t_def tb_cur_def(1) tb_cur_def(5) ts_at_def)
	+ have "reach_window args t0 sub rho (Suc i_cur, ti'_cur, si'_cur, j, tj, sj)"
	+ using reaches_on_si' reaches_on_ti' tb_cur_def(3,4) length_rho assms(2)
	+ unfolding loop_cond_def state_def
	+ by (auto simp: run_t_def run_sub_def)
	+ moreover have "steps step rho init (i + 1, Suc i_cur) = q'"
	+ using assms steps_app
	+ unfolding loop_inv_def state_def step(1)
	+ by (auto simp: tb_cur_def(6))
	+ ultimately show "loop_inv init step accept args t0 sub rho i j tj sj
	+ (loop_body step accept run_t run_sub state)"
	+ using assms accept(2) valid_s''_cur sup_acc_ext[of _ _ step accept rho]
	+ sup_acc_ext_idle[of _ _ step accept rho]
	+ unfolding loop_inv_def loop_body_def state_def
	+ by (auto simp: tb_cur_def(1,2,5) s'_cur_def q'_def b_def b_acc
	+ split: option.splits prod.splits)
	+ qed auto
	+ have valid_stac_cur: "\<forall>q bs. case Mapping.lookup st_cur (q, bs) of None \<Rightarrow> True
	+ \| Some v \<Rightarrow> step q bs = v" "\<forall>q. case Mapping.lookup ac_cur q of None \<Rightarrow> True
	+ \| Some v \<Rightarrow> accept q = v"
	+ using loop unfolding loop_inv_def valid_s_def
	+ by auto
	+ have valid_s'': "valid_s init step st_cur accept rho (i + 1) (i + 1) j s''"
	+ proof (cases "mmap_lookup s_cur q_cur")
	+ case None
	+ then have added: "steps step rho init (i + 1, j) = q_cur"
	+ "tstp_cur = sup_acc step accept rho init (i + 1) j"
	+ using loop unfolding loop_inv_def loop_cond_def
	+ by (auto dest: Mapping_keys_dest)
	+ have s''_case: "s'' = mmap_update init (q_cur, tstp_cur) s'"
	+ unfolding s''_def using None by auto
	+ show ?thesis
	+ using valid_s'_Suc_i reach_split added mmap_update_distinct valid_stac_cur
	+ unfolding s''_case valid_s_def mmap_keys_update
	+ by (auto simp add: mmap_lookup_update' split: option.splits)
	+ next
	+ case (Some p)
	+ obtain q' tstp' where p_def: "p = (q', tstp')"
	+ by (cases p) auto
	+ note lookup_s_cur = Some[unfolded p_def]
	+ have i_cur_in: "i + 1 \<le> i_cur" "i_cur \<le> j"
	+ using loop unfolding loop_inv_def by auto
	+ have q_cur_def: "steps step rho init (i + 1, i_cur) = q_cur"
	+ using loop unfolding loop_inv_def by auto
	+ have valid_s_cur: "valid_s init step st_cur accept rho i i_cur j s_cur"
	+ using loop unfolding loop_inv_def by auto
	+ have q'_steps: "steps step rho q_cur (i_cur, j) = q'"
	+ using Some valid_s_cur unfolding valid_s_def p_def
	+ by (auto intro: Mapping_keys_intro) (smt case_prodD option.simps(5))
	+ have tstp_cur: "tstp_cur = sup_acc step accept rho init (i + 1) i_cur"
	+ using loop unfolding loop_inv_def by auto
	+ have tstp': "tstp' = sup_acc step accept rho q_cur i_cur j"
	+ using loop Some unfolding loop_inv_def p_def valid_s_def
	+ by (auto intro: Mapping_keys_intro) (smt case_prodD option.simps(5))
	+ have added: "steps step rho init (i + 1, j) = q'"
	+ using steps_comp[OF i_cur_in q_cur_def q'_steps] .
	+ show ?thesis
	+ proof (cases tstp')
	+ case None
	+ have s''_case: "s'' = mmap_update init (q', tstp_cur) s'"
	+ unfolding s''_def lookup_s_cur None by auto
	+ have tstp_cur_opt: "tstp_cur = sup_acc step accept rho init (i + 1) j"
	+ using sup_acc_comp_None[OF i_cur_in, of step accept rho init, unfolded q_cur_def,
	+ OF tstp'[unfolded None, symmetric]]
	+ unfolding tstp_cur by auto
	+ then show ?thesis
	+ using valid_s'_Suc_i reach_split added mmap_update_distinct valid_stac_cur
	+ unfolding s''_case valid_s_def mmap_keys_update
	+ by (auto simp add: mmap_lookup_update' split: option.splits)
	+ next
	+ case (Some p')
	+ obtain ts tp where p'_def: "p' = (ts, tp)"
	+ by (cases p') auto
	+ have True: "tp \<ge> i_cur"
	+ using sup_acc_SomeE[OF tstp'[unfolded Some p'_def, symmetric]] by auto
	+ have s''_case: "s'' = mmap_update init (q', tstp') s'"
	+ unfolding s''_def lookup_s_cur Some p'_def using True by auto
	+ have tstp'_opt: "tstp' = sup_acc step accept rho init (i + 1) j"
	+ using sup_acc_comp_Some_ge[OF i_cur_in True
	+ tstp'[unfolded Some p'_def q_cur_def[symmetric], symmetric]]
	+ unfolding tstp' by (auto simp: q_cur_def[symmetric])
	+ then show ?thesis
	+ using valid_s'_Suc_i reach_split added mmap_update_distinct valid_stac_cur
	+ unfolding s''_case valid_s_def mmap_keys_update
	+ by (auto simp add: mmap_lookup_update' split: option.splits)
	+ qed
	+ qed
	+ have "distinct (map fst e')"
	+ using mmap_update_distinct[OF distinct_before(2), unfolded e'_def]
	+ unfolding e'_def .
	+ then have "valid_window args t0 sub rho
	+ (w\<lparr>w_st := st_cur, w_ac := ac_cur, w_i := Suc i, w_ti := ti', w_si := si', w_s := s'', w_e := e'\<rparr>)"
	+ using i_lt_j lookup_e' valid_s'' length_rho tb_def(3,4) reaches_on_si' reaches_on_ti'
	+ valid_before[unfolded step_def accept_def] valid_stac_cur(2)[unfolded accept_def]
	+ by (auto simp: valid_window_def Let_def init_def step_def accept_def run_t_def
	+ run_sub_def st_def ac_def i_def ti_def si_def j_def tj_def sj_def s_def e_def)
	+ moreover have "adv_start args w = w\<lparr>w_st := st_cur, w_ac := ac_cur, w_i := Suc i,
	+ w_ti := ti', w_si := si', w_s := s'', w_e := e'\<rparr>"
	+ unfolding adv_start_def Let_def s''_def e'_def
	+ using tb_def(1,2) s'_def i_lt_j loop_def valid_before(3)
	+ by (auto simp: valid_window_def Let_def init_def step_def accept_def run_t_def
	+ run_sub_def st_def ac_def i_def ti_def si_def j_def tj_def sj_def s_def e_def
	+ split: prod.splits)
	+ ultimately show ?thesis
	+ by auto
	+qed
	+
	+lemma valid_adv_start_bounds:
	+ assumes "valid_window args t0 sub rho w" "w_i w < w_j w"
	+ shows "w_i (adv_start args w) = Suc (w_i w)" "w_j (adv_start args w) = w_j w"
	+ "w_tj (adv_start args w) = w_tj w" "w_sj (adv_start args w) = w_sj w"
	+ using assms
	+ by (auto simp: adv_start_def Let_def valid_window_def split: option.splits prod.splits
	+ elim: reaches_on.cases)
	+
	+lemma valid_adv_start_bounds':
	+ assumes "valid_window args t0 sub rho w" "w_run_t args (w_ti w) = Some (ti', t)"
	+ "w_run_sub args (w_si w) = Some (si', bs)"
	+ shows "w_ti (adv_start args w) = ti'" "w_si (adv_start args w) = si'"
	+ using assms
	+ by (auto simp: adv_start_def Let_def valid_window_def split: option.splits prod.splits)
	+
	+end
	diff --git a/thys/VYDRA_MDL/document/root.bib b/thys/VYDRA_MDL/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/document/root.bib
	@@ -0,0 +1,35 @@
	+@article{DBLP:journals/rts/Koymans90,
	+ author = {Ron Koymans},
	+ title = {Specifying Real-Time Properties with Metric Temporal Logic},
	+ journal = {Real Time Syst.},
	+ volume = {2},
	+ number = {4},
	+ pages = {255--299},
	+ year = {1990},
	+ url = {https://doi.org/10.1007/BF01995674},
	+ doi = {10.1007/BF01995674},
	+ timestamp = {Thu, 10 Sep 2020 14:37:57 +0200},
	+ biburl = {https://dblp.org/rec/journals/rts/Koymans90.bib},
	+ bibsource = {dblp computer science bibliography, https://dblp.org}
	+}
	+
	+@inproceedings{DBLP:conf/atva/RaszykBT20,
	+ author = {Martin Raszyk and
	+ David A. Basin and
	+ Dmitriy Traytel},
	+ editor = {Dang Van Hung and
	+ Oleg Sokolsky},
	+ title = {Multi-head Monitoring of Metric Dynamic Logic},
	+ booktitle = {Automated Technology for Verification and Analysis - 18th International
	+ Symposium, {ATVA} 2020, Hanoi, Vietnam, October 19-23, 2020, Proceedings},
	+ series = {Lecture Notes in Computer Science},
	+ volume = {12302},
	+ pages = {233--250},
	+ publisher = {Springer},
	+ year = {2020},
	+ url = {https://doi.org/10.1007/978-3-030-59152-6\_13},
	+ doi = {10.1007/978-3-030-59152-6\_13},
	+ timestamp = {Tue, 20 Oct 2020 18:27:30 +0200},
	+ biburl = {https://dblp.org/rec/conf/atva/RaszykBT20.bib},
	+ bibsource = {dblp computer science bibliography, https://dblp.org}
	+}
	diff --git a/thys/VYDRA_MDL/document/root.tex b/thys/VYDRA_MDL/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/VYDRA_MDL/document/root.tex
	@@ -0,0 +1,68 @@
	+\documentclass[10pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{a4wide}
	+\usepackage[english]{babel}
	+\usepackage{eufrak}
	+\usepackage{amssymb}
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{literal}
	+
	+
	+\begin{document}
	+
	+\title{Multi-Head Monitoring of Metric Dynamic Logic}
	+\author{Martin Raszyk}
	+
	+\maketitle
	+
	+\begin{abstract}
	+Runtime monitoring (or runtime verification) is an approach to checking
	+compliance of a system's execution with a specification (e.g., a temporal
	+formula). The system's execution is logged into a \emph{trace}---a sequence of
	+time-points, each consisting of a time-stamp and observed events. A
	+\emph{monitor} is an algorithm that produces \emph{verdicts} on the satisfaction
	+of a temporal formula on a trace.
	+
	+We formalize the time-stamps as an abstract algebraic structure satisfying
	+certain assumptions. Instances of this structure include natural numbers, real
	+numbers, and lexicographic combinations of them. We also include the
	+formalization of a conversion from the abstract time domain introduced by
	+Koymans~\cite{DBLP:journals/rts/Koymans90} to our time-stamps.
	+
	+We formalize a monitoring algorithm for metric dynamic logic, an extension of
	+metric temporal logic with regular expressions. The monitor computes whether a
	+given formula is satisfied at every position in an input trace of time-stamped
	+events. Our monitor follows the multi-head paradigm: it reads the input
	+simultaneously at multiple positions and moves its reading heads asynchronously.
	+This mode of operation results in unprecedented time and space complexity
	+guarantees for metric dynamic logic: The monitor's amortized time complexity to
	+process a time-point and the monitor's space complexity neither depends on the
	+event-rate, i.e., the number of events within a fixed time-unit, nor on the
	+numeric constants occurring in the quantitative temporal constraints in the
	+given formula.
	+
	+The multi-head monitoring algorithm for metric dynamic logic is reported in our
	+paper ``Multi-Head Monitoring of Metric Dynamic
	+Logic''~\cite{DBLP:conf/atva/RaszykBT20} published at ATVA 2020. We have also
	+formalized unpublished specialized algorithms for the temporal operators of
	+metric temporal logic.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+% sane default for proof documents
	+\parindent 0pt\parskip 0.5ex
	+
	+% generated text of all theories
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/WOOT_Strong_Eventual_Consistency/Consistency.thy b/thys/WOOT_Strong_Eventual_Consistency/Consistency.thy
	--- a/thys/WOOT_Strong_Eventual_Consistency/Consistency.thy
	+++ b/thys/WOOT_Strong_Eventual_Consistency/Consistency.thy
	@@ -1,141 +1,141 @@
	subsection \<open>Consistency of sets of WOOT Messages \label{sec:consistency}\<close>

	theory Consistency
	imports SortKeys Psi Sorting DistributedExecution
	begin

	definition insert_messages :: "('\<I>, '\<Sigma>) message set \<Rightarrow> ('\<I>, '\<Sigma>) insert_message set"
	where "insert_messages M = {x. Insert x \<in> M}"

	-lemma insert_insert_message:
	+lemma insert_insert_message:
	"insert_messages (M \<union> {Insert m}) = insert_messages M \<union> {m}"
	by (simp add:insert_messages_def, simp add:set_eq_iff)

	-definition delete_messages :: "('a, 's) message set \<Rightarrow> 'a delete_message set"
	+definition delete_messages :: "('\<I>, '\<Sigma>) message set \<Rightarrow> '\<I> delete_message set"
	where "delete_messages M = {x. Delete x \<in> M}"

	fun depends_on where "depends_on M x y = (x \<in> M \<and> y \<in> M \<and> I x \<in> deps (Insert y))"

	definition a_conditions ::
	- "(('a :: linorder), 's) insert_message set \<Rightarrow> ('a extended \<Rightarrow> 'a position) \<Rightarrow> bool"
	+ "('\<I> :: linorder, '\<Sigma>) insert_message set \<Rightarrow> ('\<I> extended \<Rightarrow> '\<I> position) \<Rightarrow> bool"
	where "a_conditions M a = (
	a \<turnstile> < a \<stileturn> \<and>
	(\<forall>m. m \<in> M \<longrightarrow> a (P m) < a (S m) \<and>
	a \<lbrakk>I m\<rbrakk> = \<lbrakk>\<Psi> (a (P m), a (S m)) (I m)\<rbrakk>))"

	-definition consistent :: "('a :: linorder, 's) message set \<Rightarrow> bool"
	+definition consistent :: "('\<I> :: linorder, '\<Sigma>) message set \<Rightarrow> bool"
	where "consistent M \<equiv>
	inj_on I (insert_messages M) \<and>
	(\<Union> (deps ` M) \<subseteq> (I ` insert_messages M)) \<and>
	wfP (depends_on (insert_messages M)) \<and>
	(\<exists>a. a_conditions (insert_messages M) a)"

	lemma consistent_subset:
	assumes "consistent N"
	assumes "M \<subseteq> N"
	assumes "\<Union> (deps ` M) \<subseteq> (I ` insert_messages M)"
	shows "consistent M"
	proof -
	have a:"insert_messages M \<subseteq> insert_messages N"
	using assms(2) insert_messages_def by blast
	hence b:"inj_on I (insert_messages M)"
	using assms(1) consistent_def inj_on_subset by blast
	have "wfP (depends_on (insert_messages N))"
	using assms(1) consistent_def by blast
	moreover have
	"depends_on (insert_messages M) \<le> depends_on (insert_messages N)"
	using a by auto
	ultimately have c:"wfP (depends_on (insert_messages M))"
	using a wf_subset [to_pred] by blast
	obtain a where "a_conditions (insert_messages N) a"
	using assms(1) consistent_def by blast
	hence "a_conditions (insert_messages M) a"
	by (meson a a_conditions_def subset_iff)
	thus ?thesis using b c assms(3) consistent_def by blast
	qed

	lemma pred_is_dep: "P m = \<lbrakk> i \<rbrakk> \<longrightarrow> i \<in> deps (Insert m)"
	by (metis Un_iff deps.simps(1) extended.set_intros extended.simps(27)
	extended_to_set.simps(1) insert_message.exhaust_sel)

	lemma succ_is_dep: "S m = \<lbrakk> i \<rbrakk> \<longrightarrow> i \<in> deps (Insert m)"
	by (metis Un_insert_right deps.simps(1) extended_to_set.simps(1) insertI1
	insert_message.exhaust_sel)

	lemma a_subset:
	fixes M N a
	assumes "M \<subseteq> N"
	assumes "a_conditions (insert_messages N) a"
	shows "a_conditions (insert_messages M) a"
	using assms by (simp add:a_conditions_def insert_messages_def, blast)

	definition delete_maybe :: "'\<I> \<Rightarrow> ('\<I>, '\<Sigma>) message set \<Rightarrow> '\<Sigma> \<Rightarrow> '\<Sigma> option" where
	"delete_maybe i D s = (if Delete (DeleteMessage i) \<in> D then None else Some s)"

	definition to_woot_character ::
	"('\<I>, '\<Sigma>) message set \<Rightarrow> ('\<I>, '\<Sigma>) insert_message \<Rightarrow> ('\<I>, '\<Sigma>) woot_character"
	where
	"to_woot_character D m = (
	case m of
	(InsertMessage l i u s) \<Rightarrow> InsertMessage l i u (delete_maybe i D s))"

	lemma to_woot_character_keeps_i [simp]: "I (to_woot_character M m) = I m"
	by (cases m, simp add:to_woot_character_def)

	lemma to_woot_character_keeps_i_lifted [simp]:
	"I ` to_woot_character M ` X = I ` X"
	by (metis (no_types, lifting) image_cong image_image to_woot_character_keeps_i)

	lemma to_woot_character_keeps_P [simp]: "P (to_woot_character M m) = P m"
	by (cases m, simp add:to_woot_character_def)

	lemma to_woot_character_keeps_S [simp]: "S (to_woot_character M m) = S m"
	by (cases m, simp add:to_woot_character_def)

	lemma to_woot_character_insert_no_eff:
	"to_woot_character (insert (Insert m) M) = to_woot_character M"
	by (rule HOL.ext, simp add:delete_maybe_def to_woot_character_def insert_message.case_eq_if)

	definition is_associated_string ::
	- "('a, 's) message set \<Rightarrow> ('a :: linorder, 's) woot_character list \<Rightarrow> bool"
	+ "('\<I>, '\<Sigma>) message set \<Rightarrow> ('\<I> :: linorder, '\<Sigma>) woot_character list \<Rightarrow> bool"
	where "is_associated_string M s \<equiv> (
	consistent M \<and>
	set s = to_woot_character M ` (insert_messages M) \<and>
	(\<forall>a. a_conditions (insert_messages M) a \<longrightarrow>
	sorted_wrt (<) (map a (ext_ids s))))"

	fun is_certified_associated_string where
	"is_certified_associated_string M (Inr v) = is_associated_string M v" \|
	"is_certified_associated_string M (Inl _) = False"

	lemma associated_string_unique:
	assumes "is_associated_string M s"
	assumes "is_associated_string M t"
	shows "s = t"
	using assms
	apply (simp add:ext_ids_def is_associated_string_def consistent_def
	sorted_wrt_append)
	by (metis sort_set_unique)

	lemma is_certified_associated_string_unique:
	assumes "is_certified_associated_string M s"
	assumes "is_certified_associated_string M t"
	shows "s = t"
	using assms by (case_tac s, case_tac [!] t, (simp add:associated_string_unique)+)

	lemma empty_consistent: "consistent {}"
	proof -
	have "a_conditions {} (\<lambda>x. (case x of \<turnstile> \<Rightarrow> \<turnstile> \| \<stileturn> \<Rightarrow> \<stileturn>))"
	by (simp add: a_conditions_def)
	hence "\<exists>f. a_conditions {} f" by blast
	moreover have "wfP (depends_on {})" by (simp add: wfP_eq_minimal)
	ultimately show ?thesis by (simp add:consistent_def insert_messages_def)
	qed

	lemma empty_associated: "is_associated_string {} []"
	by (simp add:is_associated_string_def insert_messages_def empty_consistent
	ext_ids_def a_conditions_def)

	text \<open>The empty set of messages is consistent and the associated string is the empty string.\<close>

	end
	diff --git a/thys/WOOT_Strong_Eventual_Consistency/CreateConsistent.thy b/thys/WOOT_Strong_Eventual_Consistency/CreateConsistent.thy
	--- a/thys/WOOT_Strong_Eventual_Consistency/CreateConsistent.thy
	+++ b/thys/WOOT_Strong_Eventual_Consistency/CreateConsistent.thy
	@@ -1,225 +1,225 @@
	subsection \<open>Create Consistent\label{sec:create_consistent}\<close>

	theory CreateConsistent
	imports CreateAlgorithms Consistency
	begin

	lemma nth_visible_inc':
	assumes "sorted_wrt (<) (map a (ext_ids s))"
	assumes "nth_visible s n = Inr i"
	assumes "nth_visible s (Suc n) = Inr j"
	shows "a i < a j"
	proof -
	have "subseq (ext_ids (filter is_visible s)) (ext_ids s)"
	by (simp add: ext_ids_def subseq_map)
	hence "sorted_wrt (<) (map a (ext_ids (filter is_visible s)))"
	using assms(1) subseq_imp_sorted sorted_wrt_map by blast
	moreover have a:"Suc n < length (ext_ids (filter is_visible s))"
	apply (rule classical) using assms(3) by simp
	ultimately show ?thesis using assms(2) assms(3) apply (simp)
	using sorted_wrt_nth_less by fastforce
	qed

	lemma nth_visible_eff:
	assumes "nth_visible s n = Inr i"
	shows "extended_to_set i \<subseteq> I ` set s"
	proof -
	have "i \<in> set (ext_ids (filter is_visible s))"
	apply (cases "n < length (ext_ids (filter is_visible s))")
	using assms by auto
	thus ?thesis
	apply (simp add: ext_ids_def)
	using extended.inject by auto
	qed

	lemma subset_mono:
	assumes "N \<subseteq> M"
	shows "I ` insert_messages N \<subseteq> I ` insert_messages M"
	proof -
	have "insert_messages N \<subseteq> insert_messages M" using assms
	by (metis (no_types, lifting) Collect_mono_iff insert_messages_def subsetCE)
	thus ?thesis by (simp add: image_mono)
	qed

	lemma deps_insert:
	assumes "\<Union> (deps ` M) \<subseteq> (I ` insert_messages M)"
	assumes "deps m \<subseteq> I ` insert_messages M"
	shows "\<Union> (deps ` (M \<union> {m})) \<subseteq> (I ` insert_messages (M \<union> {m}))"
	proof -
	have "deps m \<subseteq> I ` insert_messages (M \<union> {m})" using assms(2) subset_mono
	by (metis Un_upper1 order_trans)
	thus ?thesis using assms(1) apply (simp)
	by (meson rev_subsetD subsetI subset_insertI subset_mono)
	qed

	lemma wf_add:
	- fixes m :: "('a,'b) insert_message"
	+ fixes m :: "('\<I>,'\<Sigma>) insert_message"
	assumes "wfP (depends_on M)"
	assumes "\<And>n. n \<in> (M \<union> {m}) \<Longrightarrow> I m \<notin> deps (Insert n)"
	assumes "m \<notin> M"
	shows "wfP (depends_on (M \<union> {m}))"
	proof -
	have "\<And>Q. Q \<noteq> {} \<Longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y \<in> M \<union> {m}) \<and> (z \<in> M \<union> {m}) \<and>
	I y \<in> deps (Insert z) \<longrightarrow> y \<notin> Q)"
	proof -
	- fix Q :: "('a, 'b) insert_message set"
	+ fix Q :: "('\<I>,'\<Sigma>) insert_message set"
	assume b:"Q \<noteq> {}"
	show "\<exists>z\<in>Q. \<forall>y. (y \<in> M \<union> {m}) \<and> (z \<in> M \<union> {m}) \<and> I y \<in> deps (Insert z)
	\<longrightarrow> y \<notin> Q"
	proof (cases "\<exists>x. x \<in> Q - {m}")
	case True
	hence "\<exists>z\<in> Q - {m}. \<forall>y. (y \<in> M) \<and> (z \<in> M) \<and> I y \<in> deps (Insert z)
	\<longrightarrow> y \<notin> Q - {m}"
	by (metis depends_on.simps assms(1) wfP_eq_minimal)
	then show ?thesis using assms(2) DiffD2 by auto
	next
	case False
	hence "Q = {m}" using b by blast
	thus ?thesis using assms(2) by blast
	qed
	qed
	thus ?thesis by (simp add:wfP_eq_minimal, blast)
	qed

	lemma create_insert_p_s_ordered:
	assumes "is_associated_string N s"
	assumes "a_conditions (insert_messages N) a"
	assumes "Inr (Insert m) = create_insert s n \<sigma> new_id"
	shows "a (P m) < a (S m)"
	proof -
	obtain p q where pq_def:
	"create_insert s n \<sigma> new_id = Inr (Insert (InsertMessage p new_id q \<sigma>))"
	by (metis (no_types, lifting) One_nat_def add.right_neutral add_Suc_right
	create_insert.elims sum.case_eq_if sum.simps(4) assms(3) bind_def)
	have "Inr p = nth_visible s n" using pq_def Error_Monad.bindE by fastforce
	moreover have "Inr q = nth_visible s (Suc n)"
	using pq_def Error_Monad.bindE by fastforce
	ultimately have "a p < a q"
	using assms by (metis is_associated_string_def nth_visible_inc')
	moreover have "m = InsertMessage p new_id q \<sigma>"
	using assms(3) pq_def by auto
	ultimately show ?thesis by (simp add: pq_def)
	qed

	lemma create_insert_consistent:
	assumes "consistent M"
	assumes "is_associated_string N s"
	assumes "N \<subseteq> M"
	assumes "Inr m = create_insert s n \<sigma> new_id"
	assumes "new_id \<notin> I ` insert_messages M"
	shows "consistent (M \<union> {m})"
	proof -
	obtain p q where pq_def:
	"create_insert s n \<sigma> new_id = Inr (Insert (InsertMessage p new_id q \<sigma>))"
	by (metis (no_types, lifting) One_nat_def add.right_neutral add_Suc_right
	create_insert.elims assms(4) sum.case_eq_if sum.simps(4) bind_def)
	define m' where "m' = InsertMessage p new_id q \<sigma>"
	hence a:"m = Insert m'" using pq_def assms(4) by auto
	hence d: "create_insert s n \<sigma> new_id = Inr (Insert m')"
	using pq_def assms by simp
	have b:"I m' = new_id" using m'_def by (simp add:I_def)
	hence "inj_on I (insert_messages M \<union> {m'})" using assms(5) assms(1)
	using consistent_def by fastforce
	hence "inj_on I (insert_messages (M \<union> {m}))" using assms(4) pq_def m'_def
	by (metis Inr_inject insert_insert_message)
	moreover
	have p:"extended_to_set p \<subseteq> I ` set s" using pq_def nth_visible_eff by fastforce
	have q: "extended_to_set q \<subseteq> I ` set s"
	using pq_def apply (simp add:bind_def del:nth_visible.simps)
	apply (cases "nth_visible s n", simp)
	by (cases "nth_visible s (Suc n)", simp, simp add: nth_visible_eff)
	have "extended_to_set p \<union> extended_to_set q \<subseteq> I ` set s" using p q by simp
	hence "extended_to_set p \<union> extended_to_set q \<subseteq> I ` insert_messages N"
	by (metis assms(2) is_associated_string_def to_woot_character_keeps_i_lifted)
	hence "extended_to_set p \<union> extended_to_set q \<subseteq> I ` insert_messages M"
	using assms(3) subset_mono by blast
	hence c:"deps m \<subseteq> I ` insert_messages M" using pq_def assms(4) by auto
	hence "\<Union> (deps ` (M \<union> {m})) \<subseteq> (I ` insert_messages (M \<union> {m}))"
	by (metis consistent_def assms(1) deps_insert)
	moreover have w:
	"\<forall>n \<in> insert_messages M \<union> {m'}. deps (Insert n) \<subseteq> I ` insert_messages M"
	by (metis a c consistent_def assms(1) Sup_le_iff imageI insert_iff
	insert_is_Un insert_messages_def mem_Collect_eq sup.commute)
	hence "\<forall>n \<in> insert_messages M \<union> {m'}. I m' \<notin> deps (Insert n)"
	using b assms(5) by blast
	hence "wfP (depends_on (insert_messages M \<union> {m'}))"
	by (metis Un_insert_right insert_absorb wf_add assms(1)
	consistent_def sup_bot.right_neutral)
	moreover obtain a where a_def: "a_conditions (insert_messages M) a"
	using consistent_def assms(1) by blast
	define a' where
	"a' = (\<lambda>i. if i = \<lbrakk> new_id \<rbrakk> then \<lbrakk>\<Psi> (a (P m'), a(S m')) new_id\<rbrakk> else a i)"
	hence "a_conditions (insert_messages (M \<union> {m})) a'"
	proof -
	have "a' \<turnstile> < a' \<stileturn>" using a'_def a_conditions_def a_def by auto
	moreover have
	"\<And>m''. m'' \<in> (insert_messages M \<union> {m'}) \<longrightarrow>
	a'(P m'') < a'(S m'') \<and>
	a' \<lbrakk>I m''\<rbrakk> = \<lbrakk>\<Psi> (a'(P m''), a'(S m'')) (I m'')\<rbrakk>"
	proof
	fix m''
	assume e:" m'' \<in> (insert_messages M \<union> {m'})"
	show "a'(P m'') < a'(S m'') \<and> a' \<lbrakk> I m''\<rbrakk> =
	\<lbrakk>\<Psi> (a'(P m''), a'(S m'')) (I m'')\<rbrakk>"
	proof (cases "m'' \<in> insert_messages M")
	case True
	moreover have "deps (Insert m'') \<subseteq> I ` insert_messages M"
	using e w by blast
	hence "P m'' \<noteq> \<lbrakk> new_id \<rbrakk> \<and> S m'' \<noteq> \<lbrakk> new_id \<rbrakk>"
	by (meson assms(5) contra_subsetD pred_is_dep succ_is_dep)
	moreover have "I m'' \<noteq> new_id"
	using assms(5) True by blast
	ultimately show ?thesis using a_def True
	by (simp add: a_conditions_def a'_def)
	next
	case False
	moreover have "I m'' = new_id" using False b e by blast
	moreover have "deps (Insert m'') \<subseteq> I ` insert_messages M"
	using False a c e by blast
	hence "P m'' \<noteq> \<lbrakk> new_id \<rbrakk> \<and> S m'' \<noteq> \<lbrakk> new_id \<rbrakk>"
	by (meson assms(5) contra_subsetD pred_is_dep succ_is_dep)
	moreover have "a_conditions (insert_messages N) a"
	using a_def a_subset assms is_associated_string_def by blast
	hence "a (P m') < a (S m')"
	by (metis assms(2) d create_insert_p_s_ordered)
	hence "a' (P m'') < a' (S m'')" using calculation a'_def False e by auto
	ultimately show ?thesis using e a'_def by auto
	qed
	qed
	ultimately show "?thesis" using a_conditions_def
	by (metis a insert_insert_message)
	qed
	ultimately show "?thesis" using consistent_def a by (metis insert_insert_message)
	qed

	lemma bind_simp: "(x \<bind> (\<lambda>l. y l) = Inr r) \<Longrightarrow> (y (projr x) = Inr r)"
	using isOK_I by force

	lemma create_delete_consistent:
	assumes "consistent M"
	assumes "is_associated_string N s"
	assumes "N \<subseteq> M"
	assumes "Inr m = create_delete s n"
	shows "consistent (M \<union> {m})"
	proof -
	obtain i where pq_def: "create_delete s n = Inr (Delete (DeleteMessage i))"
	by (metis (no_types, lifting) Error_Monad.bindE create_delete.simps assms(4))
	hence a: "m = Delete (DeleteMessage i)" using assms(4) by auto
	hence b: "insert_messages (M \<union> {m}) = insert_messages M"
	by (simp add:insert_messages_def)
	have "n \<noteq> 0" apply (rule classical) using pq_def by (simp add:bind_def ext_ids_def)
	then obtain u where "n = Suc u" using not0_implies_Suc by blast
	then have "i \<in> I ` set s" using pq_def
	apply (cases "u < length (filter is_visible s)")
	apply (simp add:bind_simp ext_ids_def nth_append)
	apply (meson filter_is_subset imageI in_set_conv_nth subset_code(1))
	apply (cases "u = length (filter is_visible s)")
	by (simp add:bind_def ext_ids_def nth_append)+
	hence "i \<in> I ` insert_messages N" using assms
	by (metis is_associated_string_def to_woot_character_keeps_i_lifted)
	hence c:"deps m \<subseteq> I ` insert_messages M" using a
	by (metis assms(3) deps.simps(2) singletonD subsetCE subsetI subset_mono)
	then show "?thesis" using assms(1) b by (simp add:consistent_def)
	qed

	end
	\ No newline at end of file
	diff --git a/thys/WOOT_Strong_Eventual_Consistency/DistributedExecution.thy b/thys/WOOT_Strong_Eventual_Consistency/DistributedExecution.thy
	--- a/thys/WOOT_Strong_Eventual_Consistency/DistributedExecution.thy
	+++ b/thys/WOOT_Strong_Eventual_Consistency/DistributedExecution.thy
	@@ -1,189 +1,189 @@
	subsection \<open>Network Model \label{sec:networkModel}\<close>

	text \<open>In the past subsections, we described the algorithms each peer uses to integrate received
	messages and broadcast new messages when an edit operation has been made on that peer.

	In this section, we model the WOOT Framework as a distributed application and set the
	basis for the consistency properties, we want to establish.

	We assume a finite set of peers starting with the same initial state of an empty W-string, each
	peer reaches a finite set of subsequent states, caused by the integration of received (or locally
	generated messages). A message is always generated from a concrete state of a peer, using the
	algorithms described in Section \ref{sec:edit}. Moreover, we assume that the same message will only
	be delivered once to a peer. Finally, we assume that the happened before relation, formed by
	\begin{itemize}
	\item Subsequent states of the same peer
	\item States following the reception and states that were the generation sites
	\end{itemize}
	do not contain loops. (Equivalently that the transitive closure of the relation is a strict
	partial order.)

	The latter is a standard assumption in the modelling of distributed systems (compare e.g.
	\cite[Chapter 6.1]{raynal2013}) effectively implied by the fact that there are no physical causal
	loops.

	Additionally, we assume that a message will be only received by a peer, when the antecedent
	messages have already been received by the peer. This is a somewhat technical assumption to
	simplify the description of the system. In a practical implementation a peer would buffer the set
	of messages that cannot yet be integrated. Note that this assumption is automatically implied if
	causal delivery is assumed.

	We establish two properties under the above assumptions
	\begin{itemize}
	\item The integration algorithm never fails.
	\item Two peers having received the same set of messages will be in the same state.
	\end{itemize}

	The model assumptions are derived from Gomes et al.\cite{gomes2017verifying} and
	Shapiro et al.\cite{shapiro:inria-00555588} with minor modifications required for WOOT.\<close>

	theory DistributedExecution
	imports IntegrateAlgorithm CreateAlgorithms "HOL-Library.Product_Lexorder"
	begin

	type_synonym 'p event_id = "'p \<times> nat"

	-datatype ('p,'s) event =
	- Send "('p event_id, 's) message" \|
	- Receive "'p event_id" "('p event_id, 's) message"
	+datatype ('p,'\<Sigma>) event =
	+ Send "('p event_id, '\<Sigma>) message" \|
	+ Receive "'p event_id" "('p event_id, '\<Sigma>) message"

	text \<open>The type variable @{typ "'p"} denotes a unique identifier identifying a peer.
	We model each peer's history as a finite sequence of events, where each event is either
	the reception or broadcast of a message.
	The index of the event in a peer's history and its identifier form a pair uniquely identifying
	an event in a distributed execution of the framework.
	In the case of a reception, @{term "Receive s m"} indicated the reception of the message @{term m}
	sent at event @{term "s"}.

	In the following we introduce the locale @{text "dist_execution_preliminary"} from which the
	@{text "dist_execution"} locale will inherit. The reason for the introduction of two
	locales is technical - in particular, it is not possible to interleave definitions and assumptions
	within the definition of a locale. The preliminary locale only introduces the assumption that the
	set of participating peers is finite.\<close>

	locale dist_execution_preliminary =
	- fixes events :: "('p :: linorder) \<Rightarrow> ('p,'s) event list"
	+ fixes events :: "('p :: linorder) \<Rightarrow> ('p,'\<Sigma>) event list"
	\<comment> \<open>We introduce a locale fixing the sequence of events per peer.\<close>

	assumes fin_peers: "finite (UNIV :: 'p set)"
	\<comment> \<open>We are assuming a finite set of peers.\<close>

	begin

	fun is_valid_event_id
	where "is_valid_event_id (i,j) = (j < length (events i))"

	fun event_pred
	where "event_pred (i,j) p = (is_valid_event_id (i,j) \<and> p (events i ! j))"

	fun event_at
	where "event_at i m = event_pred i ((=) m)"

	fun is_reception
	where
	"is_reception i j = event_pred j (\<lambda>e. case e of Receive s _ \<Rightarrow> s = i \| _ \<Rightarrow> False)"

	fun happened_immediately_before where
	"happened_immediately_before i j = (
	is_valid_event_id i \<and>
	is_valid_event_id j \<and>
	((fst i = fst j \<and> Suc (snd i) = snd j) \<or> is_reception i j))"

	text \<open>
	The @{term happened_immediately_before} describes immediate causal precedence:
	\begin{itemize}
	\item An events causally precedes the following event on the same peer.
	\item A message broadcast event causally precedes the reception event of it.
	\end{itemize}

	The transitive closure of this relation is the famous happened before relation introduced
	by Lamport\cite{Lamport1978}.

	In the @{text "dist_execution"} we will assume that the relation is acyclic - which implies that
	the transitive closure @{term "happened_immediately_before\<^sup>+\<^sup>+"} is a strict partial
	order.
	\<close>

	text \<open>Each peer passes through a sequence of states, which may change after receiving a message.
	We denote the initial state of peer $p$ as $(p,0)$ and the state after
	event $(p,i)$ as $(p,i+1)$. Note that there is one more state per peer than events, since we
	are count both the initial and terminal state of a peer.\<close>

	fun is_valid_state_id
	where "is_valid_state_id (i,j) = (j \<le> length (events i))"

	fun received_messages
	where
	"received_messages (i,j) = [m. (Receive _ m) \<leftarrow> (take j (events i))]"

	fun state where "state i = foldM integrate [] (received_messages i)"

	text \<open>Everytime a peer receives a message its state is updated by integrating the message. The
	function @{term state} returns the state for a given state id.\<close>

	end

	text \<open> The function @{text deps} computes the identifiers a message depends on. \<close>

	-fun extended_to_set :: "'a extended \<Rightarrow> 'a set"
	+fun extended_to_set :: "'\<I> extended \<Rightarrow> '\<I> set"
	where
	"extended_to_set \<lbrakk>i\<rbrakk> = {i}" \|
	"extended_to_set _ = {}"

	-fun deps :: "('id, 's) message \<Rightarrow> 'id set"
	+fun deps :: "('\<I>, '\<Sigma>) message \<Rightarrow> '\<I> set"
	where
	"deps (Insert (InsertMessage l _ u _)) = extended_to_set l \<union> extended_to_set u" \|
	"deps (Delete (DeleteMessage i)) = {i}"

	locale dist_execution = dist_execution_preliminary +
	assumes no_data_corruption:
	"\<And>i s m. event_at i (Receive s m) \<Longrightarrow> event_at s (Send m)"
	\<comment> \<open>A received message must also have been actually broadcast. Note that, we do not
	assume that a broadcast message will be received by all peers, similar to the modelling made by
	\cite[Section 5.2]{gomes2017verifying}.\<close>

	assumes at_most_once:
	"\<And>i j s m.
	event_at i (Receive s m) \<Longrightarrow>
	event_at j (Receive s m) \<Longrightarrow>
	fst i = fst j \<Longrightarrow> i = j"
	\<comment> \<open>A peer will never receive the same message twice. Note that this is something
	that can be easily implemented in the application layer, if the underlying transport mechanism
	does not guarantee it.\<close>

	assumes acyclic_happened_before:
	"acyclicP happened_immediately_before"
	\<comment> \<open>The immediate causal precendence relation is acyclic, which implies that its
	closure, the \emph{happened before} relation is a strict partial order.\<close>

	assumes semantic_causal_delivery:
	"\<And>m s i j i'. event_at (i,j) (Receive s m) \<Longrightarrow> i' \<in> deps m \<Longrightarrow>
	\<exists>s' j' m'. event_at (i,j') (Receive s' (Insert m')) \<and> j' < j \<and> I m' = i'"
	\<comment> \<open>A message will only be delivered to a peer, if its
	antecedents have already been delivered. (See beginning of this Section for the reason of this
	assumption).\<close>

	assumes send_correct:
	"\<And>m i. event_at i (Send m) \<Longrightarrow>
	(\<exists>n \<sigma>. return m = state i \<bind> (\<lambda>s. create_insert s n \<sigma> i)) \<or>
	(\<exists>n. return m = state i \<bind> (\<lambda>s. create_delete s n))"
	\<comment> \<open>A peer broadcasts messages by running the @{term create_insert} or @{term create_delete}
	algorithm on its current state. In the case of an insertion the new character is assigned
	the event id as its identifier. Note that, it would be possible to assume, a different choice
	for allocating unique identifiers to new W-characters. We choose the event id since it is
	automatically unique.\<close>

	begin

	text \<open>Based on the assumptions above we show in Section \ref{sec:strong_eventual_consistency}:
	\begin{itemize}
	\item \emph{Progress}: All reached states @{term "state i"} will be successful, i.e., the
	algorithm @{term integrate} terminates and does not fail.
	\item \emph{Strong Eventual Consistency}: Any pair of states @{term "state i"}
	and @{term "state j"} which have been reached after receiving the same set of messages,
	i.e., @{term "set (received_messages i) = set (received_messages j)"} will be equal.
	\end{itemize}\<close>

	end

	end
	diff --git a/thys/WOOT_Strong_Eventual_Consistency/IntegrateAlgorithm.thy b/thys/WOOT_Strong_Eventual_Consistency/IntegrateAlgorithm.thy
	--- a/thys/WOOT_Strong_Eventual_Consistency/IntegrateAlgorithm.thy
	+++ b/thys/WOOT_Strong_Eventual_Consistency/IntegrateAlgorithm.thy
	@@ -1,118 +1,118 @@
	subsection \<open>Integration algorithm \label{sec:integrate}\<close>

	text \<open>In this section we describe the algorithm to integrate a received message into a peers'
	state.\<close>

	theory IntegrateAlgorithm
	imports BasicAlgorithms Data
	begin

	fun fromSome :: "'a option \<Rightarrow> error + 'a"
	where
	"fromSome (Some x) = return x" \|
	"fromSome None = error (STR ''Expected Some'')"

	lemma fromSome_ok_simp [simp]: "(fromSome x = Inr y) = (x = Some y)"
	by (cases x, simp+)

	fun substr :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where
	"substr s l u = take (u - (Suc l)) (drop l s)"

	fun concurrent ::
	- "('a, 's) woot_character list
	+ "('\<I>, '\<Sigma>) woot_character list
	\<Rightarrow> nat
	\<Rightarrow> nat
	- \<Rightarrow> ('a, 's) woot_character
	- \<Rightarrow> error + ('a extended list)"
	+ \<Rightarrow> ('\<I>, '\<Sigma>) woot_character
	+ \<Rightarrow> error + ('\<I> extended list)"
	where
	"concurrent s l u w =
	do {
	p_pos \<leftarrow> idx s (P w);
	s_pos \<leftarrow> idx s (S w);
	return (if (p_pos \<le> l \<and> s_pos \<ge> u) then [\<lbrakk>I w\<rbrakk>] else [])
	}"

	function integrate_insert
	where
	"integrate_insert m w p s =
	do {
	l \<leftarrow> idx w p;
	u \<leftarrow> idx w s;
	assert (l < u);
	if Suc l = u then
	return ((take l w)@[to_woot_char m]@(drop l w))
	else do {
	d \<leftarrow> mapM (concurrent w l u) (substr w l u);
	assert (concat d \<noteq> []);
	(p', s') \<leftarrow> fromSome (find ((\<lambda>x.\<lbrakk>I m\<rbrakk> < x \<or> x = s) \<circ> snd)
	(zip (p#concat d) (concat d@[s])));
	integrate_insert m w p' s'
	}
	}"
	by fastforce+

	fun integrate_delete ::
	- "('a :: linorder) delete_message
	- \<Rightarrow> ('a, 's) woot_character list
	- \<Rightarrow> error + ('a, 's) woot_character list"
	+ "('\<I> :: linorder) delete_message
	+ \<Rightarrow> ('\<I>, '\<Sigma>) woot_character list
	+ \<Rightarrow> error + ('\<I>, '\<Sigma>) woot_character list"
	where
	"integrate_delete (DeleteMessage i) s =
	do {
	k \<leftarrow> idx s \<lbrakk>i\<rbrakk>;
	w \<leftarrow> nth s k;
	list_update s k
	(case w of (InsertMessage p i u _) \<Rightarrow> InsertMessage p i u None)
	}"

	fun integrate ::
	- "('a, 's) woot_character list
	- \<Rightarrow> ('a :: linorder, 's) message
	- \<Rightarrow> error + ('a, 's) woot_character list"
	+ "('\<I>, '\<Sigma>) woot_character list
	+ \<Rightarrow> ('\<I> :: linorder, '\<Sigma>) message
	+ \<Rightarrow> error + ('\<I>, '\<Sigma>) woot_character list"
	where
	"integrate s (Insert m) = integrate_insert m s (P m) (S m)" \|
	"integrate s (Delete m) = integrate_delete m s"

	text \<open>Algorithm @{term integrate} describes the main function that is called when a new message
	@{term m} has to be integrated into the state @{term s} of a peer.
	It is called both when @{term m} was generated locally or received from another peer.
	Note that we require that the antecedant messages have already been integrated. See also
	Section \ref{sec:networkModel} for the delivery assumptions that ensure this requirement.

	Algorithm @{term integrate_delete} describes the procedure to integrate a delete message:
	@{term "DeleteMessage i"}.
	The algorithm just replaces the symbol of the W-character with identifier @{term i} with the value
	@{term "None"}.
	It is not possible to entirely remove a W-character if it is deleted, since there might be
	unreceived insertion messages that depend on its position.

	Algorithm @{term integrate_insert} describes the procedure to integrate an insert message:
	@{term "m = InsertMessage p i s \<sigma>"}.
	Since insertion operations can happen concurrently and the order of message delivery is not fixed,
	it can happen that a remote peer receiving @{term m} finds multiple possible insertion points
	between the predecessor @{term p} and successor @{term s} that were recorded when the message
	was generated.
	An example of this situation is the conflict between
	@{term "InsertMessage \<turnstile> (A,0 :: nat) \<stileturn> (CHR ''I'')"} and @{term "InsertMessage \<turnstile> (B,0 :: nat) \<stileturn> (CHR ''N'')"}
	in Figure~\ref{fig:session}.

	A first attempt to resolve this would be to insert the W-characters by choosing an insertion point
	using the order induced by their identifiers to achieve a consistent ordering.
	But this method fails in some cases: a counter-example was found by
	Oster et al.~\cite[section 2]{oster2006data}.

	The solution introduced by the authors of WOOT is to restrict the identifier comparison to the
	set of W-characters in the range @{term "substr l u s"} whose predecessor and successor are
	outside of the possible range, i.e. @{text "idx s (P w) \<le> l"} and @{text "idx s (S w) \<ge> u"}.

	New narrowed bounds are selected by finding the first W-character within that restricted set
	with an identifier strictly larger than the identifier of the new W-character.

	This leads to a narrowed range where the found character forms an upper bound and its immediately
	preceeding character the lower bound. The method is applied recursively until the insertion point
	is uniquely determined.

	Note that the fact that this strategy leads to a consistent ordering has only been verified for a
	bounded model.
	One of the contributions of this paper is to provide a complete proof for it.\<close>

	end
	\ No newline at end of file
	diff --git a/thys/WOOT_Strong_Eventual_Consistency/IntegrateInsertCommute.thy b/thys/WOOT_Strong_Eventual_Consistency/IntegrateInsertCommute.thy
	--- a/thys/WOOT_Strong_Eventual_Consistency/IntegrateInsertCommute.thy
	+++ b/thys/WOOT_Strong_Eventual_Consistency/IntegrateInsertCommute.thy
	@@ -1,665 +1,665 @@
	subsection \<open>Termination Proof for @{term integrate_insert}\label{sec:integrate_term}\<close>

	theory IntegrateInsertCommute
	imports IntegrateAlgorithm Consistency CreateConsistent
	begin

	text \<open>In the following we show that @{term integrate_insert} terminates. Note that, this does not
	yet imply that the return value will not be an error state.\<close>

	lemma substr_simp [simp]: "substr s l u = nths s {k. l < Suc k \<and> Suc k < u}"
	proof (cases "l \<le> length s")
	case True
	have "set (nths (take l s) {k. l < Suc k \<and> Suc k < u}) = {}"
	by (simp add:set_nths)
	hence "nths (take l s) {k. l < Suc k \<and> Suc k < u} = []" by blast
	moreover have "{j. Suc (j + l) < u} = {..<(u-Suc l)}" by auto
	moreover have "min (length s) l = l" using True by auto
	ultimately
	have "nths (take l s @ drop l s) {k. l < Suc k \<and> Suc k < u} = substr s l u"
	by (simp add:nths_append del:append_take_drop_id)
	then show ?thesis by simp
	next
	case False
	hence "set (nths s {k. l < Suc k \<and> Suc k < u}) = {}"
	by (simp add:set_nths)
	hence "nths s {k. l < Suc k \<and> Suc k < u} = []" by blast
	thus ?thesis using False by simp
	qed

	declare substr.simps [simp del]

	text \<open>Instead of simplifying @{term substr} with its definition we use @{thm [source] substr_simp}
	as a simplification rule. The right hand side of @{thm [source] substr_simp} is a better
	representation within proofs. However, we cannot directly define @{term substr} using the right
	hand side as it is not constructible term for Isabelle.\<close>

	lemma int_ins_loop_term_1:
	assumes "isOK (mapM (concurrent w l u) t)"
	assumes "x \<in> set (concat (projr (mapM (concurrent w l u) t)))"
	shows "x \<in> (InString \<circ> I) ` (set t)"
	using assms
	by (induction t, simp, simp add: bind_simp del:idx.simps set_concat, blast)

	lemma fromSingleton_simp: "(fromSingleton xs = Inr x) = ([x] = xs)"
	by (cases xs rule: fromSingleton.cases, auto)

	lemma filt_simp: "([b] = filter p [0..<n]) =
	(p b \<and> b < n \<and> (\<forall>y < n. p y \<longrightarrow> b = y))"
	apply (induction n, simp, simp)
	by (metis atLeast_upt cancel_comm_monoid_add_class.diff_cancel
	filter_empty_conv lessThan_iff less_Suc_eq neq0_conv zero_less_diff)

	lemma substr_eff:
	assumes "x \<in> (InString \<circ> I) ` set (substr w l u)"
	assumes "isOK (idx w x)"
	shows "l < (projr (idx w x)) \<and> (projr (idx w x)) < u"
	proof -
	obtain i where i_def: "idx w x = Inr i" using assms(2) by blast
	then have "l < i \<and> i < u" using assms(1)
	apply (simp add: set_nths image_iff fromSingleton_simp filt_simp)
	apply (simp add:ext_ids_def)
	by (metis (no_types, lifting) Suc_mono length_map less_SucI list_update_id
	list_update_same_conv map_update nth_Cons_Suc nth_append)
	thus ?thesis using i_def by auto
	qed

	lemma find_zip:
	assumes "find (cond \<circ> snd) (zip (p#v) (v@[s])) = Some (x,y)"
	assumes "v \<noteq> []"
	shows
	"cond y"
	"x \<in> set v \<or> y \<in> set v"
	"x = p \<or> (x \<in> set v \<and> \<not>(cond x))"
	"y = s \<or> (y \<in> set v)"
	proof -
	obtain i where i_def:
	"i < Suc (length v)"
	"(zip (p#v) (v@[s])) ! i = (x,y)"
	"cond y"
	"\<forall>j. j < i \<longrightarrow> \<not>(cond ((v@[s])!j))"
	using assms apply (simp add:find_Some_iff) by force
	show "cond y" using i_def by auto
	show "x \<in> set v \<or> y \<in> set v" using assms(2) i_def(1,2)
	by (metis fst_conv in_set_conv_nth length_0_conv length_Cons length_append_singleton
	less_Suc_eq less_Suc_eq_0_disj nth_Cons_Suc nth_append nth_zip snd_conv)
	show "x = p \<or> (x \<in> set v \<and> (\<not>(cond x)))"
	apply (cases i)
	using i_def(2) apply auto[1]
	by (metis Suc_less_eq fst_conv i_def(1,2,4) length_Cons
	length_append_singleton lessI nth_Cons_Suc nth_append nth_mem nth_zip)
	show "y = s \<or> y \<in> set v"
	by (metis diff_is_0_eq' i_def(1,2) in_set_conv_nth length_Cons
	length_append_singleton less_Suc_eq_le nth_Cons_0 nth_append nth_zip snd_conv)
	qed

	fun int_ins_measure'
	where
	"int_ins_measure' (m,w,p,s) = (
	do {
	l \<leftarrow> idx w p;
	u \<leftarrow> idx w s;
	assert (l < u);
	return (u - l)
	})"

	fun int_ins_measure
	where
	"int_ins_measure (m,w,p,s) = case_sum (\<lambda>e. 0) id (int_ins_measure' (m,w,p,s))"

	text \<open>We show that during the iteration of @{term integrate_insert}, the arguments are decreasing
	with respect to @{term int_ins_measure}. Note, this means that the distance between the
	W-characters with identifiers @{term p} (resp. @{term s}) is decreasing.\<close>

	lemma int_ins_loop_term:
	assumes "idx w p = Inr l"
	assumes "idx w s = Inr u"
	assumes "mapM (concurrent w l u) (substr w l u) = Inr d"
	assumes "concat d \<noteq> []"
	assumes "find ((\<lambda>x.\<lbrakk>I m\<rbrakk> < x \<or> x = s) \<circ> snd)
	(zip (p#concat d) (concat d@[s])) = Some r"
	shows "int_ins_measure (m, w, r) < u - l"
	proof -
	have a: "\<And>x y. x \<in> set (concat d) \<Longrightarrow> idx w x = Inr y \<Longrightarrow> l < y \<and> y < u"
	using int_ins_loop_term_1 substr_eff assms(3) by (metis isOK_I sum.sel(2))
	hence b: "l < u" using assms
	by (metis concat.simps(1) diff_is_0_eq less_imp_le_nat
	mapM.simps(1) not_less_eq substr.simps sum.sel(2) take0)
	obtain p' s' where ps_def: "r = (p', s')" by (cases r, simp+)
	show ?thesis
	proof (cases "int_ins_measure' (m, w, r)")
	case (Inl a)
	then show ?thesis using b by (simp add:ps_def)
	next
	case (Inr b)
	then obtain l' u' where ps'_def: "idx w p' = Inr l'" "idx w s' = Inr u'"
	using ps_def apply (simp add:bind_simp del:idx.simps) by blast
	then have "l' \<ge> l \<and> l' < u \<and> u' > l \<and> u' \<le> u \<and> (l' > l \<or> u' < u)"
	using a b ps_def find_zip(2,3,4) assms(1,2,4,5)
	by (metis (no_types, lifting) Inr_inject order.order_iff_strict)
	thus ?thesis using ps_def ps'_def apply (simp add:bind_simp del:idx.simps)
	by (cases "l' < u'", simp del:idx.simps, linarith, simp del:idx.simps)
	qed
	qed

	lemma assert_ok_simp [simp]: "(assert p = Inr z) = p" by (cases p, simp+)

	termination integrate_insert
	apply (relation "measure int_ins_measure", simp)
	using int_ins_loop_term by (simp del:idx.simps, blast)

	subsection \<open>Integrate Commutes\<close>

	locale integrate_insert_commute =
	- fixes M :: "('a :: linorder, 's) message set"
	- fixes a :: "'a extended \<Rightarrow> 'a position"
	- fixes s :: "('a, 's) woot_character list"
	+ fixes M :: "('\<I> :: linorder, '\<Sigma>) message set"
	+ fixes a :: "'\<I> extended \<Rightarrow> '\<I> position"
	+ fixes s :: "('\<I>, '\<Sigma>) woot_character list"
	assumes associated_string_assm: "is_associated_string M s"
	assumes a_conditions_assm: "a_conditions (insert_messages M) a"
	begin

	lemma dist_ext_ids: "distinct (ext_ids s)"
	using associated_string_assm a_conditions_assm
	apply (simp add:is_associated_string_def sorted_wrt_map)
	by (metis (mono_tags) irreflp_def le_less not_le sorted_wrt_irrefl_distinct)

	lemma I_inj_on_S:
	"l < length s \<and> u < length s \<and> I(s ! l) = I(s ! u) \<Longrightarrow> l = u"
	using dist_ext_ids apply (simp add:ext_ids_def)
	using nth_eq_iff_index_eq by fastforce

	lemma idx_find:
	assumes "x < length (ext_ids s)"
	assumes "ext_ids s ! x = i"
	shows "idx s i = Inr x"
	using assms dist_ext_ids nth_eq_iff_index_eq
	by (simp add:filt_simp fromSingleton_simp, blast)

	lemma obtain_idx:
	assumes "x \<in> set (ext_ids s)"
	shows "\<exists>i. idx s x = Inr i"
	using idx_find assms by (metis in_set_conv_nth)

	lemma sorted_a:
	assumes "idx s x = Inr l"
	assumes "idx s y = Inr u"
	shows "(l \<le> u) = (a x \<le> a y)"
	proof -
	have "sorted_wrt (<) (map a (ext_ids s))"
	using associated_string_assm a_conditions_assm is_associated_string_def by blast
	then show ?thesis
	using assms apply (simp add:filt_simp fromSingleton_simp)
	by (metis leD leI le_less length_map nth_map sorted_wrt_nth_less)
	qed

	lemma sorted_a_le: "idx s x = Inr l \<Longrightarrow> idx s y = Inr u \<Longrightarrow> (l < u) = (a x < a y)"
	by (meson sorted_a not_le)

	lemma idx_intro_ext: "i < length (ext_ids s) \<Longrightarrow> idx s (ext_ids s ! i) = Inr i"
	using dist_ext_ids by (simp add:fromSingleton_simp filt_simp nth_eq_iff_index_eq)

	lemma idx_intro:
	assumes "i < length s"
	shows "idx s \<lbrakk>I (s ! i)\<rbrakk> = Inr (Suc i)"
	proof -
	have "ext_ids s ! (Suc i) = \<lbrakk>I (s ! i)\<rbrakk> \<and> Suc i < length (ext_ids s)"
	using assms by (simp add:ext_ids_def nth_append)
	thus ?thesis using idx_intro_ext by force
	qed

	end

	locale integrate_insert_commute_insert = integrate_insert_commute +
	fixes m
	assumes consistent_assm: "consistent (M \<union> {Insert m})"
	assumes insert_assm: "Insert m \<notin> M"
	assumes a_conditions_assm_2:
	"a_conditions (insert_messages (M \<union> {Insert m})) a"
	begin

	definition invariant where
	"invariant pm sm = (pm \<in> set (ext_ids s) \<and> sm \<in> set (ext_ids s) \<and>
	subset (a pm, a sm) (a (P m), a (S m)) \<and>
	elem (a \<lbrakk>I m\<rbrakk>) (a pm, a sm))"

	fun is_concurrent where
	"is_concurrent pm sm x = (x \<in> set s \<and>
	subset (a pm, a sm) (a (P x), a (S x)) \<and>
	elem (a \<lbrakk>I x\<rbrakk>) (a pm, a sm))"

	lemma no_id_collision: "I m \<notin> I ` insert_messages M"
	proof -
	have "inj_on I (insert_messages (M \<union> {Insert m}))"
	using consistent_def consistent_assm by fastforce
	hence "I m \<in> I ` insert_messages M \<longrightarrow> Insert m \<in> M"
	by (simp add: image_iff inj_on_eq_iff insert_messages_def)
	thus ?thesis using insert_assm by blast
	qed

	lemma not_deleted: "to_woot_char m = to_woot_character M m"
	proof -
	have "Delete (DeleteMessage (I m)) \<notin> M"
	proof
	assume "Delete (DeleteMessage (I m)) \<in> M"
	hence "deps (Delete (DeleteMessage (I m))) \<subseteq> I ` insert_messages M"
	using consistent_assm associated_string_assm
	apply (simp add:consistent_def is_associated_string_def)
	using image_subset_iff by fastforce
	thus "False" using no_id_collision by simp
	qed
	thus "to_woot_char m = to_woot_character M m"
	by (cases m, simp add:to_woot_character_def delete_maybe_def)
	qed

	lemma invariant_imp_sorted:
	assumes "Suc l < length (ext_ids s)"
	assumes "a(ext_ids s ! l) < a \<lbrakk>I m\<rbrakk> \<and> a \<lbrakk>I m\<rbrakk> < a(ext_ids s ! (l+1))"
	shows "sorted_wrt (<) (map a (ext_ids ((take l s)@to_woot_char m#drop l s)))"
	proof -
	have "l \<le> length s" using assms(1) by (simp add:ext_ids_def)
	hence "ext_ids (take l s@to_woot_char m#drop l s) =
	(take (Suc l) (ext_ids s))@\<lbrakk>I m\<rbrakk>#(drop (Suc l) (ext_ids s))"
	by (cases m, simp add:ext_ids_def take_map drop_map)
	thus ?thesis
	using assms associated_string_assm is_associated_string_def a_conditions_assm
	apply (simp flip:take_map drop_map)
	by (rule insort, simp+, blast)
	qed

	lemma no_self_dep: "\<not> depends_on (insert_messages M \<union> {m}) m m"
	proof -
	have "wfP (depends_on (insert_messages M \<union> {m}))"
	using consistent_assm
	apply (simp add:consistent_def)
	by (metis Un_insert_right insert_insert_message sup_bot.right_neutral)
	thus ?thesis
	by (metis mem_Collect_eq wfP_eq_minimal)
	qed

	lemma pred_succ_order:
	"m' \<in> (insert_messages M \<union> {m}) \<Longrightarrow> a(P m') < a \<lbrakk>I m'\<rbrakk> \<and> a(S m') > a \<lbrakk>I m'\<rbrakk>"
	by (metis elem.simps is_interval.simps psi_elem a_conditions_def
	a_conditions_assm_2 insert_insert_message)

	lemma find_dep:
	assumes "Insert m' \<in> (M \<union> {Insert m})"
	assumes "i \<in> deps (Insert m')"
	shows "\<lbrakk>i\<rbrakk> \<in> set (ext_ids s)"
	proof -
	have "i \<in> I ` insert_messages M"
	proof (cases "m' = m")
	case True
	hence "i \<in> I ` insert_messages (M \<union> {Insert m})"
	using assms consistent_assm
	by (simp add:consistent_def, blast)
	moreover have "i \<noteq> I m" using assms True no_self_dep by auto
	ultimately show ?thesis
	by (metis (no_types, lifting) UnE image_Un image_empty image_insert
	insert_insert_message singletonD)
	next
	case False
	hence "Insert m' \<in> M" using assms by simp
	then show "i \<in> I ` insert_messages M"
	using assms is_associated_string_def associated_string_assm consistent_def
	by (metis (no_types, opaque_lifting) Union_iff contra_subsetD image_iff)
	qed
	hence "i \<in> I ` (set s)"
	using associated_string_assm by (simp add:is_associated_string_def)
	thus "\<lbrakk>i\<rbrakk> \<in> set (ext_ids s)"
	by (simp add:ext_ids_def image_iff)
	qed

	lemma find_pred:
	"m' \<in> (insert_messages M \<union> {m}) \<Longrightarrow> P m' \<in> set (ext_ids s)"
	using find_dep by (cases "P m'", (simp add:ext_ids_def insert_messages_def pred_is_dep)+)

	lemma find_succ:
	"m' \<in> (insert_messages M \<union> {m}) \<Longrightarrow> S m' \<in> set (ext_ids s)"
	using find_dep by (cases "S m'", (simp add:ext_ids_def insert_messages_def succ_is_dep)+)

	fun is_certified_associated_string' where
	"is_certified_associated_string' (Inr v) = (
	set v = to_woot_character (M \<union> {Insert m}) `
	(insert_messages (M \<union> {Insert m})) \<and>
	sorted_wrt (<) (map a (ext_ids v)))" \|
	"is_certified_associated_string' (Inl _) = False"

	lemma integrate_insert_final_step:
	assumes "invariant pm sm"
	assumes "idx s pm = Inr l"
	assumes "idx s sm = Inr (Suc l)"
	shows "is_certified_associated_string' (Inr (take l s@(to_woot_char m)#drop l s))"
	proof -
	define t where "t = (take l s@(to_woot_char m)#drop l s)"
	hence "set t = set s \<union> {to_woot_char m}"
	by (metis Un_insert_right append_take_drop_id list.simps(15)
	set_append sup_bot.right_neutral)
	hence
	"set t = to_woot_character M ` insert_messages M \<union> {to_woot_character M m}"
	using not_deleted by (metis associated_string_assm is_associated_string_def)
	hence
	"set t = to_woot_character (M \<union> {Insert m}) ` insert_messages (M \<union> {Insert m})"
	apply (simp add: to_woot_character_insert_no_eff)
	using insert_insert_message by fastforce
	moreover have "sorted_wrt (<) (map a (ext_ids t))" using assms invariant_imp_sorted
	by (simp add:invariant_def fromSingleton_simp filt_simp t_def)
	ultimately show ?thesis
	using t_def associated_string_assm by (simp add:is_associated_string_def)
	qed

	lemma concurrent_eff:
	assumes "idx s pm = Inr l"
	assumes "idx s sm = Inr u"
	obtains d where "mapM (concurrent s l u) (substr s l u) = Inr d \<and>
	set (concat d) = InString ` I ` {x. is_concurrent pm sm x}"
	proof -
	define t where "t = substr s l u"
	have "set t \<subseteq> set s \<Longrightarrow> (isOK (mapM (concurrent s l u) t) \<and>
	set (concat (projr (mapM (concurrent s l u) t))) =
	InString ` I ` {x. x \<in> set t \<and> a (P x) \<le> a pm \<and> a (S x) \<ge> a sm})"
	proof (induction t)
	case Nil
	then show ?case by simp
	next
	case (Cons th tt)
	hence "th \<in> to_woot_character M ` insert_messages M"
	using associated_string_assm by (simp add: is_associated_string_def)
	then obtain th' where th'_def:
	"th' \<in> insert_messages M \<and> P th' = P th \<and> S th' = S th"
	by (metis image_iff to_woot_character_keeps_P to_woot_character_keeps_S)
	obtain l' where l'_def: "idx s (P th) = Inr l'"
	using th'_def find_pred obtain_idx by fastforce
	obtain u' where u'_def: "idx s (S th) = Inr u'"
	using th'_def find_succ obtain_idx by fastforce
	have "{x. x = \<lbrakk>I th\<rbrakk> \<and> l' \<le> l \<and> u \<le> u'} =
	InString ` I ` {x. x = th \<and> a (P x) \<le> a pm \<and> a sm \<le> a (S x)}"
	using sorted_a l'_def u'_def assms
	by (rule_tac set_eqI, simp add:image_iff, blast)
	then show ?case
	using Cons
	by (simp add:bind_simp l'_def u'_def
	concurrent.simps[where w=th] del:idx.simps, auto)
	qed
	moreover have
	"\<And>x. (x \<in> set (substr s l u)) = (x \<in> set s \<and> a pm < a \<lbrakk>I x\<rbrakk> \<and> a \<lbrakk>I x\<rbrakk> < a sm)"
	apply (simp add:set_nths in_set_conv_nth)
	using sorted_a_le idx_intro assms by blast
	ultimately have "
	isOK (mapM (concurrent s l u) (substr s l u)) \<and>
	set (concat (projr (mapM (concurrent s l u) (substr s l u)))) =
	InString ` I ` {x. is_concurrent pm sm x}"
	by (simp only:t_def, fastforce)
	thus ?thesis using that by auto
	qed

	lemma concurrent_eff_2:
	assumes "invariant pm sm"
	assumes "is_concurrent pm sm x"
	shows "preserve_order \<lbrakk>I x\<rbrakk> \<lbrakk>I m\<rbrakk> (a \<lbrakk>I x\<rbrakk>) (a \<lbrakk>I m\<rbrakk>)"
	proof -
	have "x \<in> to_woot_character M ` insert_messages M"
	using assms(2) associated_string_assm is_associated_string_def
	is_concurrent.elims(2) by blast
	then obtain x' where x'_def: "I x = I x' \<and> P x = P x' \<and> S x = S x' \<and> x' \<in> insert_messages M"
	using to_woot_character_keeps_P to_woot_character_keeps_S
	to_woot_character_keeps_i by fastforce
	have "elem (a \<lbrakk>I x\<rbrakk>) (a (P m), a (S m))"
	using assms by (simp add: invariant_def, auto)
	moreover have "elem (a \<lbrakk>I m\<rbrakk>) (a (P x), a (S x))"
	using assms by (simp add: invariant_def, auto)
	moreover have "a_conditions (insert_messages M \<union> {m}) a"
	by (metis insert_insert_message a_conditions_assm_2)
	ultimately have "preserve_order (I x) (I m) (a \<lbrakk>I x\<rbrakk>) (a \<lbrakk>I m\<rbrakk>)"
	by (simp add: a_conditions_def psi_preserve_order x'_def)
	thus ?thesis by (simp add: preserve_order_def)
	qed

	lemma concurrent_eff_3:
	assumes "idx s pm = Inr l"
	assumes "idx s sm = Inr u"
	assumes "Suc l < u"
	shows "{x. is_concurrent pm sm x} \<noteq> {}"
	proof -
	define H where
	"H = {x. x \<in> insert_messages M \<and> a pm < a \<lbrakk>I x\<rbrakk> \<and> a \<lbrakk>I x\<rbrakk> < a sm}"
	have "wfP (depends_on (insert_messages M))"
	using associated_string_assm by (simp add: consistent_def is_associated_string_def)
	moreover have f:"H \<subseteq> insert_messages M" using H_def by blast
	hence "depends_on H \<le> depends_on (insert_messages M)" by auto
	ultimately have "wfP (depends_on H)" using wf_subset [to_pred] by blast
	moreover
	have u: "l < length s" using assms(2) assms(3)
	by (simp add:fromSingleton_simp filt_simp, simp add:ext_ids_def)
	hence v:"a pm < a \<lbrakk>I(s ! l)\<rbrakk> \<and> a \<lbrakk>I(s ! l)\<rbrakk> < a sm"
	using sorted_a_le assms u idx_intro by blast
	have "I (s ! l) \<in> I ` insert_messages M"
	by (metis image_eqI associated_string_assm is_associated_string_def nth_mem
	to_woot_character_keeps_i_lifted u)
	hence "\<exists>x. x \<in> H" using v H_def by auto
	ultimately obtain z where z_def: "z \<in> H" "\<And> y. depends_on H y z \<Longrightarrow> y \<notin> H"
	by (metis wfP_eq_minimal)
	have a:"\<And>x. x \<in> deps (Insert z) \<Longrightarrow> \<not>(a pm < a \<lbrakk>x\<rbrakk> \<and> a \<lbrakk>x\<rbrakk> < a sm)"
	proof -
	fix x
	assume a:"x \<in> deps (Insert z)"
	hence "x \<in> I ` insert_messages M"
	using insert_messages_def associated_string_assm
	apply (simp add:consistent_def is_associated_string_def)
	using H_def z_def(1) by blast
	then obtain x' where x'_def: "x' \<in> insert_messages M \<and> x = I x'" by blast
	hence "x' \<notin> H" using z_def
	using a depends_on.simps by blast
	thus "\<not>(a pm < a \<lbrakk>x\<rbrakk> \<and> a \<lbrakk>x\<rbrakk> < a sm)" using H_def x'_def by blast
	qed
	have "ext_ids s ! 0 = \<turnstile> \<and> 0 < length (ext_ids s)" by (simp add:ext_ids_def)
	hence b:"\<not>(a pm < a \<turnstile>)"
	by (metis not_less_zero sorted_a_le assms(1) idx_intro_ext)
	have "ext_ids s ! (Suc (length s)) = \<stileturn> \<and> Suc (length s) < length (ext_ids s)"
	by (simp add:nth_append ext_ids_def)
	moreover have "\<not>(Suc (length s) < u)" using assms(2)
	by (simp add:fromSingleton_simp filt_simp, simp add:ext_ids_def)
	ultimately have c:"\<not>(a \<stileturn> < a sm)" by (metis sorted_a_le assms(2) idx_intro_ext)
	have d:"a (P z) \<le> a pm"
	using a b c pred_is_dep pred_succ_order H_def z_def(1) by (cases "P z", fastforce+)
	have e:"a (S z) \<ge> a sm"
	using a b c succ_is_dep pred_succ_order H_def z_def(1) by (cases "S z", fastforce+)
	have "to_woot_character M z \<in> set s"
	using f associated_string_assm is_associated_string_def z_def(1) by fastforce
	hence "is_concurrent pm sm (to_woot_character M z)"
	using H_def z_def(1) d e by simp
	thus ?thesis by blast
	qed

	lemma integrate_insert_result_helper:
	"invariant pm sm \<Longrightarrow> m' = m \<Longrightarrow> s' = s \<Longrightarrow>
	is_certified_associated_string' (integrate_insert m' s' pm sm)"
	proof (induction m' s' pm sm rule:integrate_insert.induct)
	case (1 m' s' pm sm)
	obtain l where l_def: "idx s pm = Inr l"
	using "1"(2) invariant_def obtain_idx by blast
	obtain u where u_def: "idx s sm = Inr u"
	using "1"(2) invariant_def obtain_idx by blast
	show ?case
	proof (cases "Suc l = u")
	case True
	then show ?thesis
	apply (simp add:l_def u_def 1 del:idx.simps is_certified_associated_string'.simps)
	using "1"(2) l_def u_def integrate_insert_final_step by blast
	next
	case False
	have "a pm < a sm" using invariant_def "1"(2) by auto
	hence a:"l < u" using sorted_a_le l_def u_def by blast
	obtain d where d_def: "mapM (concurrent s l u) (substr s l u) = Inr d \<and>
	set (concat d) = InString ` I ` {x. is_concurrent pm sm x}"
	by (metis concurrent_eff l_def u_def)
	have b:"concat d \<noteq> []"
	by (metis Suc_lessI concurrent_eff_3 False l_def u_def
	a d_def empty_set image_is_empty)
	have c:"\<And>x. x \<in> set (concat d) \<Longrightarrow>
	preserve_order x \<lbrakk>I m\<rbrakk> (a x) (a \<lbrakk>I m\<rbrakk>) \<and> x \<in> set (ext_ids s) \<and>
	a pm < a x \<and> a x < a sm"
	using 1(2) d_def concurrent_eff_2
	by (simp del:set_concat add:ext_ids_def, blast)
	obtain pm' sm' where ps'_def: "find ((\<lambda>x.\<lbrakk>I m\<rbrakk> < x \<or> x = sm) \<circ> snd)
	(zip (pm # concat d) (concat d @ [sm])) = Some (pm',sm')"
	(is "?lhs = ?rhs")
	apply (cases "?lhs")
	apply (simp add:find_None_iff)
	apply (metis in_set_conv_decomp in_set_impl_in_set_zip2 length_Cons
	length_append_singleton)
	by fastforce
	have d:"pm' = pm \<or> pm' \<in> set (concat d)" using ps'_def b
	by (metis (full_types) find_zip(3))
	hence "pm' \<in> set (ext_ids s)" using c 1(2) invariant_def by auto
	hence "pm' \<in> InString ` I ` insert_messages M \<or> pm' = \<turnstile> \<or> pm' = \<stileturn>"
	apply (simp add:ext_ids_def)
	by (metis image_image associated_string_assm is_associated_string_def
	to_woot_character_keeps_i_lifted)
	hence "pm' \<noteq> \<lbrakk>I m\<rbrakk>" using no_id_collision by blast
	hence "(pm' = pm \<or> pm' < \<lbrakk>I m\<rbrakk>) \<and> (sm' = sm \<or> sm' > \<lbrakk>I m\<rbrakk> \<and> sm' \<in> set (concat d))"
	by (metis (mono_tags, lifting) ps'_def b find_zip(1) find_zip(3) find_zip(4) less_linear)
	hence e:"invariant pm' sm'"
	using 1(2) c d apply (simp add:invariant_def del:set_concat)
	by (meson dual_order.strict_trans leD leI preserve_order_def)
	show ?thesis apply (subst integrate_insert.simps)
	using a b e ps'_def 1 d_def False l_def u_def
	by (simp add:1 del:idx.simps integrate_insert.simps)
	qed
	qed

	lemma integrate_insert_result:
	"is_certified_associated_string' (integrate_insert m s (P m) (S m))"
	proof -
	have "invariant (P m) (S m)"
	using find_pred find_succ pred_succ_order by (simp add:invariant_def)
	thus ?thesis using integrate_insert_result_helper by blast
	qed
	end

	lemma integrate_insert_result:
	assumes "consistent (M \<union> {Insert m})"
	assumes "Insert m \<notin> M"
	assumes "is_associated_string M s"
	shows "is_certified_associated_string (M \<union> {Insert m}) (integrate_insert m s (P m) (S m))"
	proof -
	obtain t where t_def: "(integrate_insert m s (P m) (S m)) = Inr t \<and>
	set t = to_woot_character (M \<union> {Insert m}) ` (insert_messages (M \<union> {Insert m}))"
	proof -
	fix tt
	assume a:"(\<And>t. (integrate_insert m s (P m) (S m)) = Inr t \<and>
	set t = to_woot_character (M \<union> {Insert m}) ` insert_messages (M \<union> {Insert m}) \<Longrightarrow>
	tt)"
	obtain a where a_def: "a_conditions (insert_messages (M \<union> {Insert m})) a"
	using consistent_def assms by blast
	moreover have "a_conditions (insert_messages M) a"
	using assms a_subset is_associated_string_def a_def by blast
	ultimately interpret integrate_insert_commute_insert "M" "a" "s" "m"
	using assms by (simp add: integrate_insert_commute_insert_def integrate_insert_commute_def (*
	*) integrate_insert_commute_insert_axioms.intro)
	show tt using a integrate_insert_result
	apply (cases "integrate_insert m s (P m) (S m)") by auto
	qed
	have b:"\<And>a. a_conditions (insert_messages (M \<union> {Insert m})) a \<Longrightarrow>
	sorted_wrt (<) (map a (ext_ids t))"
	proof -
	fix a
	assume c:"a_conditions (insert_messages (M \<union> {Insert m})) a"
	moreover have "a_conditions (insert_messages M) a"
	using assms a_subset is_associated_string_def c by blast
	ultimately interpret integrate_insert_commute_insert "M" "a" "s" "m"
	using assms by (simp add: integrate_insert_commute_insert_def integrate_insert_commute_def (*
	*) integrate_insert_commute_insert_axioms.intro)
	show "sorted_wrt (<) (map a (ext_ids t))"
	using integrate_insert_result t_def by simp
	qed
	show "?thesis" using b t_def assms(1) by (simp add:is_associated_string_def)
	qed

	locale integrate_insert_commute_delete = integrate_insert_commute +
	- fixes m
	+ fixes m :: "('\<I> :: linorder) delete_message"
	assumes consistent_assm: "consistent (M \<union> {Delete m})"
	begin

	-fun delete :: "('a, 's) woot_character \<Rightarrow> ('a, 's) woot_character"
	+fun delete :: "('\<I>, '\<Sigma>) woot_character \<Rightarrow> ('\<I>, '\<Sigma>) woot_character"
	where "delete (InsertMessage p i u _) = InsertMessage p i u None"

	-definition delete_only_m :: "('a, 's) woot_character \<Rightarrow> ('a, 's) woot_character"
	+definition delete_only_m :: "('\<I>, '\<Sigma>) woot_character \<Rightarrow> ('\<I>, '\<Sigma>) woot_character"
	where "delete_only_m x = (if DeleteMessage (I x) = m then delete x else x)"

	lemma set_s: "set s = to_woot_character M ` insert_messages M"
	using associated_string_assm by (simp add:is_associated_string_def)

	lemma delete_only_m_effect:
	"delete_only_m (to_woot_character M x) = to_woot_character (M \<union> {Delete m}) x"
	apply (cases x, simp add:to_woot_character_def delete_maybe_def)
	by (metis delete_only_m_def insert_message.sel(2) delete.simps)

	lemma integrate_delete_result:
	"is_certified_associated_string (M \<union> {Delete m}) (integrate_delete m s)"
	proof (cases m)
	case (DeleteMessage i)
	have "deps (Delete m) \<subseteq> I ` insert_messages (M \<union> {Delete m})"
	using consistent_assm by (simp add:consistent_def DeleteMessage)
	hence "i \<in> I ` insert_messages (M \<union> {Delete m})" using DeleteMessage by auto
	hence "i \<in> I ` set s" using set_s by (simp add:insert_messages_def)
	then obtain k where k_def: "I (s ! k) = i \<and> k < length s"
	by (metis imageE in_set_conv_nth)
	hence "ext_ids s ! (Suc k) = \<lbrakk>i\<rbrakk> \<and> Suc k < length (ext_ids s)"
	by (simp add:ext_ids_def nth_append)
	hence g:"idx s \<lbrakk>i\<rbrakk> = Inr (Suc k)" apply (simp add:fromSingleton_simp filt_simp)
	using dist_ext_ids nth_eq_iff_index_eq by fastforce
	moreover define t where "t = List.list_update s k (delete (s ! k))"
	ultimately have a: "integrate_delete m s = Inr t"
	using k_def DeleteMessage by (cases "s ! k", simp)
	have "\<And>j. j < length s \<Longrightarrow> (DeleteMessage (I(s ! j)) = m) = (j = k)"
	apply (simp add: DeleteMessage) using I_inj_on_S k_def by blast
	hence "List.list_update s k (delete (s ! k)) = map delete_only_m s"
	by (rule_tac nth_equalityI, (simp add:k_def delete_only_m_def)+)
	hence "set t = delete_only_m ` set s" using t_def by auto
	also have "... = to_woot_character (M \<union> {Delete m}) ` (insert_messages M)"
	using set_s delete_only_m_effect image_cong by (metis (no_types, lifting) image_image)
	finally have b:
	"set t = to_woot_character (M \<union> {Delete m}) ` (insert_messages (M \<union> {Delete m}))"
	by (simp add: insert_messages_def)
	have "ext_ids s = ext_ids t"
	apply (cases "s ! k", simp add:t_def ext_ids_def)
	by (metis (no_types, lifting) insert_message.sel(2) list_update_id map_update)
	moreover have "\<And>a. a_conditions (insert_messages M) a \<Longrightarrow> sorted_wrt (<) (map a (ext_ids s))"
	using associated_string_assm is_associated_string_def by blast
	ultimately have c: "\<And>a. a_conditions (insert_messages (M \<union> {Delete m})) a
	\<Longrightarrow> sorted_wrt (<) (map a (ext_ids t))"
	by (simp add:insert_messages_def)
	show ?thesis
	apply (simp add:a is_associated_string_def b c)
	using consistent_assm by fastforce
	qed
	end

	lemma integrate_delete_result:
	assumes "consistent (M \<union> {Delete m})"
	assumes "is_associated_string M s"
	shows "is_certified_associated_string (M \<union> {Delete m}) (integrate_delete m s)"
	proof -
	obtain a where a_def: "a_conditions (insert_messages (M \<union> {Delete m})) a"
	using consistent_def assms by blast
	moreover have "a_conditions (insert_messages M) a"
	using assms a_subset is_associated_string_def a_def by blast
	ultimately interpret integrate_insert_commute_delete "M" "a" "s" "m"
	using assms by (simp add: integrate_insert_commute_def integrate_insert_commute_delete.intro
	integrate_insert_commute_delete_axioms.intro)
	show "?thesis" using integrate_delete_result by blast
	qed

	-fun is_delete :: "(('a, 's) message) \<Rightarrow> bool"
	+fun is_delete :: "('\<I>, '\<Sigma>) message \<Rightarrow> bool"
	where
	"is_delete (Insert m) = False" \|
	"is_delete (Delete m) = True"

	proposition integrate_insert_commute:
	assumes "consistent (M \<union> {m})"
	assumes "is_delete m \<or> m \<notin> M"
	assumes "is_associated_string M s"
	shows "is_certified_associated_string (M \<union> {m}) (integrate s m)"
	using assms integrate_insert_result integrate_delete_result by (cases m, fastforce+)

	end
	\ No newline at end of file
	diff --git a/thys/WOOT_Strong_Eventual_Consistency/Psi.thy b/thys/WOOT_Strong_Eventual_Consistency/Psi.thy
	--- a/thys/WOOT_Strong_Eventual_Consistency/Psi.thy
	+++ b/thys/WOOT_Strong_Eventual_Consistency/Psi.thy
	@@ -1,272 +1,272 @@
	subsection \<open>Definition of \texorpdfstring{$\Psi$}{Psi}\label{sec:psi}\<close>

	theory Psi
	imports SortKeys "HOL-Eisbach.Eisbach"
	begin

	-fun extended_size :: "('a sort_key) extended \<Rightarrow> nat"
	+fun extended_size :: "('\<I> sort_key) extended \<Rightarrow> nat"
	where
	"extended_size \<lbrakk>x\<rbrakk> = size x" \|
	"extended_size _ = 0"

	lemma extended_simps [simp]:
	"(\<turnstile> < x) = (x \<noteq> \<turnstile>)"
	"(\<lbrakk>x'\<rbrakk> < \<lbrakk>y'\<rbrakk>) = (x' < y')"
	"\<lbrakk>x'\<rbrakk> < \<stileturn>"
	"\<not>(\<lbrakk>x'\<rbrakk> < \<turnstile>)"
	"\<not>(\<stileturn> < x)"
	"\<turnstile> \<le> x"
	- "(\<lbrakk>x'\<rbrakk> \<le> \<lbrakk>y'\<rbrakk>) = ((x' :: 'a :: linorder) \<le> y')"
	+ "(\<lbrakk>x'\<rbrakk> \<le> \<lbrakk>y'\<rbrakk>) = ((x' :: '\<I> :: linorder) \<le> y')"
	"x \<le> \<stileturn>"
	"\<not>(\<lbrakk>x'\<rbrakk> \<le> \<turnstile>)"
	"(\<stileturn> \<le> x) = (x = \<stileturn>)"
	by (case_tac [!] x, simp_all add:less_extended_def less_eq_extended_def le_less)

	fun int_size where "int_size (l,u) = max (extended_size l) (extended_size u)"

	lemma position_cases:
	assumes "\<And> y z. x = \<lbrakk>NonFinal (y,Left) z\<rbrakk> \<Longrightarrow> p"
	assumes "\<And> y z. x = \<lbrakk>NonFinal (y,Right) z\<rbrakk> \<Longrightarrow> p"
	assumes "\<And> y. x = \<lbrakk>Final y\<rbrakk> \<Longrightarrow> p"
	assumes "x = \<turnstile> \<Longrightarrow> p"
	assumes "x = \<stileturn> \<Longrightarrow> p"
	shows "p"
	by (metis assms embed_dir.cases extended_size.cases sort_key_embedding.cases)

	fun derive_pos ::
	- "('a :: linorder) \<times> sort_dir \<Rightarrow> 'a sort_key extended \<Rightarrow> 'a sort_key extended"
	+ "('\<I> :: linorder) \<times> sort_dir \<Rightarrow> '\<I> sort_key extended \<Rightarrow> '\<I> sort_key extended"
	where
	"derive_pos h \<lbrakk>NonFinal x y\<rbrakk> =
	(if h < x then \<stileturn> else (if x < h then \<turnstile> else \<lbrakk>y\<rbrakk>))" \|
	"derive_pos h \<lbrakk>Final x\<rbrakk> =
	(if fst h < x \<or> fst h = x \<and> snd h = Left then \<stileturn> else \<turnstile>)" \|
	"derive_pos _ \<turnstile> = \<turnstile>" \|
	"derive_pos _ \<stileturn> = \<stileturn>"

	lemma derive_pos_mono: "x \<le> y \<Longrightarrow> derive_pos h x \<le> derive_pos h y"
	apply (cases h, cases "snd h")
	apply (rule_tac [!] position_cases [where x=x])
	apply (rule_tac [!] position_cases [where x=y])
	by (simp_all, auto)

	-fun \<gamma> :: "('a :: linorder) position \<Rightarrow> sort_dir \<Rightarrow> 'a \<times> sort_dir"
	+fun \<gamma> :: "('\<I> :: linorder) position \<Rightarrow> sort_dir \<Rightarrow> '\<I> \<times> sort_dir"
	where
	"\<gamma> \<lbrakk>NonFinal x y\<rbrakk> _ = x" \|
	"\<gamma> \<lbrakk>Final x\<rbrakk> d = (x,d)" \|
	"\<gamma> \<turnstile> _ = undefined" \|
	"\<gamma> \<stileturn> _ = undefined"

	fun derive_left where
	"derive_left (l, u) = (derive_pos (\<gamma> l Right) l, derive_pos (\<gamma> l Right) u)"

	fun derive_right where
	"derive_right (l, u) = (derive_pos (\<gamma> u Left) l, derive_pos (\<gamma> u Left) u)"

	fun is_interval where "is_interval (l,u) = (l < u)"

	fun elem where "elem x (l,u) = (l < x \<and> x < u)"

	fun subset where "subset (l,u) (l',u') = (l' \<le> l \<and> u \<le> u')"

	-method interval_split for x :: "('a :: linorder) position \<times> 'a position" =
	+method interval_split for x :: "('\<I> :: linorder) position \<times> '\<I> position" =
	(case_tac [!] x,
	rule_tac [!] position_cases [where x="fst x"],
	rule_tac [!] position_cases [where x="snd x"])

	lemma derive_size:
	"\<lbrakk>Final i\<rbrakk> \<le> fst x \<and> is_interval x \<Longrightarrow> int_size (derive_left x) < int_size x"
	"snd x \<le> \<lbrakk>Final i\<rbrakk> \<and> is_interval x \<Longrightarrow> int_size (derive_right x) < int_size x"
	by (interval_split x, simp_all add:less_SucI)

	lemma derive_interval:
	"\<lbrakk>Final i\<rbrakk> \<le> fst x \<Longrightarrow> is_interval x \<Longrightarrow> is_interval (derive_left x)"
	"snd x \<le> \<lbrakk>Final i\<rbrakk> \<Longrightarrow> is_interval x \<Longrightarrow> is_interval (derive_right x)"
	by (interval_split x, simp_all, auto)

	-function \<Psi> :: "('a :: linorder) position \<times> 'a position \<Rightarrow> 'a \<Rightarrow> 'a sort_key"
	+function \<Psi> :: "('\<I> :: linorder) position \<times> '\<I> position \<Rightarrow> '\<I> \<Rightarrow> '\<I> sort_key"
	where
	"\<Psi> (l,u) i = Final i"
	if "l < \<lbrakk>Final i\<rbrakk> \<and> \<lbrakk>Final i\<rbrakk> < u" \|
	"\<Psi> (l,u) i = NonFinal (\<gamma> l Right) (\<Psi> (derive_left (l,u)) i)"
	if "\<lbrakk>Final i\<rbrakk> \<le> l \<and> l < u" \|
	"\<Psi> (l,u) i = NonFinal (\<gamma> u Left) (\<Psi> (derive_right (l,u)) i)"
	if "u \<le> \<lbrakk>Final i\<rbrakk> \<and> l < u" \|
	"\<Psi> (l,u) i = undefined" if "u \<le> l"
	by (metis leI old.prod.exhaust, auto)

	termination
	apply (relation "measure (\<lambda>(p,i). int_size p)", simp)
	using derive_size by fastforce+

	proposition psi_elem: "is_interval x \<Longrightarrow> elem \<lbrakk>\<Psi> x i\<rbrakk> x"
	proof (induct "int_size x" arbitrary:x rule: nat_less_induct)
	case 1
	consider (a) "\<lbrakk>Final i\<rbrakk> \<le> fst x" \| (b) "elem \<lbrakk>Final i\<rbrakk> x" \| (c) "snd x \<le> \<lbrakk>Final i\<rbrakk>"
	using not_le by (metis elem.simps prod.collapse)
	then show ?case
	proof (cases)
	case a
	hence "elem \<lbrakk>\<Psi> (derive_left x) i\<rbrakk> (derive_left x)"
	by (metis 1 derive_size(1) derive_interval(1))
	then show ?thesis using a "1"(2)
	by (interval_split x, simp_all del:\<Psi>.simps, auto)
	next
	case b
	then show ?thesis by (cases x, simp)
	next
	case c
	hence "elem \<lbrakk>\<Psi> (derive_right x) i\<rbrakk> (derive_right x)"
	by (metis 1 derive_size(2) derive_interval(2))
	then show ?thesis using c "1"(2)
	by (interval_split x, simp_all del:\<Psi>.simps, auto)
	qed
	qed

	proposition psi_mono:
	assumes "i1 < i2"
	shows "is_interval x \<Longrightarrow> \<Psi> x i1 < \<Psi> x i2"
	proof (induct "int_size x" arbitrary:x rule: nat_less_induct)
	case 1
	have a:"\<lbrakk>Final i1\<rbrakk> < \<lbrakk>Final i2\<rbrakk>"
	using assms by auto
	then consider
	(a) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> \<lbrakk>Final i2\<rbrakk> \<le> fst x" \|
	(b) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> elem \<lbrakk>Final i2\<rbrakk> x" \|
	(c) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> snd x \<le> \<lbrakk>Final i2\<rbrakk>" \|
	(d) "elem \<lbrakk>Final i1\<rbrakk> x \<and> elem \<lbrakk>Final i2\<rbrakk> x" \|
	(e) "elem \<lbrakk>Final i1\<rbrakk> x \<and> snd x \<le> \<lbrakk>Final i2\<rbrakk>" \|
	(f) "snd x \<le> \<lbrakk>Final i2\<rbrakk> \<and> snd x \<le> \<lbrakk>Final i1\<rbrakk>"
	using assms "1"(2) apply (cases x)
	by (metis (mono_tags, opaque_lifting) dual_order.strict_trans elem.simps
	fst_conv leI snd_conv)
	then show ?case
	proof (cases)
	case a
	hence "\<Psi> (derive_left x) i1 < \<Psi> (derive_left x) i2"
	by (metis 1 derive_size(1) derive_interval(1))
	thus ?thesis using a "1"(2) by (cases x, simp)
	next
	case b
	thus ?thesis using "1"(2) apply (cases x, simp)
	by (rule_tac [!] position_cases [where x="fst x"], simp_all)
	next
	case c
	show ?thesis
	proof (cases "\<gamma> (fst x) Right = \<gamma> (snd x) Left")
	case True
	have e:"is_interval (derive_left x)" using c "1"(2) derive_interval(1) by blast
	have f:"derive_left x = derive_right x" using True by (cases x, simp)
	have h:"\<Psi> (derive_left x) i1 < \<Psi> (derive_right x) i2"
	apply (cases x, simp only: f)
	by (metis "1.hyps" "1.prems" c derive_size(2) e f)
	show ?thesis using c "1"(2) h True by (cases x, simp)
	next
	case False
	hence "\<gamma> (fst x) Right < \<gamma> (snd x) Left" using "1"(2) c
	by (interval_split x, simp_all, auto)
	then show ?thesis using c "1"(2) by (cases x, simp)
	qed
	next
	case d
	thus ?thesis using "1"(2) a by (cases x, simp)
	next
	case e
	thus ?thesis using "1"(2) apply (cases x, simp)
	by (rule_tac [!] position_cases [where x="snd x"], simp_all del:\<Psi>.simps)
	next
	case f
	hence b:"\<Psi> (derive_right x) i1 < \<Psi> (derive_right x) i2"
	by (metis 1 derive_size(2) derive_interval(2))
	thus ?thesis using f "1"(2) by (cases x, simp)
	qed
	qed

	proposition psi_narrow:
	"elem \<lbrakk>\<Psi> x' i\<rbrakk> x \<Longrightarrow> subset x x' \<Longrightarrow> \<Psi> x' i = \<Psi> x i"
	proof (induct "int_size x'" arbitrary: x x' rule: nat_less_induct)
	case 1
	have a: "is_interval x" using "1"(2)
	by (metis dual_order.strict_trans elem.elims(2) is_interval.simps)
	have d: "is_interval x'" using a "1"(3) apply (cases x', cases x, simp) by auto
	consider
	(before) "\<lbrakk>Final i\<rbrakk> \<le> fst x'" \|
	(between) "elem \<lbrakk>Final i\<rbrakk> x'" \|
	(after) "snd x' \<le> \<lbrakk>Final i\<rbrakk>" using 1 apply simp
	by (metis elem.simps leI prod.collapse)
	then show ?case
	proof (cases)
	case before
	have b: "\<lbrakk>Final i\<rbrakk> \<le> fst x" using before 1 apply (cases x)
	by (metis dual_order.trans fst_conv subset.elims(2))
	obtain z where z_def: "\<Psi> x' i = NonFinal (\<gamma> (fst x') Right) z"
	using before d apply (cases x') by simp
	have c:"\<gamma> (fst x') Right = \<gamma> (fst x) Right"
	using "1"(3) z_def "1"(2) apply (cases x, cases x', simp)
	apply (rule_tac [!] position_cases [where x="fst x"])
	apply (rule_tac [!] position_cases [where x="fst x'"])
	using before by (simp_all del:\<Psi>.simps, auto)
	have c1:"subset (derive_left x) (derive_left x')"
	using c "1"(3) by (cases x, cases x', simp add:derive_pos_mono)
	have g:"z = \<Psi> (derive_left x') i" using z_def before d by (cases x', simp)
	have "elem \<lbrakk>NonFinal (\<gamma> (fst x) Right) z\<rbrakk> x"
	using "1"(2) z_def by (simp add: c)
	hence "elem \<lbrakk>z\<rbrakk> (derive_left x)" using before b
	by (interval_split x, simp_all del:\<Psi>.simps, auto)
	hence "\<Psi> (derive_left x') i = \<Psi> (derive_left x) i"
	using "1"(1) before d c1 apply (simp only:g)
	by (metis (no_types) derive_size(1))
	thus ?thesis using before b a d c by (cases x, cases x', simp)
	next
	case between
	thus ?thesis using 1 by (cases x, cases x', auto)
	next
	case after
	have b: "snd x \<le> \<lbrakk>Final i\<rbrakk>" using after 1 apply (cases x)
	by (metis (mono_tags, opaque_lifting) dual_order.trans prod.exhaust_sel
	subset.simps)
	obtain z where z_def:"\<Psi> x' i = NonFinal (\<gamma> (snd x') Left) z"
	using after d by (cases x', simp)
	have c:"\<gamma> (snd x') Left = \<gamma> (snd x) Left"
	using "1"(3) z_def "1"(2) apply (simp, cases x, cases x')
	apply (rule_tac [!] position_cases [where x="snd x"])
	apply (rule_tac [!] position_cases [where x="snd x'"]) using after
	by (simp_all del:\<Psi>.simps, auto)
	have c1:"subset (derive_right x) (derive_right x')"
	using c "1"(3) by (cases x, cases x', simp add:derive_pos_mono)
	have g:"z = \<Psi> (derive_right x') i" using z_def after d by (cases x', simp)
	have "elem \<lbrakk>NonFinal (\<gamma> (snd x) Left) z\<rbrakk> x"
	using "1"(2) z_def by (simp add: c)
	hence "elem \<lbrakk>z\<rbrakk> (derive_right x)" using after b
	by (interval_split x, simp_all del:\<Psi>.simps, auto)
	hence "\<Psi> (derive_right x') i = \<Psi> (derive_right x) i"
	using "1"(1) after d c1 apply (simp only:g)
	by (metis (no_types) derive_size(2))
	thus ?thesis using after b a d c by (cases x, cases x', simp)
	qed
	qed

	definition preserve_order :: "'a :: linorder \<Rightarrow> 'a \<Rightarrow> 'b :: linorder \<Rightarrow> 'b \<Rightarrow> bool"
	where "preserve_order x y u v \<equiv> (x < y \<longrightarrow> u < v) \<and> (x > y \<longrightarrow> u > v)"

	proposition psi_preserve_order:
	fixes l l' u u' i i'
	assumes "elem \<lbrakk>\<Psi> (l, u) i\<rbrakk> (l',u')"
	assumes "elem \<lbrakk>\<Psi> (l', u') i'\<rbrakk> (l, u)"
	shows "preserve_order i i' \<lbrakk>\<Psi> (l,u) i\<rbrakk> \<lbrakk>\<Psi> (l', u') i'\<rbrakk>"
	proof -
	have "l < u" using assms(2) by auto
	hence a:"elem \<lbrakk>\<Psi> (l, u) i\<rbrakk> (max l l', min u u')"
	using assms(1) psi_elem by fastforce
	hence b:"\<Psi> (l,u) i = \<Psi> (max l l', min u u') i"
	by (simp add: psi_narrow)
	have "l' < u'" using assms(1) by auto
	hence "elem \<lbrakk>\<Psi> (l',u') i'\<rbrakk> (max l l', min u u')"
	using assms(2) psi_elem by fastforce
	hence c:"\<Psi> (l',u') i' = \<Psi> (max l l', min u u') i'"
	by (simp add: psi_narrow)
	hence "max l l' < min u u'" using a min_def by auto
	then show ?thesis apply (simp only: preserve_order_def b c)
	using psi_mono extended_simps(2) is_interval.simps by blast
	qed

	end
	diff --git a/thys/WOOT_Strong_Eventual_Consistency/SortKeys.thy b/thys/WOOT_Strong_Eventual_Consistency/SortKeys.thy
	--- a/thys/WOOT_Strong_Eventual_Consistency/SortKeys.thy
	+++ b/thys/WOOT_Strong_Eventual_Consistency/SortKeys.thy
	@@ -1,65 +1,65 @@
	section \<open>Formalized Proof \label{sec:proof}\<close>

	theory SortKeys
	imports Data "HOL-Library.List_Lexorder" "HOL-Library.Product_Lexorder"
	begin

	datatype sort_dir =
	Left \|
	Right
	derive linorder sort_dir

	lemma sort_dir_less_def [simp]: "(x < y) = (x = Left \<and> y = Right)"
	by (cases x, case_tac [!] y, simp_all add:less_sort_dir_def)

	-datatype 'a sort_key =
	- NonFinal "('a \<times> sort_dir)" "'a sort_key" \|
	- Final 'a
	+datatype '\<I> sort_key =
	+ NonFinal "('\<I> \<times> sort_dir)" "'\<I> sort_key" \|
	+ Final '\<I>

	-type_synonym 'id position = "'id sort_key extended"
	+type_synonym '\<I> position = "'\<I> sort_key extended"

	fun embed_dir where "embed_dir (x,Left) = (x, 0)" \| "embed_dir (x,Right) = (x, Suc (Suc 0))"

	lemma embed_dir_inj [simp]: "(embed_dir x = embed_dir y) = (x = y)"
	by (cases x, cases y, case_tac [!] "snd x", case_tac [!] "snd y", simp+)

	lemma embed_dir_mono [simp]: "(embed_dir x < embed_dir y) = (x < y)"
	by (cases x, cases y, case_tac [!] "snd x", case_tac [!] "snd y", (simp add:less_sort_dir_def)+)

	-fun sort_key_embedding :: "'a sort_key \<Rightarrow> ('a \<times> nat) list"
	+fun sort_key_embedding :: "'\<I> sort_key \<Rightarrow> ('\<I> \<times> nat) list"
	where
	"sort_key_embedding (NonFinal x y) = embed_dir x#(sort_key_embedding y)" \|
	"sort_key_embedding (Final i) = [(i, Suc 0)]"

	lemma sort_key_embedding_injective:
	"sort_key_embedding x = sort_key_embedding y \<Longrightarrow> x = y"
	apply (induct x arbitrary: y)
	apply (metis embed_dir_inj list.distinct(1) list.inject sort_key.exhaust
	sort_key_embedding.simps)
	by (metis fst_conv list.distinct(1) list.inject sort_key.exhaust
	sort_key_embedding.simps)

	instantiation sort_key :: (ord) ord
	begin
	definition sort_key_less_eq_def [simp]:
	"(x :: ('a :: ord) sort_key) \<le> y \<longleftrightarrow>
	(sort_key_embedding x \<le> sort_key_embedding y)"

	definition sort_key_less_def [simp]:
	"(x :: ('a :: ord) sort_key) < y \<longleftrightarrow>
	(sort_key_embedding x < sort_key_embedding y)"

	instance ..
	end

	instantiation sort_key :: (order) order
	begin
	instance by (intro_classes, simp_all add: less_le_not_le sort_key_embedding_injective)
	end

	instantiation sort_key :: (linorder) linorder
	begin
	instance by (intro_classes, meson less_imp_le not_le sort_key_less_eq_def)
	end

	end
	\ No newline at end of file
	diff --git a/thys/WebAssembly/Wasm_Printing/Wasm_Interpreter_Printing_Pure.thy b/thys/WebAssembly/Wasm_Printing/Wasm_Interpreter_Printing_Pure.thy
	--- a/thys/WebAssembly/Wasm_Printing/Wasm_Interpreter_Printing_Pure.thy
	+++ b/thys/WebAssembly/Wasm_Printing/Wasm_Interpreter_Printing_Pure.thy
	@@ -1,36 +1,36 @@
	theory Wasm_Interpreter_Printing_Pure
	imports
	"../Wasm_Interpreter_Properties"
	Wasm_Type_Abs_Printing
	"HOL-Library.Code_Target_Nat"
	- "Native_Word.Code_Target_Bits_Int"
	+ "Native_Word.Code_Target_Int_Bit"
	begin

	axiomatization where
	mem_grow_impl_is[code]: "mem_grow_impl m n = Some (mem_grow m n)"

	definition "run = run_v (2^63) 300"

	code_printing
	constant host_apply_impl \<rightharpoonup> (OCaml) "ImplWrapper.host'_apply'_impl"

	declare Rep_bytes_inverse[code abstype]
	declare Rep_mem_inverse[code abstype]

	declare write_bytes.rep_eq[code abstract]
	and read_bytes.rep_eq[code abstract]
	and mem_append.rep_eq[code abstract]

	lemma bytes_takefill_rep_eq[code abstract]:
	"Rep_bytes (bytes_takefill b n bs) = takefill b n (Rep_bytes bs)"
	using bytes_takefill.rep_eq Rep_uint8_inverse
	by simp

	lemma bytes_replicate_rep_eq[code abstract]:
	"Rep_bytes (bytes_replicate n b) = replicate n b"
	using bytes_replicate.rep_eq Rep_uint8_inverse
	by simp

	export_code open run in OCaml

	end
	diff --git a/thys/Weight_Balanced_Trees/Weight_Balanced_Trees_log.thy b/thys/Weight_Balanced_Trees/Weight_Balanced_Trees_log.thy
	--- a/thys/Weight_Balanced_Trees/Weight_Balanced_Trees_log.thy
	+++ b/thys/Weight_Balanced_Trees/Weight_Balanced_Trees_log.thy
	@@ -1,91 +1,185 @@
	(* Author: Tobias Nipkow *)

	-section \<open>Weight-Balanced Trees Have Logarithmic Height\<close>
	-
	-text \<open>This theory is based on the original definition of weight-balanced trees
	-\cite{NievergeltR72,NievergeltR73}
	-where the size of the child of a node must be a minimum and a maximum fraction
	-of the size of the node.\<close>
	+section \<open>Weight-Balanced Trees Have Logarithmic Height, and More\<close>

	theory Weight_Balanced_Trees_log
	imports
	Complex_Main
	"HOL-Library.Tree"
	begin

	-(* FIXME mod field_simps *)
	+(* FIXME add these to field_simps *)
	lemmas neq0_if = less_imp_neq dual_order.strict_implies_not_eq

	+subsection \<open>Logarithmic Height\<close>
	+
	+text \<open>The locale below is parameterized wrt to \<open>\<Delta>\<close>. The original definition of weight-balanced trees
	+\cite{NievergeltR72,NievergeltR73} uses \<open>\<alpha>\<close>. The constants \<open>\<alpha>\<close> and \<open>\<Delta>\<close> are interdefinable.
	+Below we start from \<open>\<Delta>\<close> but derive \<open>\<alpha>\<close>-versions of theorems as well.\<close>
	+
	locale WBT0 =
	-fixes \<alpha> :: real
	-assumes alpha_pos: "0 < \<alpha>" and alpha_ub: "\<alpha> \<le> 1/2"
	+fixes \<Delta> :: real
	begin

	+fun balanced1 :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> bool" where
	+"balanced1 t1 t2 = (size1 t1 \<le> \<Delta> * size1 t2)"
	+
	fun wbt :: "'a tree \<Rightarrow> bool" where
	"wbt Leaf = True" \|
	-"wbt (Node l _ r) = (wbt l \<and> wbt r \<and> (let ratio = size1 l / (size1 l + size1 r)
	- in \<alpha> \<le> ratio \<and> ratio \<le> 1 - \<alpha>))"
	+"wbt (Node l _ r) = (balanced1 l r \<and> balanced1 r l \<and> wbt l \<and> wbt r)"

	-lemma height_size1_exp:
	- "wbt t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> 2 \<le> (1-\<alpha>) ^ (height t - 1) * size1 t"
	+end
	+
	+locale WBT1 = WBT0 +
	+assumes Delta: "\<Delta> \<ge> 1"
	+begin
	+
	+definition \<alpha> :: real where
	+"\<alpha> = 1/(\<Delta>+1)"
	+
	+lemma Delta_def: "\<Delta> = 1/\<alpha> - 1"
	+unfolding \<alpha>_def by auto
	+
	+lemma shows alpha_pos: "0 < \<alpha>" and alpha_ub: "\<alpha> \<le> 1/2"
	+unfolding \<alpha>_def using Delta by auto
	+
	+lemma wbt_Node_alpha: "wbt (Node l x r) =
	+ ((let q = size1 l / (size1 l + size1 r)
	+ in \<alpha> \<le> q \<and> q \<le> 1 - \<alpha>) \<and>
	+ wbt l \<and> wbt r)"
	+proof -
	+ have "l > 0 \<Longrightarrow> r > 0 \<Longrightarrow>
	+ (1/(\<Delta>+1) \<le> l/(l+r) \<longleftrightarrow> r/l \<le> \<Delta>) \<and>
	+ (1/(\<Delta>+1) \<le> r/(l+r) \<longleftrightarrow> l/r \<le> \<Delta>) \<and>
	+ (l/(l+r) \<le> 1 - 1/(\<Delta>+1) \<longleftrightarrow> l/r \<le> \<Delta>) \<and>
	+ (r/(l+r) \<le> 1 - 1/(\<Delta>+1) \<longleftrightarrow> r/l \<le> \<Delta>)" for l r
	+ using Delta by (simp add: field_simps divide_le_eq)
	+ thus ?thesis using Delta by(auto simp: \<alpha>_def Let_def pos_divide_le_eq add_pos_pos)
	+qed
	+
	+lemma height_size1_Delta:
	+ "wbt t \<Longrightarrow> (1 + 1/\<Delta>) ^ (height t) \<le> size1 t"
	proof(induction t)
	case Leaf thus ?case by simp
	next
	case (Node l a r)
	- have 0: "0 \<le> (1 - \<alpha>) ^ k" for k using alpha_ub by simp
	- let ?t = "Node l a r" let ?s = "size1 ?t"
	- from Node.prems(1) have 1: "size1 l \<le> (1-\<alpha>) * ?s" and 2: "size1 r \<le> (1-\<alpha>) * ?s"
	- by (auto simp: Let_def field_simps add_pos_pos neq0_if)
	+ let ?t = "Node l a r" let ?s = "size1 ?t" let ?d = "1 + 1/\<Delta>"
	+ from Node.prems(1) have 1: "size1 l * ?d \<le> ?s" and 2: "size1 r * ?d \<le> ?s"
	+ using Delta by (auto simp: Let_def field_simps add_pos_pos neq0_if)
	show ?case
	- proof (cases "l = Leaf \<and> r = Leaf")
	- case True thus ?thesis by simp
	+ proof (cases "height l \<le> height r")
	+ case True
	+ hence "?d ^ (height ?t) = ?d ^ (height r) * ?d" by(simp)
	+ also have "\<dots> \<le> size1 r * ?d"
	+ using Node.IH(2) Node.prems Delta unfolding wbt.simps
	+ by (smt (verit) divide_nonneg_nonneg mult_mono of_nat_0_le_iff)
	+ also have "\<dots> \<le> ?s" using 2 by (simp)
	+ finally show ?thesis .
	next
	- case not_Leafs: False
	- show ?thesis
	- proof (cases "height l \<le> height r")
	- case hlr: True
	- hence r: "r \<noteq> Leaf" and hr: "height r \<noteq> 0" using not_Leafs by (auto)
	- have "2 \<le> (1-\<alpha>) ^ (height r - 1) * size1 r"
	- using Node.IH(2)[OF _ r] Node.prems by simp
	- also have "\<dots> \<le> (1-\<alpha>) ^ (height r - 1) * ((1-\<alpha>) * ?s)"
	- by(rule mult_left_mono[OF 2 0])
	- also have "\<dots> = (1-\<alpha>) ^ (height r - 1 + 1) * ?s" by simp
	- also have "\<dots> = (1-\<alpha>) ^ (height r) * ?s"
	- using hr by (auto simp del: eq_height_0)
	- finally show ?thesis using hlr by (simp)
	+ case False
	+ hence "?d ^ (height ?t) = ?d ^ (height l) * ?d" by(simp)
	+ also have "\<dots> \<le> size1 l * ?d"
	+ using Node.IH(1) Node.prems Delta unfolding wbt.simps
	+ by (smt (verit) divide_nonneg_nonneg mult_mono of_nat_0_le_iff)
	+ also have "\<dots> \<le> ?s" using 1 by (simp)
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+lemma height_size1_alpha:
	+ "wbt t \<Longrightarrow> (1/(1-\<alpha>)) ^ (height t) \<le> size1 t"
	+proof(induction t)
	+ case Leaf thus ?case by simp
	+next
	+ note wbt.simps[simp del] wbt_Node_alpha[simp]
	+ case (Node l a r)
	+ let ?t = "Node l a r" let ?s = "size1 ?t"
	+ from Node.prems(1) have 1: "size1 l / (1-\<alpha>) \<le> ?s" and 2: "size1 r / (1-\<alpha>) \<le> ?s"
	+ using alpha_ub by (auto simp: Let_def field_simps add_pos_pos neq0_if)
	+ show ?case
	+ proof (cases "height l \<le> height r")
	+ case True
	+ hence "(1/(1-\<alpha>)) ^ (height ?t) = (1/(1-\<alpha>)) ^ (height r) * (1/(1-\<alpha>))" by(simp)
	+ also have "\<dots> \<le> size1 r * (1/(1-\<alpha>))"
	+ using Node.IH(2) Node.prems unfolding wbt_Node_alpha
	+ by (smt (verit) mult_right_mono zero_le_divide_1_iff)
	+ also have "\<dots> \<le> ?s" using 2 by (simp)
	+ finally show ?thesis .
	+ next
	+ case False
	+ hence "(1/(1-\<alpha>)) ^ (height ?t) = (1/(1-\<alpha>)) ^ (height l) * (1/(1-\<alpha>))" by(simp)
	+ also have "\<dots> \<le> size1 l * (1/(1-\<alpha>))"
	+ using Node.IH(1) Node.prems unfolding wbt_Node_alpha
	+ by (smt (verit) mult_right_mono zero_le_divide_1_iff)
	+ also have "\<dots> \<le> ?s" using 1 by (simp)
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+lemma height_size1_log_Delta: assumes "wbt t"
	+shows "height t \<le> log 2 (size1 t) / log 2 (1 + 1/\<Delta>)"
	+proof -
	+ from height_size1_Delta[OF assms]
	+ have "height t \<le> log (1 + 1/\<Delta>) (size1 t)"
	+ using Delta le_log_of_power by auto
	+ also have "\<dots> = log 2 (size1 t) / log 2 (1 + 1/\<Delta>)"
	+ by (simp add: log_base_change)
	+ finally show ?thesis .
	+qed
	+
	+lemma height_size1_log_alpha: assumes "wbt t"
	+shows "height t \<le> log 2 (size1 t) / log 2 (1/(1-\<alpha>))"
	+proof -
	+ from height_size1_alpha[OF assms]
	+ have "height t \<le> log (1/(1-\<alpha>)) (size1 t)"
	+ using alpha_pos alpha_ub le_log_of_power by auto
	+ also have "\<dots> = log 2 (size1 t) / log 2 (1/(1-\<alpha>))"
	+ by (simp add: log_base_change)
	+ finally show ?thesis .
	+qed
	+
	+end
	+
	+subsection \<open>Every \<open>1 \<le> \<Delta> < 2\<close> Yields Exactly the Complete Trees\<close>
	+
	+declare WBT0.wbt.simps [simp] WBT0.balanced1.simps [simp]
	+
	+lemma wbt1_if_complete: assumes "1 \<le> \<Delta>" shows "complete t \<Longrightarrow> WBT0.wbt \<Delta> t"
	+apply(induction t)
	+ apply simp
	+apply (simp add: assms size1_if_complete)
	+done
	+
	+lemma complete_if_wbt2: assumes "\<Delta> < 2" shows "WBT0.wbt \<Delta> t \<Longrightarrow> complete t"
	+proof(induction t)
	+ case Leaf
	+ then show ?case by simp
	+next
	+ case (Node t1 x t2)
	+ let ?h1 = "height t1" let ?h2 = "height t2"
	+ from Node have *: "complete t1 \<and> complete t2" by auto
	+ hence sz: "size1 t1 = 2 ^ ?h1 \<and> size1 t2 = 2 ^ ?h2"
	+ using size1_if_complete by blast
	+ show ?case
	+ proof (rule ccontr)
	+ assume "\<not> complete \<langle>t1, x, t2\<rangle>"
	+ hence "?h1 \<noteq> ?h2" using * by auto
	+ thus False
	+ proof (cases "?h1 < ?h2")
	+ case True
	+ hence "2 * (2::real) ^ ?h1 \<le> 2 ^ ?h2"
	+ by (metis Suc_leI one_le_numeral power_Suc power_increasing)
	+ also have "\<dots> \<le> \<Delta> * 2 ^ ?h1" using sz Node.prems by (simp)
	+ finally show False using \<open>\<Delta> < 2\<close> by simp
	next
	- case hlr: False
	- hence l: "l \<noteq> Leaf" and hl: "height l \<noteq> 0" using not_Leafs by (auto)
	- have "2 \<le> (1-\<alpha>) ^ (height l - 1) * size1 l"
	- using Node.IH(1)[OF _ l] Node.prems by simp
	- also have "\<dots> \<le> (1-\<alpha>) ^ (height l - 1) * ((1-\<alpha>) * ?s)"
	- by(rule mult_left_mono[OF 1 0])
	- also have "\<dots> = (1-\<alpha>) ^ (height l - 1 + 1) * ?s" by simp
	- also have "\<dots> = (1-\<alpha>) ^ (height l) * ?s"
	- using hl by (auto simp del: eq_height_0)
	- finally show ?thesis using hlr by (simp)
	+ case False
	+ with \<open>?h1 \<noteq> ?h2\<close> have "?h2 < ?h1" by linarith
	+ hence "2 * (2::real) ^ ?h2 \<le> 2 ^ ?h1"
	+ by (metis Suc_leI one_le_numeral power_Suc power_increasing)
	+ also have "\<dots> \<le> \<Delta> * 2 ^ ?h2" using sz Node.prems by (simp)
	+ finally show False using \<open>\<Delta> < 2\<close> by simp
	qed
	qed
	qed

	-lemma height_size1_log: assumes "wbt t" "t \<noteq> Leaf"
	-shows "height t \<le> (log 2 (size1 t) - 1) / log 2 (1/(1-\<alpha>)) + 1"
	-proof -
	- have "1 \<le> log 2 ((1-\<alpha>) ^ (height t - 1) * size1 t)"
	- using height_size1_exp[OF assms] by simp
	- hence "1 \<le> log 2 ((1-\<alpha>) ^ (height t - 1)) + log 2 (size1 t)"
	- using alpha_ub by(simp add: log_mult)
	- hence "1 \<le> (height t - 1) * log 2 (1-\<alpha>) + log 2 (size1 t)"
	- using alpha_ub by(simp add: log_nat_power)
	- hence "- (height t - 1) * log 2 (1-\<alpha>) \<le> log 2 (size1 t) - 1"
	- by(simp add: algebra_simps)
	- hence "(height t - 1) * log 2 (1/(1-\<alpha>)) \<le> log 2 (size1 t) - 1"
	- using alpha_ub by(simp add: log_divide)
	- hence "height t - 1 \<le> (log 2 (size1 t) - 1) / log 2 (1/(1-\<alpha>))"
	- using alpha_pos alpha_ub by(simp add: field_simps log_divide)
	- thus ?thesis by(simp)
	-qed
	-
	end
	-
	-end
	diff --git a/thys/Wetzels_Problem/ROOT b/thys/Wetzels_Problem/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Wetzels_Problem/ROOT
	@@ -0,0 +1,12 @@
	+chapter AFP
	+
	+session Wetzels_Problem (AFP) = "HOL-Complex_Analysis" +
	+ options [timeout = 300]
	+ sessions
	+ ZFC_in_HOL
	+ theories
	+ Wetzels_Problem
	+ document_files
	+ "root.tex"
	+ "root.bib"
	+
	diff --git a/thys/Wetzels_Problem/Wetzels_Problem.thy b/thys/Wetzels_Problem/Wetzels_Problem.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Wetzels_Problem/Wetzels_Problem.thy
	@@ -0,0 +1,369 @@
	+section \<open>Wetzel's Problem, Solved by Erdös\<close>
	+
	+text \<open>Martin Aigner and Günter M. Ziegler. Proofs from THE BOOK. (Springer, 2018).
	+Chapter 19: Sets, functions, and the continuum hypothesis
	+Theorem 5 (pages 137--8)\<close>
	+
	+theory Wetzels_Problem imports
	+ "HOL-Complex_Analysis.Complex_Analysis" "ZFC_in_HOL.General_Cardinals"
	+
	+begin
	+
	+definition Wetzel :: "(complex \<Rightarrow> complex) set \<Rightarrow> bool"
	+ where "Wetzel \<equiv> \<lambda>F. (\<forall>f\<in>F. f analytic_on UNIV) \<and> (\<forall>z. countable((\<lambda>f. f z) ` F))"
	+
	+subsubsection \<open>When the continuum hypothesis is false\<close>
	+
	+proposition Erdos_Wetzel_nonCH:
	+ assumes W: "Wetzel F" and NCH: "C_continuum > \<aleph>1" and "small F"
	+ shows "countable F"
	+proof -
	+ have "\<exists>z0. gcard ((\<lambda>f. f z0) ` F) \<ge> \<aleph>1" if "uncountable F"
	+ proof -
	+ have "gcard F \<ge> \<aleph>1"
	+ using \<open>small F\<close> that uncountable_gcard_ge by blast
	+ then obtain F' where "F' \<subseteq> F" and F': "gcard F' = \<aleph>1"
	+ by (meson Card_Aleph Ord_1 subset_smaller_gcard \<open>small F\<close>)
	+ then obtain \<phi> where \<phi>: "bij_betw \<phi> (elts (\<aleph>1)) F'"
	+ by (metis TC_small eqpoll_def gcard_eqpoll)
	+ define S where "S \<equiv> \<lambda>\<alpha> \<beta>. {z. \<phi> \<alpha> z = \<phi> \<beta> z}"
	+ have co_S: "gcard (S \<alpha> \<beta>) \<le> \<aleph>0" if "\<alpha> \<in> elts \<beta>" "\<beta> \<in> elts (\<aleph>1)" for \<alpha> \<beta>
	+ proof -
	+ have "\<phi> \<alpha> holomorphic_on UNIV" "\<phi> \<beta> holomorphic_on UNIV"
	+ using W \<open>F' \<subseteq> F\<close> unfolding Wetzel_def
	+ by (meson Ord_\<omega>1 Ord_trans \<phi> analytic_imp_holomorphic bij_betwE subsetD that)+
	+ moreover have "\<phi> \<alpha> \<noteq> \<phi> \<beta>"
	+ by (metis Ord_\<omega>1 Ord_in_Ord Ord_trans OrdmemD \<phi> bij_betw_imp_inj_on inj_on_def less_V_def that)
	+ ultimately have "countable (S \<alpha> \<beta>)"
	+ using holomorphic_countable_equal_UNIV unfolding S_def by blast
	+ then show ?thesis
	+ using countable_imp_g_le_Aleph0 by blast
	+ qed
	+ define SS where "SS \<equiv>\<Squnion>\<beta> \<in> elts(\<aleph>1). \<Squnion>\<alpha> \<in> elts \<beta>. S \<alpha> \<beta>"
	+ have F'_eq: "F' = \<phi> ` elts \<omega>1"
	+ using \<phi> bij_betw_imp_surj_on by auto
	+ have \<section>: "\<And>x xa. xa \<in> elts \<omega>1 \<Longrightarrow> gcard (\<Union>\<alpha>\<in>elts xa. S \<alpha> xa) \<le> \<omega>"
	+ by (metis Aleph_0 TC_small co_S countable_UN countable_iff_g_le_Aleph0 less_\<omega>1_imp_countable)
	+ have "gcard SS \<le> gcard ((\<lambda>\<beta>. \<Union>\<alpha>\<in>elts \<beta>. S \<alpha> \<beta>) ` elts \<omega>1) \<otimes> \<aleph>0"
	+ apply (simp add: SS_def)
	+ by (metis (no_types, lifting) "\<section>" TC_small gcard_Union_le_cmult imageE)
	+ also have "\<dots> \<le> \<aleph>1"
	+ proof (rule cmult_InfCard_le)
	+ show "gcard ((\<lambda>\<beta>. \<Union>\<alpha>\<in>elts \<beta>. S \<alpha> \<beta>) ` elts \<omega>1) \<le> \<omega>1"
	+ using gcard_image_le by fastforce
	+ qed auto
	+ finally have "gcard SS \<le> \<aleph>1" .
	+ with NCH obtain z0 where "z0 \<notin> SS"
	+ by (metis Complex_gcard UNIV_eq_I less_le_not_le)
	+ then have "inj_on (\<lambda>x. \<phi> x z0) (elts \<omega>1)"
	+ apply (simp add: SS_def S_def inj_on_def)
	+ by (metis Ord_\<omega>1 Ord_in_Ord Ord_linear)
	+ then have "gcard ((\<lambda>f. f z0) ` F') = \<aleph>1"
	+ by (smt (verit) F' F'_eq gcard_image imageE inj_on_def)
	+ then show ?thesis
	+ by (metis TC_small \<open>F' \<subseteq> F\<close> image_mono subset_imp_gcard_le)
	+ qed
	+ with W show ?thesis
	+ unfolding Wetzel_def by (meson countable uncountable_gcard_ge)
	+qed
	+
	+subsubsection \<open>When the continuum hypothesis is true\<close>
	+
	+lemma Rats_closure_real2: "closure (\<rat>\<times>\<rat>) = (UNIV::real set)\<times>(UNIV::real set)"
	+ by (simp add: Rats_closure_real closure_Times)
	+
	+proposition Erdos_Wetzel_CH:
	+ assumes CH: "C_continuum = \<aleph>1"
	+ obtains F where "Wetzel F" and "uncountable F"
	+proof -
	+ define D where "D \<equiv> {z. Re z \<in> \<rat> \<and> Im z \<in> \<rat>}"
	+ have Deq: "D = (\<Union>x\<in>\<rat>. \<Union>y\<in>\<rat>. {Complex x y})"
	+ using complex.collapse by (force simp: D_def)
	+ with countable_rat have "countable D"
	+ by blast
	+ have "infinite D"
	+ unfolding Deq
	+ by (intro infinite_disjoint_family_imp_infinite_UNION Rats_infinite) (auto simp: disjoint_family_on_def)
	+ have "\<exists>w. Re w \<in> \<rat> \<and> Im w \<in> \<rat> \<and> norm (w - z) < e" if "e > 0" for z and e::real
	+ proof -
	+ obtain x y where "x\<in>\<rat>" "y\<in>\<rat>" and xy: "dist (x,y) (Re z, Im z) < e"
	+ using \<open>e > 0\<close> Rats_closure_real2 by (force simp: closure_approachable)
	+ moreover have "dist (x,y) (Re z, Im z) = norm (Complex x y - z)"
	+ by (simp add: norm_complex_def norm_prod_def dist_norm)
	+ ultimately show "\<exists>w. Re w \<in> \<rat> \<and> Im w \<in> \<rat> \<and> norm (w - z) < e"
	+ by (metis complex.sel)
	+ qed
	+ then have cloD: "closure D = UNIV"
	+ by (auto simp: D_def closure_approachable dist_complex_def)
	+ obtain \<zeta> where \<zeta>: "bij_betw \<zeta> (elts (\<aleph>1)) (UNIV::complex set)"
	+ by (metis Complex_gcard TC_small assms eqpoll_def gcard_eqpoll)
	+ define inD where "inD \<equiv> \<lambda>\<beta> f. (\<forall>\<alpha> \<in> elts \<beta>. f (\<zeta> \<alpha>) \<in> D)"
	+ define \<Phi> where "\<Phi> \<equiv> \<lambda>\<beta> f. f \<beta> analytic_on UNIV \<and> inD \<beta> (f \<beta>) \<and> inj_on f (elts (succ \<beta>))"
	+ have *: "\<exists>h. \<Phi> \<gamma> ((restrict f (elts \<gamma>))(\<gamma>:=h))"
	+ if \<gamma>: "\<gamma> \<in> elts (\<aleph>1)" and "\<forall>\<beta> \<in> elts \<gamma>. \<Phi> \<beta> f" for \<gamma> f
	+ proof -
	+ have f: "\<forall>\<beta> \<in> elts \<gamma>. f \<beta> analytic_on UNIV \<and> inD \<beta> (f \<beta>)"
	+ using that by (auto simp: \<Phi>_def)
	+ have inj: "inj_on f (elts \<gamma>)"
	+ using that by (simp add: \<Phi>_def inj_on_def) (meson Ord_\<omega>1 Ord_in_Ord Ord_linear)
	+ obtain h where "h analytic_on UNIV" "inD \<gamma> h" "(\<forall>\<beta> \<in> elts \<gamma>. h \<noteq> f \<beta>)"
	+ proof (cases "finite (elts \<gamma>)")
	+ case True
	+ then obtain \<eta> where \<eta>: "bij_betw \<eta> {..<card (elts \<gamma>)} (elts \<gamma>)"
	+ using bij_betw_from_nat_into_finite by blast
	+ define g where "g \<equiv> f o \<eta>"
	+ define w where "w \<equiv> \<zeta> o \<eta>"
	+ have gf: "\<forall>i<card (elts \<gamma>). h \<noteq> g i \<Longrightarrow> \<forall>\<beta>\<in>elts \<gamma>. h \<noteq> f \<beta>" for h
	+ using \<eta> by (auto simp: bij_betw_iff_bijections g_def)
	+ have *: "\<exists>h. h analytic_on UNIV \<and> (\<forall>i<n. h (w i) \<in> D \<and> h (w i) \<noteq> g i (w i))"
	+ if "n \<le> card (elts \<gamma>)" for n
	+ using that
	+ proof (induction n)
	+ case 0
	+ then show ?case
	+ using analytic_on_const by blast
	+ next
	+ case (Suc n)
	+ then obtain h where "h analytic_on UNIV" and hg: "\<forall>i<n. h (w i) \<in> D \<and> h (w i) \<noteq> g i (w i)"
	+ using Suc_leD by blast
	+ define p where "p \<equiv> \<lambda>z. \<Prod>i<n. z - w i"
	+ have p0: "p z = 0 \<longleftrightarrow> (\<exists>i<n. z = w i)" for z
	+ unfolding p_def by force
	+ obtain d where d: "d \<in> D - {g n (w n)}"
	+ using \<open>infinite D\<close> by (metis ex_in_conv finite.emptyI infinite_remove)
	+ define h' where "h' \<equiv> \<lambda>z. h z + p z * (d - h (w n)) / p (w n)"
	+ have h'_eq: "h' (w i) = h (w i)" if "i<n" for i
	+ using that by (force simp: h'_def p0)
	+ show ?case
	+ proof (intro exI strip conjI)
	+ have nless: "n < card (elts \<gamma>)"
	+ using Suc.prems Suc_le_eq by blast
	+ with \<eta> have "\<eta> n \<noteq> \<eta> i" if "i<n" for i
	+ using that unfolding bij_betw_iff_bijections
	+ by (metis lessThan_iff less_not_refl order_less_trans)
	+ with \<zeta> \<eta> \<gamma> have pwn_nonzero: "p (w n) \<noteq> 0"
	+ apply (clarsimp simp: p0 w_def bij_betw_iff_bijections)
	+ by (metis Ord_\<omega>1 Ord_trans nless lessThan_iff order_less_trans)
	+ then show "h' analytic_on UNIV"
	+ unfolding h'_def p_def by (intro analytic_intros \<open>h analytic_on UNIV\<close>)
	+ fix i
	+ assume "i < Suc n"
	+ then have \<section>: "i < n \<or> i = n"
	+ by linarith
	+ then show "h' (w i) \<in> D"
	+ using h'_eq hg d h'_def pwn_nonzero by force
	+ show "h' (w i) \<noteq> g i (w i)"
	+ using \<section> h'_eq hg h'_def d pwn_nonzero by fastforce
	+ qed
	+ qed
	+ show ?thesis
	+ using * [OF order_refl] \<eta> that gf
	+ by (simp add: w_def bij_betw_iff_bijections inD_def) metis
	+ next
	+ case False
	+ then obtain \<eta> where \<eta>: "bij_betw \<eta> (UNIV::nat set) (elts \<gamma>)"
	+ by (meson \<gamma> countable_infiniteE' less_\<omega>1_imp_countable)
	+ then have \<eta>_inject [simp]: "\<eta> i = \<eta> j \<longleftrightarrow> i=j" for i j
	+ by (simp add: bij_betw_imp_inj_on inj_eq)
	+ define g where "g \<equiv> f o \<eta>"
	+ define w where "w \<equiv> \<zeta> o \<eta>"
	+ then have w_inject [simp]: "w i = w j \<longleftrightarrow> i=j" for i j
	+ by (smt (verit) Ord_\<omega>1 Ord_trans UNIV_I \<eta> \<gamma> \<zeta> bij_betw_iff_bijections comp_apply)
	+ define p where "p \<equiv> \<lambda>n z. \<Prod>i<n. z - w i"
	+ define q where "q \<equiv> \<lambda>n. \<Prod>i<n. 1 + norm (w i)"
	+ define h where "h \<equiv> \<lambda>n \<epsilon> z. \<Sum>i<n. \<epsilon> i * p i z"
	+ define BALL where "BALL \<equiv> \<lambda>n \<epsilon>. ball (h n \<epsilon> (w n)) (norm (p n (w n)) / (fact n * q n))"
	+ \<comment> \<open>The demonimator above is the key to keeping the epsilons small\<close>
	+ define DD where "DD \<equiv> \<lambda>n \<epsilon>. D \<inter> BALL n \<epsilon> - {g n (w n)}"
	+ define dd where "dd \<equiv> \<lambda>n \<epsilon>. SOME x. x \<in> DD n \<epsilon>"
	+ have p0: "p n z = 0 \<longleftrightarrow> (\<exists>i<n. z = w i)" for z n
	+ unfolding p_def by force
	+ have [simp]: "p n (w i) = 0" if "i<n" for i n
	+ using that by (simp add: p0)
	+ have q_gt0: "0 < q n" for n
	+ unfolding q_def by (smt (verit) norm_not_less_zero prod_pos)
	+ have "DD n \<epsilon> \<noteq> {}" for n \<epsilon>
	+ proof -
	+ have "r > 0 \<Longrightarrow> infinite (D \<inter> ball z r)" for z r
	+ by (metis islimpt_UNIV limpt_of_closure islimpt_eq_infinite_ball cloD)
	+ then have "infinite (D \<inter> BALL n \<epsilon>)" for n \<epsilon>
	+ by (simp add: BALL_def p0 q_gt0)
	+ then show ?thesis
	+ by (metis DD_def finite.emptyI infinite_remove)
	+ qed
	+ then have dd_in_DD: "dd n \<epsilon> \<in> DD n \<epsilon>" for n \<epsilon>
	+ by (simp add: dd_def some_in_eq)
	+
	+ have h_cong: "h n \<epsilon> = h n \<epsilon>'" if "\<And>i. i<n \<Longrightarrow> \<epsilon> i = \<epsilon>' i" for n \<epsilon> \<epsilon>'
	+ using that by (simp add: h_def)
	+ have dd_cong: "dd n \<epsilon> = dd n \<epsilon>'" if "\<And>i. i<n \<Longrightarrow> \<epsilon> i = \<epsilon>' i" for n \<epsilon> \<epsilon>'
	+ using that by (metis dd_def DD_def BALL_def h_cong)
	+
	+ have [simp]: "h n (cut \<epsilon> less_than n) = h n \<epsilon>" for n \<epsilon>
	+ by (meson cut_apply h_cong less_than_iff)
	+ have [simp]: "dd n (cut \<epsilon> less_than n) = dd n \<epsilon>" for n \<epsilon>
	+ by (meson cut_apply dd_cong less_than_iff)
	+
	+ define coeff where "coeff \<equiv> wfrec less_than (\<lambda>\<epsilon> n. (dd n \<epsilon> - h n \<epsilon> (w n)) / p n (w n))"
	+ have coeff_eq: "coeff n = (dd n coeff - h n coeff (w n)) / p n (w n)" for n
	+ by (simp add: def_wfrec [OF coeff_def])
	+
	+ have norm_coeff: "norm (coeff n) < 1 / (fact n * q n)" for n
	+ using dd_in_DD [of n coeff]
	+ by (simp add: q_gt0 coeff_eq DD_def BALL_def dist_norm norm_minus_commute norm_divide divide_simps)
	+ have h_truncated: "h n coeff (w k) = h (Suc k) coeff (w k)" if "k < n" for n k
	+ proof -
	+ have "(\<Sum>i<n. coeff i * p i (w k)) = (\<Sum>i<Suc k. coeff i * p i (w k)) + (\<Sum>i=Suc k..<n. coeff i * p i (w k))"
	+ by (smt (verit) Suc_le_eq atLeast0LessThan le0 sum.atLeastLessThan_concat that)
	+ also have "\<dots> = (\<Sum>i<Suc k. coeff i * p i (w k))"
	+ by simp
	+ finally show ?thesis
	+ by (simp add: h_def)
	+ qed
	+ have norm_p_bound: "norm (p n z') \<le> q n * (1 + norm z) ^ n"
	+ if "dist z z' \<le> 1" for n z z'
	+ proof (induction n )
	+ case 0
	+ then show ?case
	+ by (auto simp: p_def q_def)
	+ next
	+ case (Suc n)
	+ have "norm z' - norm z \<le> 1"
	+ by (smt (verit) dist_norm norm_triangle_ineq3 that)
	+ then have \<section>: "norm (z' - w n) \<le> (1 + norm (w n)) * (1 + norm z)"
	+ by (simp add: mult.commute add_mono distrib_left norm_triangle_le_diff)
	+ have "norm (p n z') * norm (z' - w n) \<le> (q n * (1 + norm z) ^ n) * norm (z' - w n)"
	+ by (metis Suc mult.commute mult_left_mono norm_ge_zero)
	+ also have "\<dots> \<le> (q n * (1 + norm z) ^ n) * (1 + norm (w n)) * ((1 + norm z))"
	+ by (smt (verit) "\<section>" Suc mult.assoc mult_left_mono norm_ge_zero)
	+ also have "\<dots> \<le> q n * (1 + norm (w n)) * ((1 + norm z) * (1 + norm z) ^ n)"
	+ by (simp add: mult_ac)
	+ finally have "norm (p n z') * norm (z' - w n) \<le> q n * (1 + norm (w n)) * ((1 + norm z) * (1 + norm z) ^ n)" .
	+ with that show ?case
	+ by (auto simp: p_def q_def norm_mult simp del: fact_Suc)
	+ qed
	+
	+ show ?thesis
	+ proof
	+ define hh where "hh \<equiv> \<lambda>z. suminf (\<lambda>i. coeff i * p i z)"
	+ have "hh holomorphic_on UNIV"
	+ proof (rule holomorphic_uniform_sequence)
	+ fix n \<comment>\<open>Many thanks to Manuel Eberl for suggesting these approach\<close>
	+ show "h n coeff holomorphic_on UNIV"
	+ unfolding h_def p_def by (intro holomorphic_intros)
	+ next
	+ fix z
	+ have "uniform_limit (cball z 1) (\<lambda>n. h n coeff) hh sequentially"
	+ unfolding hh_def h_def
	+ proof (rule Weierstrass_m_test)
	+ let ?M = "\<lambda>n. (1 + norm z) ^ n / fact n"
	+ have "\<exists>N. \<forall>n\<ge>N. B \<le> (1 + real n) / (1 + norm z)" for B
	+ proof
	+ show "\<forall>n\<ge>nat \<lceil>B * (1 + norm z)\<rceil>. B \<le> (1 + real n) / (1 + norm z)"
	+ using norm_ge_zero [of z] by (auto simp: divide_simps simp del: norm_ge_zero)
	+ qed
	+ then have L: "liminf (\<lambda>n. ereal ((1 + real n) / (1 + norm z))) = \<infinity>"
	+ by (simp add: Lim_PInfty flip: liminf_PInfty)
	+ have "\<forall>\<^sub>F n in sequentially. 0 < (1 + cmod z) ^ n / fact n"
	+ using norm_ge_zero [of z] by (simp del: norm_ge_zero)
	+ then show "summable ?M"
	+ by (rule ratio_test_convergence) (auto simp: add_nonneg_eq_0_iff L)
	+ fix n z'
	+ assume "z' \<in> cball z 1"
	+ then have "norm (coeff n * p n z') \<le> norm (coeff n) * q n * (1 + norm z) ^ n"
	+ by (metis norm_p_bound norm_mult mem_cball mult.assoc mult_left_mono norm_ge_zero)
	+ also have "\<dots> \<le> (1 / fact n) * (1 + norm z) ^ n"
	+ proof (rule mult_right_mono)
	+ show "norm (coeff n) * q n \<le> 1 / fact n"
	+ by (metis divide_divide_eq_left less_divide_eq less_eq_real_def norm_coeff q_gt0)
	+ qed auto
	+ also have "\<dots> \<le> ?M n"
	+ by (simp add: divide_simps)
	+ finally show "norm (coeff n * p n z') \<le> ?M n" .
	+ qed
	+ then show "\<exists>d>0. cball z d \<subseteq> UNIV \<and> uniform_limit (cball z d) (\<lambda>n. h n coeff) hh sequentially"
	+ using zero_less_one by blast
	+ qed auto
	+ then show "hh analytic_on UNIV"
	+ by (simp add: analytic_on_open)
	+ have hh_eq_dd: "hh (w n) = dd n coeff" for n
	+ proof -
	+ have "hh (w n) = h (Suc n) coeff (w n)"
	+ unfolding hh_def h_def by (intro suminf_finite) auto
	+ also have "\<dots> = dd n coeff"
	+ by (induction n) (auto simp add: p0 h_def p_def coeff_eq [of "Suc _"] coeff_eq [of 0])
	+ finally show ?thesis .
	+ qed
	+ then have "hh (w n) \<in> D" for n
	+ using DD_def dd_in_DD by fastforce
	+ then show "inD \<gamma> hh"
	+ unfolding inD_def by (metis \<eta> bij_betw_iff_bijections comp_apply w_def)
	+ have "hh (w n) \<noteq> f (\<eta> n) (w n)" for n
	+ using DD_def dd_in_DD g_def hh_eq_dd by auto
	+ then show "\<forall>\<beta>\<in>elts \<gamma>. hh \<noteq> f \<beta>"
	+ by (metis \<eta> bij_betw_imp_surj_on imageE)
	+ qed
	+ qed
	+ with f show ?thesis
	+ using inj by (rule_tac x="h" in exI) (auto simp: \<Phi>_def inj_on_def)
	+ qed
	+ define G where "G \<equiv> \<lambda>f \<gamma>. @h. \<Phi> \<gamma> ((restrict f (elts \<gamma>))(\<gamma>:=h))"
	+ have nxt: "\<Phi> \<gamma> ((restrict f (elts \<gamma>))(\<gamma>:= G f \<gamma>))"
	+ if "\<gamma> \<in> elts (\<aleph>1)" "\<forall>\<beta> \<in> elts \<gamma>. \<Phi> \<beta> f" for f \<gamma>
	+ unfolding G_def using * [OF that] by (metis someI)
	+ have G_restr: "G (restrict f (elts \<gamma>)) \<gamma> = G f \<gamma>" if "\<gamma> \<in> elts (\<aleph>1)" for f \<gamma>
	+ by (auto simp: G_def)
	+ define f where "f \<equiv> transrec G"
	+ have \<Phi>f: "\<Phi> \<beta> f" if "\<beta> \<in> elts (\<aleph>1)" for \<beta>
	+ using that
	+ proof (induction \<beta> rule: eps_induct)
	+ case (step \<gamma>)
	+ then have *: "\<forall>\<beta>\<in>elts \<gamma>. \<Phi> \<beta> f"
	+ using Ord_\<omega>1 Ord_trans by blast
	+ have [simp]: "inj_on (\<lambda>\<beta>. G (restrict f (elts \<beta>)) \<beta>) (elts \<gamma>) \<longleftrightarrow> inj_on f (elts \<gamma>)"
	+ by (metis (no_types, lifting) f_def transrec inj_on_cong)
	+ have "f \<gamma> = G f \<gamma>"
	+ by (metis G_restr transrec f_def step.prems)
	+ with nxt [OF step.prems] * show ?case
	+ by (metis \<Phi>_def elts_succ fun_upd_same fun_upd_triv inj_on_restrict_eq restrict_upd)
	+ qed
	+ then have anf: "\<And>\<beta>. \<beta> \<in> elts (\<aleph>1) \<Longrightarrow> f \<beta> analytic_on UNIV"
	+ and inD: "\<And>\<alpha> \<beta>. \<lbrakk>\<beta> \<in> elts (\<aleph>1); \<alpha> \<in> elts \<beta>\<rbrakk> \<Longrightarrow> f \<beta> (\<zeta> \<alpha>) \<in> D"
	+ using \<Phi>_def inD_def by blast+
	+ have injf: "inj_on f (elts (\<aleph>1))"
	+ using \<Phi>f unfolding inj_on_def \<Phi>_def by (metis Ord_\<omega>1 Ord_in_Ord Ord_linear_le in_succ_iff)
	+ show ?thesis
	+ proof
	+ let ?F = "f ` elts (\<aleph>1)"
	+ have "countable ((\<lambda>f. f z) ` f ` elts \<omega>1)" for z
	+ proof -
	+ obtain \<alpha> where \<alpha>: "\<zeta> \<alpha> = z" "\<alpha> \<in> elts (\<aleph>1)" "Ord \<alpha>"
	+ by (meson Ord_\<omega>1 Ord_in_Ord UNIV_I \<zeta> bij_betw_iff_bijections)
	+ let ?B = "elts \<omega>1 - elts (succ \<alpha>)"
	+ have eq: "elts \<omega>1 = elts (succ \<alpha>) \<union> ?B"
	+ using \<alpha> by (metis Diff_partition Ord_\<omega>1 OrdmemD less_eq_V_def succ_le_iff)
	+ have "(\<lambda>f. f z) ` f ` ?B \<subseteq> D"
	+ using \<alpha> inD by clarsimp (meson Ord_\<omega>1 Ord_in_Ord Ord_linear)
	+ then have "countable ((\<lambda>f. f z) ` f ` ?B)"
	+ by (meson \<open>countable D\<close> countable_subset)
	+ moreover have "countable ((\<lambda>f. f z) ` f ` elts (succ \<alpha>))"
	+ by (simp add: \<alpha> less_\<omega>1_imp_countable)
	+ ultimately show ?thesis
	+ using eq by (metis countable_Un_iff image_Un)
	+ qed
	+ then show "Wetzel ?F"
	+ unfolding Wetzel_def by (blast intro: anf)
	+ show "uncountable ?F"
	+ using Ord_\<omega>1 countable_iff_less_\<omega>1 countable_image_inj_eq injf by blast
	+ qed
	+qed
	+
	+theorem Erdos_Wetzel: "C_continuum = \<aleph>1 \<longleftrightarrow> (\<exists>F. Wetzel F \<and> uncountable F)"
	+ by (metis C_continuum_ge Erdos_Wetzel_CH Erdos_Wetzel_nonCH TC_small less_V_def)
	+
	+text \<open>The originally submitted version of this theory included the development of cardinals
	+for general Isabelle/HOL sets (as opposed to ZF sets, elements of type V), as well as other
	+generally useful library material. From March 2022, that material has been moved to
	+the analysis libraries or to @{theory ZFC_in_HOL.General_Cardinals}, as appropriate.\<close>
	+
	+end
	diff --git a/thys/Wetzels_Problem/document/root.bib b/thys/Wetzels_Problem/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Wetzels_Problem/document/root.bib
	@@ -0,0 +1,35 @@
	+%% This BibTeX bibliography file was created using BibDesk.
	+%% http://bibdesk.sourceforge.net/
	+
	+
	+%% Created for Larry Paulson at 2022-01-28 15:00:12 +0000
	+
	+
	+%% Saved with string encoding Unicode (UTF-8)
	+
	+
	+
	+@article{cunningham-youngs,
	+ author = {F. Cunningham and Nathaniel Grossman},
	+ date-added = {2022-01-28 14:56:42 +0000},
	+ date-modified = {2022-01-28 15:00:12 +0000},
	+ issn = {00029890, 19300972},
	+ journal = {The American Mathematical Monthly},
	+ number = {7},
	+ pages = {781-783},
	+ publisher = {Mathematical Association of America},
	+ title = {On {Young's} Inequality},
	+ url = {http://www.jstor.org/stable/2318018},
	+ volume = {78},
	+ year = {1971},
	+ bdsk-url-1 = {http://www.jstor.org/stable/2318018}}
	+
	+@book{aigner-proofs,
	+ author = {M. Aigner and G. M. Ziegler},
	+ booktitle = {Proofs from THE BOOK},
	+ date-added = {2022-01-06 11:42:58 +0000},
	+ date-modified = {2022-01-06 13:07:25 +0000},
	+ edition = {6th},
	+ publisher = {Springer},
	+ title = {Proofs from THE BOOK},
	+ year = {2018}}
	diff --git a/thys/Wetzels_Problem/document/root.tex b/thys/Wetzels_Problem/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Wetzels_Problem/document/root.tex
	@@ -0,0 +1,51 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\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{Wetzel's Problem and the Continuum Hypothesis}
	+\author{Lawrence C. Paulson}
	+\maketitle
	+
	+\begin{abstract}
	+Let $F$ be a set of analytic functions on the complex plane such that,
	+for each $z\in\mathbb{C}$, the set $\{f(z) \mid f\in F\}$ is countable;
	+must then $F$ itself be countable?
	+The answer is yes if the Continuum Hypothesis is false, i.e.,
	+if the cardinality of $\mathbb{R}$ exceeds $\aleph_1$.
	+But if CH is true then such an $F$, of cardinality $\aleph_1$,
	+can be constructed by transfinite recursion.
	+
	+The formal proof illustrates reasoning about complex
	+analysis (analytic and homomorphic functions) and set theory
	+(transfinite cardinalities) in a single setting.
	+The mathematical text comes from \emph{Proofs from THE BOOK}~\cite[pp.\thinspace137--8]{aigner-proofs}, by Aigner and Ziegler.
	+\end{abstract}
	+
	+\newpage
	+\tableofcontents
	+
	+\paragraph*{Acknowledgements}
	+The author was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178) funded by the European Research Council.
	+Thanks also to Manuel Eberl for advice on proving a function to be holomorphic.
	+
	+\newpage
	+
	+% include generated text of all theories
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/Word_Lib/Ancient_Numeral.thy b/thys/Word_Lib/Ancient_Numeral.thy
	deleted file mode 100644
	--- a/thys/Word_Lib/Ancient_Numeral.thy
	+++ /dev/null
	@@ -1,237 +0,0 @@
	-(*
	- * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
	- *
	- * SPDX-License-Identifier: BSD-2-Clause
	- *)
	-
	-theory Ancient_Numeral
	- imports Main Reversed_Bit_Lists Legacy_Aliases
	-begin
	-
	-definition Bit :: "int \<Rightarrow> bool \<Rightarrow> int" (infixl "BIT" 90)
	- where "k BIT b = (if b then 1 else 0) + k + k"
	-
	-lemma Bit_B0: "k BIT False = k + k"
	- by (simp add: Bit_def)
	-
	-lemma Bit_B1: "k BIT True = k + k + 1"
	- by (simp add: Bit_def)
	-
	-lemma Bit_B0_2t: "k BIT False = 2 * k"
	- by (rule trans, rule Bit_B0) simp
	-
	-lemma Bit_B1_2t: "k BIT True = 2 * k + 1"
	- by (rule trans, rule Bit_B1) simp
	-
	-lemma uminus_Bit_eq:
	- "- k BIT b = (- k - of_bool b) BIT b"
	- by (cases b) (simp_all add: Bit_def)
	-
	-lemma power_BIT: "2 ^ Suc n - 1 = (2 ^ n - 1) BIT True"
	- by (simp add: Bit_B1)
	-
	-lemma bin_rl_simp [simp]: "bin_rest w BIT bin_last w = w"
	- by (simp add: Bit_def)
	-
	-lemma bin_rest_BIT [simp]: "bin_rest (x BIT b) = x"
	- by (simp add: Bit_def)
	-
	-lemma even_BIT [simp]: "even (x BIT b) \<longleftrightarrow> \<not> b"
	- by (simp add: Bit_def)
	-
	-lemma bin_last_BIT [simp]: "bin_last (x BIT b) = b"
	- by simp
	-
	-lemma BIT_eq_iff [iff]: "u BIT b = v BIT c \<longleftrightarrow> u = v \<and> b = c"
	- by (auto simp: Bit_def) arith+
	-
	-lemma BIT_bin_simps [simp]:
	- "numeral k BIT False = numeral (Num.Bit0 k)"
	- "numeral k BIT True = numeral (Num.Bit1 k)"
	- "(- numeral k) BIT False = - numeral (Num.Bit0 k)"
	- "(- numeral k) BIT True = - numeral (Num.BitM k)"
	- by (simp_all only: Bit_B0 Bit_B1 numeral.simps numeral_BitM)
	-
	-lemma BIT_special_simps [simp]:
	- shows "0 BIT False = 0"
	- and "0 BIT True = 1"
	- and "1 BIT False = 2"
	- and "1 BIT True = 3"
	- and "(- 1) BIT False = - 2"
	- and "(- 1) BIT True = - 1"
	- by (simp_all add: Bit_def)
	-
	-lemma Bit_eq_0_iff: "w BIT b = 0 \<longleftrightarrow> w = 0 \<and> \<not> b"
	- by (auto simp: Bit_def) arith
	-
	-lemma Bit_eq_m1_iff: "w BIT b = -1 \<longleftrightarrow> w = -1 \<and> b"
	- by (auto simp: Bit_def) arith
	-
	-lemma expand_BIT:
	- "numeral (Num.Bit0 w) = numeral w BIT False"
	- "numeral (Num.Bit1 w) = numeral w BIT True"
	- "- numeral (Num.Bit0 w) = (- numeral w) BIT False"
	- "- numeral (Num.Bit1 w) = (- numeral (w + Num.One)) BIT True"
	- by (simp_all add: BitM_inc_eq add_One)
	-
	-lemma less_Bits: "v BIT b < w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> \<not> b \<and> c"
	- by (auto simp: Bit_def)
	-
	-lemma le_Bits: "v BIT b \<le> w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> (\<not> b \<or> c)"
	- by (auto simp: Bit_def)
	-
	-lemma pred_BIT_simps [simp]:
	- "x BIT False - 1 = (x - 1) BIT True"
	- "x BIT True - 1 = x BIT False"
	- by (simp_all add: Bit_B0_2t Bit_B1_2t)
	-
	-lemma succ_BIT_simps [simp]:
	- "x BIT False + 1 = x BIT True"
	- "x BIT True + 1 = (x + 1) BIT False"
	- by (simp_all add: Bit_B0_2t Bit_B1_2t)
	-
	-lemma add_BIT_simps [simp]:
	- "x BIT False + y BIT False = (x + y) BIT False"
	- "x BIT False + y BIT True = (x + y) BIT True"
	- "x BIT True + y BIT False = (x + y) BIT True"
	- "x BIT True + y BIT True = (x + y + 1) BIT False"
	- by (simp_all add: Bit_B0_2t Bit_B1_2t)
	-
	-lemma mult_BIT_simps [simp]:
	- "x BIT False * y = (x * y) BIT False"
	- "x * y BIT False = (x * y) BIT False"
	- "x BIT True * y = (x * y) BIT False + y"
	- by (simp_all add: Bit_B0_2t Bit_B1_2t algebra_simps)
	-
	-lemma B_mod_2': "X = 2 \<Longrightarrow> (w BIT True) mod X = 1 \<and> (w BIT False) mod X = 0"
	- by (simp add: Bit_B0 Bit_B1)
	-
	-lemma bin_ex_rl: "\<exists>w b. w BIT b = bin"
	- by (metis bin_rl_simp)
	-
	-lemma bin_exhaust: "(\<And>x b. bin = x BIT b \<Longrightarrow> Q) \<Longrightarrow> Q"
	-by (metis bin_ex_rl)
	-
	-lemma bin_abs_lem: "bin = (w BIT b) \<Longrightarrow> bin \<noteq> -1 \<longrightarrow> bin \<noteq> 0 \<longrightarrow> nat \<bar>w\<bar> < nat \<bar>bin\<bar>"
	- apply clarsimp
	- apply (unfold Bit_def)
	- apply (cases b)
	- apply (clarsimp, arith)
	- apply (clarsimp, arith)
	- done
	-
	-lemma bin_induct:
	- assumes PPls: "P 0"
	- and PMin: "P (- 1)"
	- and PBit: "\<And>bin bit. P bin \<Longrightarrow> P (bin BIT bit)"
	- shows "P bin"
	- apply (rule_tac P=P and a=bin and f1="nat \<circ> abs" in wf_measure [THEN wf_induct])
	- apply (simp add: measure_def inv_image_def)
	- apply (case_tac x rule: bin_exhaust)
	- apply (frule bin_abs_lem)
	- apply (auto simp add : PPls PMin PBit)
	- done
	-
	-lemma Bit_div2: "(w BIT b) div 2 = w"
	- by (fact bin_rest_BIT)
	-
	-lemma twice_conv_BIT: "2 * x = x BIT False"
	- by (simp add: Bit_def)
	-
	-lemma BIT_lt0 [simp]: "x BIT b < 0 \<longleftrightarrow> x < 0"
	-by(cases b)(auto simp add: Bit_def)
	-
	-lemma BIT_ge0 [simp]: "x BIT b \<ge> 0 \<longleftrightarrow> x \<ge> 0"
	-by(cases b)(auto simp add: Bit_def)
	-
	-lemma bin_to_bl_aux_Bit_minus_simp [simp]:
	- "0 < n \<Longrightarrow> bin_to_bl_aux n (w BIT b) bl = bin_to_bl_aux (n - 1) w (b # bl)"
	- by (cases n) auto
	-
	-lemma bl_to_bin_BIT:
	- "bl_to_bin bs BIT b = bl_to_bin (bs @ [b])"
	- by (simp add: bl_to_bin_append Bit_def)
	-
	-lemma bin_nth_0_BIT: "bin_nth (w BIT b) 0 \<longleftrightarrow> b"
	- by simp
	-
	-lemma bin_nth_Suc_BIT: "bin_nth (w BIT b) (Suc n) = bin_nth w n"
	- by (simp add: bit_Suc)
	-
	-lemma bin_nth_minus [simp]: "0 < n \<Longrightarrow> bin_nth (w BIT b) n = bin_nth w (n - 1)"
	- by (cases n) (simp_all add: bit_Suc)
	-
	-lemma bin_sign_simps [simp]:
	- "bin_sign (w BIT b) = bin_sign w"
	- by (simp add: bin_sign_def Bit_def)
	-
	-lemma bin_nth_Bit: "bin_nth (w BIT b) n \<longleftrightarrow> n = 0 \<and> b \<or> (\<exists>m. n = Suc m \<and> bin_nth w m)"
	- by (cases n) auto
	-
	-lemmas sbintrunc_Suc_BIT [simp] =
	- signed_take_bit_Suc [where a="w BIT b", simplified bin_last_BIT bin_rest_BIT] for w b
	-
	-lemmas sbintrunc_0_BIT_B0 [simp] =
	- signed_take_bit_0 [where a="w BIT False", simplified bin_last_numeral_simps bin_rest_numeral_simps]
	- for w
	-
	-lemmas sbintrunc_0_BIT_B1 [simp] =
	- signed_take_bit_0 [where a="w BIT True", simplified bin_last_BIT bin_rest_numeral_simps]
	- for w
	-
	-lemma sbintrunc_Suc_minus_Is:
	- \<open>0 < n \<Longrightarrow>
	- sbintrunc (n - 1) w = y \<Longrightarrow>
	- sbintrunc n (w BIT b) = y BIT b\<close>
	- by (cases n) (simp_all add: Bit_def signed_take_bit_Suc)
	-
	-lemma bin_cat_Suc_Bit: "bin_cat w (Suc n) (v BIT b) = bin_cat w n v BIT b"
	- by (auto simp add: Bit_def concat_bit_Suc)
	-
	-context
	- includes bit_operations_syntax
	-begin
	-
	-lemma int_not_BIT [simp]: "NOT (w BIT b) = (NOT w) BIT (\<not> b)"
	- by (simp add: not_int_def Bit_def)
	-
	-lemma int_and_Bits [simp]: "(x BIT b) AND (y BIT c) = (x AND y) BIT (b \<and> c)"
	- using and_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)
	-
	-lemma int_or_Bits [simp]: "(x BIT b) OR (y BIT c) = (x OR y) BIT (b \<or> c)"
	- using or_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)
	-
	-lemma int_xor_Bits [simp]: "(x BIT b) XOR (y BIT c) = (x XOR y) BIT ((b \<or> c) \<and> \<not> (b \<and> c))"
	- using xor_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)
	-
	-end
	-
	-lemma mod_BIT:
	- "bin BIT bit mod 2 ^ Suc n = (bin mod 2 ^ n) BIT bit" for bit
	-proof -
	- have "2 * (bin mod 2 ^ n) + 1 = (2 * bin mod 2 ^ Suc n) + 1"
	- by (simp add: mod_mult_mult1)
	- also have "\<dots> = ((2 * bin mod 2 ^ Suc n) + 1) mod 2 ^ Suc n"
	- by (simp add: ac_simps pos_zmod_mult_2)
	- also have "\<dots> = (2 * bin + 1) mod 2 ^ Suc n"
	- by (simp only: mod_simps)
	- finally show ?thesis
	- by (auto simp add: Bit_def)
	-qed
	-
	-lemma minus_BIT_0: fixes x y :: int shows "x BIT b - y BIT False = (x - y) BIT b"
	-by(simp add: Bit_def)
	-
	-lemma int_lsb_BIT [simp]: fixes x :: int shows
	- "lsb (x BIT b) \<longleftrightarrow> b"
	-by(simp add: lsb_int_def)
	-
	-lemma int_shiftr_BIT [simp]: fixes x :: int
	- shows int_shiftr0: "drop_bit 0 x = x"
	- and int_shiftr_Suc: "drop_bit (Suc n) (x BIT b) = drop_bit n x"
	- by (simp_all add: drop_bit_Suc)
	-
	-lemma msb_BIT [simp]: "msb (x BIT b) = msb x"
	-by(simp add: msb_int_def)
	-
	-end
	\ No newline at end of file
	diff --git a/thys/Word_Lib/Bit_Comprehension.thy b/thys/Word_Lib/Bit_Comprehension.thy
	--- a/thys/Word_Lib/Bit_Comprehension.thy
	+++ b/thys/Word_Lib/Bit_Comprehension.thy
	@@ -1,251 +1,251 @@
	(*
	* Copyright Brian Huffman, PSU; Jeremy Dawson and Gerwin Klein, NICTA
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	section \<open>Comprehension syntax for bit expressions\<close>

	theory Bit_Comprehension
	imports
	"HOL-Library.Word"
	begin

	class bit_comprehension = ring_bit_operations +
	fixes set_bits :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> 'a\<close> (binder \<open>BITS \<close> 10)
	assumes set_bits_bit_eq: \<open>set_bits (bit a) = a\<close>
	begin

	lemma set_bits_False_eq [simp]:
	\<open>(BITS _. False) = 0\<close>
	using set_bits_bit_eq [of 0] by (simp add: bot_fun_def)

	end

	instantiation int :: bit_comprehension
	begin

	definition
	\<open>set_bits f = (
	if \<exists>n. \<forall>m\<ge>n. f m = f n then
	let n = LEAST n. \<forall>m\<ge>n. f m = f n
	in signed_take_bit n (horner_sum of_bool 2 (map f [0..<Suc n]))
	else 0 :: int)\<close>

	instance proof
	fix k :: int
	from int_bit_bound [of k]
	obtain n where *: \<open>\<And>m. n \<le> m \<Longrightarrow> bit k m \<longleftrightarrow> bit k n\<close>
	and **: \<open>n > 0 \<Longrightarrow> bit k (n - 1) \<noteq> bit k n\<close>
	by blast
	then have ***: \<open>\<exists>n. \<forall>n'\<ge>n. bit k n' \<longleftrightarrow> bit k n\<close>
	by meson
	have l: \<open>(LEAST q. \<forall>m\<ge>q. bit k m \<longleftrightarrow> bit k q) = n\<close>
	apply (rule Least_equality)
	using * apply blast
	apply (metis "**" One_nat_def Suc_pred le_cases le0 neq0_conv not_less_eq_eq)
	done
	show \<open>set_bits (bit k) = k\<close>
	apply (simp only: *** set_bits_int_def horner_sum_bit_eq_take_bit l)
	apply simp
	apply (rule bit_eqI)
	apply (simp add: bit_signed_take_bit_iff min_def)
	apply (auto simp add: not_le bit_take_bit_iff dest: *)
	done
	qed

	end

	lemma int_set_bits_K_False [simp]: "(BITS _. False) = (0 :: int)"
	by (simp add: set_bits_int_def)

	lemma int_set_bits_K_True [simp]: "(BITS _. True) = (-1 :: int)"
	by (simp add: set_bits_int_def)

	instantiation word :: (len) bit_comprehension
	begin

	definition word_set_bits_def:
	\<open>(BITS n. P n) = (horner_sum of_bool 2 (map P [0..<LENGTH('a)]) :: 'a word)\<close>

	instance by standard
	(simp add: word_set_bits_def horner_sum_bit_eq_take_bit)

	end

	lemma bit_set_bits_word_iff [bit_simps]:
	\<open>bit (set_bits P :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a) \<and> P n\<close>
	by (auto simp add: word_set_bits_def bit_horner_sum_bit_word_iff)

	lemma set_bits_K_False [simp]:
	\<open>set_bits (\<lambda>_. False) = (0 :: 'a :: len word)\<close>
	by (rule bit_word_eqI) (simp add: bit_set_bits_word_iff)

	lemma set_bits_int_unfold':
	\<open>set_bits f =
	(if \<exists>n. \<forall>n'\<ge>n. \<not> f n' then
	let n = LEAST n. \<forall>n'\<ge>n. \<not> f n'
	in horner_sum of_bool 2 (map f [0..<n])
	else if \<exists>n. \<forall>n'\<ge>n. f n' then
	let n = LEAST n. \<forall>n'\<ge>n. f n'
	in signed_take_bit n (horner_sum of_bool 2 (map f [0..<n] @ [True]))
	else 0 :: int)\<close>
	proof (cases \<open>\<exists>n. \<forall>m\<ge>n. f m \<longleftrightarrow> f n\<close>)
	case True
	then obtain q where q: \<open>\<forall>m\<ge>q. f m \<longleftrightarrow> f q\<close>
	by blast
	define n where \<open>n = (LEAST n. \<forall>m\<ge>n. f m \<longleftrightarrow> f n)\<close>
	have \<open>\<forall>m\<ge>n. f m \<longleftrightarrow> f n\<close>
	unfolding n_def
	using q by (rule LeastI [of _ q])
	then have n: \<open>\<And>m. n \<le> m \<Longrightarrow> f m \<longleftrightarrow> f n\<close>
	by blast
	from n_def have n_eq: \<open>(LEAST q. \<forall>m\<ge>q. f m \<longleftrightarrow> f n) = n\<close>
	by (smt (verit, best) Least_le \<open>\<forall>m\<ge>n. f m = f n\<close> dual_order.antisym wellorder_Least_lemma(1))
	show ?thesis
	proof (cases \<open>f n\<close>)
	case False
	with n have *: \<open>\<exists>n. \<forall>n'\<ge>n. \<not> f n'\<close>
	by blast
	have **: \<open>(LEAST n. \<forall>n'\<ge>n. \<not> f n') = n\<close>
	using False n_eq by simp
	from * False show ?thesis
	apply (simp add: set_bits_int_def n_def [symmetric] ** del: upt.upt_Suc)
	apply (auto simp add: take_bit_horner_sum_bit_eq
	bit_horner_sum_bit_iff take_map
	signed_take_bit_def set_bits_int_def
	horner_sum_bit_eq_take_bit simp del: upt.upt_Suc)
	done
	next
	case True
	with n have *: \<open>\<exists>n. \<forall>n'\<ge>n. f n'\<close>
	by blast
	have ***: \<open>\<not> (\<exists>n. \<forall>n'\<ge>n. \<not> f n')\<close>
	apply (rule ccontr)
	using * nat_le_linear by auto
	have **: \<open>(LEAST n. \<forall>n'\<ge>n. f n') = n\<close>
	using True n_eq by simp
	from * *** True show ?thesis
	apply (simp add: set_bits_int_def n_def [symmetric] ** del: upt.upt_Suc)
	apply (auto simp add: take_bit_horner_sum_bit_eq
	bit_horner_sum_bit_iff take_map
	signed_take_bit_def set_bits_int_def
	horner_sum_bit_eq_take_bit nth_append simp del: upt.upt_Suc)
	done
	qed
	next
	case False
	then show ?thesis
	by (auto simp add: set_bits_int_def)
	qed

	inductive wf_set_bits_int :: "(nat \<Rightarrow> bool) \<Rightarrow> bool"
	for f :: "nat \<Rightarrow> bool"
	where
	zeros: "\<forall>n' \<ge> n. \<not> f n' \<Longrightarrow> wf_set_bits_int f"
	\| ones: "\<forall>n' \<ge> n. f n' \<Longrightarrow> wf_set_bits_int f"

	lemma wf_set_bits_int_simps: "wf_set_bits_int f \<longleftrightarrow> (\<exists>n. (\<forall>n'\<ge>n. \<not> f n') \<or> (\<forall>n'\<ge>n. f n'))"
	by(auto simp add: wf_set_bits_int.simps)

	lemma wf_set_bits_int_const [simp]: "wf_set_bits_int (\<lambda>_. b)"
	by(cases b)(auto intro: wf_set_bits_int.intros)

	lemma wf_set_bits_int_fun_upd [simp]:
	"wf_set_bits_int (f(n := b)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
	proof
	assume ?lhs
	then obtain n'
	where "(\<forall>n''\<ge>n'. \<not> (f(n := b)) n'') \<or> (\<forall>n''\<ge>n'. (f(n := b)) n'')"
	by(auto simp add: wf_set_bits_int_simps)
	hence "(\<forall>n''\<ge>max (Suc n) n'. \<not> f n'') \<or> (\<forall>n''\<ge>max (Suc n) n'. f n'')" by auto
	thus ?rhs by(auto simp only: wf_set_bits_int_simps)
	next
	assume ?rhs
	then obtain n' where "(\<forall>n''\<ge>n'. \<not> f n'') \<or> (\<forall>n''\<ge>n'. f n'')" (is "?wf f n'")
	by(auto simp add: wf_set_bits_int_simps)
	hence "?wf (f(n := b)) (max (Suc n) n')" by auto
	thus ?lhs by(auto simp only: wf_set_bits_int_simps)
	qed

	lemma wf_set_bits_int_Suc [simp]:
	"wf_set_bits_int (\<lambda>n. f (Suc n)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
	by(auto simp add: wf_set_bits_int_simps intro: le_SucI dest: Suc_le_D)

	context
	fixes f
	assumes wff: "wf_set_bits_int f"
	begin

	lemma int_set_bits_unfold_BIT:
	"set_bits f = of_bool (f 0) + (2 :: int) * set_bits (f \<circ> Suc)"
	using wff proof cases
	case (zeros n)
	show ?thesis
	proof(cases "\<forall>n. \<not> f n")
	case True
	hence "f = (\<lambda>_. False)" by auto
	thus ?thesis using True by(simp add: o_def)
	next
	case False
	then obtain n' where "f n'" by blast
	with zeros have "(LEAST n. \<forall>n'\<ge>n. \<not> f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. \<not> f n')"
	by(auto intro: Least_Suc)
	also have "(\<lambda>n. \<forall>n'\<ge>Suc n. \<not> f n') = (\<lambda>n. \<forall>n'\<ge>n. \<not> f (Suc n'))" by(auto dest: Suc_le_D)
	also from zeros have "\<forall>n'\<ge>n. \<not> f (Suc n')" by auto
	ultimately show ?thesis using zeros
	apply (simp (no_asm_simp) add: set_bits_int_unfold' exI
	del: upt.upt_Suc flip: map_map split del: if_split)
	apply (simp only: map_Suc_upt upt_conv_Cons)
	apply simp
	done
	qed
	next
	case (ones n)
	show ?thesis
	proof(cases "\<forall>n. f n")
	case True
	hence "f = (\<lambda>_. True)" by auto
	thus ?thesis using True by(simp add: o_def)
	next
	case False
	then obtain n' where "\<not> f n'" by blast
	with ones have "(LEAST n. \<forall>n'\<ge>n. f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. f n')"
	by(auto intro: Least_Suc)
	also have "(\<lambda>n. \<forall>n'\<ge>Suc n. f n') = (\<lambda>n. \<forall>n'\<ge>n. f (Suc n'))" by(auto dest: Suc_le_D)
	also from ones have "\<forall>n'\<ge>n. f (Suc n')" by auto
	moreover from ones have "(\<exists>n. \<forall>n'\<ge>n. \<not> f n') = False"
	by(auto intro!: exI[where x="max n m" for n m] simp add: max_def split: if_split_asm)
	moreover hence "(\<exists>n. \<forall>n'\<ge>n. \<not> f (Suc n')) = False"
	by(auto elim: allE[where x="Suc n" for n] dest: Suc_le_D)
	ultimately show ?thesis using ones
	apply (simp (no_asm_simp) add: set_bits_int_unfold' exI split del: if_split)
	apply (auto simp add: Let_def hd_map map_tl[symmetric] map_map[symmetric] map_Suc_upt upt_conv_Cons signed_take_bit_Suc
	not_le simp del: map_map)
	done
	qed
	qed

	lemma bin_last_set_bits [simp]:
	"odd (set_bits f :: int) = f 0"
	by (subst int_set_bits_unfold_BIT) simp_all

	lemma bin_rest_set_bits [simp]:
	"set_bits f div (2 :: int) = set_bits (f \<circ> Suc)"
	by (subst int_set_bits_unfold_BIT) simp_all

	lemma bin_nth_set_bits [simp]:
	"bit (set_bits f :: int) m \<longleftrightarrow> f m"
	using wff proof (induction m arbitrary: f)
	case 0
	then show ?case
	- by (simp add: Bit_Comprehension.bin_last_set_bits)
	+ by (simp add: Bit_Comprehension.bin_last_set_bits bit_0)
	next
	case Suc
	from Suc.IH [of "f \<circ> Suc"] Suc.prems show ?case
	by (simp add: Bit_Comprehension.bin_rest_set_bits comp_def bit_Suc)
	qed

	end

	end
	diff --git a/thys/Word_Lib/Bits_Int.thy b/thys/Word_Lib/Bits_Int.thy
	--- a/thys/Word_Lib/Bits_Int.thy
	+++ b/thys/Word_Lib/Bits_Int.thy
	@@ -1,1572 +1,1558 @@
	(*
	* Copyright Brian Huffman, PSU; Jeremy Dawson and Gerwin Klein, NICTA
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	section \<open>Bitwise Operations on integers\<close>

	theory Bits_Int
	imports
	"Word_Lib.Most_significant_bit"
	"Word_Lib.Least_significant_bit"
	"Word_Lib.Generic_set_bit"
	"Word_Lib.Bit_Comprehension"
	begin

	subsection \<open>Implicit bit representation of \<^typ>\<open>int\<close>\<close>

	lemma bin_last_def:
	"(odd :: int \<Rightarrow> bool) w \<longleftrightarrow> w mod 2 = 1"
	by (fact odd_iff_mod_2_eq_one)

	lemma bin_last_numeral_simps [simp]:
	"\<not> odd (0 :: int)"
	"odd (1 :: int)"
	"odd (- 1 :: int)"
	"odd (Numeral1 :: int)"
	"\<not> odd (numeral (Num.Bit0 w) :: int)"
	"odd (numeral (Num.Bit1 w) :: int)"
	"\<not> odd (- numeral (Num.Bit0 w) :: int)"
	"odd (- numeral (Num.Bit1 w) :: int)"
	by simp_all

	lemma bin_rest_numeral_simps [simp]:
	"(\<lambda>k::int. k div 2) 0 = 0"
	"(\<lambda>k::int. k div 2) 1 = 0"
	"(\<lambda>k::int. k div 2) (- 1) = - 1"
	"(\<lambda>k::int. k div 2) Numeral1 = 0"
	"(\<lambda>k::int. k div 2) (numeral (Num.Bit0 w)) = numeral w"
	"(\<lambda>k::int. k div 2) (numeral (Num.Bit1 w)) = numeral w"
	"(\<lambda>k::int. k div 2) (- numeral (Num.Bit0 w)) = - numeral w"
	"(\<lambda>k::int. k div 2) (- numeral (Num.Bit1 w)) = - numeral (w + Num.One)"
	by simp_all

	lemma bin_rl_eqI: "\<lbrakk>(\<lambda>k::int. k div 2) x = (\<lambda>k::int. k div 2) y; odd x = odd y\<rbrakk> \<Longrightarrow> x = y"
	by (auto elim: oddE)

	lemma [simp]:
	shows bin_rest_lt0: "(\<lambda>k::int. k div 2) i < 0 \<longleftrightarrow> i < 0"
	and bin_rest_ge_0: "(\<lambda>k::int. k div 2) i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
	by auto

	lemma bin_rest_gt_0 [simp]: "(\<lambda>k::int. k div 2) x > 0 \<longleftrightarrow> x > 1"
	by auto


	subsection \<open>Bit projection\<close>

	lemma bin_nth_eq_iff: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) x = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y \<longleftrightarrow> x = y"
	by (simp add: bit_eq_iff fun_eq_iff)

	lemma bin_eqI:
	"x = y" if "\<And>n. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
	using that by (rule bit_eqI)

	lemma bin_eq_iff: "x = y \<longleftrightarrow> (\<forall>n. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n)"
	by (metis bit_eq_iff)

	lemma bin_nth_zero [simp]: "\<not> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) 0 n"
	by simp

	lemma bin_nth_1 [simp]: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) 1 n \<longleftrightarrow> n = 0"
	by (cases n) (simp_all add: bit_Suc)

	lemma bin_nth_minus1 [simp]: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (- 1) n"
	by simp

	lemma bin_nth_numeral: "(\<lambda>k::int. k div 2) x = y \<Longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (numeral n) = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y (pred_numeral n)"
	by (simp add: numeral_eq_Suc bit_Suc)

	lemmas bin_nth_numeral_simps [simp] =
	bin_nth_numeral [OF bin_rest_numeral_simps(8)]

	lemmas bin_nth_simps =
	bit_0 bit_Suc bin_nth_zero bin_nth_minus1
	bin_nth_numeral_simps

	lemma nth_2p_bin: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (2 ^ n) m = (m = n)" \<comment> \<open>for use when simplifying with \<open>bin_nth_Bit\<close>\<close>
	by (auto simp add: bit_exp_iff)

	lemma nth_rest_power_bin: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (((\<lambda>k::int. k div 2) ^^ k) w) n = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w (n + k)"
	apply (induct k arbitrary: n)
	apply clarsimp
	apply clarsimp
	apply (simp only: bit_Suc [symmetric] add_Suc)
	done

	lemma bin_nth_numeral_unfold:
	"(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (num.Bit0 x)) n \<longleftrightarrow> n > 0 \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral x) (n - 1)"
	"(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (num.Bit1 x)) n \<longleftrightarrow> (n > 0 \<longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral x) (n - 1))"
	by (cases n; simp)+


	subsection \<open>Truncating\<close>

	definition bin_sign :: "int \<Rightarrow> int"
	where "bin_sign k = (if k \<ge> 0 then 0 else - 1)"

	lemma bin_sign_simps [simp]:
	"bin_sign 0 = 0"
	"bin_sign 1 = 0"
	"bin_sign (- 1) = - 1"
	"bin_sign (numeral k) = 0"
	"bin_sign (- numeral k) = -1"
	by (simp_all add: bin_sign_def)

	lemma bin_sign_rest [simp]: "bin_sign ((\<lambda>k::int. k div 2) w) = bin_sign w"
	by (simp add: bin_sign_def)

	lemma bintrunc_mod2p: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w = w mod 2 ^ n"
	by (fact take_bit_eq_mod)

	lemma sbintrunc_mod2p: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w = (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n"
	by (simp add: bintrunc_mod2p signed_take_bit_eq_take_bit_shift)

	lemma sbintrunc_eq_take_bit:
	\<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k = take_bit (Suc n) (k + 2 ^ n) - 2 ^ n\<close>
	by (fact signed_take_bit_eq_take_bit_shift)

	lemma sign_bintr: "bin_sign ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = 0"
	by (simp add: bin_sign_def)

	lemma bintrunc_n_0: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 0"
	by (fact take_bit_of_0)

	lemma sbintrunc_n_0: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 0"
	by (fact signed_take_bit_of_0)

	lemma sbintrunc_n_minus1: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = -1"
	by (fact signed_take_bit_of_minus_1)

	lemma bintrunc_Suc_numeral:
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) 1 = 1"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- 1) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit0 w)) = 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit0 w)) = 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral w)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral (w + Num.One))"
	by (simp_all add: take_bit_Suc del: take_bit_minus_one_eq_mask)

	lemma sbintrunc_0_numeral [simp]:
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 1 = -1"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (numeral (Num.Bit0 w)) = 0"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (numeral (Num.Bit1 w)) = -1"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (- numeral (Num.Bit0 w)) = 0"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (- numeral (Num.Bit1 w)) = -1"
	by simp_all

	lemma sbintrunc_Suc_numeral:
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) 1 = 1"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit0 w)) = 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit0 w)) = 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral w)"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral (w + Num.One))"
	by (simp_all add: signed_take_bit_Suc)

	lemma bin_sign_lem: "(bin_sign ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = -1) = bit bin n"
	by (simp add: bin_sign_def)

	lemma nth_bintr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) n \<longleftrightarrow> n < m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n"
	by (fact bit_take_bit_iff)

	lemma nth_sbintr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) n = (if n < m then (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w m)"
	by (simp add: bit_signed_take_bit_iff min_def)

	lemma bin_nth_Bit0:
	"(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (Num.Bit0 w)) n \<longleftrightarrow>
	(\<exists>m. n = Suc m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral w) m)"
	using bit_double_iff [of \<open>numeral w :: int\<close> n]
	by (auto intro: exI [of _ \<open>n - 1\<close>])

	lemma bin_nth_Bit1:
	"(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (Num.Bit1 w)) n \<longleftrightarrow>
	n = 0 \<or> (\<exists>m. n = Suc m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral w) m)"
	using even_bit_succ_iff [of \<open>2 * numeral w :: int\<close> n]
	bit_double_iff [of \<open>numeral w :: int\<close> n]
	by auto

	lemma bintrunc_bintrunc_l: "n \<le> m \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by simp

	lemma sbintrunc_sbintrunc_l: "n \<le> m \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by simp

	lemma bintrunc_bintrunc_ge: "n \<le> m \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (rule bin_eqI) (auto simp: nth_bintr)

	lemma bintrunc_bintrunc_min [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) w"
	by (rule take_bit_take_bit)

	lemma sbintrunc_sbintrunc_min [simp]: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) w"
	by (rule signed_take_bit_signed_take_bit)

	lemmas sbintrunc_Suc_Pls =
	signed_take_bit_Suc [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]

	lemmas sbintrunc_Suc_Min =
	signed_take_bit_Suc [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]

	lemmas sbintrunc_Sucs = sbintrunc_Suc_Pls sbintrunc_Suc_Min
	sbintrunc_Suc_numeral

	lemmas sbintrunc_Pls =
	signed_take_bit_0 [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]

	lemmas sbintrunc_Min =
	signed_take_bit_0 [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]

	lemmas sbintrunc_0_simps =
	sbintrunc_Pls sbintrunc_Min

	lemmas sbintrunc_simps = sbintrunc_0_simps sbintrunc_Sucs

	lemma bintrunc_minus: "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc (n - 1)) w = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by auto

	lemma sbintrunc_minus: "0 < n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc (n - 1)) w = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by auto

	lemmas sbintrunc_minus_simps =
	sbintrunc_Sucs [THEN [2] sbintrunc_minus [symmetric, THEN trans]]

	lemma sbintrunc_BIT_I:
	\<open>0 < n \<Longrightarrow>
	(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) 0 = y \<Longrightarrow>
	(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 2 * y\<close>
	by simp

	lemma sbintrunc_Suc_Is:
	\<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = y \<Longrightarrow>
	(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- 1) = 1 + 2 * y\<close>
	by auto

	lemma sbintrunc_Suc_lem: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) x = y \<Longrightarrow> m = Suc n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m x = y"
	by (rule ssubst)

	lemmas sbintrunc_Suc_Ialts =
	sbintrunc_Suc_Is [THEN sbintrunc_Suc_lem]

	lemma sbintrunc_bintrunc_lt: "m > n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (rule bin_eqI) (auto simp: nth_sbintr nth_bintr)

	lemma bintrunc_sbintrunc_le: "m \<le> Suc n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w"
	by (rule take_bit_signed_take_bit)

	lemmas bintrunc_sbintrunc [simp] = order_refl [THEN bintrunc_sbintrunc_le]
	lemmas sbintrunc_bintrunc [simp] = lessI [THEN sbintrunc_bintrunc_lt]
	lemmas bintrunc_bintrunc [simp] = order_refl [THEN bintrunc_bintrunc_l]
	lemmas sbintrunc_sbintrunc [simp] = order_refl [THEN sbintrunc_sbintrunc_l]

	lemma bintrunc_sbintrunc' [simp]: "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (cases n) simp_all

	lemma sbintrunc_bintrunc' [simp]: "0 < n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) w"
	by (cases n) simp_all

	lemma bin_sbin_eq_iff: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) y \<longleftrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y"
	apply (rule iffI)
	apply (rule box_equals [OF _ sbintrunc_bintrunc sbintrunc_bintrunc])
	apply simp
	apply (rule box_equals [OF _ bintrunc_sbintrunc bintrunc_sbintrunc])
	apply simp
	done

	lemma bin_sbin_eq_iff':
	"0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y \<longleftrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) y"
	by (cases n) (simp_all add: bin_sbin_eq_iff)

	lemmas bintrunc_sbintruncS0 [simp] = bintrunc_sbintrunc' [unfolded One_nat_def]
	lemmas sbintrunc_bintruncS0 [simp] = sbintrunc_bintrunc' [unfolded One_nat_def]

	lemmas bintrunc_bintrunc_l' = le_add1 [THEN bintrunc_bintrunc_l]
	lemmas sbintrunc_sbintrunc_l' = le_add1 [THEN sbintrunc_sbintrunc_l]

	(* although bintrunc_minus_simps, if added to default simpset,
	tends to get applied where it's not wanted in developing the theories,
	we get a version for when the word length is given literally *)

	lemmas nat_non0_gr =
	trans [OF iszero_def [THEN Not_eq_iff [THEN iffD2]] refl]

	lemma bintrunc_numeral:
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) x = of_bool (odd x) + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (x div 2)"
	by (simp add: numeral_eq_Suc take_bit_Suc mod_2_eq_odd)

	lemma sbintrunc_numeral:
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) x = of_bool (odd x) + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (x div 2)"
	by (simp add: numeral_eq_Suc signed_take_bit_Suc mod2_eq_if)

	lemma bintrunc_numeral_simps [simp]:
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit0 w)) =
	2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit1 w)) =
	1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit0 w)) =
	2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral w)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit1 w)) =
	1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral (w + Num.One))"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) 1 = 1"
	by (simp_all add: bintrunc_numeral)

	lemma sbintrunc_numeral_simps [simp]:
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit0 w)) =
	2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit1 w)) =
	1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit0 w)) =
	2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral w)"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit1 w)) =
	1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral (w + Num.One))"
	"(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) 1 = 1"
	by (simp_all add: sbintrunc_numeral)

	lemma no_bintr_alt1: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>w. w mod 2 ^ n :: int)"
	by (rule ext) (rule bintrunc_mod2p)

	lemma range_bintrunc: "range ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) = {i. 0 \<le> i \<and> i < 2 ^ n}"
	by (auto simp add: take_bit_eq_mod image_iff) (metis mod_pos_pos_trivial)

	lemma no_sbintr_alt2: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>w. (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n :: int)"
	by (rule ext) (simp add : sbintrunc_mod2p)

	lemma range_sbintrunc: "range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) = {i. - (2 ^ n) \<le> i \<and> i < 2 ^ n}"
	proof -
	have \<open>surj (\<lambda>k::int. k + 2 ^ n)\<close>
	by (rule surjI [of _ \<open>(\<lambda>k. k - 2 ^ n)\<close>]) simp
	moreover have \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = ((\<lambda>k. k - 2 ^ n) \<circ> take_bit (Suc n) \<circ> (\<lambda>k. k + 2 ^ n))\<close>
	by (simp add: sbintrunc_eq_take_bit fun_eq_iff)
	ultimately show ?thesis
	apply (simp only: fun.set_map range_bintrunc)
	apply (auto simp add: image_iff)
	apply presburger
	done
	qed

	lemma sbintrunc_inc:
	\<open>k + 2 ^ Suc n \<le> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k\<close> if \<open>k < - (2 ^ n)\<close>
	using that by (fact signed_take_bit_int_greater_eq)

	lemma sbintrunc_dec:
	\<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k \<le> k - 2 ^ (Suc n)\<close> if \<open>k \<ge> 2 ^ n\<close>
	using that by (fact signed_take_bit_int_less_eq)

	lemma bintr_ge0: "0 \<le> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (simp add: bintrunc_mod2p)

	lemma bintr_lt2p: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w < 2 ^ n"
	by (simp add: bintrunc_mod2p)

	lemma bintr_Min: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = 2 ^ n - 1"
	by (simp add: stable_imp_take_bit_eq mask_eq_exp_minus_1)

	lemma sbintr_ge: "- (2 ^ n) \<le> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (fact signed_take_bit_int_greater_eq_minus_exp)

	lemma sbintr_lt: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w < 2 ^ n"
	by (fact signed_take_bit_int_less_exp)

	lemma sign_Pls_ge_0: "bin_sign bin = 0 \<longleftrightarrow> bin \<ge> 0"
	for bin :: int
	by (simp add: bin_sign_def)

	lemma sign_Min_lt_0: "bin_sign bin = -1 \<longleftrightarrow> bin < 0"
	for bin :: int
	by (simp add: bin_sign_def)

	lemma bin_rest_trunc: "(\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) ((\<lambda>k::int. k div 2) bin)"
	by (simp add: take_bit_rec [of n bin])

	lemma bin_rest_power_trunc:
	"((\<lambda>k::int. k div 2) ^^ k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - k) (((\<lambda>k::int. k div 2) ^^ k) bin)"
	by (induct k) (auto simp: bin_rest_trunc)

	lemma bin_rest_trunc_i: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) bin) = (\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) bin)"
	by (auto simp add: take_bit_Suc)

	lemma bin_rest_strunc: "(\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) bin) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) bin)"
	by (simp add: signed_take_bit_Suc)

	lemma bintrunc_rest [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)) = (\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)"
	by (induct n arbitrary: bin) (simp_all add: take_bit_Suc)

	lemma sbintrunc_rest [simp]: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)) = (\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)"
	by (induct n arbitrary: bin) (simp_all add: signed_take_bit_Suc mod2_eq_if)

	lemma bintrunc_rest': "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n \<circ> (\<lambda>k::int. k div 2) \<circ> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>k::int. k div 2) \<circ> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n"
	by (rule ext) auto

	lemma sbintrunc_rest': "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n \<circ> (\<lambda>k::int. k div 2) \<circ> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>k::int. k div 2) \<circ> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n"
	by (rule ext) auto

	lemma rco_lem: "f \<circ> g \<circ> f = g \<circ> f \<Longrightarrow> f \<circ> (g \<circ> f) ^^ n = g ^^ n \<circ> f"
	apply (rule ext)
	apply (induct_tac n)
	apply (simp_all (no_asm))
	apply (drule fun_cong)
	apply (unfold o_def)
	apply (erule trans)
	apply simp
	done

	lemmas rco_bintr = bintrunc_rest'
	[THEN rco_lem [THEN fun_cong], unfolded o_def]
	lemmas rco_sbintr = sbintrunc_rest'
	[THEN rco_lem [THEN fun_cong], unfolded o_def]


	subsection \<open>Splitting and concatenation\<close>

	definition bin_split :: \<open>nat \<Rightarrow> int \<Rightarrow> int \<times> int\<close>
	where [simp]: \<open>bin_split n k = (drop_bit n k, take_bit n k)\<close>

	lemma [code]:
	"bin_split (Suc n) w = (let (w1, w2) = bin_split n (w div 2) in (w1, of_bool (odd w) + 2 * w2))"
	"bin_split 0 w = (w, 0)"
	by (simp_all add: drop_bit_Suc take_bit_Suc mod_2_eq_odd)

	lemma bin_cat_eq_push_bit_add_take_bit:
	\<open>concat_bit n l k = push_bit n k + take_bit n l\<close>
	by (simp add: concat_bit_eq)

	lemma bin_sign_cat: "bin_sign ((\<lambda>k n l. concat_bit n l k) x n y) = bin_sign x"
	proof -
	have \<open>0 \<le> x\<close> if \<open>0 \<le> x * 2 ^ n + y mod 2 ^ n\<close>
	proof -
	have \<open>y mod 2 ^ n < 2 ^ n\<close>
	using pos_mod_bound [of \<open>2 ^ n\<close> y] by simp
	then have \<open>\<not> y mod 2 ^ n \<ge> 2 ^ n\<close>
	by (simp add: less_le)
	with that have \<open>x \<noteq> - 1\<close>
	by auto
	have *: \<open>- 1 \<le> (- (y mod 2 ^ n)) div 2 ^ n\<close>
	by (simp add: zdiv_zminus1_eq_if)
	from that have \<open>- (y mod 2 ^ n) \<le> x * 2 ^ n\<close>
	by simp
	then have \<open>(- (y mod 2 ^ n)) div 2 ^ n \<le> (x * 2 ^ n) div 2 ^ n\<close>
	using zdiv_mono1 zero_less_numeral zero_less_power by blast
	with * have \<open>- 1 \<le> x * 2 ^ n div 2 ^ n\<close> by simp
	with \<open>x \<noteq> - 1\<close> show ?thesis
	by simp
	qed
	then show ?thesis
	by (simp add: bin_sign_def not_le not_less bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult take_bit_eq_mod)
	qed

	lemma bin_cat_assoc: "(\<lambda>k n l. concat_bit n l k) ((\<lambda>k n l. concat_bit n l k) x m y) n z = (\<lambda>k n l. concat_bit n l k) x (m + n) ((\<lambda>k n l. concat_bit n l k) y n z)"
	by (fact concat_bit_assoc)

	lemma bin_cat_assoc_sym: "(\<lambda>k n l. concat_bit n l k) x m ((\<lambda>k n l. concat_bit n l k) y n z) = (\<lambda>k n l. concat_bit n l k) ((\<lambda>k n l. concat_bit n l k) x (m - n) y) (min m n) z"
	by (fact concat_bit_assoc_sym)

	definition bin_rcat :: \<open>nat \<Rightarrow> int list \<Rightarrow> int\<close>
	where \<open>bin_rcat n = horner_sum (take_bit n) (2 ^ n) \<circ> rev\<close>

	lemma bin_rcat_eq_foldl:
	\<open>bin_rcat n = foldl (\<lambda>u v. (\<lambda>k n l. concat_bit n l k) u n v) 0\<close>
	proof
	fix ks :: \<open>int list\<close>
	show \<open>bin_rcat n ks = foldl (\<lambda>u v. (\<lambda>k n l. concat_bit n l k) u n v) 0 ks\<close>
	by (induction ks rule: rev_induct)
	(simp_all add: bin_rcat_def concat_bit_eq push_bit_eq_mult)
	qed

	fun bin_rsplit_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
	where "bin_rsplit_aux n m c bs =
	(if m = 0 \<or> n = 0 then bs
	else
	let (a, b) = bin_split n c
	in bin_rsplit_aux n (m - n) a (b # bs))"

	definition bin_rsplit :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
	where "bin_rsplit n w = bin_rsplit_aux n (fst w) (snd w) []"

	fun bin_rsplitl_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
	where "bin_rsplitl_aux n m c bs =
	(if m = 0 \<or> n = 0 then bs
	else
	let (a, b) = bin_split (min m n) c
	in bin_rsplitl_aux n (m - n) a (b # bs))"

	definition bin_rsplitl :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
	where "bin_rsplitl n w = bin_rsplitl_aux n (fst w) (snd w) []"

	declare bin_rsplit_aux.simps [simp del]
	declare bin_rsplitl_aux.simps [simp del]

	lemma bin_nth_cat:
	"(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((\<lambda>k n l. concat_bit n l k) x k y) n =
	(if n < k then (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (n - k))"
	by (simp add: bit_concat_bit_iff)

	lemma bin_nth_drop_bit_iff:
	\<open>(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (drop_bit n c) k \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c (n + k)\<close>
	by (simp add: bit_drop_bit_eq)

	lemma bin_nth_take_bit_iff:
	\<open>(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (take_bit n c) k \<longleftrightarrow> k < n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c k\<close>
	by (fact bit_take_bit_iff)

	lemma bin_nth_split:
	"bin_split n c = (a, b) \<Longrightarrow>
	(\<forall>k. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) a k = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c (n + k)) \<and>
	(\<forall>k. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) b k = (k < n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c k))"
	by (auto simp add: bin_nth_drop_bit_iff bin_nth_take_bit_iff)

	lemma bin_cat_zero [simp]: "(\<lambda>k n l. concat_bit n l k) 0 n w = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (simp add: bin_cat_eq_push_bit_add_take_bit)

	lemma bintr_cat1: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (k + n) ((\<lambda>k n l. concat_bit n l k) a n b) = (\<lambda>k n l. concat_bit n l k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) k a) n b"
	by (metis bin_cat_assoc bin_cat_zero)

	lemma bintr_cat: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((\<lambda>k n l. concat_bit n l k) a n b) =
	(\<lambda>k n l. concat_bit n l k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) b)"
	by (rule bin_eqI) (auto simp: bin_nth_cat nth_bintr)

	lemma bintr_cat_same [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k n l. concat_bit n l k) a n b) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b"
	by (auto simp add : bintr_cat)

	lemma cat_bintr [simp]: "(\<lambda>k n l. concat_bit n l k) a n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b) = (\<lambda>k n l. concat_bit n l k) a n b"
	by (simp add: bin_cat_eq_push_bit_add_take_bit)

	lemma split_bintrunc: "bin_split n c = (a, b) \<Longrightarrow> b = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n c"
	by simp

	lemma bin_cat_split: "bin_split n w = (u, v) \<Longrightarrow> w = (\<lambda>k n l. concat_bit n l k) u n v"
	by (auto simp add: bin_cat_eq_push_bit_add_take_bit bits_ident)

	lemma drop_bit_bin_cat_eq:
	\<open>drop_bit n ((\<lambda>k n l. concat_bit n l k) v n w) = v\<close>
	by (rule bit_eqI) (simp add: bit_drop_bit_eq bit_concat_bit_iff)

	lemma take_bit_bin_cat_eq:
	\<open>take_bit n ((\<lambda>k n l. concat_bit n l k) v n w) = take_bit n w\<close>
	by (rule bit_eqI) (simp add: bit_concat_bit_iff)

	lemma bin_split_cat: "bin_split n ((\<lambda>k n l. concat_bit n l k) v n w) = (v, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w)"
	by (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)

	lemma bin_split_zero [simp]: "bin_split n 0 = (0, 0)"
	by simp

	lemma bin_split_minus1 [simp]:
	"bin_split n (- 1) = (- 1, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1))"
	by simp

	lemma bin_split_trunc:
	"bin_split (min m n) c = (a, b) \<Longrightarrow>
	bin_split n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m c) = ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a, b)"
	apply (induct n arbitrary: m b c, clarsimp)
	apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
	apply (case_tac m)
	apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
	done

	lemma bin_split_trunc1:
	"bin_split n c = (a, b) \<Longrightarrow>
	bin_split n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m c) = ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m b)"
	apply (induct n arbitrary: m b c, clarsimp)
	apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
	apply (case_tac m)
	apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
	done

	lemma bin_cat_num: "(\<lambda>k n l. concat_bit n l k) a n b = a * 2 ^ n + (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b"
	by (simp add: bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult)

	lemma bin_split_num: "bin_split n b = (b div 2 ^ n, b mod 2 ^ n)"
	by (simp add: drop_bit_eq_div take_bit_eq_mod)

	lemmas bin_rsplit_aux_simps = bin_rsplit_aux.simps bin_rsplitl_aux.simps
	lemmas rsplit_aux_simps = bin_rsplit_aux_simps

	lemmas th_if_simp1 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct1, THEN mp] for l
	lemmas th_if_simp2 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct2, THEN mp] for l

	lemmas rsplit_aux_simp1s = rsplit_aux_simps [THEN th_if_simp1]

	lemmas rsplit_aux_simp2ls = rsplit_aux_simps [THEN th_if_simp2]
	\<comment> \<open>these safe to \<open>[simp add]\<close> as require calculating \<open>m - n\<close>\<close>
	lemmas bin_rsplit_aux_simp2s [simp] = rsplit_aux_simp2ls [unfolded Let_def]
	lemmas rbscl = bin_rsplit_aux_simp2s (2)

	lemmas rsplit_aux_0_simps [simp] =
	rsplit_aux_simp1s [OF disjI1] rsplit_aux_simp1s [OF disjI2]

	lemma bin_rsplit_aux_append: "bin_rsplit_aux n m c (bs @ cs) = bin_rsplit_aux n m c bs @ cs"
	apply (induct n m c bs rule: bin_rsplit_aux.induct)
	apply (subst bin_rsplit_aux.simps)
	apply (subst bin_rsplit_aux.simps)
	apply (clarsimp split: prod.split)
	done

	lemma bin_rsplitl_aux_append: "bin_rsplitl_aux n m c (bs @ cs) = bin_rsplitl_aux n m c bs @ cs"
	apply (induct n m c bs rule: bin_rsplitl_aux.induct)
	apply (subst bin_rsplitl_aux.simps)
	apply (subst bin_rsplitl_aux.simps)
	apply (clarsimp split: prod.split)
	done

	lemmas rsplit_aux_apps [where bs = "[]"] =
	bin_rsplit_aux_append bin_rsplitl_aux_append

	lemmas rsplit_def_auxs = bin_rsplit_def bin_rsplitl_def

	lemmas rsplit_aux_alts = rsplit_aux_apps
	[unfolded append_Nil rsplit_def_auxs [symmetric]]

	lemma bin_split_minus: "0 < n \<Longrightarrow> bin_split (Suc (n - 1)) w = bin_split n w"
	by auto

	lemma bin_split_pred_simp [simp]:
	"(0::nat) < numeral bin \<Longrightarrow>
	bin_split (numeral bin) w =
	(let (w1, w2) = bin_split (numeral bin - 1) ((\<lambda>k::int. k div 2) w)
	in (w1, of_bool (odd w) + 2 * w2))"
	by (simp add: take_bit_rec drop_bit_rec mod_2_eq_odd)

	lemma bin_rsplit_aux_simp_alt:
	"bin_rsplit_aux n m c bs =
	(if m = 0 \<or> n = 0 then bs
	else let (a, b) = bin_split n c in bin_rsplit n (m - n, a) @ b # bs)"
	apply (simp add: bin_rsplit_aux.simps [of n m c bs])
	apply (subst rsplit_aux_alts)
	apply (simp add: bin_rsplit_def)
	done

	lemmas bin_rsplit_simp_alt =
	trans [OF bin_rsplit_def bin_rsplit_aux_simp_alt]

	lemmas bthrs = bin_rsplit_simp_alt [THEN [2] trans]

	lemma bin_rsplit_size_sign' [rule_format]:
	"n > 0 \<Longrightarrow> rev sw = bin_rsplit n (nw, w) \<Longrightarrow> \<forall>v\<in>set sw. (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n v = v"
	apply (induct sw arbitrary: nw w)
	apply clarsimp
	apply clarsimp
	apply (drule bthrs)
	apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
	apply clarify
	apply simp
	done

	lemmas bin_rsplit_size_sign = bin_rsplit_size_sign' [OF asm_rl
	rev_rev_ident [THEN trans] set_rev [THEN equalityD2 [THEN subsetD]]]

	lemma bin_nth_rsplit [rule_format] :
	"n > 0 \<Longrightarrow> m < n \<Longrightarrow>
	\<forall>w k nw.
	rev sw = bin_rsplit n (nw, w) \<longrightarrow>
	k < size sw \<longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (sw ! k) m = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w (k * n + m)"
	apply (induct sw)
	apply clarsimp
	apply clarsimp
	apply (drule bthrs)
	apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
	apply (erule allE, erule impE, erule exI)
	apply (case_tac k)
	apply clarsimp
	prefer 2
	apply clarsimp
	apply (erule allE)
	apply (erule (1) impE)
	apply (simp add: bit_drop_bit_eq ac_simps)
	apply (simp add: bit_take_bit_iff ac_simps)
	done

	lemma bin_rsplit_all: "0 < nw \<Longrightarrow> nw \<le> n \<Longrightarrow> bin_rsplit n (nw, w) = [(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w]"
	by (auto simp: bin_rsplit_def rsplit_aux_simp2ls split: prod.split dest!: split_bintrunc)

	lemma bin_rsplit_l [rule_format]:
	"\<forall>bin. bin_rsplitl n (m, bin) = bin_rsplit n (m, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m bin)"
	apply (rule_tac a = "m" in wf_less_than [THEN wf_induct])
	apply (simp (no_asm) add: bin_rsplitl_def bin_rsplit_def)
	apply (rule allI)
	apply (subst bin_rsplitl_aux.simps)
	apply (subst bin_rsplit_aux.simps)
	apply (clarsimp simp: Let_def split: prod.split)
	apply (simp add: ac_simps)
	apply (subst rsplit_aux_alts(1))
	apply (subst rsplit_aux_alts(2))
	apply clarsimp
	unfolding bin_rsplit_def bin_rsplitl_def
	apply (simp add: drop_bit_take_bit)
	apply (case_tac \<open>x < n\<close>)
	apply (simp_all add: not_less min_def)
	done

	lemma bin_rsplit_rcat [rule_format]:
	"n > 0 \<longrightarrow> bin_rsplit n (n * size ws, bin_rcat n ws) = map ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) ws"
	apply (unfold bin_rsplit_def bin_rcat_eq_foldl)
	apply (rule_tac xs = ws in rev_induct)
	apply clarsimp
	apply clarsimp
	apply (subst rsplit_aux_alts)
	apply (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)
	done

	lemma bin_rsplit_aux_len_le [rule_format] :
	"\<forall>ws m. n \<noteq> 0 \<longrightarrow> ws = bin_rsplit_aux n nw w bs \<longrightarrow>
	length ws \<le> m \<longleftrightarrow> nw + length bs * n \<le> m * n"
	proof -
	have *: R
	if d: "i \<le> j \<or> m < j'"
	and R1: "i * k \<le> j * k \<Longrightarrow> R"
	and R2: "Suc m * k' \<le> j' * k' \<Longrightarrow> R"
	for i j j' k k' m :: nat and R
	using d
	apply safe
	apply (rule R1, erule mult_le_mono1)
	apply (rule R2, erule Suc_le_eq [THEN iffD2 [THEN mult_le_mono1]])
	done
	have *: "0 < sc \<Longrightarrow> sc - n + (n + lb n) \<le> m * n \<longleftrightarrow> sc + lb * n \<le> m * n"
	for sc m n lb :: nat
	apply safe
	apply arith
	apply (case_tac "sc \<ge> n")
	apply arith
	apply (insert linorder_le_less_linear [of m lb])
	apply (erule_tac k=n and k'=n in *)
	apply arith
	apply simp
	done
	show ?thesis
	apply (induct n nw w bs rule: bin_rsplit_aux.induct)
	apply (subst bin_rsplit_aux.simps)
	apply (simp add: ** Let_def split: prod.split)
	done
	qed

	lemma bin_rsplit_len_le: "n \<noteq> 0 \<longrightarrow> ws = bin_rsplit n (nw, w) \<longrightarrow> length ws \<le> m \<longleftrightarrow> nw \<le> m * n"
	by (auto simp: bin_rsplit_def bin_rsplit_aux_len_le)

	lemma bin_rsplit_aux_len:
	"n \<noteq> 0 \<Longrightarrow> length (bin_rsplit_aux n nw w cs) = (nw + n - 1) div n + length cs"
	apply (induct n nw w cs rule: bin_rsplit_aux.induct)
	apply (subst bin_rsplit_aux.simps)
	apply (clarsimp simp: Let_def split: prod.split)
	apply (erule thin_rl)
	apply (case_tac m)
	apply simp
	apply (case_tac "m \<le> n")
	apply (auto simp add: div_add_self2)
	done

	lemma bin_rsplit_len: "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, w)) = (nw + n - 1) div n"
	by (auto simp: bin_rsplit_def bin_rsplit_aux_len)

	lemma bin_rsplit_aux_len_indep:
	"n \<noteq> 0 \<Longrightarrow> length bs = length cs \<Longrightarrow>
	length (bin_rsplit_aux n nw v bs) =
	length (bin_rsplit_aux n nw w cs)"
	proof (induct n nw w cs arbitrary: v bs rule: bin_rsplit_aux.induct)
	case (1 n m w cs v bs)
	show ?case
	proof (cases "m = 0")
	case True
	with \<open>length bs = length cs\<close> show ?thesis by simp
	next
	case False
	from "1.hyps" [of \<open>bin_split n w\<close> \<open>drop_bit n w\<close> \<open>take_bit n w\<close>] \<open>m \<noteq> 0\<close> \<open>n \<noteq> 0\<close>
	have hyp: "\<And>v bs. length bs = Suc (length cs) \<Longrightarrow>
	length (bin_rsplit_aux n (m - n) v bs) =
	length (bin_rsplit_aux n (m - n) (drop_bit n w) (take_bit n w # cs))"
	using bin_rsplit_aux_len by fastforce
	from \<open>length bs = length cs\<close> \<open>n \<noteq> 0\<close> show ?thesis
	by (auto simp add: bin_rsplit_aux_simp_alt Let_def bin_rsplit_len split: prod.split)
	qed
	qed

	lemma bin_rsplit_len_indep:
	"n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, v)) = length (bin_rsplit n (nw, w))"
	apply (unfold bin_rsplit_def)
	apply (simp (no_asm))
	apply (erule bin_rsplit_aux_len_indep)
	apply (rule refl)
	done


	subsection \<open>Logical operations\<close>

	abbreviation (input) bin_sc :: \<open>nat \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> int\<close>
	where \<open>bin_sc n b i \<equiv> set_bit i n b\<close>

	lemma bin_sc_0 [simp]:
	"bin_sc 0 b w = of_bool b + 2 * (\<lambda>k::int. k div 2) w"
	by (simp add: set_bit_int_def)

	lemma bin_sc_Suc [simp]:
	"bin_sc (Suc n) b w = of_bool (odd w) + 2 * bin_sc n b (w div 2)"
	by (simp add: set_bit_int_def set_bit_Suc unset_bit_Suc bin_last_def)

	lemma bin_nth_sc [bit_simps]: "bit (bin_sc n b w) n \<longleftrightarrow> b"
	by (simp add: bit_simps)

	lemma bin_sc_sc_same [simp]: "bin_sc n c (bin_sc n b w) = bin_sc n c w"
	by (induction n arbitrary: w) (simp_all add: bit_Suc)

	lemma bin_sc_sc_diff: "m \<noteq> n \<Longrightarrow> bin_sc m c (bin_sc n b w) = bin_sc n b (bin_sc m c w)"
	apply (induct n arbitrary: w m)
	apply (case_tac [!] m)
	apply auto
	done

	lemma bin_nth_sc_gen: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (bin_sc n b w) m = (if m = n then b else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w m)"
	- apply (induct n arbitrary: w m)
	- apply (case_tac m; simp add: bit_Suc)
	- apply (case_tac m; simp add: bit_Suc)
	- done
	+ by (simp add: bit_simps)

	lemma bin_sc_eq:
	\<open>bin_sc n False = unset_bit n\<close>
	\<open>bin_sc n True = Bit_Operations.set_bit n\<close>
	apply (simp_all add: fun_eq_iff bit_eq_iff)
	apply (simp_all add: bit_simps bin_nth_sc_gen)
	done

	lemma bin_sc_nth [simp]: "bin_sc n ((bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n) w = w"
	by (rule bit_eqI) (simp add: bin_nth_sc_gen)

	lemma bin_sign_sc [simp]: "bin_sign (bin_sc n b w) = bin_sign w"
	proof (induction n arbitrary: w)
	case 0
	then show ?case
	by (auto simp add: bin_sign_def) (use bin_rest_ge_0 in fastforce)
	next
	case (Suc n)
	from Suc [of \<open>w div 2\<close>]
	show ?case by (auto simp add: bin_sign_def split: if_splits)
	qed

	lemma bin_sc_bintr [simp]:
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m (bin_sc n x ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w)) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m (bin_sc n x w)"
	apply (rule bit_eqI)
	apply (cases x)
	apply (auto simp add: bit_simps bin_sc_eq)
	done

	lemma bin_clr_le: "bin_sc n False w \<le> w"
	by (simp add: set_bit_int_def unset_bit_less_eq)

	lemma bin_set_ge: "bin_sc n True w \<ge> w"
	by (simp add: set_bit_int_def set_bit_greater_eq)

	lemma bintr_bin_clr_le: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (bin_sc m False w) \<le> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (simp add: set_bit_int_def take_bit_unset_bit_eq unset_bit_less_eq)

	lemma bintr_bin_set_ge: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (bin_sc m True w) \<ge> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
	by (simp add: set_bit_int_def take_bit_set_bit_eq set_bit_greater_eq)

	lemma bin_sc_FP [simp]: "bin_sc n False 0 = 0"
	by (induct n) auto

	lemma bin_sc_TM [simp]: "bin_sc n True (- 1) = - 1"
	by (induct n) auto

	lemmas bin_sc_simps = bin_sc_0 bin_sc_Suc bin_sc_TM bin_sc_FP

	lemma bin_sc_minus: "0 < n \<Longrightarrow> bin_sc (Suc (n - 1)) b w = bin_sc n b w"
	by auto

	lemmas bin_sc_Suc_minus =
	trans [OF bin_sc_minus [symmetric] bin_sc_Suc]

	lemma bin_sc_numeral [simp]:
	"bin_sc (numeral k) b w =
	of_bool (odd w) + 2 * bin_sc (pred_numeral k) b (w div 2)"
	by (simp add: numeral_eq_Suc)

	lemmas bin_sc_minus_simps =
	bin_sc_simps (2,3,4) [THEN [2] trans, OF bin_sc_minus [THEN sym]]

	lemma int_set_bit_0 [simp]: fixes x :: int shows
	"set_bit x 0 b = of_bool b + 2 * (x div 2)"
	by (fact bin_sc_0)

	lemma int_set_bit_Suc: fixes x :: int shows
	"set_bit x (Suc n) b = of_bool (odd x) + 2 * set_bit (x div 2) n b"
	by (fact bin_sc_Suc)

	lemma bin_last_set_bit:
	"odd (set_bit x n b :: int) = (if n > 0 then odd x else b)"
	by (cases n) (simp_all add: int_set_bit_Suc)

	lemma bin_rest_set_bit:
	"(set_bit x n b :: int) div 2 = (if n > 0 then set_bit (x div 2) (n - 1) b else x div 2)"
	by (cases n) (simp_all add: int_set_bit_Suc)

	lemma int_set_bit_numeral: fixes x :: int shows
	"set_bit x (numeral w) b = of_bool (odd x) + 2 * set_bit (x div 2) (pred_numeral w) b"
	by (fact bin_sc_numeral)

	lemmas int_set_bit_numerals [simp] =
	int_set_bit_numeral[where x="numeral w'"]
	int_set_bit_numeral[where x="- numeral w'"]
	int_set_bit_numeral[where x="Numeral1"]
	int_set_bit_numeral[where x="1"]
	int_set_bit_numeral[where x="0"]
	int_set_bit_Suc[where x="numeral w'"]
	int_set_bit_Suc[where x="- numeral w'"]
	int_set_bit_Suc[where x="Numeral1"]
	int_set_bit_Suc[where x="1"]
	int_set_bit_Suc[where x="0"]
	for w'

	lemma msb_set_bit [simp]:
	"msb (set_bit (x :: int) n b) \<longleftrightarrow> msb x"
	by (simp add: msb_int_def set_bit_int_def)

	lemma word_set_bit_def:
	\<open>set_bit a n x = word_of_int (bin_sc n x (uint a))\<close>
	apply (rule bit_word_eqI)
	apply (cases x)
	apply (simp_all add: bit_simps bin_sc_eq)
	done

	lemma set_bit_word_of_int:
	"set_bit (word_of_int x) n b = word_of_int (bin_sc n b x)"
	unfolding word_set_bit_def
	by (rule word_eqI) (simp add: word_size bin_nth_sc_gen nth_bintr bit_simps)

	lemma word_set_numeral [simp]:
	"set_bit (numeral bin::'a::len word) n b =
	word_of_int (bin_sc n b (numeral bin))"
	unfolding word_numeral_alt by (rule set_bit_word_of_int)

	lemma word_set_neg_numeral [simp]:
	"set_bit (- numeral bin::'a::len word) n b =
	word_of_int (bin_sc n b (- numeral bin))"
	unfolding word_neg_numeral_alt by (rule set_bit_word_of_int)

	lemma word_set_bit_0 [simp]: "set_bit 0 n b = word_of_int (bin_sc n b 0)"
	unfolding word_0_wi by (rule set_bit_word_of_int)

	lemma word_set_bit_1 [simp]: "set_bit 1 n b = word_of_int (bin_sc n b 1)"
	unfolding word_1_wi by (rule set_bit_word_of_int)

	lemmas shiftl_int_def = shiftl_eq_mult[of x for x::int]
	lemmas shiftr_int_def = shiftr_eq_div[of x for x::int]


	subsubsection \<open>Basic simplification rules\<close>

	context
	includes bit_operations_syntax
	begin

	lemmas int_not_def = not_int_def

	lemma int_not_simps:
	"NOT (0::int) = -1"
	"NOT (1::int) = -2"
	"NOT (- 1::int) = 0"
	"NOT (numeral w::int) = - numeral (w + Num.One)"
	"NOT (- numeral (Num.Bit0 w)::int) = numeral (Num.BitM w)"
	"NOT (- numeral (Num.Bit1 w)::int) = numeral (Num.Bit0 w)"
	by (simp_all add: not_int_def)

	lemma int_not_not: "NOT (NOT x) = x"
	for x :: int
	by (fact bit.double_compl)

	lemma int_and_0 [simp]: "0 AND x = 0"
	for x :: int
	by (fact bit.conj_zero_left)

	lemma int_and_m1 [simp]: "-1 AND x = x"
	for x :: int
	by (fact and.left_neutral)

	lemma int_or_zero [simp]: "0 OR x = x"
	for x :: int
	by (fact or.left_neutral)

	lemma int_or_minus1 [simp]: "-1 OR x = -1"
	for x :: int
	by (fact bit.disj_one_left)

	lemma int_xor_zero [simp]: "0 XOR x = x"
	for x :: int
	by (fact xor.left_neutral)


	subsubsection \<open>Binary destructors\<close>

	lemma bin_rest_NOT [simp]: "(\<lambda>k::int. k div 2) (NOT x) = NOT ((\<lambda>k::int. k div 2) x)"
	by (fact not_int_div_2)

	lemma bin_last_NOT [simp]: "(odd :: int \<Rightarrow> bool) (NOT x) \<longleftrightarrow> \<not> (odd :: int \<Rightarrow> bool) x"
	by simp

	lemma bin_rest_AND [simp]: "(\<lambda>k::int. k div 2) (x AND y) = (\<lambda>k::int. k div 2) x AND (\<lambda>k::int. k div 2) y"
	by (subst and_int_rec) auto

	lemma bin_last_AND [simp]: "(odd :: int \<Rightarrow> bool) (x AND y) \<longleftrightarrow> (odd :: int \<Rightarrow> bool) x \<and> (odd :: int \<Rightarrow> bool) y"
	by (subst and_int_rec) auto

	lemma bin_rest_OR [simp]: "(\<lambda>k::int. k div 2) (x OR y) = (\<lambda>k::int. k div 2) x OR (\<lambda>k::int. k div 2) y"
	by (subst or_int_rec) auto

	lemma bin_last_OR [simp]: "(odd :: int \<Rightarrow> bool) (x OR y) \<longleftrightarrow> (odd :: int \<Rightarrow> bool) x \<or> (odd :: int \<Rightarrow> bool) y"
	by (subst or_int_rec) auto

	lemma bin_rest_XOR [simp]: "(\<lambda>k::int. k div 2) (x XOR y) = (\<lambda>k::int. k div 2) x XOR (\<lambda>k::int. k div 2) y"
	by (subst xor_int_rec) auto

	lemma bin_last_XOR [simp]: "(odd :: int \<Rightarrow> bool) (x XOR y) \<longleftrightarrow> ((odd :: int \<Rightarrow> bool) x \<or> (odd :: int \<Rightarrow> bool) y) \<and> \<not> ((odd :: int \<Rightarrow> bool) x \<and> (odd :: int \<Rightarrow> bool) y)"
	by (subst xor_int_rec) auto

	lemma bin_nth_ops:
	"\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x AND y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
	"\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x OR y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<or> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
	"\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x XOR y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<noteq> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
	"\<And>x. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (NOT x) n \<longleftrightarrow> \<not> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n"
	by (simp_all add: bit_and_iff bit_or_iff bit_xor_iff bit_not_iff)


	subsubsection \<open>Derived properties\<close>

	lemma int_xor_minus1 [simp]: "-1 XOR x = NOT x"
	for x :: int
	by (fact bit.xor_one_left)

	lemma int_xor_extra_simps [simp]:
	"w XOR 0 = w"
	"w XOR -1 = NOT w"
	for w :: int
	by simp_all

	lemma int_or_extra_simps [simp]:
	"w OR 0 = w"
	"w OR -1 = -1"
	for w :: int
	by simp_all

	lemma int_and_extra_simps [simp]:
	"w AND 0 = 0"
	"w AND -1 = w"
	for w :: int
	by simp_all

	text \<open>Commutativity of the above.\<close>
	lemma bin_ops_comm:
	fixes x y :: int
	shows int_and_comm: "x AND y = y AND x"
	and int_or_comm: "x OR y = y OR x"
	and int_xor_comm: "x XOR y = y XOR x"
	by (simp_all add: ac_simps)

	lemma bin_ops_same [simp]:
	"x AND x = x"
	"x OR x = x"
	"x XOR x = 0"
	for x :: int
	by simp_all

	lemmas bin_log_esimps =
	int_and_extra_simps int_or_extra_simps int_xor_extra_simps
	int_and_0 int_and_m1 int_or_zero int_or_minus1 int_xor_zero int_xor_minus1


	subsubsection \<open>Basic properties of logical (bit-wise) operations\<close>

	lemma bbw_ao_absorb: "x AND (y OR x) = x \<and> x OR (y AND x) = x"
	for x y :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemma bbw_ao_absorbs_other:
	"x AND (x OR y) = x \<and> (y AND x) OR x = x"
	"(y OR x) AND x = x \<and> x OR (x AND y) = x"
	"(x OR y) AND x = x \<and> (x AND y) OR x = x"
	for x y :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemmas bbw_ao_absorbs [simp] = bbw_ao_absorb bbw_ao_absorbs_other

	lemma int_xor_not: "(NOT x) XOR y = NOT (x XOR y) \<and> x XOR (NOT y) = NOT (x XOR y)"
	for x y :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemma int_and_assoc: "(x AND y) AND z = x AND (y AND z)"
	for x y z :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemma int_or_assoc: "(x OR y) OR z = x OR (y OR z)"
	for x y z :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemma int_xor_assoc: "(x XOR y) XOR z = x XOR (y XOR z)"
	for x y z :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemmas bbw_assocs = int_and_assoc int_or_assoc int_xor_assoc

	(* BH: Why are these declared as simp rules??? *)
	lemma bbw_lcs [simp]:
	"y AND (x AND z) = x AND (y AND z)"
	"y OR (x OR z) = x OR (y OR z)"
	"y XOR (x XOR z) = x XOR (y XOR z)"
	for x y :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemma bbw_not_dist:
	"NOT (x OR y) = (NOT x) AND (NOT y)"
	"NOT (x AND y) = (NOT x) OR (NOT y)"
	for x y :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemma bbw_oa_dist: "(x AND y) OR z = (x OR z) AND (y OR z)"
	for x y z :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)

	lemma bbw_ao_dist: "(x OR y) AND z = (x AND z) OR (y AND z)"
	for x y z :: int
	by (auto simp add: bin_eq_iff bin_nth_ops)


	subsubsection \<open>Simplification with numerals\<close>

	text \<open>Cases for \<open>0\<close> and \<open>-1\<close> are already covered by other simp rules.\<close>

	lemma bin_rest_neg_numeral_BitM [simp]:
	"(\<lambda>k::int. k div 2) (- numeral (Num.BitM w)) = - numeral w"
	by simp

	lemma bin_last_neg_numeral_BitM [simp]:
	"(odd :: int \<Rightarrow> bool) (- numeral (Num.BitM w))"
	by simp


	subsubsection \<open>Interactions with arithmetic\<close>

	lemma le_int_or: "bin_sign y = 0 \<Longrightarrow> x \<le> x OR y"
	for x y :: int
	by (simp add: bin_sign_def or_greater_eq split: if_splits)

	lemmas int_and_le =
	xtrans(3) [OF bbw_ao_absorbs (2) [THEN conjunct2, symmetric] le_int_or]

	text \<open>Interaction between bit-wise and arithmetic: good example of \<open>bin_induction\<close>.\<close>
	lemma bin_add_not: "x + NOT x = (-1::int)"
	by (simp add: not_int_def)

	lemma AND_mod: "x AND (2 ^ n - 1) = x mod 2 ^ n"
	for x :: int
	by (simp flip: take_bit_eq_mod add: take_bit_eq_mask mask_eq_exp_minus_1)


	subsubsection \<open>Truncating results of bit-wise operations\<close>

	lemma bin_trunc_ao:
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x AND (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x AND y)"
	"(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x OR (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x OR y)"
	by simp_all

	lemma bin_trunc_xor: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x XOR (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x XOR y)"
	by simp

	lemma bin_trunc_not: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (NOT ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x)) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (NOT x)"
	by (fact take_bit_not_take_bit)

	text \<open>Want theorems of the form of \<open>bin_trunc_xor\<close>.\<close>
	lemma bintr_bintr_i: "x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y"
	by auto

	lemmas bin_trunc_and = bin_trunc_ao(1) [THEN bintr_bintr_i]
	lemmas bin_trunc_or = bin_trunc_ao(2) [THEN bintr_bintr_i]


	subsubsection \<open>More lemmas\<close>

	lemma not_int_cmp_0 [simp]:
	fixes i :: int shows
	"0 < NOT i \<longleftrightarrow> i < -1"
	"0 \<le> NOT i \<longleftrightarrow> i < 0"
	"NOT i < 0 \<longleftrightarrow> i \<ge> 0"
	"NOT i \<le> 0 \<longleftrightarrow> i \<ge> -1"
	by(simp_all add: int_not_def) arith+

	lemma bbw_ao_dist2: "(x :: int) AND (y OR z) = x AND y OR x AND z"
	by (fact bit.conj_disj_distrib)

	lemmas int_and_ac = bbw_lcs(1) int_and_comm int_and_assoc

	lemma int_nand_same [simp]: fixes x :: int shows "x AND NOT x = 0"
	by simp

	lemma int_nand_same_middle: fixes x :: int shows "x AND y AND NOT x = 0"
	by (simp add: bit_eq_iff bit_and_iff bit_not_iff)

	lemma and_xor_dist: fixes x :: int shows
	"x AND (y XOR z) = (x AND y) XOR (x AND z)"
	by (fact bit.conj_xor_distrib)

	lemma int_and_lt0 [simp]:
	\<open>x AND y < 0 \<longleftrightarrow> x < 0 \<and> y < 0\<close> for x y :: int
	by (fact and_negative_int_iff)

	lemma int_and_ge0 [simp]:
	\<open>x AND y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<or> y \<ge> 0\<close> for x y :: int
	by (fact and_nonnegative_int_iff)

	lemma int_and_1: fixes x :: int shows "x AND 1 = x mod 2"
	by (fact and_one_eq)

	lemma int_1_and: fixes x :: int shows "1 AND x = x mod 2"
	by (fact one_and_eq)

	lemma int_or_lt0 [simp]:
	\<open>x OR y < 0 \<longleftrightarrow> x < 0 \<or> y < 0\<close> for x y :: int
	by (fact or_negative_int_iff)

	lemma int_or_ge0 [simp]:
	\<open>x OR y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<and> y \<ge> 0\<close> for x y :: int
	by (fact or_nonnegative_int_iff)

	lemma int_xor_lt0 [simp]:
	\<open>x XOR y < 0 \<longleftrightarrow> (x < 0) \<noteq> (y < 0)\<close> for x y :: int
	by (fact xor_negative_int_iff)

	lemma int_xor_ge0 [simp]:
	\<open>x XOR y \<ge> 0 \<longleftrightarrow> (x \<ge> 0 \<longleftrightarrow> y \<ge> 0)\<close> for x y :: int
	by (fact xor_nonnegative_int_iff)

	lemma even_conv_AND:
	\<open>even i \<longleftrightarrow> i AND 1 = 0\<close> for i :: int
	by (simp add: and_one_eq mod2_eq_if)

	lemma bin_last_conv_AND:
	"(odd :: int \<Rightarrow> bool) i \<longleftrightarrow> i AND 1 \<noteq> 0"
	by (simp add: and_one_eq mod2_eq_if)

	lemma bitval_bin_last:
	"of_bool ((odd :: int \<Rightarrow> bool) i) = i AND 1"
	by (simp add: and_one_eq mod2_eq_if)

	lemma bin_sign_and:
	"bin_sign (i AND j) = - (bin_sign i * bin_sign j)"
	by(simp add: bin_sign_def)

	lemma int_not_neg_numeral: "NOT (- numeral n) = (Num.sub n num.One :: int)"
	by(simp add: int_not_def)

	lemma int_neg_numeral_pOne_conv_not: "- numeral (n + num.One) = (NOT (numeral n) :: int)"
	by(simp add: int_not_def)


	subsection \<open>Setting and clearing bits\<close>

	lemma int_shiftl_BIT: fixes x :: int
	shows int_shiftl0: "x << 0 = x"
	and int_shiftl_Suc: "x << Suc n = 2 * x << n"
	by (auto simp add: shiftl_int_def)

	lemma int_0_shiftl: "push_bit n 0 = (0 :: int)"
	by (fact push_bit_of_0)

	lemma bin_last_shiftl: "odd (push_bit n x) \<longleftrightarrow> n = 0 \<and> (odd :: int \<Rightarrow> bool) x"
	by simp

	lemma bin_rest_shiftl: "(\<lambda>k::int. k div 2) (push_bit n x) = (if n > 0 then push_bit (n - 1) x else (\<lambda>k::int. k div 2) x)"
	by (cases n) (simp_all add: push_bit_eq_mult)

	lemma bin_nth_shiftl: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (push_bit n x) m \<longleftrightarrow> n \<le> m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (m - n)"
	by (fact bit_push_bit_iff_int)

	lemma bin_last_shiftr: "odd (drop_bit n x) \<longleftrightarrow> bit x n" for x :: int
	by (simp add: bit_iff_odd_drop_bit)

	lemma bin_rest_shiftr: "(\<lambda>k::int. k div 2) (drop_bit n x) = drop_bit (Suc n) x"
	by (simp add: drop_bit_Suc drop_bit_half)

	lemma bin_nth_shiftr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (drop_bit n x) m = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (n + m)"
	by (simp add: bit_simps)

	lemma bin_nth_conv_AND:
	fixes x :: int shows
	"(bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<longleftrightarrow> x AND (push_bit n 1) \<noteq> 0"
	by (fact bit_iff_and_push_bit_not_eq_0)

	lemma int_shiftl_numeral [simp]:
	"push_bit (numeral w') (numeral w :: int) = push_bit (pred_numeral w') (numeral (num.Bit0 w))"
	"push_bit (numeral w') (- numeral w :: int) = push_bit (pred_numeral w') (- numeral (num.Bit0 w))"
	by(simp_all add: numeral_eq_Suc shiftl_int_def)
	(metis add_One mult_inc semiring_norm(11) semiring_norm(13) semiring_norm(2) semiring_norm(6) semiring_norm(87))+

	lemma int_shiftl_One_numeral [simp]:
	"push_bit (numeral w) (1::int) = push_bit (pred_numeral w) 2"
	using int_shiftl_numeral [of Num.One w]
	by (simp only: numeral_eq_Suc push_bit_Suc) simp

	lemma shiftl_ge_0: fixes i :: int shows "push_bit n i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
	by (fact push_bit_nonnegative_int_iff)

	lemma shiftl_lt_0: fixes i :: int shows "push_bit n i < 0 \<longleftrightarrow> i < 0"
	by (fact push_bit_negative_int_iff)

	lemma int_shiftl_test_bit: "bit (push_bit i n :: int) m \<longleftrightarrow> m \<ge> i \<and> bit n (m - i)"
	by (fact bit_push_bit_iff_int)

	lemma int_0shiftr: "drop_bit x (0 :: int) = 0"
	by (fact drop_bit_of_0)

	lemma int_minus1_shiftr: "drop_bit x (-1 :: int) = -1"
	by (fact drop_bit_minus_one)

	lemma int_shiftr_ge_0: fixes i :: int shows "drop_bit n i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
	by (fact drop_bit_nonnegative_int_iff)

	lemma int_shiftr_lt_0 [simp]: fixes i :: int shows "drop_bit n i < 0 \<longleftrightarrow> i < 0"
	by (fact drop_bit_negative_int_iff)

	lemma int_shiftr_numeral [simp]:
	"drop_bit (numeral w') (1 :: int) = 0"
	"drop_bit (numeral w') (numeral num.One :: int) = 0"
	"drop_bit (numeral w') (numeral (num.Bit0 w) :: int) = drop_bit (pred_numeral w') (numeral w)"
	"drop_bit (numeral w') (numeral (num.Bit1 w) :: int) = drop_bit (pred_numeral w') (numeral w)"
	"drop_bit (numeral w') (- numeral (num.Bit0 w) :: int) = drop_bit (pred_numeral w') (- numeral w)"
	"drop_bit (numeral w') (- numeral (num.Bit1 w) :: int) = drop_bit (pred_numeral w') (- numeral (Num.inc w))"
	by (simp_all add: numeral_eq_Suc add_One drop_bit_Suc)

	lemma int_shiftr_numeral_Suc0 [simp]:
	"drop_bit (Suc 0) (1 :: int) = 0"
	"drop_bit (Suc 0) (numeral num.One :: int) = 0"
	"drop_bit (Suc 0) (numeral (num.Bit0 w) :: int) = numeral w"
	"drop_bit (Suc 0) (numeral (num.Bit1 w) :: int) = numeral w"
	"drop_bit (Suc 0) (- numeral (num.Bit0 w) :: int) = - numeral w"
	"drop_bit (Suc 0) (- numeral (num.Bit1 w) :: int) = - numeral (Num.inc w)"
	by (simp_all add: drop_bit_Suc add_One)

	lemma bin_nth_minus_p2:
	assumes sign: "bin_sign x = 0"
	- and y: "y = push_bit n 1"
	- and m: "m < n"
	- and x: "x < y"
	+ and y: "y = push_bit n 1"
	+ and m: "m < n"
	+ and x: "x < y"
	shows "bit (x - y) m = bit x m"
	proof -
	- from sign y x have \<open>x \<ge> 0\<close> and \<open>y = 2 ^ n\<close> and \<open>x < 2 ^ n\<close>
	- by (simp_all add: bin_sign_def push_bit_eq_mult split: if_splits)
	- from \<open>0 \<le> x\<close> \<open>x < 2 ^ n\<close> \<open>m < n\<close> have \<open>bit x m \<longleftrightarrow> bit (x - 2 ^ n) m\<close>
	- proof (induction m arbitrary: x n)
	- case 0
	- then show ?case
	- by simp
	- next
	- case (Suc m)
	- moreover define q where \<open>q = n - 1\<close>
	- ultimately have n: \<open>n = Suc q\<close>
	- by simp
	- have \<open>(x - 2 ^ Suc q) div 2 = x div 2 - 2 ^ q\<close>
	- by simp
	- moreover from Suc.IH [of \<open>x div 2\<close> q] Suc.prems
	- have \<open>bit (x div 2) m \<longleftrightarrow> bit (x div 2 - 2 ^ q) m\<close>
	- by (simp add: n)
	- ultimately show ?case
	- by (simp add: bit_Suc n)
	- qed
	- with \<open>y = 2 ^ n\<close> show ?thesis
	+ from \<open>bin_sign x = 0\<close> have \<open>x \<ge> 0\<close>
	+ by (simp add: sign_Pls_ge_0)
	+ moreover from x y have \<open>x < 2 ^ n\<close>
	by simp
	+ ultimately have \<open>q < n\<close> if \<open>bit x q\<close> for q
	+ using that by (metis bit_take_bit_iff take_bit_int_eq_self)
	+ then have \<open>bit (x + NOT (mask n)) m = bit x m\<close>
	+ using \<open>m < n\<close> by (simp add: disjunctive_add bit_simps)
	+ also have \<open>x + NOT (mask n) = x - y\<close>
	+ using y by (simp flip: minus_exp_eq_not_mask)
	+ finally show ?thesis .
	qed

	lemma bin_clr_conv_NAND:
	"bin_sc n False i = i AND NOT (push_bit n 1)"
	by (rule bit_eqI) (auto simp add: bin_sc_eq bit_simps)

	lemma bin_set_conv_OR:
	"bin_sc n True i = i OR (push_bit n 1)"
	by (rule bit_eqI) (auto simp add: bin_sc_eq bit_simps)

	end


	subsection \<open>More lemmas on words\<close>

	lemma msb_conv_bin_sign:
	"msb x \<longleftrightarrow> bin_sign x = -1"
	by (simp add: bin_sign_def not_le msb_int_def)

	lemma msb_bin_sc:
	"msb (bin_sc n b x) \<longleftrightarrow> msb x"
	by (simp add: msb_conv_bin_sign)

	lemma msb_word_def:
	\<open>msb a \<longleftrightarrow> bin_sign (signed_take_bit (LENGTH('a) - 1) (uint a)) = - 1\<close>
	for a :: \<open>'a::len word\<close>
	by (simp add: bin_sign_def bit_simps msb_word_iff_bit)

	lemma word_msb_def:
	"msb a \<longleftrightarrow> bin_sign (sint a) = - 1"
	by (simp add: msb_word_def sint_uint)

	lemma word_rcat_eq:
	\<open>word_rcat ws = word_of_int (bin_rcat (LENGTH('a::len)) (map uint ws))\<close>
	for ws :: \<open>'a::len word list\<close>
	apply (simp add: word_rcat_def bin_rcat_def rev_map)
	apply transfer
	apply (simp add: horner_sum_foldr foldr_map comp_def)
	done

	lemma sign_uint_Pls [simp]: "bin_sign (uint x) = 0"
	by (simp add: sign_Pls_ge_0)

	lemmas bin_log_bintrs = bin_trunc_not bin_trunc_xor bin_trunc_and bin_trunc_or

	\<comment> \<open>following definitions require both arithmetic and bit-wise word operations\<close>

	\<comment> \<open>to get \<open>word_no_log_defs\<close> from \<open>word_log_defs\<close>, using \<open>bin_log_bintrs\<close>\<close>
	lemmas wils1 = bin_log_bintrs [THEN word_of_int_eq_iff [THEN iffD2],
	folded uint_word_of_int_eq, THEN eq_reflection]

	\<comment> \<open>the binary operations only\<close> (* BH: why is this needed? *)
	lemmas word_log_binary_defs =
	word_and_def word_or_def word_xor_def

	lemma setBit_no: "Bit_Operations.set_bit n (numeral bin) = word_of_int (bin_sc n True (numeral bin))"
	by (rule bit_word_eqI) (simp add: bit_simps)

	lemma clearBit_no:
	"unset_bit n (numeral bin) = word_of_int (bin_sc n False (numeral bin))"
	by (rule bit_word_eqI) (simp add: bit_simps)

	lemma eq_mod_iff: "0 < n \<Longrightarrow> b = b mod n \<longleftrightarrow> 0 \<le> b \<and> b < n"
	for b n :: int
	by auto (metis pos_mod_conj)+

	lemma split_uint_lem: "bin_split n (uint w) = (a, b) \<Longrightarrow>
	a = take_bit (LENGTH('a) - n) a \<and> b = take_bit (LENGTH('a)) b"
	for w :: "'a::len word"
	by transfer (simp add: drop_bit_take_bit ac_simps)

	\<comment> \<open>limited hom result\<close>
	lemma word_cat_hom:
	"LENGTH('a::len) \<le> LENGTH('b::len) + LENGTH('c::len) \<Longrightarrow>
	(word_cat (word_of_int w :: 'b word) (b :: 'c word) :: 'a word) =
	word_of_int ((\<lambda>k n l. concat_bit n l k) w (size b) (uint b))"
	by transfer (simp add: take_bit_concat_bit_eq)

	lemma bintrunc_shiftl:
	"take_bit n (push_bit i m) = push_bit i (take_bit (n - i) m)"
	for m :: int
	by (fact take_bit_push_bit)

	lemma uint_shiftl:
	"uint (push_bit i n) = take_bit (size n) (push_bit i (uint n))"
	by (simp add: unsigned_push_bit_eq word_size)

	lemma bin_mask_conv_pow2:
	"mask n = 2 ^ n - (1 :: int)"
	by (fact mask_eq_exp_minus_1)

	lemma bin_mask_ge0: "mask n \<ge> (0 :: int)"
	by (fact mask_nonnegative_int)

	context
	includes bit_operations_syntax
	begin

	lemma and_bin_mask_conv_mod: "x AND mask n = x mod 2 ^ n"
	for x :: int
	by (simp flip: take_bit_eq_mod add: take_bit_eq_mask)

	end

	lemma bin_mask_numeral:
	"mask (numeral n) = (1 :: int) + 2 * mask (pred_numeral n)"
	by (fact mask_numeral)

	lemma bin_nth_mask: "bit (mask n :: int) i \<longleftrightarrow> i < n"
	by (simp add: bit_mask_iff)

	lemma bin_sign_mask [simp]: "bin_sign (mask n) = 0"
	by (simp add: bin_sign_def bin_mask_conv_pow2)

	lemma bin_mask_p1_conv_shift: "mask n + 1 = push_bit n (1 :: int)"
	by (simp add: bin_mask_conv_pow2 shiftl_int_def)

	lemma sbintrunc_eq_in_range:
	"((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = x) = (x \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n))"
	"(x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x) = (x \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n))"
	apply (simp_all add: image_def)
	apply (metis sbintrunc_sbintrunc)+
	done

	lemma sbintrunc_If:
	"- 3 * (2 ^ n) \<le> x \<and> x < 3 * (2 ^ n)
	\<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (if x < - (2 ^ n) then x + 2 * (2 ^ n)
	else if x \<ge> 2 ^ n then x - 2 * (2 ^ n) else x)"
	apply (simp add: no_sbintr_alt2, safe)
	apply (simp add: mod_pos_geq)
	apply (subst mod_add_self1[symmetric], simp)
	done

	lemma sint_range':
	\<open>- (2 ^ (LENGTH('a) - Suc 0)) \<le> sint x \<and> sint x < 2 ^ (LENGTH('a) - Suc 0)\<close>
	for x :: \<open>'a::len word\<close>
	apply transfer
	using sbintr_ge sbintr_lt apply auto
	done

	lemma signed_arith_eq_checks_to_ord:
	"(sint a + sint b = sint (a + b ))
	= ((a <=s a + b) = (0 <=s b))"
	"(sint a - sint b = sint (a - b ))
	= ((0 <=s a - b) = (b <=s a))"
	"(- sint a = sint (- a)) = (0 <=s (- a) = (a <=s 0))"
	using sint_range'[where x=a] sint_range'[where x=b]
	by (simp_all add: sint_word_ariths word_sle_eq word_sless_alt sbintrunc_If)

	lemma signed_mult_eq_checks_double_size:
	assumes mult_le: "(2 ^ (len_of TYPE ('a) - 1) + 1) ^ 2 \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
	and le: "2 ^ (LENGTH('a) - 1) \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
	shows "(sint (a :: 'a :: len word) * sint b = sint (a * b))
	= (scast a * scast b = (scast (a * b) :: 'b :: len word))"
	proof -
	have P: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (size a - 1) (sint a * sint b) \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (size a - 1))"
	by simp

	have abs: "!! x :: 'a word. abs (sint x) < 2 ^ (size a - 1) + 1"
	apply (cut_tac x=x in sint_range')
	apply (simp add: abs_le_iff word_size)
	done
	have abs_ab: "abs (sint a * sint b) < 2 ^ (LENGTH('b) - 1)"
	using abs_mult_less[OF abs[where x=a] abs[where x=b]] mult_le
	by (simp add: abs_mult power2_eq_square word_size)
	define r s where \<open>r = LENGTH('a) - 1\<close> \<open>s = LENGTH('b) - 1\<close>
	then have \<open>LENGTH('a) = Suc r\<close> \<open>LENGTH('b) = Suc s\<close>
	\<open>size a = Suc r\<close> \<open>size b = Suc r\<close>
	by (simp_all add: word_size)
	then show ?thesis
	using P[unfolded range_sbintrunc] abs_ab le
	apply clarsimp
	apply (transfer fixing: r s)
	apply (auto simp add: signed_take_bit_int_eq_self simp flip: signed_take_bit_eq_iff_take_bit_eq)
	done
	qed

	lemma bintrunc_id:
	"\<lbrakk>m \<le> int n; 0 < m\<rbrakk> \<Longrightarrow> take_bit n m = m"
	by (simp add: take_bit_int_eq_self_iff le_less_trans)

	lemma bin_cat_cong: "concat_bit n b a = concat_bit m d c"
	if "n = m" "a = c" "take_bit m b = take_bit m d"
	using that(3) unfolding that(1,2)
	by (simp add: bin_cat_eq_push_bit_add_take_bit)

	lemma bin_cat_eqD1: "concat_bit n b a = concat_bit n d c \<Longrightarrow> a = c"
	by (metis drop_bit_bin_cat_eq)

	lemma bin_cat_eqD2: "concat_bit n b a = concat_bit n d c \<Longrightarrow> take_bit n b = take_bit n d"
	by (metis take_bit_bin_cat_eq)

	lemma bin_cat_inj: "(concat_bit n b a) = concat_bit n d c \<longleftrightarrow> a = c \<and> take_bit n b = take_bit n d"
	by (auto intro: bin_cat_cong bin_cat_eqD1 bin_cat_eqD2)

	lemma bin_sc_pos:
	"0 \<le> i \<Longrightarrow> 0 \<le> bin_sc n b i"
	by (metis bin_sign_sc sign_Pls_ge_0)

	code_identifier
	code_module Bits_Int \<rightharpoonup>
	(SML) Bit_Operations and (OCaml) Bit_Operations and (Haskell) Bit_Operations and (Scala) Bit_Operations

	end
	diff --git a/thys/Word_Lib/Guide.thy b/thys/Word_Lib/Guide.thy
	--- a/thys/Word_Lib/Guide.thy
	+++ b/thys/Word_Lib/Guide.thy
	@@ -1,420 +1,424 @@
	(*
	* Copyright Florian Haftmann
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	(<)
	theory Guide
	- imports Word_Lib_Sumo Machine_Word_32 Machine_Word_64 Ancient_Numeral
	+ imports Word_Lib_Sumo Machine_Word_32 Machine_Word_64
	begin

	context semiring_bit_operations
	begin

	lemma bit_eq_iff:
	\<open>a = b \<longleftrightarrow> (\<forall>n. 2 ^ n \<noteq> 0 \<longrightarrow> bit a n \<longleftrightarrow> bit b n)\<close>
	using bit_eq_iff [of a b] by (simp add: possible_bit_def)

	end

	notation (output) Generic_set_bit.set_bit (\<open>Generic'_set'_bit.set'_bit\<close>)

	hide_const (open) Generic_set_bit.set_bit

	no_notation bit (infixl \<open>!!\<close> 100)

	(>)
	section \<open>A short overview over bit operations and word types\<close>

	subsection \<open>Key principles\<close>

	text \<open>
	When formalizing bit operations, it is tempting to represent
	bit values as explicit lists over a binary type. This however
	is a bad idea, mainly due to the inherent ambiguities in
	representation concerning repeating leading bits.

	Hence this approach avoids such explicit lists altogether
	following an algebraic path:

	\<^item> Bit values are represented by numeric types: idealized
	unbounded bit values can be represented by type \<^typ>\<open>int\<close>,
	bounded bit values by quotient types over \<^typ>\<open>int\<close>, aka \<^typ>\<open>'a word\<close>.

	\<^item> (A special case are idealized unbounded bit values ending
	in @{term [source] 0} which can be represented by type \<^typ>\<open>nat\<close> but
	only support a restricted set of operations).

	The fundamental principles are developed in theory \<^theory>\<open>HOL.Bit_Operations\<close>
	(which is part of \<^theory>\<open>Main\<close>):

	\<^item> Multiplication by \<^term>\<open>2 :: int\<close> is a bit shift to the left and

	\<^item> Division by \<^term>\<open>2 :: int\<close> is a bit shift to the right.

	\<^item> Concerning bounded bit values, iterated shifts to the left
	may result in eliminating all bits by shifting them all
	beyond the boundary. The property \<^prop>\<open>(2 :: int) ^ n \<noteq> 0\<close>
	represents that \<^term>\<open>n\<close> is \<^emph>\<open>not\<close> beyond that boundary.

	\<^item> The projection on a single bit is then @{thm [mode=iff] bit_iff_odd [where ?'a = int, no_vars]}.

	\<^item> This leads to the most fundamental properties of bit values:

	\<^item> Equality rule: @{thm [display, mode=iff] bit_eq_iff [where ?'a = int, no_vars]}

	\<^item> Induction rule: @{thm [display, mode=iff] bits_induct [where ?'a = int, no_vars]}

	\<^item> Characteristic properties @{prop [source] \<open>bit (f x) n \<longleftrightarrow> P x n\<close>}
	are available in fact collection \<^text>\<open>bit_simps\<close>.

	On top of this, the following generic operations are provided:

	\<^item> Singleton \<^term>\<open>n\<close>th bit: \<^term>\<open>(2 :: int) ^ n\<close>

	\<^item> Bit mask upto bit \<^term>\<open>n\<close>: @{thm mask_eq_exp_minus_1 [where ?'a = int, no_vars]}

	\<^item> Left shift: @{thm push_bit_eq_mult [where ?'a = int, no_vars]}

	\<^item> Right shift: @{thm drop_bit_eq_div [where ?'a = int, no_vars]}

	\<^item> Truncation: @{thm take_bit_eq_mod [where ?'a = int, no_vars]}

	\<^item> Bitwise negation: @{thm [mode=iff] bit_not_iff_eq [where ?'a = int, no_vars]}

	\<^item> Bitwise conjunction: @{thm [mode=iff] bit_and_iff [where ?'a = int, no_vars]}

	\<^item> Bitwise disjunction: @{thm [mode=iff] bit_or_iff [where ?'a = int, no_vars]}

	\<^item> Bitwise exclusive disjunction: @{thm [mode=iff] bit_xor_iff [where ?'a = int, no_vars]}

	\<^item> Setting a single bit: @{thm set_bit_def [where ?'a = int, no_vars]}

	\<^item> Unsetting a single bit: @{thm unset_bit_def [where ?'a = int, no_vars]}

	\<^item> Flipping a single bit: @{thm flip_bit_def [where ?'a = int, no_vars]}

	\<^item> Signed truncation, or modulus centered around \<^term>\<open>0::int\<close>:
	@{thm [display] signed_take_bit_def [where ?'a = int, no_vars]}

	\<^item> (Bounded) conversion from and to a list of bits:
	@{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}

	Bit concatenation on \<^typ>\<open>int\<close> as given by
	@{thm [display] concat_bit_def [no_vars]}
	appears quite
	technical but is the logical foundation for the quite natural bit concatenation
	on \<^typ>\<open>'a word\<close> (see below).
	\<close>

	subsection \<open>Core word theory\<close>

	text \<open>
	Proper word types are introduced in theory \<^theory>\<open>HOL-Library.Word\<close>, with
	the following specific operations:

	\<^item> Standard arithmetic:
	@{term \<open>(+) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
	@{term \<open>uminus :: 'a::len word \<Rightarrow> 'a word\<close>},
	@{term \<open>(-) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
	@{term \<open>(*) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
	@{term \<open>0 :: 'a::len word\<close>}, @{term \<open>1 :: 'a::len word\<close>}, numerals etc.

	\<^item> Standard bit operations: see above.

	\<^item> Conversion with unsigned interpretation of words:

	\<^item> @{term [source] \<open>unsigned :: 'a::len word \<Rightarrow> 'b::semiring_1\<close>}

	\<^item> Important special cases as abbreviations:

	\<^item> @{term [source] \<open>unat :: 'a::len word \<Rightarrow> nat\<close>}

	\<^item> @{term [source] \<open>uint :: 'a::len word \<Rightarrow> int\<close>}

	\<^item> @{term [source] \<open>ucast :: 'a::len word \<Rightarrow> 'b::len word\<close>}

	\<^item> Conversion with signed interpretation of words:

	\<^item> @{term [source] \<open>signed :: 'a::len word \<Rightarrow> 'b::ring_1\<close>}

	\<^item> Important special cases as abbreviations:

	\<^item> @{term [source] \<open>sint :: 'a::len word \<Rightarrow> int\<close>}

	\<^item> @{term [source] \<open>scast :: 'a::len word \<Rightarrow> 'b::len word\<close>}

	\<^item> Operations with unsigned interpretation of words:

	\<^item> @{thm [mode=iff] word_le_nat_alt [no_vars]}

	\<^item> @{thm [mode=iff] word_less_nat_alt [no_vars]}

	\<^item> @{thm unat_div_distrib [no_vars]}

	\<^item> @{thm unat_drop_bit_eq [no_vars]}

	\<^item> @{thm unat_mod_distrib [no_vars]}

	\<^item> @{thm [mode=iff] udvd_iff_dvd [no_vars]}

	\<^item> Operations with signed interpretation of words:

	\<^item> @{thm [mode=iff] word_sle_eq [no_vars]}

	\<^item> @{thm [mode=iff] word_sless_alt [no_vars]}

	\<^item> @{thm sint_signed_drop_bit_eq [no_vars]}

	\<^item> Rotation and reversal:

	\<^item> @{term [source] \<open>word_rotl :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

	\<^item> @{term [source] \<open>word_rotr :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

	\<^item> @{term [source] \<open>word_roti :: int \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

	\<^item> @{term [source] \<open>word_reverse :: 'a::len word \<Rightarrow> 'a word\<close>}

	\<^item> Concatenation: @{term [source, display] \<open>word_cat :: 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'c::len word\<close>}

	For proofs about words the following default strategies are applicable:

	\<^item> Using bit extensionality (facts \<^text>\<open>bit_eq_iff\<close>, \<^text>\<open>bit_word_eqI\<close>; fact
	collection \<^text>\<open>bit_simps\<close>).

	\<^item> Using the @{method transfer} method.
	\<close>


	subsection \<open>More library theories\<close>

	text \<open>
	Note: currently, most theories listed here are hardly separate
	entities since they import each other in various ways.
	Always inspect them to understand what you pull in if you
	want to import one.

	\<^descr>[Syntax]

	\<^descr>[\<^theory>\<open>Word_Lib.Syntax_Bundles\<close>]
	Bundles to provide alternative syntax for various bit operations.

	\<^descr>[\<^theory>\<open>Word_Lib.Hex_Words\<close>]
	Printing word numerals as hexadecimal numerals.

	\<^descr>[\<^theory>\<open>Word_Lib.Type_Syntax\<close>]
	Pretty type-sensitive syntax for cast operations.

	\<^descr>[\<^theory>\<open>Word_Lib.Word_Syntax\<close>]
	Specific ASCII syntax for prominent bit operations on word.

	\<^descr>[Proof tools]

	\<^descr>[\<^theory>\<open>Word_Lib.Norm_Words\<close>]
	Rewriting word numerals to normal forms.

	\<^descr>[\<^theory>\<open>Word_Lib.Bitwise\<close>]
	Method @{method word_bitwise} decomposes word equalities and inequalities into bit propositions.

	\<^descr>[\<^theory>\<open>Word_Lib.Bitwise_Signed\<close>]
	Method @{method word_bitwise_signed} decomposes word equalities and inequalities into bit propositions.

	\<^descr>[\<^theory>\<open>Word_Lib.Word_EqI\<close>]
	Method @{method word_eqI_solve} decomposes word equalities and inequalities into bit propositions.

	\<^descr>[Operations]

	\<^descr>[\<^theory>\<open>Word_Lib.Signed_Division_Word\<close>]

	Signed division on word:

	\<^item> @{term [source] \<open>(sdiv) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}

	\<^item> @{term [source] \<open>(smod) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}

	\<^descr>[\<^theory>\<open>Word_Lib.Aligned\<close>] \

	\<^item> @{thm [mode=iff] is_aligned_iff_udvd [no_vars]}

	\<^descr>[\<^theory>\<open>Word_Lib.Least_significant_bit\<close>]

	The least significant bit as an alias:
	@{thm [mode=iff] lsb_odd [where ?'a = int, no_vars]}

	\<^descr>[\<^theory>\<open>Word_Lib.Most_significant_bit\<close>]

	The most significant bit:

	\<^item> @{thm [mode=iff] msb_int_def [of k]}

	\<^item> @{thm [mode=iff] word_msb_sint [no_vars]}

	\<^item> @{thm [mode=iff] msb_word_iff_sless_0 [no_vars]}

	\<^item> @{thm [mode=iff] msb_word_iff_bit [no_vars]}

	\<^descr>[\<^theory>\<open>Word_Lib.Bit_Shifts_Infix_Syntax\<close>]

	Bit shifts decorated with infix syntax:

	\<^item> @{thm Bit_Shifts_Infix_Syntax.shiftl_def [no_vars]}

	\<^item> @{thm Bit_Shifts_Infix_Syntax.shiftr_def [no_vars]}

	\<^item> @{thm Bit_Shifts_Infix_Syntax.sshiftr_def [no_vars]}

	\<^descr>[\<^theory>\<open>Word_Lib.Next_and_Prev\<close>] \

	\<^item> @{thm word_next_unfold [no_vars]}

	\<^item> @{thm word_prev_unfold [no_vars]}

	\<^descr>[\<^theory>\<open>Word_Lib.Enumeration_Word\<close>]

	More on explicit enumeration of word types.

	\<^descr>[\<^theory>\<open>Word_Lib.More_Word_Operations\<close>]

	Even more operations on word.

	\<^descr>[Types]

	\<^descr>[\<^theory>\<open>Word_Lib.Signed_Words\<close>]

	Formal tagging of word types with a \<^text>\<open>signed\<close> marker.

	\<^descr>[Lemmas]

	\<^descr>[\<^theory>\<open>Word_Lib.More_Word\<close>]

	More lemmas on words.

	\<^descr>[\<^theory>\<open>Word_Lib.Word_Lemmas\<close>]

	More lemmas on words, covering many other theories mentioned here.

	\<^descr>[Words of popular lengths].

	\<^descr>[\<^theory>\<open>Word_Lib.Word_8\<close>]

	for 8-bit words.

	\<^descr>[\<^theory>\<open>Word_Lib.Word_16\<close>]

	for 16-bit words.

	\<^descr>[\<^theory>\<open>Word_Lib.Word_32\<close>]

	for 32-bit words.

	\<^descr>[\<^theory>\<open>Word_Lib.Word_64\<close>]

	for 64-bit words. This theory is not part of \<^text>\<open>Word_Lib_Sumo\<close>, because it shadows
	names from \<^theory>\<open>Word_Lib.Word_32\<close>. They can be used together, but then will have
	to use qualified names in applications.

	\<^descr>[\<^theory>\<open>Word_Lib.Machine_Word_32\<close> and \<^theory>\<open>Word_Lib.Machine_Word_64\<close>]

	provide lemmas for 32-bit words and 64-bit words under the same name,
	which can help to organize applications relying on some form
	of genericity.
	\<close>


	subsection \<open>More library sessions\<close>

	text \<open>
	\<^descr>[\<^text>\<open>Native_Word\<close>] Makes machine words and machine arithmetic available for code generation.
	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.
	\<close>

	subsection \<open>Legacy theories\<close>

	text \<open>
	The following theories contain material which has been
	factored out since it is not recommended to use it in
	new applications, mostly because matters can be expressed
	succinctly using already existing operations.

	This section gives some indication how to migrate away
	from those theories. However theorem coverage may still
	be terse in some cases.

	\<^descr>[\<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>]

	An entry point importing any relevant theory in that session. Intended
	for backward compatibility: start importing this theory when
	migrating applications to Isabelle2021, and later sort out
	what you really need. You may need to include
	\<^theory>\<open>Word_Lib.Word_64\<close> separately.

	\<^descr>[\<^theory>\<open>Word_Lib.Generic_set_bit\<close>]

	Kind of an alias: @{thm set_bit_eq [no_vars]}

	\<^descr>[\<^theory>\<open>Word_Lib.Typedef_Morphisms\<close>]

	A low-level extension to HOL typedef providing
	conversions along type morphisms. The @{method transfer} method
	seems to be sufficient for most applications though.

	\<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension\<close>]

	Comprehension syntax for bit values over predicates
	\<^typ>\<open>nat \<Rightarrow> bool\<close>. For \<^typ>\<open>'a::len word\<close>, straightforward
	alternatives exist; difficult to handle for \<^typ>\<open>int\<close>.

	\<^descr>[\<^theory>\<open>Word_Lib.Reversed_Bit_Lists\<close>]

	Representation of bit values as explicit list in
	\<^emph>\<open>reversed\<close> order.

	This should rarely be necessary: the \<^const>\<open>bit\<close> projection
	should be sufficient in most cases. In case explicit lists
	are needed, existing operations can be used:

	@{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}

	\<^descr>[\<^theory>\<open>Word_Lib.Many_More\<close>]

	Collection of operations and theorems which are kept for backward
	compatibility and not used in other theories in session \<^text>\<open>Word_Lib\<close>.
	They are used in applications of \<^text>\<open>Word_Lib\<close>, but should be migrated to there.
	\<close>

	section \<open>Changelog\<close>

	text \<open>
	+ \<^descr>[Changes since AFP 2022] ~
	+
	+ \<^item> Theory \<^text>\<open>Word_Lib.Ancient_Numeral\<close> has been removed from session.
	+
	\<^descr>[Changes since AFP 2021] ~

	- \<^item> Theory \<^theory>\<open>Word_Lib.Ancient_Numeral\<close> is not part of \<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>
	+ \<^item> Theory \<^text>\<open>Word_Lib.Ancient_Numeral\<close> is not part of \<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>
	any longer.

	\<^item> Infix syntax for \<^term>\<open>(AND)\<close>, \<^term>\<open>(OR)\<close>, \<^term>\<open>(XOR)\<close> organized in
	syntax bundle \<^bundle>\<open>bit_operations_syntax\<close>.

	\<^item> Abbreviation \<^abbrev>\<open>max_word\<close> moved from distribution into theory
	\<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.

	\<^item> Operation \<^const>\<open>test_bit\<close> replaced by input abbreviation \<^abbrev>\<open>test_bit\<close>.

	\<^item> Abbreviations \<^abbrev>\<open>bin_nth\<close>, \<^abbrev>\<open>bin_last\<close>, \<^abbrev>\<open>bin_rest\<close>,
	\<^abbrev>\<open>bintrunc\<close>, \<^abbrev>\<open>sbintrunc\<close>, \<^abbrev>\<open>norm_sint\<close>,
	\<^abbrev>\<open>bin_cat\<close> moved into theory \<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.

	\<^item> Operations \<^abbrev>\<open>bshiftr1\<close>,
	\<^abbrev>\<open>setBit\<close>, \<^abbrev>\<open>clearBit\<close> moved from distribution into theory
	\<^theory>\<open>Word_Lib.Legacy_Aliases\<close> and replaced by input abbreviations.

	\<^item> Operations \<^const>\<open>shiftl1\<close>, \<^const>\<open>shiftr1\<close>, \<^const>\<open>sshiftr1\<close>
	moved here from distribution.

	\<^item> Operation \<^const>\<open>complement\<close> replaced by input abbreviation \<^abbrev>\<open>complement\<close>.
	\<close>

	(<)
	end
	(>)
	diff --git a/thys/Word_Lib/Least_significant_bit.thy b/thys/Word_Lib/Least_significant_bit.thy
	--- a/thys/Word_Lib/Least_significant_bit.thy
	+++ b/thys/Word_Lib/Least_significant_bit.thy
	@@ -1,94 +1,94 @@
	(*
	* Copyright Data61, CSIRO (ABN 41 687 119 230)
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	(* Author: Jeremy Dawson, NICTA *)

	section \<open>Operation variant for the least significant bit\<close>

	theory Least_significant_bit
	imports
	"HOL-Library.Word"
	More_Word
	begin

	class lsb = semiring_bits +
	fixes lsb :: \<open>'a \<Rightarrow> bool\<close>
	assumes lsb_odd: \<open>lsb = odd\<close>

	instantiation int :: lsb
	begin

	definition lsb_int :: \<open>int \<Rightarrow> bool\<close>
	where \<open>lsb i = bit i 0\<close> for i :: int

	instance
	- by standard (simp add: fun_eq_iff lsb_int_def)
	+ by standard (simp add: fun_eq_iff lsb_int_def bit_0)

	end

	lemma bin_last_conv_lsb: "odd = (lsb :: int \<Rightarrow> bool)"
	by (simp add: lsb_odd)

	lemma int_lsb_numeral [simp]:
	"lsb (0 :: int) = False"
	"lsb (1 :: int) = True"
	"lsb (Numeral1 :: int) = True"
	"lsb (- 1 :: int) = True"
	"lsb (- Numeral1 :: int) = True"
	"lsb (numeral (num.Bit0 w) :: int) = False"
	"lsb (numeral (num.Bit1 w) :: int) = True"
	"lsb (- numeral (num.Bit0 w) :: int) = False"
	"lsb (- numeral (num.Bit1 w) :: int) = True"
	- by (simp_all add: lsb_int_def)
	+ by (simp_all add: lsb_int_def bit_0)

	instantiation word :: (len) lsb
	begin

	definition lsb_word :: \<open>'a word \<Rightarrow> bool\<close>
	where word_lsb_def: \<open>lsb a \<longleftrightarrow> odd (uint a)\<close> for a :: \<open>'a word\<close>

	instance
	apply standard
	apply (simp add: fun_eq_iff word_lsb_def)
	apply transfer apply simp
	done

	end

	lemma lsb_word_eq:
	\<open>lsb = (odd :: 'a word \<Rightarrow> bool)\<close> for w :: \<open>'a::len word\<close>
	by (fact lsb_odd)

	lemma word_lsb_alt: "lsb w = bit w 0"
	for w :: "'a::len word"
	- by (simp add: lsb_word_eq)
	+ by (simp add: lsb_word_eq bit_0)

	lemma word_lsb_1_0 [simp]: "lsb (1::'a::len word) \<and> \<not> lsb (0::'b::len word)"
	unfolding word_lsb_def by simp

	lemma word_lsb_int: "lsb w \<longleftrightarrow> uint w mod 2 = 1"
	apply (simp add: lsb_odd flip: odd_iff_mod_2_eq_one)
	apply transfer
	apply simp
	done

	lemmas word_ops_lsb = lsb0 [unfolded word_lsb_alt]

	lemma word_lsb_numeral [simp]:
	"lsb (numeral bin :: 'a::len word) \<longleftrightarrow> odd (numeral bin :: int)"
	by (simp only: lsb_odd, transfer) rule

	lemma word_lsb_neg_numeral [simp]:
	"lsb (- numeral bin :: 'a::len word) \<longleftrightarrow> odd (- numeral bin :: int)"
	by (simp only: lsb_odd, transfer) rule

	lemma word_lsb_nat:"lsb w = (unat w mod 2 = 1)"
	apply (simp add: word_lsb_def Groebner_Basis.algebra(31))
	apply transfer
	apply (simp add: even_nat_iff)
	done

	end
	diff --git a/thys/Word_Lib/More_Word.thy b/thys/Word_Lib/More_Word.thy
	--- a/thys/Word_Lib/More_Word.thy
	+++ b/thys/Word_Lib/More_Word.thy
	@@ -1,2563 +1,2546 @@
	(*
	* Copyright Data61, CSIRO (ABN 41 687 119 230)
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	section \<open>Lemmas on words\<close>

	theory More_Word
	imports
	"HOL-Library.Word"
	More_Arithmetic
	More_Divides
	begin

	-context unique_euclidean_semiring_with_bit_operations \<comment>\<open>TODO: move\<close>
	-begin
	-
	-lemma possible_bit [simp]:
	- \<open>possible_bit TYPE('a) n\<close>
	- by (simp add: possible_bit_def)
	-
	-lemma drop_bit_mask_eq:
	- \<open>drop_bit m (mask n) = mask (n - m)\<close>
	- by (rule bit_eqI) (auto simp add: bit_simps possible_bit_def)
	-
	-end
	-
	context
	includes bit_operations_syntax
	begin

	\<comment> \<open>problem posed by TPHOLs referee:
	criterion for overflow of addition of signed integers\<close>

	lemma sofl_test:
	\<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
	drop_bit (size x - 1) ((x + y XOR x) AND (x + y XOR y)) = 0\<close>
	for x y :: \<open>'a::len word\<close>
	proof -
	obtain n where n: \<open>LENGTH('a) = Suc n\<close>
	by (cases \<open>LENGTH('a)\<close>) simp_all
	have *: \<open>sint x + sint y + 2 ^ Suc n > signed_take_bit n (sint x + sint y) \<Longrightarrow> sint x + sint y \<ge> - (2 ^ n)\<close>
	\<open>signed_take_bit n (sint x + sint y) > sint x + sint y - 2 ^ Suc n \<Longrightarrow> 2 ^ n > sint x + sint y\<close>
	using signed_take_bit_int_greater_eq [of \<open>sint x + sint y\<close> n] signed_take_bit_int_less_eq [of n \<open>sint x + sint y\<close>]
	by (auto intro: ccontr)
	have \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
	(sint (x + y) < 0 \<longleftrightarrow> sint x < 0) \<or>
	(sint (x + y) < 0 \<longleftrightarrow> sint y < 0)\<close>
	using sint_less [of x] sint_greater_eq [of x] sint_less [of y] sint_greater_eq [of y]
	signed_take_bit_int_eq_self [of \<open>LENGTH('a) - 1\<close> \<open>sint x + sint y\<close>]
	apply (auto simp add: not_less)
	apply (unfold sint_word_ariths)
	apply (subst signed_take_bit_int_eq_self)
	prefer 4
	apply (subst signed_take_bit_int_eq_self)
	prefer 7
	apply (subst signed_take_bit_int_eq_self)
	prefer 10
	apply (subst signed_take_bit_int_eq_self)
	apply (auto simp add: signed_take_bit_int_eq_self signed_take_bit_eq_take_bit_minus take_bit_Suc_from_most n not_less intro!: *)
	- apply (smt (z3) take_bit_nonnegative)
	- apply (smt (z3) take_bit_int_less_exp)
	- apply (smt (z3) take_bit_nonnegative)
	- apply (smt (z3) take_bit_int_less_exp)
	done
	then show ?thesis
	apply (simp only: One_nat_def word_size drop_bit_eq_zero_iff_not_bit_last bit_and_iff bit_xor_iff)
	apply (simp add: bit_last_iff)
	done
	qed

	lemma unat_power_lower [simp]:
	"unat ((2::'a::len word) ^ n) = 2 ^ n" if "n < LENGTH('a::len)"
	using that by transfer simp

	lemma unat_p2: "n < LENGTH('a :: len) \<Longrightarrow> unat (2 ^ n :: 'a word) = 2 ^ n"
	by (fact unat_power_lower)

	lemma word_div_lt_eq_0:
	"x < y \<Longrightarrow> x div y = 0" for x :: "'a :: len word"
	by transfer simp

	lemma word_div_eq_1_iff: "n div m = 1 \<longleftrightarrow> n \<ge> m \<and> unat n < 2 * unat (m :: 'a :: len word)"
	apply (simp only: word_arith_nat_defs word_le_nat_alt word_of_nat_eq_iff flip: nat_div_eq_Suc_0_iff)
	apply (simp flip: unat_div unsigned_take_bit_eq)
	done

	lemma AND_twice [simp]:
	"(w AND m) AND m = w AND m"
	by (fact and.right_idem)

	lemma word_combine_masks:
	"w AND m = z \<Longrightarrow> w AND m' = z' \<Longrightarrow> w AND (m OR m') = (z OR z')"
	for w m m' z z' :: \<open>'a::len word\<close>
	by (simp add: bit.conj_disj_distrib)

	lemma p2_gt_0:
	"(0 < (2 ^ n :: 'a :: len word)) = (n < LENGTH('a))"
	by (simp add : word_gt_0 not_le)

	lemma uint_2p_alt:
	\<open>n < LENGTH('a::len) \<Longrightarrow> uint ((2::'a::len word) ^ n) = 2 ^ n\<close>
	using p2_gt_0 [of n, where ?'a = 'a] by (simp add: uint_2p)

	lemma p2_eq_0:
	\<open>(2::'a::len word) ^ n = 0 \<longleftrightarrow> LENGTH('a::len) \<le> n\<close>
	by (fact exp_eq_zero_iff)

	lemma p2len:
	\<open>(2 :: 'a word) ^ LENGTH('a::len) = 0\<close>
	by simp

	lemma neg_mask_is_div:
	"w AND NOT (mask n) = (w div 2^n) * 2^n"
	for w :: \<open>'a::len word\<close>
	by (rule bit_word_eqI)
	(auto simp add: bit_simps simp flip: push_bit_eq_mult drop_bit_eq_div)

	lemma neg_mask_is_div':
	"n < size w \<Longrightarrow> w AND NOT (mask n) = ((w div (2 ^ n)) * (2 ^ n))"
	for w :: \<open>'a::len word\<close>
	by (rule neg_mask_is_div)

	lemma and_mask_arith:
	"w AND mask n = (w * 2^(size w - n)) div 2^(size w - n)"
	for w :: \<open>'a::len word\<close>
	by (rule bit_word_eqI)
	(auto simp add: bit_simps word_size simp flip: push_bit_eq_mult drop_bit_eq_div)

	lemma and_mask_arith':
	"0 < n \<Longrightarrow> w AND mask n = (w * 2^(size w - n)) div 2^(size w - n)"
	for w :: \<open>'a::len word\<close>
	by (rule and_mask_arith)

	lemma mask_2pm1: "mask n = 2 ^ n - (1 :: 'a::len word)"
	by (fact mask_eq_decr_exp)

	lemma add_mask_fold:
	"x + 2 ^ n - 1 = x + mask n"
	for x :: \<open>'a::len word\<close>
	by (simp add: mask_eq_decr_exp)

	lemma word_and_mask_le_2pm1: "w AND mask n \<le> 2 ^ n - 1"
	for w :: \<open>'a::len word\<close>
	by (simp add: mask_2pm1[symmetric] word_and_le1)

	lemma is_aligned_AND_less_0:
	"u AND mask n = 0 \<Longrightarrow> v < 2^n \<Longrightarrow> u AND v = 0"
	for u v :: \<open>'a::len word\<close>
	apply (drule less_mask_eq)
	apply (simp flip: take_bit_eq_mask)
	apply (simp add: bit_eq_iff)
	apply (auto simp add: bit_simps)
	done

	lemma and_mask_eq_iff_le_mask:
	\<open>w AND mask n = w \<longleftrightarrow> w \<le> mask n\<close>
	for w :: \<open>'a::len word\<close>
	apply (simp flip: take_bit_eq_mask)
	apply (cases \<open>n \<ge> LENGTH('a)\<close>; transfer)
	apply (simp_all add: not_le min_def)
	apply (simp_all add: mask_eq_exp_minus_1)
	apply auto
	apply (metis take_bit_int_less_exp)
	apply (metis min_def nat_less_le take_bit_int_eq_self_iff take_bit_take_bit)
	done

	lemma less_eq_mask_iff_take_bit_eq_self:
	\<open>w \<le> mask n \<longleftrightarrow> take_bit n w = w\<close>
	for w :: \<open>'a::len word\<close>
	by (simp add: and_mask_eq_iff_le_mask take_bit_eq_mask)

	lemma NOT_eq:
	"NOT (x :: 'a :: len word) = - x - 1"
	apply (cut_tac x = "x" in word_add_not)
	apply (drule add.commute [THEN trans])
	apply (drule eq_diff_eq [THEN iffD2])
	by simp

	lemma NOT_mask: "NOT (mask n :: 'a::len word) = - (2 ^ n)"
	by (simp add : NOT_eq mask_2pm1)

	lemma le_m1_iff_lt: "(x > (0 :: 'a :: len word)) = ((y \<le> x - 1) = (y < x))"
	by uint_arith

	lemma gt0_iff_gem1:
	\<open>0 < x \<longleftrightarrow> x - 1 < x\<close>
	for x :: \<open>'a::len word\<close>
	by (metis add.right_neutral diff_add_cancel less_irrefl measure_unat unat_arith_simps(2) word_neq_0_conv word_sub_less_iff)

	lemma power_2_ge_iff:
	\<open>2 ^ n - (1 :: 'a::len word) < 2 ^ n \<longleftrightarrow> n < LENGTH('a)\<close>
	using gt0_iff_gem1 p2_gt_0 by blast

	lemma le_mask_iff_lt_2n:
	"n < len_of TYPE ('a) = (((w :: 'a :: len word) \<le> mask n) = (w < 2 ^ n))"
	unfolding mask_2pm1 by (rule trans [OF p2_gt_0 [THEN sym] le_m1_iff_lt])

	lemma mask_lt_2pn:
	\<open>n < LENGTH('a) \<Longrightarrow> mask n < (2 :: 'a::len word) ^ n\<close>
	by (simp add: mask_eq_exp_minus_1 power_2_ge_iff)

	lemma word_unat_power:
	"(2 :: 'a :: len word) ^ n = of_nat (2 ^ n)"
	by simp

	lemma of_nat_mono_maybe:
	assumes xlt: "x < 2 ^ len_of TYPE ('a)"
	shows "y < x \<Longrightarrow> of_nat y < (of_nat x :: 'a :: len word)"
	apply (subst word_less_nat_alt)
	apply (subst unat_of_nat)+
	apply (subst mod_less)
	apply (erule order_less_trans [OF _ xlt])
	apply (subst mod_less [OF xlt])
	apply assumption
	done

	lemma word_and_max_word:
	fixes a::"'a::len word"
	shows "x = - 1 \<Longrightarrow> a AND x = a"
	by simp

	lemma word_and_full_mask_simp:
	\<open>x AND mask LENGTH('a) = x\<close> for x :: \<open>'a::len word\<close>
	by (simp add: bit_eq_iff bit_simps)

	lemma of_int_uint:
	"of_int (uint x) = x"
	by (fact word_of_int_uint)

	corollary word_plus_and_or_coroll:
	"x AND y = 0 \<Longrightarrow> x + y = x OR y"
	for x y :: \<open>'a::len word\<close>
	using word_plus_and_or[where x=x and y=y]
	by simp

	corollary word_plus_and_or_coroll2:
	"(x AND w) + (x AND NOT w) = x"
	for x w :: \<open>'a::len word\<close>
	apply (subst disjunctive_add)
	apply (simp add: bit_simps)
	apply (simp flip: bit.conj_disj_distrib)
	done

	lemma unat_mask_eq:
	\<open>unat (mask n :: 'a::len word) = mask (min LENGTH('a) n)\<close>
	by transfer (simp add: nat_mask_eq)

	lemma word_plus_mono_left:
	fixes x :: "'a :: len word"
	shows "\<lbrakk>y \<le> z; x \<le> x + z\<rbrakk> \<Longrightarrow> y + x \<le> z + x"
	by unat_arith

	lemma less_Suc_unat_less_bound:
	"n < Suc (unat (x :: 'a :: len word)) \<Longrightarrow> n < 2 ^ LENGTH('a)"
	by (auto elim!: order_less_le_trans intro: Suc_leI)

	lemma up_ucast_inj:
	"\<lbrakk> ucast x = (ucast y::'b::len word); LENGTH('a) \<le> len_of TYPE ('b) \<rbrakk> \<Longrightarrow> x = (y::'a::len word)"
	by transfer (simp add: min_def split: if_splits)

	lemmas ucast_up_inj = up_ucast_inj

	lemma up_ucast_inj_eq:
	"LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow> (ucast x = (ucast y::'b::len word)) = (x = (y::'a::len word))"
	by (fastforce dest: up_ucast_inj)

	lemma no_plus_overflow_neg:
	"(x :: 'a :: len word) < -y \<Longrightarrow> x \<le> x + y"
	by (metis diff_minus_eq_add less_imp_le sub_wrap_lt)

	lemma ucast_ucast_eq:
	"\<lbrakk> ucast x = (ucast (ucast y::'a word)::'c::len word); LENGTH('a) \<le> LENGTH('b);
	LENGTH('b) \<le> LENGTH('c) \<rbrakk> \<Longrightarrow>
	x = ucast y" for x :: "'a::len word" and y :: "'b::len word"
	apply transfer
	apply (cases \<open>LENGTH('c) = LENGTH('a)\<close>)
	apply (auto simp add: min_def)
	done

	lemma ucast_0_I:
	"x = 0 \<Longrightarrow> ucast x = 0"
	by simp

	lemma word_add_offset_less:
	fixes x :: "'a :: len word"
	assumes yv: "y < 2 ^ n"
	and xv: "x < 2 ^ m"
	and mnv: "sz < LENGTH('a :: len)"
	and xv': "x < 2 ^ (LENGTH('a :: len) - n)"
	and mn: "sz = m + n"
	shows "x * 2 ^ n + y < 2 ^ sz"
	proof (subst mn)
	from mnv mn have nv: "n < LENGTH('a)" and mv: "m < LENGTH('a)" by auto

	have uy: "unat y < 2 ^ n"
	by (rule order_less_le_trans [OF unat_mono [OF yv] order_eq_refl],
	rule unat_power_lower[OF nv])

	have ux: "unat x < 2 ^ m"
	by (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl],
	rule unat_power_lower[OF mv])

	then show "x * 2 ^ n + y < 2 ^ (m + n)" using ux uy nv mnv xv'
	apply (subst word_less_nat_alt)
	apply (subst unat_word_ariths)+
	apply (subst mod_less)
	apply simp
	apply (subst mult.commute)
	apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
	apply (rule order_less_le_trans [OF unat_mono [OF xv']])
	apply (cases "n = 0"; simp)
	apply (subst unat_power_lower[OF nv])
	apply (subst mod_less)
	apply (erule order_less_le_trans [OF nat_add_offset_less], assumption)
	apply (rule mn)
	apply simp
	apply (simp add: mn mnv)
	apply (erule nat_add_offset_less; simp)
	done
	qed

	lemma word_less_power_trans:
	fixes n :: "'a :: len word"
	assumes nv: "n < 2 ^ (m - k)"
	and kv: "k \<le> m"
	and mv: "m < len_of TYPE ('a)"
	shows "2 ^ k * n < 2 ^ m"
	using nv kv mv
	apply -
	apply (subst word_less_nat_alt)
	apply (subst unat_word_ariths)
	apply (subst mod_less)
	apply simp
	apply (rule nat_less_power_trans)
	apply (erule order_less_trans [OF unat_mono])
	apply simp
	apply simp
	apply simp
	apply (rule nat_less_power_trans)
	apply (subst unat_power_lower[where 'a = 'a, symmetric])
	apply simp
	apply (erule unat_mono)
	apply simp
	done

	lemma word_less_power_trans2:
	fixes n :: "'a::len word"
	shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk> \<Longrightarrow> n * 2 ^ k < 2 ^ m"
	by (subst field_simps, rule word_less_power_trans)

	lemma Suc_unat_diff_1:
	fixes x :: "'a :: len word"
	assumes lt: "1 \<le> x"
	shows "Suc (unat (x - 1)) = unat x"
	proof -
	have "0 < unat x"
	by (rule order_less_le_trans [where y = 1], simp, subst unat_1 [symmetric],
	rule iffD1 [OF word_le_nat_alt lt])

	then show ?thesis
	by ((subst unat_sub [OF lt])+, simp only: unat_1)
	qed

	lemma word_eq_unatI:
	\<open>v = w\<close> if \<open>unat v = unat w\<close>
	using that by transfer (simp add: nat_eq_iff)

	lemma word_div_sub:
	fixes x :: "'a :: len word"
	assumes yx: "y \<le> x"
	and y0: "0 < y"
	shows "(x - y) div y = x div y - 1"
	apply (rule word_eq_unatI)
	apply (subst unat_div)
	apply (subst unat_sub [OF yx])
	apply (subst unat_sub)
	apply (subst word_le_nat_alt)
	apply (subst unat_div)
	apply (subst le_div_geq)
	apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
	apply simp
	apply (subst word_le_nat_alt [symmetric], rule yx)
	apply simp
	apply (subst unat_div)
	apply (subst le_div_geq [OF _ iffD1 [OF word_le_nat_alt yx]])
	apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
	apply simp
	apply simp
	done

	lemma word_mult_less_mono1:
	fixes i :: "'a :: len word"
	assumes ij: "i < j"
	and knz: "0 < k"
	and ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
	shows "i * k < j * k"
	proof -
	from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
	by (auto intro: order_less_subst2 simp: word_less_nat_alt elim: mult_less_mono1)

	then show ?thesis using ujk knz ij
	by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem])
	qed

	lemma word_mult_less_dest:
	fixes i :: "'a :: len word"
	assumes ij: "i * k < j * k"
	and uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
	shows "i < j"
	using uik ujk ij
	by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem] elim: mult_less_mono1)

	lemma word_mult_less_cancel:
	fixes k :: "'a :: len word"
	assumes knz: "0 < k"
	and uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
	shows "(i * k < j * k) = (i < j)"
	by (rule iffI [OF word_mult_less_dest [OF _ uik ujk] word_mult_less_mono1 [OF _ knz ujk]])

	lemma Suc_div_unat_helper:
	assumes szv: "sz < LENGTH('a :: len)"
	and usszv: "us \<le> sz"
	shows "2 ^ (sz - us) = Suc (unat (((2::'a :: len word) ^ sz - 1) div 2 ^ us))"
	proof -
	note usv = order_le_less_trans [OF usszv szv]

	from usszv obtain q where qv: "sz = us + q" by (auto simp: le_iff_add)

	have "Suc (unat (((2:: 'a word) ^ sz - 1) div 2 ^ us)) =
	(2 ^ us + unat ((2:: 'a word) ^ sz - 1)) div 2 ^ us"
	apply (subst unat_div unat_power_lower[OF usv])+
	apply (subst div_add_self1, simp+)
	done

	also have "\<dots> = ((2 ^ us - 1) + 2 ^ sz) div 2 ^ us" using szv
	by (simp add: unat_minus_one)

	also have "\<dots> = 2 ^ q + ((2 ^ us - 1) div 2 ^ us)"
	apply (subst qv)
	apply (subst power_add)
	apply (subst div_mult_self2; simp)
	done

	also have "\<dots> = 2 ^ (sz - us)" using qv by simp

	finally show ?thesis ..
	qed

	lemma enum_word_nth_eq:
	\<open>(Enum.enum :: 'a::len word list) ! n = word_of_nat n\<close>
	if \<open>n < 2 ^ LENGTH('a)\<close>
	for n
	using that by (simp add: enum_word_def)

	lemma length_enum_word_eq:
	\<open>length (Enum.enum :: 'a::len word list) = 2 ^ LENGTH('a)\<close>
	by (simp add: enum_word_def)

	lemma unat_lt2p [iff]:
	\<open>unat x < 2 ^ LENGTH('a)\<close> for x :: \<open>'a::len word\<close>
	by transfer simp

	lemma of_nat_unat [simp]:
	"of_nat \<circ> unat = id"
	by (rule ext, simp)

	lemma Suc_unat_minus_one [simp]:
	"x \<noteq> 0 \<Longrightarrow> Suc (unat (x - 1)) = unat x"
	by (metis Suc_diff_1 unat_gt_0 unat_minus_one)

	lemma word_add_le_dest:
	fixes i :: "'a :: len word"
	assumes le: "i + k \<le> j + k"
	and uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
	shows "i \<le> j"
	using uik ujk le
	by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem] elim: add_le_mono1)

	lemma word_add_le_mono1:
	fixes i :: "'a :: len word"
	assumes ij: "i \<le> j"
	and ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
	shows "i + k \<le> j + k"
	proof -
	from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
	by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: add_le_mono1)

	then show ?thesis using ujk ij
	by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem])
	qed

	lemma word_add_le_mono2:
	fixes i :: "'a :: len word"
	shows "\<lbrakk>i \<le> j; unat j + unat k < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> k + i \<le> k + j"
	by (subst field_simps, subst field_simps, erule (1) word_add_le_mono1)

	lemma word_add_le_iff:
	fixes i :: "'a :: len word"
	assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
	shows "(i + k \<le> j + k) = (i \<le> j)"
	proof
	assume "i \<le> j"
	show "i + k \<le> j + k" by (rule word_add_le_mono1) fact+
	next
	assume "i + k \<le> j + k"
	show "i \<le> j" by (rule word_add_le_dest) fact+
	qed

	lemma word_add_less_mono1:
	fixes i :: "'a :: len word"
	assumes ij: "i < j"
	and ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
	shows "i + k < j + k"
	proof -
	from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
	by (auto elim: order_le_less_subst2 simp: word_less_nat_alt elim: add_less_mono1)

	then show ?thesis using ujk ij
	by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem])
	qed

	lemma word_add_less_dest:
	fixes i :: "'a :: len word"
	assumes le: "i + k < j + k"
	and uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
	shows "i < j"
	using uik ujk le
	by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem] elim: add_less_mono1)

	lemma word_add_less_iff:
	fixes i :: "'a :: len word"
	assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
	shows "(i + k < j + k) = (i < j)"
	proof
	assume "i < j"
	show "i + k < j + k" by (rule word_add_less_mono1) fact+
	next
	assume "i + k < j + k"
	show "i < j" by (rule word_add_less_dest) fact+
	qed

	lemma word_mult_less_iff:
	fixes i :: "'a :: len word"
	assumes knz: "0 < k"
	and uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
	shows "(i * k < j * k) = (i < j)"
	using assms by (rule word_mult_less_cancel)

	lemma word_le_imp_diff_le:
	fixes n :: "'a::len word"
	shows "\<lbrakk>k \<le> n; n \<le> m\<rbrakk> \<Longrightarrow> n - k \<le> m"
	by (auto simp: unat_sub word_le_nat_alt)

	lemma word_less_imp_diff_less:
	fixes n :: "'a::len word"
	shows "\<lbrakk>k \<le> n; n < m\<rbrakk> \<Longrightarrow> n - k < m"
	by (clarsimp simp: unat_sub word_less_nat_alt
	intro!: less_imp_diff_less)

	lemma word_mult_le_mono1:
	fixes i :: "'a :: len word"
	assumes ij: "i \<le> j"
	and knz: "0 < k"
	and ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
	shows "i * k \<le> j * k"
	proof -
	from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
	by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: mult_le_mono1)

	then show ?thesis using ujk knz ij
	by (auto simp: word_le_nat_alt iffD1 [OF unat_mult_lem])
	qed

	lemma word_mult_le_iff:
	fixes i :: "'a :: len word"
	assumes knz: "0 < k"
	and uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
	and ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
	shows "(i * k \<le> j * k) = (i \<le> j)"
	proof
	assume "i \<le> j"
	show "i * k \<le> j * k" by (rule word_mult_le_mono1) fact+
	next
	assume p: "i * k \<le> j * k"

	have "0 < unat k" using knz by (simp add: word_less_nat_alt)
	then show "i \<le> j" using p
	by (clarsimp simp: word_le_nat_alt iffD1 [OF unat_mult_lem uik]
	iffD1 [OF unat_mult_lem ujk])
	qed

	lemma word_diff_less:
	fixes n :: "'a :: len word"
	shows "\<lbrakk>0 < n; 0 < m; n \<le> m\<rbrakk> \<Longrightarrow> m - n < m"
	apply (subst word_less_nat_alt)
	apply (subst unat_sub)
	apply assumption
	apply (rule diff_less)
	apply (simp_all add: word_less_nat_alt)
	done

	lemma word_add_increasing:
	fixes x :: "'a :: len word"
	shows "\<lbrakk> p + w \<le> x; p \<le> p + w \<rbrakk> \<Longrightarrow> p \<le> x"
	by unat_arith

	lemma word_random:
	fixes x :: "'a :: len word"
	shows "\<lbrakk> p \<le> p + x'; x \<le> x' \<rbrakk> \<Longrightarrow> p \<le> p + x"
	by unat_arith

	lemma word_sub_mono:
	"\<lbrakk> a \<le> c; d \<le> b; a - b \<le> a; c - d \<le> c \<rbrakk>
	\<Longrightarrow> (a - b) \<le> (c - d :: 'a :: len word)"
	by unat_arith

	lemma power_not_zero:
	"n < LENGTH('a::len) \<Longrightarrow> (2 :: 'a word) ^ n \<noteq> 0"
	by (metis p2_gt_0 word_neq_0_conv)

	lemma word_gt_a_gt_0:
	"a < n \<Longrightarrow> (0 :: 'a::len word) < n"
	apply (case_tac "n = 0")
	apply clarsimp
	apply (clarsimp simp: word_neq_0_conv)
	done

	lemma word_power_less_1 [simp]:
	"sz < LENGTH('a::len) \<Longrightarrow> (2::'a word) ^ sz - 1 < 2 ^ sz"
	apply (simp add: word_less_nat_alt)
	apply (subst unat_minus_one)
	apply simp_all
	done

	lemma word_sub_1_le:
	"x \<noteq> 0 \<Longrightarrow> x - 1 \<le> (x :: ('a :: len) word)"
	apply (subst no_ulen_sub)
	apply simp
	apply (cases "uint x = 0")
	apply (simp add: uint_0_iff)
	apply (insert uint_ge_0[where x=x])
	apply arith
	done

	lemma push_bit_word_eq_nonzero:
	\<open>push_bit n w \<noteq> 0\<close> if \<open>w < 2 ^ m\<close> \<open>m + n < LENGTH('a)\<close> \<open>w \<noteq> 0\<close>
	for w :: \<open>'a::len word\<close>
	using that
	apply (simp only: word_neq_0_conv word_less_nat_alt
	mod_0 unat_word_ariths
	unat_power_lower word_le_nat_alt)
	apply (metis add_diff_cancel_right' gr0I gr_implies_not0 less_or_eq_imp_le min_def push_bit_eq_0_iff take_bit_nat_eq_self_iff take_bit_push_bit take_bit_take_bit unsigned_push_bit_eq)
	done

	lemma unat_less_power:
	fixes k :: "'a::len word"
	assumes szv: "sz < LENGTH('a)"
	and kv: "k < 2 ^ sz"
	shows "unat k < 2 ^ sz"
	using szv unat_mono [OF kv] by simp

	lemma unat_mult_power_lem:
	assumes kv: "k < 2 ^ (LENGTH('a::len) - sz)"
	shows "unat (2 ^ sz * of_nat k :: (('a::len) word)) = 2 ^ sz * k"
	proof (cases \<open>sz < LENGTH('a)\<close>)
	case True
	with assms show ?thesis
	by (simp add: unat_word_ariths take_bit_eq_mod mod_simps unsigned_of_nat)
	(simp add: take_bit_nat_eq_self_iff nat_less_power_trans flip: take_bit_eq_mod)
	next
	case False
	with assms show ?thesis
	by simp
	qed

	lemma word_plus_mcs_4:
	"\<lbrakk>v + x \<le> w + x; x \<le> v + x\<rbrakk> \<Longrightarrow> v \<le> (w::'a::len word)"
	by uint_arith

	lemma word_plus_mcs_3:
	"\<lbrakk>v \<le> w; x \<le> w + x\<rbrakk> \<Longrightarrow> v + x \<le> w + (x::'a::len word)"
	by unat_arith

	lemma word_le_minus_one_leq:
	"x < y \<Longrightarrow> x \<le> y - 1" for x :: "'a :: len word"
	by transfer (metis le_less_trans less_irrefl take_bit_decr_eq take_bit_nonnegative zle_diff1_eq)

	lemma word_less_sub_le[simp]:
	fixes x :: "'a :: len word"
	assumes nv: "n < LENGTH('a)"
	shows "(x \<le> 2 ^ n - 1) = (x < 2 ^ n)"
	using le_less_trans word_le_minus_one_leq nv power_2_ge_iff by blast

	lemma unat_of_nat_len:
	"x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x :: 'a::len word) = x"
	by (simp add: unsigned_of_nat take_bit_nat_eq_self_iff)

	lemma unat_of_nat_eq:
	"x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x ::'a::len word) = x"
	by (rule unat_of_nat_len)

	lemma unat_eq_of_nat:
	"n < 2 ^ LENGTH('a) \<Longrightarrow> (unat (x :: 'a::len word) = n) = (x = of_nat n)"
	by transfer
	(auto simp add: take_bit_of_nat nat_eq_iff take_bit_nat_eq_self_iff intro: sym)

	lemma alignUp_div_helper:
	fixes a :: "'a::len word"
	assumes kv: "k < 2 ^ (LENGTH('a) - n)"
	and xk: "x = 2 ^ n * of_nat k"
	and le: "a \<le> x"
	and sz: "n < LENGTH('a)"
	and anz: "a mod 2 ^ n \<noteq> 0"
	shows "a div 2 ^ n < of_nat k"
	proof -
	have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ LENGTH('a)"
	using xk kv sz
	apply (subst unat_of_nat_eq)
	apply (erule order_less_le_trans)
	apply simp
	apply (subst unat_power_lower, simp)
	apply (subst mult.commute)
	apply (rule nat_less_power_trans)
	apply simp
	apply simp
	done

	have "unat a div 2 ^ n * 2 ^ n \<noteq> unat a"
	proof -
	have "unat a = unat a div 2 ^ n * 2 ^ n + unat a mod 2 ^ n"
	by (simp add: div_mult_mod_eq)
	also have "\<dots> \<noteq> unat a div 2 ^ n * 2 ^ n" using sz anz
	by (simp add: unat_arith_simps)
	finally show ?thesis ..
	qed

	then have "a div 2 ^ n * 2 ^ n < a" using sz anz
	apply (subst word_less_nat_alt)
	apply (subst unat_word_ariths)
	apply (subst unat_div)
	apply simp
	apply (rule order_le_less_trans [OF mod_less_eq_dividend])
	apply (erule order_le_neq_trans [OF div_mult_le])
	done

	also from xk le have "\<dots> \<le> of_nat k * 2 ^ n" by (simp add: field_simps)
	finally show ?thesis using sz kv
	apply -
	apply (erule word_mult_less_dest [OF _ _ kn])
	apply (simp add: unat_div)
	apply (rule order_le_less_trans [OF div_mult_le])
	apply (rule unat_lt2p)
	done
	qed

	lemma mask_out_sub_mask:
	"(x AND NOT (mask n)) = x - (x AND (mask n))"
	for x :: \<open>'a::len word\<close>
	by (simp add: field_simps word_plus_and_or_coroll2)

	lemma subtract_mask:
	"p - (p AND mask n) = (p AND NOT (mask n))"
	"p - (p AND NOT (mask n)) = (p AND mask n)"
	for p :: \<open>'a::len word\<close>
	by (simp add: field_simps word_plus_and_or_coroll2)+

	lemma take_bit_word_eq_self_iff:
	\<open>take_bit n w = w \<longleftrightarrow> n \<ge> LENGTH('a) \<or> w < 2 ^ n\<close>
	for w :: \<open>'a::len word\<close>
	using take_bit_int_eq_self_iff [of n \<open>take_bit LENGTH('a) (uint w)\<close>]
	by (transfer fixing: n) auto

	lemma word_power_increasing:
	assumes x: "2 ^ x < (2 ^ y::'a::len word)" "x < LENGTH('a::len)" "y < LENGTH('a::len)"
	shows "x < y" using x
	using assms by transfer simp

	lemma mask_twice:
	"(x AND mask n) AND mask m = x AND mask (min m n)"
	for x :: \<open>'a::len word\<close>
	by (simp flip: take_bit_eq_mask)

	lemma plus_one_helper[elim!]:
	"x < n + (1 :: 'a :: len word) \<Longrightarrow> x \<le> n"
	apply (simp add: word_less_nat_alt word_le_nat_alt field_simps)
	apply (case_tac "1 + n = 0")
	apply simp_all
	apply (subst(asm) unatSuc, assumption)
	apply arith
	done

	lemma plus_one_helper2:
	"\<lbrakk> x \<le> n; n + 1 \<noteq> 0 \<rbrakk> \<Longrightarrow> x < n + (1 :: 'a :: len word)"
	by (simp add: word_less_nat_alt word_le_nat_alt field_simps
	unatSuc)

	lemma less_x_plus_1:
	fixes x :: "'a :: len word" shows
	"x \<noteq> - 1 \<Longrightarrow> (y < (x + 1)) = (y < x \<or> y = x)"
	apply (rule iffI)
	apply (rule disjCI)
	apply (drule plus_one_helper)
	apply simp
	apply (subgoal_tac "x < x + 1")
	apply (erule disjE, simp_all)
	apply (rule plus_one_helper2 [OF order_refl])
	apply (rule notI, drule max_word_wrap)
	apply simp
	done

	lemma word_Suc_leq:
	fixes k::"'a::len word" shows "k \<noteq> - 1 \<Longrightarrow> x < k + 1 \<longleftrightarrow> x \<le> k"
	using less_x_plus_1 word_le_less_eq by auto

	lemma word_Suc_le:
	fixes k::"'a::len word" shows "x \<noteq> - 1 \<Longrightarrow> x + 1 \<le> k \<longleftrightarrow> x < k"
	by (meson not_less word_Suc_leq)

	lemma word_lessThan_Suc_atMost:
	\<open>{..< k + 1} = {..k}\<close> if \<open>k \<noteq> - 1\<close> for k :: \<open>'a::len word\<close>
	using that by (simp add: lessThan_def atMost_def word_Suc_leq)

	lemma word_atLeastLessThan_Suc_atLeastAtMost:
	\<open>{l ..< u + 1} = {l..u}\<close> if \<open>u \<noteq> - 1\<close> for l :: \<open>'a::len word\<close>
	using that by (simp add: atLeastAtMost_def atLeastLessThan_def word_lessThan_Suc_atMost)

	lemma word_atLeastAtMost_Suc_greaterThanAtMost:
	\<open>{m<..u} = {m + 1..u}\<close> if \<open>m \<noteq> - 1\<close> for m :: \<open>'a::len word\<close>
	using that by (simp add: greaterThanAtMost_def greaterThan_def atLeastAtMost_def atLeast_def word_Suc_le)

	lemma word_atLeastLessThan_Suc_atLeastAtMost_union:
	fixes l::"'a::len word"
	assumes "m \<noteq> - 1" and "l \<le> m" and "m \<le> u"
	shows "{l..m} \<union> {m+1..u} = {l..u}"
	proof -
	from ivl_disj_un_two(8)[OF assms(2) assms(3)] have "{l..u} = {l..m} \<union> {m<..u}" by blast
	with assms show ?thesis by(simp add: word_atLeastAtMost_Suc_greaterThanAtMost)
	qed

	lemma max_word_less_eq_iff [simp]:
	\<open>- 1 \<le> w \<longleftrightarrow> w = - 1\<close> for w :: \<open>'a::len word\<close>
	by (fact word_order.extremum_unique)

	lemma word_or_zero:
	"(a OR b = 0) = (a = 0 \<and> b = 0)"
	for a b :: \<open>'a::len word\<close>
	by (fact or_eq_0_iff)

	lemma word_2p_mult_inc:
	assumes x: "2 * 2 ^ n < (2::'a::len word) * 2 ^ m"
	assumes suc_n: "Suc n < LENGTH('a::len)"
	shows "2^n < (2::'a::len word)^m"
	by (smt suc_n le_less_trans lessI nat_less_le nat_mult_less_cancel_disj p2_gt_0
	power_Suc power_Suc unat_power_lower word_less_nat_alt x)

	lemma power_overflow:
	"n \<ge> LENGTH('a) \<Longrightarrow> 2 ^ n = (0 :: 'a::len word)"
	by simp

	lemmas extra_sle_sless_unfolds [simp] =
	word_sle_eq[where a=0 and b=1]
	word_sle_eq[where a=0 and b="numeral n"]
	word_sle_eq[where a=1 and b=0]
	word_sle_eq[where a=1 and b="numeral n"]
	word_sle_eq[where a="numeral n" and b=0]
	word_sle_eq[where a="numeral n" and b=1]
	word_sless_alt[where a=0 and b=1]
	word_sless_alt[where a=0 and b="numeral n"]
	word_sless_alt[where a=1 and b=0]
	word_sless_alt[where a=1 and b="numeral n"]
	word_sless_alt[where a="numeral n" and b=0]
	word_sless_alt[where a="numeral n" and b=1]
	for n

	lemma word_sint_1:
	"sint (1::'a::len word) = (if LENGTH('a) = 1 then -1 else 1)"
	by (fact signed_1)

	lemma ucast_of_nat:
	"is_down (ucast :: 'a :: len word \<Rightarrow> 'b :: len word)
	\<Longrightarrow> ucast (of_nat n :: 'a word) = (of_nat n :: 'b word)"
	by transfer simp

	lemma scast_1':
	"(scast (1::'a::len word) :: 'b::len word) =
	(word_of_int (signed_take_bit (LENGTH('a::len) - Suc 0) (1::int)))"
	by transfer simp

	lemma scast_1:
	"(scast (1::'a::len word) :: 'b::len word) = (if LENGTH('a) = 1 then -1 else 1)"
	by (fact signed_1)

	lemma unat_minus_one_word:
	"unat (-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
	by (simp add: mask_eq_exp_minus_1 unsigned_minus_1_eq_mask)

	lemmas word_diff_ls'' = word_diff_ls [where xa=x and x=x for x]
	lemmas word_diff_ls' = word_diff_ls'' [simplified]

	lemmas word_l_diffs' = word_l_diffs [where xa=x and x=x for x]
	lemmas word_l_diffs = word_l_diffs' [simplified]

	lemma two_power_increasing:
	"\<lbrakk> n \<le> m; m < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ n \<le> 2 ^ m"
	by (simp add: word_le_nat_alt)

	lemma word_leq_le_minus_one:
	"\<lbrakk> x \<le> y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x - 1 < (y :: 'a :: len word)"
	apply (simp add: word_less_nat_alt word_le_nat_alt)
	apply (subst unat_minus_one)
	apply assumption
	apply (cases "unat x")
	apply (simp add: unat_eq_zero)
	apply arith
	done

	lemma neg_mask_combine:
	"NOT(mask a) AND NOT(mask b) = NOT(mask (max a b) :: 'a::len word)"
	by (rule bit_word_eqI) (auto simp add: bit_simps)

	lemma neg_mask_twice:
	"x AND NOT(mask n) AND NOT(mask m) = x AND NOT(mask (max n m))"
	for x :: \<open>'a::len word\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps)

	lemma multiple_mask_trivia:
	"n \<ge> m \<Longrightarrow> (x AND NOT(mask n)) + (x AND mask n AND NOT(mask m)) = x AND NOT(mask m)"
	for x :: \<open>'a::len word\<close>
	apply (rule trans[rotated], rule_tac w="mask n" in word_plus_and_or_coroll2)
	apply (simp add: word_bw_assocs word_bw_comms word_bw_lcs neg_mask_twice
	max_absorb2)
	done

	lemma word_of_nat_less:
	"\<lbrakk> n < unat x \<rbrakk> \<Longrightarrow> of_nat n < x"
	apply (simp add: word_less_nat_alt)
	apply (erule order_le_less_trans[rotated])
	apply (simp add: unsigned_of_nat take_bit_eq_mod)
	done

	lemma unat_mask:
	"unat (mask n :: 'a :: len word) = 2 ^ (min n (LENGTH('a))) - 1"
	apply (subst min.commute)
	apply (simp add: mask_eq_decr_exp not_less min_def split: if_split_asm)
	apply (intro conjI impI)
	apply (simp add: unat_sub_if_size)
	apply (simp add: power_overflow word_size)
	apply (simp add: unat_sub_if_size)
	done

	lemma mask_over_length:
	"LENGTH('a) \<le> n \<Longrightarrow> mask n = (-1::'a::len word)"
	by (simp add: mask_eq_decr_exp)

	lemma Suc_2p_unat_mask:
	"n < LENGTH('a) \<Longrightarrow> Suc (2 ^ n * k + unat (mask n :: 'a::len word)) = 2 ^ n * (k+1)"
	by (simp add: unat_mask)

	lemma sint_of_nat_ge_zero:
	"x < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> sint (of_nat x :: 'a :: len word) \<ge> 0"
	by (simp add: bit_iff_odd signed_of_nat)

	lemma int_eq_sint:
	"x < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> sint (of_nat x :: 'a :: len word) = int x"
	apply transfer
	apply (rule signed_take_bit_int_eq_self)
	apply simp_all
	apply (metis negative_zle numeral_power_eq_of_nat_cancel_iff)
	done

	lemma sint_of_nat_le:
	"\<lbrakk> b < 2 ^ (LENGTH('a) - 1); a \<le> b \<rbrakk>
	\<Longrightarrow> sint (of_nat a :: 'a :: len word) \<le> sint (of_nat b :: 'a :: len word)"
	apply (cases \<open>LENGTH('a)\<close>)
	apply simp_all
	apply transfer
	apply (subst signed_take_bit_eq_if_positive)
	apply (simp add: bit_simps)
	apply (metis bit_take_bit_iff nat_less_le order_less_le_trans take_bit_nat_eq_self_iff)
	apply (subst signed_take_bit_eq_if_positive)
	apply (simp add: bit_simps)
	apply (metis bit_take_bit_iff nat_less_le take_bit_nat_eq_self_iff)
	apply (simp flip: of_nat_take_bit add: take_bit_nat_eq_self)
	done

	lemma word_le_not_less:
	"((b::'a::len word) \<le> a) = (\<not>(a < b))"
	by fastforce

	lemma less_is_non_zero_p1:
	fixes a :: "'a :: len word"
	shows "a < k \<Longrightarrow> a + 1 \<noteq> 0"
	apply (erule contrapos_pn)
	apply (drule max_word_wrap)
	apply (simp add: not_less)
	done

	lemma unat_add_lem':
	"(unat x + unat y < 2 ^ LENGTH('a)) \<Longrightarrow>
	(unat (x + y :: 'a :: len word) = unat x + unat y)"
	by (subst unat_add_lem[symmetric], assumption)

	lemma word_less_two_pow_divI:
	"\<lbrakk> (x :: 'a::len word) < 2 ^ (n - m); m \<le> n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> x < 2 ^ n div 2 ^ m"
	apply (simp add: word_less_nat_alt)
	apply (subst unat_word_ariths)
	apply (subst mod_less)
	apply (rule order_le_less_trans [OF div_le_dividend])
	apply (rule unat_lt2p)
	apply (simp add: power_sub)
	done

	lemma word_less_two_pow_divD:
	"\<lbrakk> (x :: 'a::len word) < 2 ^ n div 2 ^ m \<rbrakk>
	\<Longrightarrow> n \<ge> m \<and> (x < 2 ^ (n - m))"
	apply (cases "n < LENGTH('a)")
	apply (cases "m < LENGTH('a)")
	apply (simp add: word_less_nat_alt)
	apply (subst(asm) unat_word_ariths)
	apply (subst(asm) mod_less)
	apply (rule order_le_less_trans [OF div_le_dividend])
	apply (rule unat_lt2p)
	apply (clarsimp dest!: less_two_pow_divD)
	apply (simp add: power_overflow)
	apply (simp add: word_div_def)
	apply (simp add: power_overflow word_div_def)
	done

	lemma of_nat_less_two_pow_div_set:
	"\<lbrakk> n < LENGTH('a) \<rbrakk> \<Longrightarrow>
	{x. x < (2 ^ n div 2 ^ m :: 'a::len word)}
	= of_nat ` {k. k < 2 ^ n div 2 ^ m}"
	apply (simp add: image_def)
	apply (safe dest!: word_less_two_pow_divD less_two_pow_divD
	intro!: word_less_two_pow_divI)
	apply (rule_tac x="unat x" in exI)
	apply (simp add: power_sub[symmetric])
	apply (subst unat_power_lower[symmetric, where 'a='a])
	apply simp
	apply (erule unat_mono)
	apply (subst word_unat_power)
	apply (rule of_nat_mono_maybe)
	apply (rule power_strict_increasing)
	apply simp
	apply simp
	apply assumption
	done

	lemma ucast_less:
	"LENGTH('b) < LENGTH('a) \<Longrightarrow>
	(ucast (x :: 'b :: len word) :: ('a :: len word)) < 2 ^ LENGTH('b)"
	by transfer simp

	lemma ucast_range_less:
	"LENGTH('a :: len) < LENGTH('b :: len) \<Longrightarrow>
	range (ucast :: 'a word \<Rightarrow> 'b word) = {x. x < 2 ^ len_of TYPE ('a)}"
	apply safe
	apply (erule ucast_less)
	apply (simp add: image_def)
	apply (rule_tac x="ucast x" in exI)
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps)
	apply (metis bit_take_bit_iff take_bit_word_eq_self_iff)
	done

	lemma word_power_less_diff:
	"\<lbrakk>2 ^ n * q < (2::'a::len word) ^ m; q < 2 ^ (LENGTH('a) - n)\<rbrakk> \<Longrightarrow> q < 2 ^ (m - n)"
	apply (case_tac "m \<ge> LENGTH('a)")
	apply (simp add: power_overflow)
	apply (case_tac "n \<ge> LENGTH('a)")
	apply (simp add: power_overflow)
	apply (cases "n = 0")
	apply simp
	apply (subst word_less_nat_alt)
	apply (subst unat_power_lower)
	apply simp
	apply (rule nat_power_less_diff)
	apply (simp add: word_less_nat_alt)
	apply (subst (asm) iffD1 [OF unat_mult_lem])
	apply (simp add:nat_less_power_trans)
	apply simp
	done

	lemma word_less_sub_1:
	"x < (y :: 'a :: len word) \<Longrightarrow> x \<le> y - 1"
	by (fact word_le_minus_one_leq)

	lemma word_sub_mono2:
	"\<lbrakk> a + b \<le> c + d; c \<le> a; b \<le> a + b; d \<le> c + d \<rbrakk>
	\<Longrightarrow> b \<le> (d :: 'a :: len word)"
	apply (drule(1) word_sub_mono)
	apply simp
	apply simp
	apply simp
	done

	lemma word_not_le:
	"(\<not> x \<le> (y :: 'a :: len word)) = (y < x)"
	by fastforce

	lemma word_subset_less:
	"\<lbrakk> {x .. x + r - 1} \<subseteq> {y .. y + s - 1};
	x \<le> x + r - 1; y \<le> y + (s :: 'a :: len word) - 1;
	s \<noteq> 0 \<rbrakk>
	\<Longrightarrow> r \<le> s"
	apply (frule subsetD[where c=x])
	apply simp
	apply (drule subsetD[where c="x + r - 1"])
	apply simp
	apply (clarsimp simp: add_diff_eq[symmetric])
	apply (drule(1) word_sub_mono2)
	apply (simp_all add: olen_add_eqv[symmetric])
	apply (erule word_le_minus_cancel)
	apply (rule ccontr)
	apply (simp add: word_not_le)
	done

	lemma uint_power_lower:
	"n < LENGTH('a) \<Longrightarrow> uint (2 ^ n :: 'a :: len word) = (2 ^ n :: int)"
	by (rule uint_2p_alt)

	lemma power_le_mono:
	"\<lbrakk>2 ^ n \<le> (2::'a::len word) ^ m; n < LENGTH('a); m < LENGTH('a)\<rbrakk>
	\<Longrightarrow> n \<le> m"
	apply (clarsimp simp add: le_less)
	apply safe
	apply (simp add: word_less_nat_alt)
	apply (simp only: uint_arith_simps(3))
	apply (drule uint_power_lower)+
	apply simp
	done

	lemma two_power_eq:
	"\<lbrakk>n < LENGTH('a); m < LENGTH('a)\<rbrakk>
	\<Longrightarrow> ((2::'a::len word) ^ n = 2 ^ m) = (n = m)"
	apply safe
	apply (rule order_antisym)
	apply (simp add: power_le_mono[where 'a='a])+
	done

	lemma unat_less_helper:
	"x < of_nat n \<Longrightarrow> unat x < n"
	apply (simp add: word_less_nat_alt)
	apply (erule order_less_le_trans)
	apply (simp add: take_bit_eq_mod unsigned_of_nat)
	done

	lemma nat_uint_less_helper:
	"nat (uint y) = z \<Longrightarrow> x < y \<Longrightarrow> nat (uint x) < z"
	apply (erule subst)
	apply (subst unat_eq_nat_uint [symmetric])
	apply (subst unat_eq_nat_uint [symmetric])
	by (simp add: unat_mono)

	lemma of_nat_0:
	"\<lbrakk>of_nat n = (0::'a::len word); n < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> n = 0"
	by (auto simp add: word_of_nat_eq_0_iff)

	lemma of_nat_inj:
	"\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
	(of_nat x = (of_nat y :: 'a :: len word)) = (x = y)"
	by (metis unat_of_nat_len)

	lemma div_to_mult_word_lt:
	"\<lbrakk> (x :: 'a :: len word) \<le> y div z \<rbrakk> \<Longrightarrow> x * z \<le> y"
	apply (cases "z = 0")
	apply simp
	apply (simp add: word_neq_0_conv)
	apply (rule order_trans)
	apply (erule(1) word_mult_le_mono1)
	apply (simp add: unat_div)
	apply (rule order_le_less_trans [OF div_mult_le])
	apply simp
	apply (rule word_div_mult_le)
	done

	lemma ucast_ucast_mask:
	"(ucast :: 'a :: len word \<Rightarrow> 'b :: len word) (ucast x) = x AND mask (len_of TYPE ('a))"
	apply (simp flip: take_bit_eq_mask)
	apply transfer
	apply (simp add: ac_simps)
	done

	lemma ucast_ucast_len:
	"\<lbrakk> x < 2 ^ LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (ucast x::'b::len word) = (x::'a::len word)"
	apply (subst ucast_ucast_mask)
	apply (erule less_mask_eq)
	done

	lemma ucast_ucast_id:
	"LENGTH('a) < LENGTH('b) \<Longrightarrow> ucast (ucast (x::'a::len word)::'b::len word) = x"
	by (auto intro: ucast_up_ucast_id simp: is_up_def source_size_def target_size_def word_size)

	lemma unat_ucast:
	"unat (ucast x :: ('a :: len) word) = unat x mod 2 ^ (LENGTH('a))"
	proof -
	have \<open>2 ^ LENGTH('a) = nat (2 ^ LENGTH('a))\<close>
	by simp
	moreover have \<open>unat (ucast x :: 'a word) = unat x mod nat (2 ^ LENGTH('a))\<close>
	by transfer (simp flip: nat_mod_distrib take_bit_eq_mod)
	ultimately show ?thesis
	by (simp only:)
	qed

	lemma ucast_less_ucast:
	"LENGTH('a) \<le> LENGTH('b) \<Longrightarrow>
	(ucast x < ((ucast (y :: 'a::len word)) :: 'b::len word)) = (x < y)"
	apply (simp add: word_less_nat_alt unat_ucast)
	apply (subst mod_less)
	apply(rule less_le_trans[OF unat_lt2p], simp)
	apply (subst mod_less)
	apply(rule less_le_trans[OF unat_lt2p], simp)
	apply simp
	done

	\<comment> \<open>This weaker version was previously called @{text ucast_less_ucast}. We retain it to
	support existing proofs.\<close>
	lemmas ucast_less_ucast_weak = ucast_less_ucast[OF order.strict_implies_order]

	lemma unat_Suc2:
	fixes n :: "'a :: len word"
	shows
	"n \<noteq> -1 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
	apply (subst add.commute, rule unatSuc)
	apply (subst eq_diff_eq[symmetric], simp add: minus_equation_iff)
	done

	lemma word_div_1:
	"(n :: 'a :: len word) div 1 = n"
	by (fact bits_div_by_1)

	lemma word_minus_one_le:
	"-1 \<le> (x :: 'a :: len word) = (x = -1)"
	by (fact word_order.extremum_unique)

	lemma up_scast_inj:
	"\<lbrakk> scast x = (scast y :: 'b :: len word); size x \<le> LENGTH('b) \<rbrakk>
	\<Longrightarrow> x = y"
	apply transfer
	apply (cases \<open>LENGTH('a)\<close>)
	apply simp_all
	apply (metis order_refl take_bit_signed_take_bit take_bit_tightened)
	done

	lemma up_scast_inj_eq:
	"LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow>
	(scast x = (scast y::'b::len word)) = (x = (y::'a::len word))"
	by (fastforce dest: up_scast_inj simp: word_size)

	lemma word_le_add:
	fixes x :: "'a :: len word"
	shows "x \<le> y \<Longrightarrow> \<exists>n. y = x + of_nat n"
	by (rule exI [where x = "unat (y - x)"]) simp

	lemma word_plus_mcs_4':
	fixes x :: "'a :: len word"
	shows "\<lbrakk>x + v \<le> x + w; x \<le> x + v\<rbrakk> \<Longrightarrow> v \<le> w"
	apply (rule word_plus_mcs_4)
	apply (simp add: add.commute)
	apply (simp add: add.commute)
	done

	lemma unat_eq_1:
	\<open>unat x = Suc 0 \<longleftrightarrow> x = 1\<close>
	by (auto intro!: unsigned_word_eqI [where ?'a = nat])

	lemma word_unat_Rep_inject1:
	\<open>unat x = unat 1 \<longleftrightarrow> x = 1\<close>
	by (simp add: unat_eq_1)

	lemma and_not_mask_twice:
	"(w AND NOT (mask n)) AND NOT (mask m) = w AND NOT (mask (max m n))"
	for w :: \<open>'a::len word\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps)

	lemma word_less_cases:
	"x < y \<Longrightarrow> x = y - 1 \<or> x < y - (1 ::'a::len word)"
	apply (drule word_less_sub_1)
	apply (drule order_le_imp_less_or_eq)
	apply auto
	done

	lemma mask_and_mask:
	"mask a AND mask b = (mask (min a b) :: 'a::len word)"
	by (simp flip: take_bit_eq_mask ac_simps)

	lemma mask_eq_0_eq_x:
	"(x AND w = 0) = (x AND NOT w = x)"
	for x w :: \<open>'a::len word\<close>
	using word_plus_and_or_coroll2[where x=x and w=w]
	by auto

	lemma mask_eq_x_eq_0:
	"(x AND w = x) = (x AND NOT w = 0)"
	for x w :: \<open>'a::len word\<close>
	using word_plus_and_or_coroll2[where x=x and w=w]
	by auto

	lemma compl_of_1: "NOT 1 = (-2 :: 'a :: len word)"
	by (fact not_one_eq)

	lemma split_word_eq_on_mask:
	"(x = y) = (x AND m = y AND m \<and> x AND NOT m = y AND NOT m)"
	for x y m :: \<open>'a::len word\<close>
	apply transfer
	apply (simp add: bit_eq_iff)
	apply (auto simp add: bit_simps ac_simps)
	done

	lemma word_FF_is_mask:
	"0xFF = (mask 8 :: 'a::len word)"
	by (simp add: mask_eq_decr_exp)

	lemma word_1FF_is_mask:
	"0x1FF = (mask 9 :: 'a::len word)"
	by (simp add: mask_eq_decr_exp)

	lemma ucast_of_nat_small:
	"x < 2 ^ LENGTH('a) \<Longrightarrow> ucast (of_nat x :: 'a :: len word) = (of_nat x :: 'b :: len word)"
	apply transfer
	apply (auto simp add: take_bit_of_nat min_def not_le)
	apply (metis linorder_not_less min_def take_bit_nat_eq_self take_bit_take_bit)
	done

	lemma word_le_make_less:
	fixes x :: "'a :: len word"
	shows "y \<noteq> -1 \<Longrightarrow> (x \<le> y) = (x < (y + 1))"
	apply safe
	apply (erule plus_one_helper2)
	apply (simp add: eq_diff_eq[symmetric])
	done

	lemmas finite_word = finite [where 'a="'a::len word"]

	lemma word_to_1_set:
	"{0 ..< (1 :: 'a :: len word)} = {0}"
	by fastforce

	lemma word_leq_minus_one_le:
	fixes x :: "'a::len word"
	shows "\<lbrakk>y \<noteq> 0; x \<le> y - 1 \<rbrakk> \<Longrightarrow> x < y"
	using le_m1_iff_lt word_neq_0_conv by blast

	lemma word_count_from_top:
	"n \<noteq> 0 \<Longrightarrow> {0 ..< n :: 'a :: len word} = {0 ..< n - 1} \<union> {n - 1}"
	apply (rule set_eqI, rule iffI)
	apply simp
	apply (drule word_le_minus_one_leq)
	apply (rule disjCI)
	apply simp
	apply simp
	apply (erule word_leq_minus_one_le)
	apply fastforce
	done

	lemma word_minus_one_le_leq:
	"\<lbrakk> x - 1 < y \<rbrakk> \<Longrightarrow> x \<le> (y :: 'a :: len word)"
	apply (cases "x = 0")
	apply simp
	apply (simp add: word_less_nat_alt word_le_nat_alt)
	apply (subst(asm) unat_minus_one)
	apply (simp add: word_less_nat_alt)
	apply (cases "unat x")
	apply (simp add: unat_eq_zero)
	apply arith
	done

	lemma word_must_wrap:
	"\<lbrakk> x \<le> n - 1; n \<le> x \<rbrakk> \<Longrightarrow> n = (0 :: 'a :: len word)"
	using dual_order.trans sub_wrap word_less_1 by blast

	lemma range_subset_card:
	"\<lbrakk> {a :: 'a :: len word .. b} \<subseteq> {c .. d}; b \<ge> a \<rbrakk> \<Longrightarrow> d \<ge> c \<and> d - c \<ge> b - a"
	using word_sub_le word_sub_mono by fastforce

	lemma less_1_simp:
	"n - 1 < m = (n \<le> (m :: 'a :: len word) \<and> n \<noteq> 0)"
	by unat_arith

	lemma word_power_mod_div:
	fixes x :: "'a::len word"
	shows "\<lbrakk> n < LENGTH('a); m < LENGTH('a)\<rbrakk>
	\<Longrightarrow> x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)"
	apply (simp add: word_arith_nat_div unat_mod power_mod_div)
	apply (subst unat_arith_simps(3))
	apply (subst unat_mod)
	apply (subst unat_of_nat)+
	apply (simp add: mod_mod_power min.commute)
	done

	lemma word_range_minus_1':
	fixes a :: "'a :: len word"
	shows "a \<noteq> 0 \<Longrightarrow> {a - 1<..b} = {a..b}"
	by (simp add: greaterThanAtMost_def atLeastAtMost_def greaterThan_def atLeast_def less_1_simp)

	lemma word_range_minus_1:
	fixes a :: "'a :: len word"
	shows "b \<noteq> 0 \<Longrightarrow> {a..b - 1} = {a..<b}"
	apply (simp add: atLeastLessThan_def atLeastAtMost_def atMost_def lessThan_def)
	apply (rule arg_cong [where f = "\<lambda>x. {a..} \<inter> x"])
	apply rule
	apply clarsimp
	apply (erule contrapos_pp)
	apply (simp add: linorder_not_less linorder_not_le word_must_wrap)
	apply (clarsimp)
	apply (drule word_le_minus_one_leq)
	apply (auto simp: word_less_sub_1)
	done

	lemma ucast_nat_def:
	"of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> 'b :: len word) x"
	by transfer simp

	lemma overflow_plus_one_self:
	"(1 + p \<le> p) = (p = (-1 :: 'a :: len word))"
	apply rule
	apply (rule ccontr)
	apply (drule plus_one_helper2)
	apply (rule notI)
	apply (drule arg_cong[where f="\<lambda>x. x - 1"])
	apply simp
	apply (simp add: field_simps)
	apply simp
	done

	lemma plus_1_less:
	"(x + 1 \<le> (x :: 'a :: len word)) = (x = -1)"
	apply (rule iffI)
	apply (rule ccontr)
	apply (cut_tac plus_one_helper2[where x=x, OF order_refl])
	apply simp
	apply clarsimp
	apply (drule arg_cong[where f="\<lambda>x. x - 1"])
	apply simp
	apply simp
	done

	lemma pos_mult_pos_ge:
	"[\|x > (0::int); n>=0 \|] ==> n * x >= n*1"
	apply (simp only: mult_left_mono)
	done

	lemma word_plus_strict_mono_right:
	fixes x :: "'a :: len word"
	shows "\<lbrakk>y < z; x \<le> x + z\<rbrakk> \<Longrightarrow> x + y < x + z"
	by unat_arith

	lemma word_div_mult:
	"0 < c \<Longrightarrow> a < b * c \<Longrightarrow> a div c < b" for a b c :: "'a::len word"
	by (rule classical)
	(use div_to_mult_word_lt [of b a c] in
	\<open>auto simp add: word_less_nat_alt word_le_nat_alt unat_div\<close>)

	lemma word_less_power_trans_ofnat:
	"\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk>
	\<Longrightarrow> of_nat n * 2 ^ k < (2::'a::len word) ^ m"
	apply (subst mult.commute)
	apply (rule word_less_power_trans)
	apply (simp_all add: word_less_nat_alt unsigned_of_nat)
	using take_bit_nat_less_eq_self
	apply (rule le_less_trans)
	apply assumption
	done

	lemma word_1_le_power:
	"n < LENGTH('a) \<Longrightarrow> (1 :: 'a :: len word) \<le> 2 ^ n"
	by (rule inc_le[where i=0, simplified], erule iffD2[OF p2_gt_0])

	lemma unat_1_0:
	"1 \<le> (x::'a::len word) = (0 < unat x)"
	by (auto simp add: word_le_nat_alt)

	lemma x_less_2_0_1':
	fixes x :: "'a::len word"
	shows "\<lbrakk>LENGTH('a) \<noteq> 1; x < 2\<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
	apply (cases \<open>2 \<le> LENGTH('a)\<close>)
	apply simp_all
	apply transfer
	apply auto
	apply (metis add.commute add.right_neutral even_two_times_div_two mod_div_trivial mod_pos_pos_trivial mult.commute mult_zero_left not_less not_take_bit_negative odd_two_times_div_two_succ)
	done

	lemmas word_add_le_iff2 = word_add_le_iff [folded no_olen_add_nat]

	lemma of_nat_power:
	shows "\<lbrakk> p < 2 ^ x; x < len_of TYPE ('a) \<rbrakk> \<Longrightarrow> of_nat p < (2 :: 'a :: len word) ^ x"
	apply (rule order_less_le_trans)
	apply (rule of_nat_mono_maybe)
	apply (erule power_strict_increasing)
	apply simp
	apply assumption
	apply (simp add: word_unat_power del: of_nat_power)
	done

	lemma of_nat_n_less_equal_power_2:
	"n < LENGTH('a::len) \<Longrightarrow> ((of_nat n)::'a word) < 2 ^ n"
	apply (induct n)
	apply clarsimp
	apply clarsimp
	apply (metis of_nat_power n_less_equal_power_2 of_nat_Suc power_Suc)
	done

	lemma eq_mask_less:
	fixes w :: "'a::len word"
	assumes eqm: "w = w AND mask n"
	and sz: "n < len_of TYPE ('a)"
	shows "w < (2::'a word) ^ n"
	by (subst eqm, rule and_mask_less' [OF sz])

	lemma of_nat_mono_maybe':
	fixes Y :: "nat"
	assumes xlt: "x < 2 ^ len_of TYPE ('a)"
	assumes ylt: "y < 2 ^ len_of TYPE ('a)"
	shows "(y < x) = (of_nat y < (of_nat x :: 'a :: len word))"
	apply (subst word_less_nat_alt)
	apply (subst unat_of_nat)+
	apply (subst mod_less)
	apply (rule ylt)
	apply (subst mod_less)
	apply (rule xlt)
	apply simp
	done

	lemma of_nat_mono_maybe_le:
	"\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
	(y \<le> x) = ((of_nat y :: 'a :: len word) \<le> of_nat x)"
	apply (clarsimp simp: le_less)
	apply (rule disj_cong)
	apply (rule of_nat_mono_maybe', assumption+)
	apply auto
	using of_nat_inj apply blast
	done

	lemma mask_AND_NOT_mask:
	"(w AND NOT (mask n)) AND mask n = 0"
	for w :: \<open>'a::len word\<close>
	by (rule bit_word_eqI) (simp add: bit_simps)

	lemma AND_NOT_mask_plus_AND_mask_eq:
	"(w AND NOT (mask n)) + (w AND mask n) = w"
	for w :: \<open>'a::len word\<close>
	apply (subst disjunctive_add)
	apply (auto simp add: bit_simps)
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps)
	done

	lemma mask_eqI:
	fixes x :: "'a :: len word"
	assumes m1: "x AND mask n = y AND mask n"
	and m2: "x AND NOT (mask n) = y AND NOT (mask n)"
	shows "x = y"
	proof -
	have *: \<open>x = x AND mask n OR x AND NOT (mask n)\<close> for x :: \<open>'a word\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps)
	from assms * [of x] * [of y] show ?thesis
	by simp
	qed

	lemma neq_0_no_wrap:
	fixes x :: "'a :: len word"
	shows "\<lbrakk> x \<le> x + y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
	by clarsimp

	lemma unatSuc2:
	fixes n :: "'a :: len word"
	shows "n + 1 \<noteq> 0 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
	by (simp add: add.commute unatSuc)

	lemma word_of_nat_le:
	"n \<le> unat x \<Longrightarrow> of_nat n \<le> x"
	apply (simp add: word_le_nat_alt unat_of_nat)
	apply (erule order_trans[rotated])
	apply (simp add: take_bit_eq_mod)
	done

	lemma word_unat_less_le:
	"a \<le> of_nat b \<Longrightarrow> unat a \<le> b"
	by (metis eq_iff le_cases le_unat_uoi word_of_nat_le)

	lemma mask_Suc_0 : "mask (Suc 0) = (1 :: 'a::len word)"
	by (simp add: mask_eq_decr_exp)

	lemma bool_mask':
	fixes x :: "'a :: len word"
	shows "2 < LENGTH('a) \<Longrightarrow> (0 < x AND 1) = (x AND 1 = 1)"
	by (simp add: and_one_eq mod_2_eq_odd)

	lemma ucast_ucast_add:
	fixes x :: "'a :: len word"
	fixes y :: "'b :: len word"
	shows
	"LENGTH('b) \<ge> LENGTH('a) \<Longrightarrow>
	ucast (ucast x + y) = x + ucast y"
	apply transfer
	apply simp
	apply (subst (2) take_bit_add [symmetric])
	apply (subst take_bit_add [symmetric])
	apply simp
	done

	lemma lt1_neq0:
	fixes x :: "'a :: len word"
	shows "(1 \<le> x) = (x \<noteq> 0)" by unat_arith

	lemma word_plus_one_nonzero:
	fixes x :: "'a :: len word"
	shows "\<lbrakk>x \<le> x + y; y \<noteq> 0\<rbrakk> \<Longrightarrow> x + 1 \<noteq> 0"
	apply (subst lt1_neq0 [symmetric])
	apply (subst olen_add_eqv [symmetric])
	apply (erule word_random)
	apply (simp add: lt1_neq0)
	done

	lemma word_sub_plus_one_nonzero:
	fixes n :: "'a :: len word"
	shows "\<lbrakk>n' \<le> n; n' \<noteq> 0\<rbrakk> \<Longrightarrow> (n - n') + 1 \<noteq> 0"
	apply (subst lt1_neq0 [symmetric])
	apply (subst olen_add_eqv [symmetric])
	apply (rule word_random [where x' = n'])
	apply simp
	apply (erule word_sub_le)
	apply (simp add: lt1_neq0)
	done

	lemma word_le_minus_mono_right:
	fixes x :: "'a :: len word"
	shows "\<lbrakk> z \<le> y; y \<le> x; z \<le> x \<rbrakk> \<Longrightarrow> x - y \<le> x - z"
	apply (rule word_sub_mono)
	apply simp
	apply assumption
	apply (erule word_sub_le)
	apply (erule word_sub_le)
	done

	lemma word_0_sle_from_less:
	\<open>0 \<le>s x\<close> if \<open>x < 2 ^ (LENGTH('a) - 1)\<close> for x :: \<open>'a::len word\<close>
	using that
	apply transfer
	apply (cases \<open>LENGTH('a)\<close>)
	apply simp_all
	apply (metis bit_take_bit_iff min_def nat_less_le not_less_eq take_bit_int_eq_self_iff take_bit_take_bit)
	done

	lemma ucast_sub_ucast:
	fixes x :: "'a::len word"
	assumes "y \<le> x"
	assumes T: "LENGTH('a) \<le> LENGTH('b)"
	shows "ucast (x - y) = (ucast x - ucast y :: 'b::len word)"
	proof -
	from T
	have P: "unat x < 2 ^ LENGTH('b)" "unat y < 2 ^ LENGTH('b)"
	by (fastforce intro!: less_le_trans[OF unat_lt2p])+
	then show ?thesis
	by (simp add: unat_arith_simps unat_ucast assms[simplified unat_arith_simps])
	qed

	lemma word_1_0:
	"\<lbrakk>a + (1::('a::len) word) \<le> b; a < of_nat x\<rbrakk> \<Longrightarrow> a < b"
	apply transfer
	apply (subst (asm) take_bit_incr_eq)
	apply (auto simp add: diff_less_eq)
	using take_bit_int_less_exp le_less_trans by blast

	lemma unat_of_nat_less:"\<lbrakk> a < b; unat b = c \<rbrakk> \<Longrightarrow> a < of_nat c"
	by fastforce

	lemma word_le_plus_1: "\<lbrakk> (y::('a::len) word) < y + n; a < n \<rbrakk> \<Longrightarrow> y + a \<le> y + a + 1"
	by unat_arith

	lemma word_le_plus:"\<lbrakk>(a::('a::len) word) < a + b; c < b\<rbrakk> \<Longrightarrow> a \<le> a + c"
	by (metis order_less_imp_le word_random)

	lemma sint_minus1 [simp]: "(sint x = -1) = (x = -1)"
	apply (cases \<open>LENGTH('a)\<close>)
	apply simp_all
	apply transfer
	apply (simp only: flip: signed_take_bit_eq_iff_take_bit_eq)
	apply simp
	done

	lemma sint_0 [simp]: "(sint x = 0) = (x = 0)"
	by (fact signed_eq_0_iff)

	(* It is not always that case that "sint 1 = 1", because of 1-bit word sizes.
	* This lemma produces the different cases. *)
	lemma sint_1_cases:
	P if \<open>\<lbrakk> len_of TYPE ('a::len) = 1; (a::'a word) = 0; sint a = 0 \<rbrakk> \<Longrightarrow> P\<close>
	\<open>\<lbrakk> len_of TYPE ('a) = 1; a = 1; sint (1 :: 'a word) = -1 \<rbrakk> \<Longrightarrow> P\<close>
	\<open>\<lbrakk> len_of TYPE ('a) > 1; sint (1 :: 'a word) = 1 \<rbrakk> \<Longrightarrow> P\<close>
	proof (cases \<open>LENGTH('a) = 1\<close>)
	case True
	then have \<open>a = 0 \<or> a = 1\<close>
	by transfer auto
	with True that show ?thesis
	by auto
	next
	case False
	with that show ?thesis
	by (simp add: less_le Suc_le_eq)
	qed

	lemma sint_int_min:
	"sint (- (2 ^ (LENGTH('a) - Suc 0)) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
	apply (cases \<open>LENGTH('a)\<close>)
	apply simp_all
	apply transfer
	apply (simp add: signed_take_bit_int_eq_self)
	done

	lemma sint_int_max_plus_1:
	"sint (2 ^ (LENGTH('a) - Suc 0) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
	apply (cases \<open>LENGTH('a)\<close>)
	apply simp_all
	apply (subst word_of_int_2p [symmetric])
	apply (subst int_word_sint)
	apply simp
	done

	lemma uint_range':
	\<open>0 \<le> uint x \<and> uint x < 2 ^ LENGTH('a)\<close>
	for x :: \<open>'a::len word\<close>
	by transfer simp

	lemma sint_of_int_eq:
	"\<lbrakk> - (2 ^ (LENGTH('a) - 1)) \<le> x; x < 2 ^ (LENGTH('a) - 1) \<rbrakk> \<Longrightarrow> sint (of_int x :: ('a::len) word) = x"
	by (simp add: signed_take_bit_int_eq_self signed_of_int)

	lemma of_int_sint:
	"of_int (sint a) = a"
	by simp

	lemma sint_ucast_eq_uint:
	"\<lbrakk> \<not> is_down (ucast :: ('a::len word \<Rightarrow> 'b::len word)) \<rbrakk>
	\<Longrightarrow> sint ((ucast :: ('a::len word \<Rightarrow> 'b::len word)) x) = uint x"
	apply transfer
	apply (simp add: signed_take_bit_take_bit)
	done

	lemma word_less_nowrapI':
	"(x :: 'a :: len word) \<le> z - k \<Longrightarrow> k \<le> z \<Longrightarrow> 0 < k \<Longrightarrow> x < x + k"
	by uint_arith

	lemma mask_plus_1:
	"mask n + 1 = (2 ^ n :: 'a::len word)"
	by (clarsimp simp: mask_eq_decr_exp)

	lemma unat_inj: "inj unat"
	by (metis eq_iff injI word_le_nat_alt)

	lemma unat_ucast_upcast:
	"is_up (ucast :: 'b word \<Rightarrow> 'a word)
	\<Longrightarrow> unat (ucast x :: ('a::len) word) = unat (x :: ('b::len) word)"
	unfolding ucast_eq unat_eq_nat_uint
	apply transfer
	apply simp
	done

	lemma ucast_mono:
	"\<lbrakk> (x :: 'b :: len word) < y; y < 2 ^ LENGTH('a) \<rbrakk>
	\<Longrightarrow> ucast x < ((ucast y) :: 'a :: len word)"
	apply (simp only: flip: ucast_nat_def)
	apply (rule of_nat_mono_maybe)
	apply (rule unat_less_helper)
	apply simp
	apply (simp add: word_less_nat_alt)
	done

	lemma ucast_mono_le:
	"\<lbrakk>x \<le> y; y < 2 ^ LENGTH('b)\<rbrakk> \<Longrightarrow> (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> ucast y"
	apply (simp only: flip: ucast_nat_def)
	apply (subst of_nat_mono_maybe_le[symmetric])
	apply (rule unat_less_helper)
	apply simp
	apply (rule unat_less_helper)
	apply (erule le_less_trans)
	apply (simp_all add: word_le_nat_alt)
	done

	lemma ucast_mono_le':
	"\<lbrakk> unat y < 2 ^ LENGTH('b); LENGTH('b::len) < LENGTH('a::len); x \<le> y \<rbrakk>
	\<Longrightarrow> ucast x \<le> (ucast y :: 'b word)" for x y :: \<open>'a::len word\<close>
	by (auto simp: word_less_nat_alt intro: ucast_mono_le)

	lemma neg_mask_add_mask:
	"((x:: 'a :: len word) AND NOT (mask n)) + (2 ^ n - 1) = x OR mask n"
	unfolding mask_2pm1 [symmetric]
	apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
	apply (auto simp add: bit_simps)
	done

	lemma le_step_down_word:"\<lbrakk>(i::('a::len) word) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
	by unat_arith

	lemma le_step_down_word_2:
	fixes x :: "'a::len word"
	shows "\<lbrakk>x \<le> y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
	by (subst (asm) word_le_less_eq,
	clarsimp,
	simp add: word_le_minus_one_leq)

	lemma NOT_mask_AND_mask[simp]: "(w AND mask n) AND NOT (mask n) = 0"
	by (rule bit_eqI) (simp add: bit_simps)

	lemma and_and_not[simp]:"(a AND b) AND NOT b = 0"
	for a b :: \<open>'a::len word\<close>
	apply (subst word_bw_assocs(1))
	apply clarsimp
	done

	lemma ex_mask_1[simp]: "(\<exists>x. mask x = (1 :: 'a::len word))"
	apply (rule_tac x=1 in exI)
	apply (simp add:mask_eq_decr_exp)
	done

	lemma not_switch:"NOT a = x \<Longrightarrow> a = NOT x"
	by auto

	lemma test_bit_eq_iff: "bit u = bit v \<longleftrightarrow> u = v"
	for u v :: "'a::len word"
	by (auto intro: bit_eqI simp add: fun_eq_iff)

	lemma test_bit_size: "bit w n \<Longrightarrow> n < size w"
	for w :: "'a::len word"
	by transfer simp

	lemma word_eq_iff: "x = y \<longleftrightarrow> (\<forall>n<LENGTH('a). bit x n = bit y n)" (is \<open>?P \<longleftrightarrow> ?Q\<close>)
	for x y :: "'a::len word"
	by transfer (auto simp add: bit_eq_iff bit_take_bit_iff)

	lemma word_eqI: "(\<And>n. n < size u \<longrightarrow> bit u n = bit v n) \<Longrightarrow> u = v"
	for u :: "'a::len word"
	by (simp add: word_size word_eq_iff)

	lemma word_eqD: "u = v \<Longrightarrow> bit u x = bit v x"
	for u v :: "'a::len word"
	by simp

	lemma test_bit_bin': "bit w n \<longleftrightarrow> n < size w \<and> bit (uint w) n"
	by transfer (simp add: bit_take_bit_iff)

	lemmas test_bit_bin = test_bit_bin' [unfolded word_size]

	lemma word_test_bit_def:
	\<open>bit a = bit (uint a)\<close>
	by transfer (simp add: fun_eq_iff bit_take_bit_iff)

	lemmas test_bit_def' = word_test_bit_def [THEN fun_cong]

	lemma word_test_bit_transfer [transfer_rule]:
	"(rel_fun pcr_word (rel_fun (=) (=)))
	(\<lambda>x n. n < LENGTH('a) \<and> bit x n) (bit :: 'a::len word \<Rightarrow> _)"
	by transfer_prover

	lemma test_bit_wi:
	"bit (word_of_int x :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a) \<and> bit x n"
	by transfer simp

	lemma word_ops_nth_size:
	"n < size x \<Longrightarrow>
	bit (x OR y) n = (bit x n \| bit y n) \<and>
	bit (x AND y) n = (bit x n \<and> bit y n) \<and>
	bit (x XOR y) n = (bit x n \<noteq> bit y n) \<and>
	bit (NOT x) n = (\<not> bit x n)"
	for x :: "'a::len word"
	by transfer (simp add: bit_or_iff bit_and_iff bit_xor_iff bit_not_iff)

	lemma word_ao_nth:
	"bit (x OR y) n = (bit x n \| bit y n) \<and>
	bit (x AND y) n = (bit x n \<and> bit y n)"
	for x :: "'a::len word"
	by transfer (auto simp add: bit_or_iff bit_and_iff)

	lemmas lsb0 = len_gt_0 [THEN word_ops_nth_size [unfolded word_size]]

	lemma nth_sint:
	fixes w :: "'a::len word"
	defines "l \<equiv> LENGTH('a)"
	shows "bit (sint w) n = (if n < l - 1 then bit w n else bit w (l - 1))"
	unfolding sint_uint l_def
	by (auto simp: bit_signed_take_bit_iff word_test_bit_def not_less min_def)

	lemma test_bit_2p: "bit (word_of_int (2 ^ n)::'a::len word) m \<longleftrightarrow> m = n \<and> m < LENGTH('a)"
	by transfer (auto simp add: bit_exp_iff)

	lemma nth_w2p: "bit ((2::'a::len word) ^ n) m \<longleftrightarrow> m = n \<and> m < LENGTH('a::len)"
	by transfer (auto simp add: bit_exp_iff)

	lemma bang_is_le: "bit x m \<Longrightarrow> 2 ^ m \<le> x"
	for x :: "'a::len word"
	apply (rule xtrans(3))
	apply (rule_tac [2] y = "x" in le_word_or2)
	apply (rule word_eqI)
	apply (auto simp add: word_ao_nth nth_w2p word_size)
	done

	lemmas msb0 = len_gt_0 [THEN diff_Suc_less, THEN word_ops_nth_size [unfolded word_size]]
	lemmas msb1 = msb0 [where i = 0]

	lemma test_bit_1 [iff]: "bit (1 :: 'a::len word) n \<longleftrightarrow> n = 0"
	by transfer (auto simp add: bit_1_iff)

	lemma nth_0: "\<not> bit (0 :: 'a::len word) n"
	by transfer simp

	lemma nth_minus1: "bit (-1 :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a)"
	by transfer simp

	lemma nth_ucast:
	"bit (ucast w::'a::len word) n = (bit w n \<and> n < LENGTH('a))"
	by transfer (simp add: bit_take_bit_iff ac_simps)

	lemma drop_bit_numeral_bit0_1 [simp]:
	\<open>drop_bit (Suc 0) (numeral k) =
	(word_of_int (drop_bit (Suc 0) (take_bit LENGTH('a) (numeral k))) :: 'a::len word)\<close>
	by (metis Word_eq_word_of_int drop_bit_word.abs_eq of_int_numeral)

	lemma nth_mask:
	\<open>bit (mask n :: 'a::len word) i \<longleftrightarrow> i < n \<and> i < size (mask n :: 'a word)\<close>
	by (auto simp add: word_size Word.bit_mask_iff)

	lemma nth_slice: "bit (slice n w :: 'a::len word) m = (bit w (m + n) \<and> m < LENGTH('a))"
	apply (auto simp add: bit_simps less_diff_conv dest: bit_imp_le_length)
	using bit_imp_le_length
	apply fastforce
	done

	lemma test_bit_cat [OF refl]:
	"wc = word_cat a b \<Longrightarrow> bit wc n = (n < size wc \<and>
	(if n < size b then bit b n else bit a (n - size b)))"
	apply (simp add: word_size not_less; transfer)
	apply (auto simp add: bit_concat_bit_iff bit_take_bit_iff)
	done

	\<comment> \<open>keep quantifiers for use in simplification\<close>
	lemma test_bit_split':
	"word_split c = (a, b) \<longrightarrow>
	(\<forall>n m.
	bit b n = (n < size b \<and> bit c n) \<and>
	bit a m = (m < size a \<and> bit c (m + size b)))"
	by (auto simp add: word_split_bin' bit_unsigned_iff word_size bit_drop_bit_eq ac_simps
	dest: bit_imp_le_length)

	lemma test_bit_split:
	"word_split c = (a, b) \<Longrightarrow>
	(\<forall>n::nat. bit b n \<longleftrightarrow> n < size b \<and> bit c n) \<and>
	(\<forall>m::nat. bit a m \<longleftrightarrow> m < size a \<and> bit c (m + size b))"
	by (simp add: test_bit_split')

	lemma test_bit_split_eq:
	"word_split c = (a, b) \<longleftrightarrow>
	((\<forall>n::nat. bit b n = (n < size b \<and> bit c n)) \<and>
	(\<forall>m::nat. bit a m = (m < size a \<and> bit c (m + size b))))"
	apply (rule_tac iffI)
	apply (rule_tac conjI)
	apply (erule test_bit_split [THEN conjunct1])
	apply (erule test_bit_split [THEN conjunct2])
	apply (case_tac "word_split c")
	apply (frule test_bit_split)
	apply (erule trans)
	apply (fastforce intro!: word_eqI simp add: word_size)
	done

	lemma test_bit_rcat:
	"sw = size (hd wl) \<Longrightarrow> rc = word_rcat wl \<Longrightarrow> bit rc n =
	(n < size rc \<and> n div sw < size wl \<and> bit ((rev wl) ! (n div sw)) (n mod sw))"
	for wl :: "'a::len word list"
	by (simp add: word_size word_rcat_def rev_map bit_horner_sum_uint_exp_iff bit_simps not_le)

	lemmas test_bit_cong = arg_cong [where f = "bit", THEN fun_cong]

	lemma max_test_bit: "bit (- 1::'a::len word) n \<longleftrightarrow> n < LENGTH('a)"
	by (fact nth_minus1)

	lemma map_nth_0 [simp]: "map (bit (0::'a::len word)) xs = replicate (length xs) False"
	by (simp flip: map_replicate_const)

	lemma word_and_1:
	"n AND 1 = (if bit n 0 then 1 else 0)" for n :: "_ word"
	by (rule bit_word_eqI) (auto simp add: bit_and_iff bit_1_iff intro: gr0I)

	lemma test_bit_1':
	"bit (1 :: 'a :: len word) n \<longleftrightarrow> 0 < LENGTH('a) \<and> n = 0"
	by simp

	lemma nth_w2p_same:
	"bit (2^n :: 'a :: len word) n = (n < LENGTH('a))"
	by (simp add: nth_w2p)

	lemma word_leI:
	"(\<And>n. \<lbrakk>n < size (u::'a::len word); bit u n \<rbrakk> \<Longrightarrow> bit (v::'a::len word) n) \<Longrightarrow> u <= v"
	apply (rule order_trans [of u \<open>u AND v\<close> v])
	apply (rule eq_refl)
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps word_and_le1 word_size)
	done

	lemma bang_eq:
	fixes x :: "'a::len word"
	shows "(x = y) = (\<forall>n. bit x n = bit y n)"
	by (auto intro!: bit_eqI)

	lemma neg_mask_test_bit:
	"bit (NOT(mask n) :: 'a :: len word) m = (n \<le> m \<and> m < LENGTH('a))"
	by (auto simp add: bit_simps)

	lemma upper_bits_unset_is_l2p:
	\<open>(\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> bit p n') \<longleftrightarrow> (p < 2 ^ n)\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
	if \<open>n < LENGTH('a)\<close>
	for p :: "'a :: len word"
	proof
	assume ?Q
	then show ?P
	by (meson bang_is_le le_less_trans not_le word_power_increasing)
	next
	assume ?P
	have \<open>take_bit n p = p\<close>
	proof (rule bit_word_eqI)
	fix q
	assume \<open>q < LENGTH('a)\<close>
	show \<open>bit (take_bit n p) q \<longleftrightarrow> bit p q\<close>
	proof (cases \<open>q < n\<close>)
	case True
	then show ?thesis
	by (auto simp add: bit_simps)
	next
	case False
	then have \<open>n \<le> q\<close>
	by simp
	with \<open>?P\<close> \<open>q < LENGTH('a)\<close> have \<open>\<not> bit p q\<close>
	by simp
	then show ?thesis
	by (simp add: bit_simps)
	qed
	qed
	with that show ?Q
	using take_bit_word_eq_self_iff [of n p] by auto
	qed

	lemma less_2p_is_upper_bits_unset:
	"p < 2 ^ n \<longleftrightarrow> n < LENGTH('a) \<and> (\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> bit p n')" for p :: "'a :: len word"
	by (meson le_less_trans le_mask_iff_lt_2n upper_bits_unset_is_l2p word_zero_le)

	lemma test_bit_over:
	"n \<ge> size (x::'a::len word) \<Longrightarrow> (bit x n) = False"
	by transfer auto

	lemma le_mask_high_bits:
	"w \<le> mask n \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. \<not> bit w i)"
	for w :: \<open>'a::len word\<close>
	apply (auto simp add: bit_simps word_size less_eq_mask_iff_take_bit_eq_self)
	apply (metis bit_take_bit_iff leD)
	apply (metis atLeastLessThan_iff leI take_bit_word_eq_self_iff upper_bits_unset_is_l2p)
	done

	lemma test_bit_conj_lt:
	"(bit x m \<and> m < LENGTH('a)) = bit x m" for x :: "'a :: len word"
	using test_bit_bin by blast

	lemma neg_test_bit:
	"bit (NOT x) n = (\<not> bit x n \<and> n < LENGTH('a))" for x :: "'a::len word"
	by (cases "n < LENGTH('a)") (auto simp add: test_bit_over word_ops_nth_size word_size)

	lemma nth_bounded:
	"\<lbrakk>bit (x :: 'a :: len word) n; x < 2 ^ m; m \<le> len_of TYPE ('a)\<rbrakk> \<Longrightarrow> n < m"
	apply (rule ccontr)
	apply (auto simp add: not_less)
	apply (meson bit_imp_le_length bit_uint_iff less_2p_is_upper_bits_unset test_bit_bin)
	done

	lemma and_neq_0_is_nth:
	\<open>x AND y \<noteq> 0 \<longleftrightarrow> bit x n\<close> if \<open>y = 2 ^ n\<close> for x y :: \<open>'a::len word\<close>
	apply (simp add: bit_eq_iff bit_simps)
	using that apply (simp add: bit_simps not_le)
	apply transfer
	apply auto
	done

	lemma nth_is_and_neq_0:
	"bit (x::'a::len word) n = (x AND 2 ^ n \<noteq> 0)"
	by (subst and_neq_0_is_nth; rule refl)

	lemma max_word_not_less [simp]:
	"\<not> - 1 < x" for x :: \<open>'a::len word\<close>
	by (fact word_order.extremum_strict)

	lemma bit_twiddle_min:
	"(y::'a::len word) XOR (((x::'a::len word) XOR y) AND (if x < y then -1 else 0)) = min x y"
	by (rule bit_eqI) (auto simp add: bit_simps)

	lemma bit_twiddle_max:
	"(x::'a::len word) XOR (((x::'a::len word) XOR y) AND (if x < y then -1 else 0)) = max x y"
	by (rule bit_eqI) (auto simp add: bit_simps max_def)

	lemma swap_with_xor:
	"\<lbrakk>(x::'a::len word) = a XOR b; y = b XOR x; z = x XOR y\<rbrakk> \<Longrightarrow> z = b \<and> y = a"
	by (auto intro: bit_word_eqI simp add: bit_simps)

	lemma le_mask_imp_and_mask:
	"(x::'a::len word) \<le> mask n \<Longrightarrow> x AND mask n = x"
	by (metis and_mask_eq_iff_le_mask)

	lemma or_not_mask_nop:
	"((x::'a::len word) OR NOT (mask n)) AND mask n = x AND mask n"
	by (metis word_and_not word_ao_dist2 word_bw_comms(1) word_log_esimps(3))

	lemma mask_subsume:
	"\<lbrakk>n \<le> m\<rbrakk> \<Longrightarrow> ((x::'a::len word) OR y AND mask n) AND NOT (mask m) = x AND NOT (mask m)"
	by (rule bit_word_eqI) (auto simp add: bit_simps word_size)

	lemma and_mask_0_iff_le_mask:
	fixes w :: "'a::len word"
	shows "(w AND NOT(mask n) = 0) = (w \<le> mask n)"
	by (simp add: mask_eq_0_eq_x le_mask_imp_and_mask and_mask_eq_iff_le_mask)

	lemma mask_twice2:
	"n \<le> m \<Longrightarrow> ((x::'a::len word) AND mask m) AND mask n = x AND mask n"
	by (metis mask_twice min_def)

	lemma uint_2_id:
	"LENGTH('a) \<ge> 2 \<Longrightarrow> uint (2::('a::len) word) = 2"
	by simp

	lemma div_of_0_id[simp]:"(0::('a::len) word) div n = 0"
	by (simp add: word_div_def)

	lemma degenerate_word:"LENGTH('a) = 1 \<Longrightarrow> (x::('a::len) word) = 0 \<or> x = 1"
	by (metis One_nat_def less_irrefl_nat sint_1_cases)

	lemma div_by_0_word:"(x::('a::len) word) div 0 = 0"
	by (metis div_0 div_by_0 unat_0 word_arith_nat_defs(6) word_div_1)

	lemma div_less_dividend_word:"\<lbrakk>x \<noteq> 0; n \<noteq> 1\<rbrakk> \<Longrightarrow> (x::('a::len) word) div n < x"
	apply (cases \<open>n = 0\<close>)
	apply clarsimp
	apply (simp add:word_neq_0_conv)
	apply (subst word_arith_nat_div)
	apply (rule word_of_nat_less)
	apply (rule div_less_dividend)
	using unat_eq_zero word_unat_Rep_inject1 apply force
	apply (simp add:unat_gt_0)
	done

	lemma word_less_div:
	fixes x :: "('a::len) word"
	and y :: "('a::len) word"
	shows "x div y = 0 \<Longrightarrow> y = 0 \<or> x < y"
	apply (case_tac "y = 0", clarsimp+)
	by (metis One_nat_def Suc_le_mono le0 le_div_geq not_less unat_0 unat_div unat_gt_0 word_less_nat_alt zero_less_one)

	lemma not_degenerate_imp_2_neq_0:"LENGTH('a) > 1 \<Longrightarrow> (2::('a::len) word) \<noteq> 0"
	by (metis numerals(1) power_not_zero power_zero_numeral)

	lemma word_overflow:"(x::('a::len) word) + 1 > x \<or> x + 1 = 0"
	apply clarsimp
	by (metis diff_0 eq_diff_eq less_x_plus_1)

	lemma word_overflow_unat:"unat ((x::('a::len) word) + 1) = unat x + 1 \<or> x + 1 = 0"
	by (metis Suc_eq_plus1 add.commute unatSuc)

	lemma even_word_imp_odd_next:"even (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> odd (unat (x + 1))"
	apply (cut_tac x=x in word_overflow_unat)
	apply clarsimp
	done

	lemma odd_word_imp_even_next:"odd (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> even (unat (x + 1))"
	apply (cut_tac x=x in word_overflow_unat)
	apply clarsimp
	done

	lemma overflow_imp_lsb:"(x::('a::len) word) + 1 = 0 \<Longrightarrow> bit x 0"
	- using even_plus_one_iff [of x] by simp
	+ using even_plus_one_iff [of x] by (simp add: bit_0)

	lemma odd_iff_lsb:"odd (unat (x::('a::len) word)) = bit x 0"
	- by transfer (simp add: even_nat_iff)
	+ by transfer (simp add: even_nat_iff bit_0)

	lemma of_nat_neq_iff_word:
	"x mod 2 ^ LENGTH('a) \<noteq> y mod 2 ^ LENGTH('a) \<Longrightarrow>
	(((of_nat x)::('a::len) word) \<noteq> of_nat y) = (x \<noteq> y)"
	apply (rule iffI)
	apply (case_tac "x = y")
	apply (subst (asm) of_nat_eq_iff[symmetric])
	apply auto
	apply (case_tac "((of_nat x)::('a::len) word) = of_nat y")
	apply auto
	apply (metis unat_of_nat)
	done

	lemma lsb_this_or_next: "\<not> (bit ((x::('a::len) word) + 1) 0) \<Longrightarrow> bit x 0"
	- by simp
	+ by (simp add: bit_0)

	lemma mask_or_not_mask:
	"x AND mask n OR x AND NOT (mask n) = x"
	for x :: \<open>'a::len word\<close>
	apply (subst word_oa_dist, simp)
	apply (subst word_oa_dist2, simp)
	done

	lemma word_gr0_conv_Suc: "(m::'a::len word) > 0 \<Longrightarrow> \<exists>n. m = n + 1"
	by (metis add.commute add_minus_cancel)

	lemma revcast_down_us [OF refl]:
	"rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (signed_drop_bit n w)"
	for w :: "'a::len word"
	apply (simp add: source_size_def target_size_def)
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps ac_simps)
	done

	lemma revcast_down_ss [OF refl]:
	"rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (signed_drop_bit n w)"
	for w :: "'a::len word"
	apply (simp add: source_size_def target_size_def)
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps ac_simps)
	done

	lemma revcast_down_uu [OF refl]:
	"rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (drop_bit n w)"
	for w :: "'a::len word"
	apply (simp add: source_size_def target_size_def)
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps ac_simps)
	done

	lemma revcast_down_su [OF refl]:
	"rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (drop_bit n w)"
	for w :: "'a::len word"
	apply (simp add: source_size_def target_size_def)
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps ac_simps)
	done

	lemma cast_down_rev [OF refl]:
	"uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow> uc w = revcast (push_bit n w)"
	for w :: "'a::len word"
	apply (simp add: source_size_def target_size_def)
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps)
	done

	lemma revcast_up [OF refl]:
	"rc = revcast \<Longrightarrow> source_size rc + n = target_size rc \<Longrightarrow>
	rc w = push_bit n (ucast w :: 'a::len word)"
	apply (simp add: source_size_def target_size_def)
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps)
	apply auto
	apply (metis add.commute add_diff_cancel_right)
	apply (metis diff_add_inverse2 diff_diff_add)
	done

	lemmas rc1 = revcast_up [THEN
	revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
	lemmas rc2 = revcast_down_uu [THEN
	revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]

	lemma word_ops_nth:
	fixes x y :: \<open>'a::len word\<close>
	shows
	word_or_nth: "bit (x OR y) n = (bit x n \<or> bit y n)" and
	word_and_nth: "bit (x AND y) n = (bit x n \<and> bit y n)" and
	word_xor_nth: "bit (x XOR y) n = (bit x n \<noteq> bit y n)"
	by (simp_all add: bit_simps)

	lemma word_power_nonzero:
	"\<lbrakk> (x :: 'a::len word) < 2 ^ (LENGTH('a) - n); n < LENGTH('a); x \<noteq> 0 \<rbrakk>
	\<Longrightarrow> x * 2 ^ n \<noteq> 0"
	- by (metis gr_implies_not0 mult_eq_0_iff nat_mult_power_less_eq numeral_2_eq_2
	- p2_gt_0 unat_eq_zero unat_less_power unat_mult_lem unat_power_lower word_gt_a_gt_0 zero_less_Suc)
	+ by (metis Word.word_div_mult bits_div_0 len_gt_0 len_of_finite_2_def nat_mult_power_less_eq
	+ p2_gt_0 unat_mono unat_power_lower word_gt_a_gt_0)

	lemma less_1_helper:
	"n \<le> m \<Longrightarrow> (n - 1 :: int) < m"
	by arith

	lemma div_power_helper:
	"\<lbrakk> x \<le> y; y < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 ^ y - 1) div (2 ^ x :: 'a::len word) = 2 ^ (y - x) - 1"
	apply (simp flip: mask_eq_exp_minus_1 drop_bit_eq_div)
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps not_le)
	done

	lemma max_word_mask:
	"(- 1 :: 'a::len word) = mask LENGTH('a)"
	by (fact minus_1_eq_mask)

	lemmas mask_len_max = max_word_mask[symmetric]

	lemma mask_out_first_mask_some:
	"\<lbrakk> x AND NOT (mask n) = y; n \<le> m \<rbrakk> \<Longrightarrow> x AND NOT (mask m) = y AND NOT (mask m)"
	for x y :: \<open>'a::len word\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps word_size)

	lemma mask_lower_twice:
	"n \<le> m \<Longrightarrow> (x AND NOT (mask n)) AND NOT (mask m) = x AND NOT (mask m)"
	for x :: \<open>'a::len word\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps word_size)

	lemma mask_lower_twice2:
	"(a AND NOT (mask n)) AND NOT (mask m) = a AND NOT (mask (max n m))"
	for a :: \<open>'a::len word\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps)

	lemma ucast_and_neg_mask:
	"ucast (x AND NOT (mask n)) = ucast x AND NOT (mask n)"
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps dest: bit_imp_le_length)
	done

	lemma ucast_and_mask:
	"ucast (x AND mask n) = ucast x AND mask n"
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps dest: bit_imp_le_length)
	done

	lemma ucast_mask_drop:
	"LENGTH('a :: len) \<le> n \<Longrightarrow> (ucast (x AND mask n) :: 'a word) = ucast x"
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps dest: bit_imp_le_length)
	done

	lemma mask_exceed:
	"n \<ge> LENGTH('a) \<Longrightarrow> (x::'a::len word) AND NOT (mask n) = 0"
	by (rule bit_word_eqI) (simp add: bit_simps)

	lemma word_add_no_overflow:"(x::'a::len word) < - 1 \<Longrightarrow> x < x + 1"
	using less_x_plus_1 order_less_le by blast

	lemma lt_plus_1_le_word:
	fixes x :: "'a::len word"
	assumes bound:"n < unat (maxBound::'a word)"
	shows "x < 1 + of_nat n = (x \<le> of_nat n)"
	by (metis add.commute bound max_word_max word_Suc_leq word_not_le word_of_nat_less)

	lemma unat_ucast_up_simp:
	fixes x :: "'a::len word"
	assumes "LENGTH('a) \<le> LENGTH('b)"
	shows "unat (ucast x :: 'b::len word) = unat x"
	apply (rule bit_eqI)
	using assms apply (auto simp add: bit_simps dest: bit_imp_le_length)
	done

	lemma unat_ucast_less_no_overflow:
	"\<lbrakk>n < 2 ^ LENGTH('a); unat f < n\<rbrakk> \<Longrightarrow> (f::('a::len) word) < of_nat n"
	by (erule (1) order_le_less_trans[OF _ of_nat_mono_maybe,rotated]) simp

	lemma unat_ucast_less_no_overflow_simp:
	"n < 2 ^ LENGTH('a) \<Longrightarrow> (unat f < n) = ((f::('a::len) word) < of_nat n)"
	using unat_less_helper unat_ucast_less_no_overflow by blast

	lemma unat_ucast_no_overflow_le:
	assumes no_overflow: "unat b < (2 :: nat) ^ LENGTH('a)"
	and upward_cast: "LENGTH('a) < LENGTH('b)"
	shows "(ucast (f::'a::len word) < (b :: 'b :: len word)) = (unat f < unat b)"
	proof -
	have LR: "ucast f < b \<Longrightarrow> unat f < unat b"
	apply (rule unat_less_helper)
	apply (simp add:ucast_nat_def)
	apply (rule_tac 'b1 = 'b in ucast_less_ucast[OF order.strict_implies_order, THEN iffD1])
	apply (rule upward_cast)
	apply (simp add: ucast_ucast_mask less_mask_eq word_less_nat_alt
	unat_power_lower[OF upward_cast] no_overflow)
	done
	have RL: "unat f < unat b \<Longrightarrow> ucast f < b"
	proof-
	assume ineq: "unat f < unat b"
	have "ucast (f::'a::len word) < ((ucast (ucast b ::'a::len word)) :: 'b :: len word)"
	apply (simp add: ucast_less_ucast[OF order.strict_implies_order] upward_cast)
	apply (simp only: flip: ucast_nat_def)
	apply (rule unat_ucast_less_no_overflow[OF no_overflow ineq])
	done
	then show ?thesis
	apply (rule order_less_le_trans)
	apply (simp add:ucast_ucast_mask word_and_le2)
	done
	qed
	then show ?thesis by (simp add:RL LR iffI)
	qed

	lemmas ucast_up_mono = ucast_less_ucast[THEN iffD2]

	lemma minus_one_word:
	"(-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
	by simp

	lemma le_2p_upper_bits:
	"\<lbrakk> (p::'a::len word) \<le> 2^n - 1; n < LENGTH('a) \<rbrakk> \<Longrightarrow>
	\<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> bit p n'"
	by (subst upper_bits_unset_is_l2p; simp)

	lemma le2p_bits_unset:
	"p \<le> 2 ^ n - 1 \<Longrightarrow> \<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> bit (p::'a::len word) n'"
	using upper_bits_unset_is_l2p [where p=p]
	by (cases "n < LENGTH('a)") auto

	lemma complement_nth_w2p:
	shows "n' < LENGTH('a) \<Longrightarrow> bit (NOT (2 ^ n :: 'a::len word)) n' = (n' \<noteq> n)"
	by (fastforce simp: word_ops_nth_size word_size nth_w2p)

	lemma word_unat_and_lt:
	"unat x < n \<or> unat y < n \<Longrightarrow> unat (x AND y) < n"
	by (meson le_less_trans word_and_le1 word_and_le2 word_le_nat_alt)

	lemma word_unat_mask_lt:
	"m \<le> size w \<Longrightarrow> unat ((w::'a::len word) AND mask m) < 2 ^ m"
	by (rule word_unat_and_lt) (simp add: unat_mask word_size)

	lemma word_sless_sint_le:"x <s y \<Longrightarrow> sint x \<le> sint y - 1"
	by (metis word_sless_alt zle_diff1_eq)

	lemma upper_trivial:
	fixes x :: "'a::len word"
	shows "x \<noteq> 2 ^ LENGTH('a) - 1 \<Longrightarrow> x < 2 ^ LENGTH('a) - 1"
	by (simp add: less_le)

	lemma constraint_expand:
	fixes x :: "'a::len word"
	shows "x \<in> {y. lower \<le> y \<and> y \<le> upper} = (lower \<le> x \<and> x \<le> upper)"
	by (rule mem_Collect_eq)

	lemma card_map_elide:
	"card ((of_nat :: nat \<Rightarrow> 'a::len word) ` {0..<n}) = card {0..<n}"
	if "n \<le> CARD('a::len word)"
	proof -
	let ?of_nat = "of_nat :: nat \<Rightarrow> 'a word"
	have "inj_on ?of_nat {i. i < CARD('a word)}"
	by (rule inj_onI) (simp add: card_word of_nat_inj)
	moreover have "{0..<n} \<subseteq> {i. i < CARD('a word)}"
	using that by auto
	ultimately have "inj_on ?of_nat {0..<n}"
	by (rule inj_on_subset)
	then show ?thesis
	by (simp add: card_image)
	qed

	lemma card_map_elide2:
	"n \<le> CARD('a::len word) \<Longrightarrow> card ((of_nat::nat \<Rightarrow> 'a::len word) ` {0..<n}) = n"
	by (subst card_map_elide) clarsimp+

	lemma eq_ucast_ucast_eq:
	"LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> x = ucast y \<Longrightarrow> ucast x = y"
	for x :: "'a::len word" and y :: "'b::len word"
	by transfer simp

	lemma le_ucast_ucast_le:
	"x \<le> ucast y \<Longrightarrow> ucast x \<le> y"
	for x :: "'a::len word" and y :: "'b::len word"
	by (smt le_unat_uoi linorder_not_less order_less_imp_le ucast_nat_def unat_arith_simps(1))

	lemma less_ucast_ucast_less:
	"LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> x < ucast y \<Longrightarrow> ucast x < y"
	for x :: "'a::len word" and y :: "'b::len word"
	by (metis ucast_nat_def unat_mono unat_ucast_up_simp word_of_nat_less)

	lemma ucast_le_ucast:
	"LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> (ucast x \<le> (ucast y::'b::len word)) = (x \<le> y)"
	for x :: "'a::len word"
	by (simp add: unat_arith_simps(1) unat_ucast_up_simp)

	lemmas ucast_up_mono_le = ucast_le_ucast[THEN iffD2]

	lemma ucast_or_distrib:
	fixes x :: "'a::len word"
	fixes y :: "'a::len word"
	shows "(ucast (x OR y) :: ('b::len) word) = ucast x OR ucast y"
	by (fact unsigned_or_eq)

	lemma word_exists_nth:
	"(w::'a::len word) \<noteq> 0 \<Longrightarrow> \<exists>i. bit w i"
	by (auto simp add: bit_eq_iff)

	lemma max_word_not_0 [simp]:
	"- 1 \<noteq> (0 :: 'a::len word)"
	by simp

	lemma unat_max_word_pos[simp]: "0 < unat (- 1 :: 'a::len word)"
	using unat_gt_0 [of \<open>- 1 :: 'a::len word\<close>] by simp


	(* Miscellaneous conditional injectivity rules. *)

	lemma mult_pow2_inj:
	assumes ws: "m + n \<le> LENGTH('a)"
	assumes le: "x \<le> mask m" "y \<le> mask m"
	assumes eq: "x * 2 ^ n = y * (2 ^ n::'a::len word)"
	shows "x = y"
	proof (rule bit_word_eqI)
	fix q
	assume \<open>q < LENGTH('a)\<close>
	from eq have \<open>push_bit n x = push_bit n y\<close>
	by (simp add: push_bit_eq_mult)
	moreover from le have \<open>take_bit m x = x\<close> \<open>take_bit m y = y\<close>
	by (simp_all add: less_eq_mask_iff_take_bit_eq_self)
	ultimately have \<open>push_bit n (take_bit m x) = push_bit n (take_bit m y)\<close>
	by simp_all
	with \<open>q < LENGTH('a)\<close> ws show \<open>bit x q \<longleftrightarrow> bit y q\<close>
	apply (simp add: push_bit_take_bit)
	unfolding bit_eq_iff
	apply (simp add: bit_simps not_le)
	apply (metis (full_types) \<open>take_bit m x = x\<close> \<open>take_bit m y = y\<close> add.commute add_diff_cancel_right' add_less_cancel_right bit_take_bit_iff le_add2 less_le_trans)
	done
	qed

	lemma word_of_nat_inj:
	assumes bounded: "x < 2 ^ LENGTH('a)" "y < 2 ^ LENGTH('a)"
	assumes of_nats: "of_nat x = (of_nat y :: 'a::len word)"
	shows "x = y"
	by (rule contrapos_pp[OF of_nats]; cases "x < y"; cases "y < x")
	(auto dest: bounded[THEN of_nat_mono_maybe])

	lemma word_of_int_bin_cat_eq_iff:
	"(word_of_int (concat_bit LENGTH('b) (uint b) (uint a))::'c::len word) =
	word_of_int (concat_bit LENGTH('b) (uint d) (uint c)) \<longleftrightarrow> b = d \<and> a = c"
	if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
	for a::"'a::len word" and b::"'b::len word"
	proof -
	from that show ?thesis
	using that concat_bit_eq_iff [of \<open>LENGTH('b)\<close> \<open>uint b\<close> \<open>uint a\<close> \<open>uint d\<close> \<open>uint c\<close>]
	apply (simp add: word_of_int_eq_iff take_bit_int_eq_self flip: word_eq_iff_unsigned)
	apply (simp add: concat_bit_def take_bit_int_eq_self bintr_uint take_bit_push_bit)
	done
	qed

	lemma word_cat_inj: "(word_cat a b::'c::len word) = word_cat c d \<longleftrightarrow> a = c \<and> b = d"
	if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
	for a::"'a::len word" and b::"'b::len word"
	using word_of_int_bin_cat_eq_iff [OF that, of b a d c]
	by (simp add: word_cat_eq' ac_simps)

	lemma p2_eq_1: "2 ^ n = (1::'a::len word) \<longleftrightarrow> n = 0"
	proof -
	have "2 ^ n = (1::'a word) \<Longrightarrow> n = 0"
	by (metis One_nat_def not_less one_less_numeral_iff p2_eq_0 p2_gt_0 power_0 power_0
	power_inject_exp semiring_norm(76) unat_power_lower zero_neq_one)
	then show ?thesis by auto
	qed

	end

	lemmas word_div_less = div_word_less

	(* FIXME: move to Word distribution? *)
	lemma bin_nth_minus_Bit0[simp]:
	"0 < n \<Longrightarrow> bit (numeral (num.Bit0 w) :: int) n = bit (numeral w :: int) (n - 1)"
	by (cases n; simp)

	lemma bin_nth_minus_Bit1[simp]:
	"0 < n \<Longrightarrow> bit (numeral (num.Bit1 w) :: int) n = bit (numeral w :: int) (n - 1)"
	by (cases n; simp)

	lemma word_mod_by_0: "k mod (0::'a::len word) = k"
	by (simp add: word_arith_nat_mod)

	end
	diff --git a/thys/Word_Lib/More_Word_Operations.thy b/thys/Word_Lib/More_Word_Operations.thy
	--- a/thys/Word_Lib/More_Word_Operations.thy
	+++ b/thys/Word_Lib/More_Word_Operations.thy
	@@ -1,1015 +1,1015 @@
	(*
	* Copyright Data61, CSIRO (ABN 41 687 119 230)
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	section \<open>Misc word operations\<close>

	theory More_Word_Operations
	imports
	"HOL-Library.Word"
	Aligned
	Reversed_Bit_Lists
	More_Misc
	Signed_Words
	Word_Lemmas
	Word_EqI
	begin

	context
	includes bit_operations_syntax
	begin

	definition
	ptr_add :: "'a :: len word \<Rightarrow> nat \<Rightarrow> 'a word" where
	"ptr_add ptr n \<equiv> ptr + of_nat n"

	definition
	alignUp :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word" where
	"alignUp x n \<equiv> x + 2 ^ n - 1 AND NOT (2 ^ n - 1)"

	lemma alignUp_unfold:
	\<open>alignUp w n = (w + mask n) AND NOT (mask n)\<close>
	by (simp add: alignUp_def mask_eq_exp_minus_1 add_mask_fold)

	(* standard notation for blocks of 2^n-1 words, usually aligned;
	abbreviation so it simplifies directly *)
	abbreviation mask_range :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word set" where
	"mask_range p n \<equiv> {p .. p + mask n}"

	definition
	w2byte :: "'a :: len word \<Rightarrow> 8 word" where
	"w2byte \<equiv> ucast"

	(* Count leading zeros *)
	definition
	word_clz :: "'a::len word \<Rightarrow> nat"
	where
	"word_clz w \<equiv> length (takeWhile Not (to_bl w))"

	(* Count trailing zeros *)
	definition
	word_ctz :: "'a::len word \<Rightarrow> nat"
	where
	"word_ctz w \<equiv> length (takeWhile Not (rev (to_bl w)))"

	lemma word_ctz_unfold:
	\<open>word_ctz w = length (takeWhile (Not \<circ> bit w) [0..<LENGTH('a)])\<close> for w :: \<open>'a::len word\<close>
	by (simp add: word_ctz_def rev_to_bl_eq takeWhile_map)

	lemma word_ctz_unfold':
	\<open>word_ctz w = Min (insert LENGTH('a) {n. bit w n})\<close> for w :: \<open>'a::len word\<close>
	proof (cases \<open>\<exists>n. bit w n\<close>)
	case True
	then obtain n where \<open>bit w n\<close> ..
	from \<open>bit w n\<close> show ?thesis
	apply (simp add: word_ctz_unfold)
	apply (subst Min_eq_length_takeWhile [symmetric])
	apply (auto simp add: bit_imp_le_length)
	apply (subst Min_insert)
	apply auto
	apply (subst min.absorb2)
	apply (subst Min_le_iff)
	apply auto
	apply (meson bit_imp_le_length order_less_le)
	done
	next
	case False
	then have \<open>bit w = bot\<close>
	by auto
	then have \<open>word_ctz w = LENGTH('a)\<close>
	by (simp add: word_ctz_def rev_to_bl_eq bot_fun_def map_replicate_const)
	with \<open>bit w = bot\<close> show ?thesis
	by simp
	qed

	lemma word_ctz_le:
	"word_ctz (w :: ('a::len word)) \<le> LENGTH('a)"
	apply (clarsimp simp: word_ctz_def)
	using length_takeWhile_le apply (rule order_trans)
	apply simp
	done

	lemma word_ctz_less:
	"w \<noteq> 0 \<Longrightarrow> word_ctz (w :: ('a::len word)) < LENGTH('a)"
	apply (clarsimp simp: word_ctz_def eq_zero_set_bl)
	using length_takeWhile_less apply (rule less_le_trans)
	apply auto
	done

	lemma take_bit_word_ctz_eq [simp]:
	\<open>take_bit LENGTH('a) (word_ctz w) = word_ctz w\<close>
	for w :: \<open>'a::len word\<close>
	apply (simp add: take_bit_nat_eq_self_iff word_ctz_def to_bl_unfold)
	using length_takeWhile_le apply (rule le_less_trans)
	apply simp
	done

	lemma word_ctz_not_minus_1:
	\<open>word_of_nat (word_ctz (w :: 'a :: len word)) \<noteq> (- 1 :: 'a::len word)\<close> if \<open>1 < LENGTH('a)\<close>
	proof -
	note word_ctz_le
	also from that have \<open>LENGTH('a) < mask LENGTH('a)\<close>
	by (simp add: less_mask)
	finally have \<open>word_ctz w < mask LENGTH('a)\<close> .
	then have \<open>word_of_nat (word_ctz w) < (word_of_nat (mask LENGTH('a)) :: 'a word)\<close>
	by (simp add: of_nat_word_less_iff)
	also have \<open>\<dots> = - 1\<close>
	by (rule bit_word_eqI) (simp add: bit_simps)
	finally show ?thesis
	by simp
	qed

	lemma unat_of_nat_ctz_mw:
	"unat (of_nat (word_ctz (w :: 'a :: len word)) :: 'a :: len word) = word_ctz w"
	by (simp add: unsigned_of_nat)

	lemma unat_of_nat_ctz_smw:
	"unat (of_nat (word_ctz (w :: 'a :: len word)) :: 'a :: len signed word) = word_ctz w"
	by (simp add: unsigned_of_nat)

	definition
	word_log2 :: "'a::len word \<Rightarrow> nat"
	where
	"word_log2 (w::'a::len word) \<equiv> size w - 1 - word_clz w"

	(* Bit population count. Equivalent of __builtin_popcount. *)
	definition
	pop_count :: "('a::len) word \<Rightarrow> nat"
	where
	"pop_count w \<equiv> length (filter id (to_bl w))"

	(* Sign extension from bit n *)
	definition
	sign_extend :: "nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word"
	where
	"sign_extend n w \<equiv> if bit w n then w OR NOT (mask n) else w AND mask n"

	lemma sign_extend_eq_signed_take_bit:
	\<open>sign_extend = signed_take_bit\<close>
	proof (rule ext)+
	fix n and w :: \<open>'a::len word\<close>
	show \<open>sign_extend n w = signed_take_bit n w\<close>
	proof (rule bit_word_eqI)
	fix q
	assume \<open>q < LENGTH('a)\<close>
	then show \<open>bit (sign_extend n w) q \<longleftrightarrow> bit (signed_take_bit n w) q\<close>
	by (auto simp add: bit_signed_take_bit_iff
	sign_extend_def bit_and_iff bit_or_iff bit_not_iff bit_mask_iff not_less
	exp_eq_0_imp_not_bit not_le min_def)
	qed
	qed

	definition
	sign_extended :: "nat \<Rightarrow> 'a::len word \<Rightarrow> bool"
	where
	"sign_extended n w \<equiv> \<forall>i. n < i \<longrightarrow> i < size w \<longrightarrow> bit w i = bit w n"

	lemma ptr_add_0 [simp]:
	"ptr_add ref 0 = ref "
	unfolding ptr_add_def by simp

	lemma pop_count_0[simp]:
	"pop_count 0 = 0"
	by (clarsimp simp:pop_count_def)

	lemma pop_count_1[simp]:
	"pop_count 1 = 1"
	by (clarsimp simp:pop_count_def to_bl_1)

	lemma pop_count_0_imp_0:
	"(pop_count w = 0) = (w = 0)"
	apply (rule iffI)
	apply (clarsimp simp:pop_count_def)
	apply (subst (asm) filter_empty_conv)
	apply (clarsimp simp:eq_zero_set_bl)
	apply fast
	apply simp
	done

	lemma word_log2_zero_eq [simp]:
	\<open>word_log2 0 = 0\<close>
	by (simp add: word_log2_def word_clz_def word_size)

	lemma word_log2_unfold:
	\<open>word_log2 w = (if w = 0 then 0 else Max {n. bit w n})\<close>
	for w :: \<open>'a::len word\<close>
	proof (cases \<open>w = 0\<close>)
	case True
	then show ?thesis
	by simp
	next
	case False
	then obtain r where \<open>bit w r\<close>
	by (auto simp add: bit_eq_iff)
	then have \<open>Max {m. bit w m} = LENGTH('a) - Suc (length
	(takeWhile (Not \<circ> bit w) (rev [0..<LENGTH('a)])))\<close>
	by (subst Max_eq_length_takeWhile [of _ \<open>LENGTH('a)\<close>])
	(auto simp add: bit_imp_le_length)
	then have \<open>word_log2 w = Max {x. bit w x}\<close>
	by (simp add: word_log2_def word_clz_def word_size to_bl_unfold rev_map takeWhile_map)
	with \<open>w \<noteq> 0\<close> show ?thesis
	by simp
	qed

	lemma word_log2_eqI:
	\<open>word_log2 w = n\<close>
	if \<open>w \<noteq> 0\<close> \<open>bit w n\<close> \<open>\<And>m. bit w m \<Longrightarrow> m \<le> n\<close>
	for w :: \<open>'a::len word\<close>
	proof -
	from \<open>w \<noteq> 0\<close> have \<open>word_log2 w = Max {n. bit w n}\<close>
	by (simp add: word_log2_unfold)
	also have \<open>Max {n. bit w n} = n\<close>
	using that by (auto intro: Max_eqI)
	finally show ?thesis .
	qed

	lemma bit_word_log2:
	\<open>bit w (word_log2 w)\<close> if \<open>w \<noteq> 0\<close>
	proof -
	from \<open>w \<noteq> 0\<close> have \<open>\<exists>r. bit w r\<close>
	by (auto intro: bit_eqI)
	then obtain r where \<open>bit w r\<close> ..
	from \<open>w \<noteq> 0\<close> have \<open>word_log2 w = Max {n. bit w n}\<close>
	by (simp add: word_log2_unfold)
	also have \<open>Max {n. bit w n} \<in> {n. bit w n}\<close>
	using \<open>bit w r\<close> by (subst Max_in) auto
	finally show ?thesis
	by simp
	qed

	lemma word_log2_maximum:
	\<open>n \<le> word_log2 w\<close> if \<open>bit w n\<close>
	proof -
	have \<open>n \<le> Max {n. bit w n}\<close>
	using that by (auto intro: Max_ge)
	also from that have \<open>w \<noteq> 0\<close>
	by force
	then have \<open>Max {n. bit w n} = word_log2 w\<close>
	by (simp add: word_log2_unfold)
	finally show ?thesis .
	qed

	lemma word_log2_nth_same:
	"w \<noteq> 0 \<Longrightarrow> bit w (word_log2 w)"
	by (drule bit_word_log2) simp

	lemma word_log2_nth_not_set:
	"\<lbrakk> word_log2 w < i ; i < size w \<rbrakk> \<Longrightarrow> \<not> bit w i"
	using word_log2_maximum [of w i] by auto

	lemma word_log2_highest:
	assumes a: "bit w i"
	shows "i \<le> word_log2 w"
	using a by (simp add: word_log2_maximum)

	lemma word_log2_max:
	"word_log2 w < size w"
	apply (cases \<open>w = 0\<close>)
	apply (simp_all add: word_size)
	apply (drule bit_word_log2)
	apply (fact bit_imp_le_length)
	done

	lemma word_clz_0[simp]:
	"word_clz (0::'a::len word) = LENGTH('a)"
	unfolding word_clz_def by simp

	lemma word_clz_minus_one[simp]:
	"word_clz (-1::'a::len word) = 0"
	unfolding word_clz_def by simp

	lemma is_aligned_alignUp[simp]:
	"is_aligned (alignUp p n) n"
	by (simp add: alignUp_def is_aligned_mask mask_eq_decr_exp word_bw_assocs)

	lemma alignUp_le[simp]:
	"alignUp p n \<le> p + 2 ^ n - 1"
	unfolding alignUp_def by (rule word_and_le2)

	lemma alignUp_idem:
	fixes a :: "'a::len word"
	assumes "is_aligned a n" "n < LENGTH('a)"
	shows "alignUp a n = a"
	using assms unfolding alignUp_def
	by (metis add_cancel_right_right add_diff_eq and_mask_eq_iff_le_mask mask_eq_decr_exp mask_out_add_aligned order_refl word_plus_and_or_coroll2)

	lemma alignUp_not_aligned_eq:
	fixes a :: "'a :: len word"
	assumes al: "\<not> is_aligned a n"
	and sz: "n < LENGTH('a)"
	shows "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
	proof -
	have anz: "a mod 2 ^ n \<noteq> 0"
	by (rule not_aligned_mod_nz) fact+

	then have um: "unat (a mod 2 ^ n - 1) div 2 ^ n = 0" using sz
	by (meson Euclidean_Division.div_eq_0_iff le_m1_iff_lt measure_unat order_less_trans
	unat_less_power word_less_sub_le word_mod_less_divisor)

	have "a + 2 ^ n - 1 = (a div 2 ^ n) * 2 ^ n + (a mod 2 ^ n) + 2 ^ n - 1"
	by (simp add: word_mod_div_equality)
	also have "\<dots> = (a mod 2 ^ n - 1) + (a div 2 ^ n + 1) * 2 ^ n"
	by (simp add: field_simps)
	finally show "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n" using sz
	unfolding alignUp_def
	apply (subst mask_eq_decr_exp [symmetric])
	apply (erule ssubst)
	apply (subst neg_mask_is_div)
	apply (simp add: word_arith_nat_div)
	apply (subst unat_word_ariths(1) unat_word_ariths(2))+
	apply (subst uno_simps)
	apply (subst unat_1)
	apply (subst mod_add_right_eq)
	apply simp
	apply (subst power_mod_div)
	apply (subst div_mult_self1)
	apply simp
	apply (subst um)
	apply simp
	apply (subst mod_mod_power)
	apply simp
	apply (subst word_unat_power, subst Abs_fnat_hom_mult)
	apply (subst mult_mod_left)
	apply (subst power_add [symmetric])
	apply simp
	apply (subst Abs_fnat_hom_1)
	apply (subst Abs_fnat_hom_add)
	apply (subst word_unat_power, subst Abs_fnat_hom_mult)
	apply (subst word_unat.Rep_inverse[symmetric], subst Abs_fnat_hom_mult)
	apply simp
	done
	qed

	lemma alignUp_ge:
	fixes a :: "'a :: len word"
	assumes sz: "n < LENGTH('a)"
	and nowrap: "alignUp a n \<noteq> 0"
	shows "a \<le> alignUp a n"
	proof (cases "is_aligned a n")
	case True
	then show ?thesis using sz
	by (subst alignUp_idem, simp_all)
	next
	case False

	have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
	by (metis le_add_diff_inverse2 less_mult_imp_div_less order_less_imp_le power_add unsigned_less)

	have"2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
	by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right lt0 nat_le_power_trans nat_less_le)
	moreover have "2 ^ n * (unat a div 2 ^ n + 1) \<noteq> 2 ^ LENGTH('a)" using nowrap sz
	apply -
	apply (erule contrapos_nn)
	apply (subst alignUp_not_aligned_eq [OF False sz])
	apply (subst unat_arith_simps)
	apply (subst unat_word_ariths)
	apply (subst unat_word_ariths)
	apply simp
	apply (subst mult_mod_left)
	apply (simp add: unat_div field_simps power_add[symmetric] mod_mod_power)
	done
	ultimately have lt: "2 ^ n * (unat a div 2 ^ n + 1) < 2 ^ LENGTH('a)" by simp

	have "a = a div 2 ^ n * 2 ^ n + a mod 2 ^ n" by (rule word_mod_div_equality [symmetric])
	also have "\<dots> < (a div 2 ^ n + 1) * 2 ^ n" using sz lt
	apply (simp add: field_simps)
	apply (rule word_add_less_mono1)
	apply (rule word_mod_less_divisor)
	apply (simp add: word_less_nat_alt)
	apply (subst unat_word_ariths)
	apply (simp add: unat_div)
	done
	also have "\<dots> = alignUp a n"
	by (rule alignUp_not_aligned_eq [symmetric]) fact+
	finally show ?thesis by (rule order_less_imp_le)
	qed

	lemma alignUp_le_greater_al:
	fixes x :: "'a :: len word"
	assumes le: "a \<le> x"
	and sz: "n < LENGTH('a)"
	and al: "is_aligned x n"
	shows "alignUp a n \<le> x"
	proof (cases "is_aligned a n")
	case True
	then show ?thesis using sz le by (simp add: alignUp_idem)
	next
	case False

	then have anz: "a mod 2 ^ n \<noteq> 0"
	by (rule not_aligned_mod_nz)

	from al obtain k where xk: "x = 2 ^ n * of_nat k" and kv: "k < 2 ^ (LENGTH('a) - n)"
	by (auto elim!: is_alignedE)

	then have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ LENGTH('a)"
	using sz
	apply (subst unat_of_nat_eq)
	apply (erule order_less_le_trans)
	apply simp
	apply (subst mult.commute)
	apply simp
	apply (rule nat_less_power_trans)
	apply simp
	apply simp
	done

	have au: "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
	by (rule alignUp_not_aligned_eq) fact+
	also have "\<dots> \<le> of_nat k * 2 ^ n"
	proof (rule word_mult_le_mono1 [OF inc_le _ kn])
	show "a div 2 ^ n < of_nat k" using kv xk le sz anz
	by (simp add: alignUp_div_helper)

	show "(0:: 'a word) < 2 ^ n" using sz by (simp add: p2_gt_0 sz)
	qed

	finally show ?thesis using xk by (simp add: field_simps)
	qed

	lemma alignUp_is_aligned_nz:
	fixes a :: "'a :: len word"
	assumes al: "is_aligned x n"
	and sz: "n < LENGTH('a)"
	and ax: "a \<le> x"
	and az: "a \<noteq> 0"
	shows "alignUp (a::'a :: len word) n \<noteq> 0"
	proof (cases "is_aligned a n")
	case True
	then have "alignUp a n = a" using sz by (simp add: alignUp_idem)
	then show ?thesis using az by simp
	next
	case False
	then have anz: "a mod 2 ^ n \<noteq> 0"
	by (rule not_aligned_mod_nz)

	{
	assume asm: "alignUp a n = 0"

	have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
	by (metis le_add_diff_inverse2 less_mult_imp_div_less order_less_imp_le power_add unsigned_less)

	have leq: "2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
	by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right lt0 nat_le_power_trans
	order_less_imp_le)

	from al obtain k where kv: "k < 2 ^ (LENGTH('a) - n)" and xk: "x = 2 ^ n * of_nat k"
	by (auto elim!: is_alignedE)

	then have "a div 2 ^ n < of_nat k" using ax sz anz
	by (rule alignUp_div_helper)

	then have r: "unat a div 2 ^ n < k" using sz
	by (simp flip: drop_bit_eq_div unat_drop_bit_eq) (metis leI le_unat_uoi unat_mono)

	have "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
	by (rule alignUp_not_aligned_eq) fact+

	then have "\<dots> = 0" using asm by simp
	then have "2 ^ LENGTH('a) dvd 2 ^ n * (unat a div 2 ^ n + 1)"
	using sz by (simp add: unat_arith_simps ac_simps)
	(simp add: unat_word_ariths mod_simps mod_eq_0_iff_dvd)
	with leq have "2 ^ n * (unat a div 2 ^ n + 1) = 2 ^ LENGTH('a)"
	by (force elim!: le_SucE)
	then have "unat a div 2 ^ n = 2 ^ LENGTH('a) div 2 ^ n - 1"
	by (metis (no_types, opaque_lifting) Groups.add_ac(2) add.right_neutral
	add_diff_cancel_left' div_le_dividend div_mult_self4 gr_implies_not0
	le_neq_implies_less power_eq_0_iff zero_neq_numeral)
	then have "unat a div 2 ^ n = 2 ^ (LENGTH('a) - n) - 1"
	using sz by (simp add: power_sub)
	then have "2 ^ (LENGTH('a) - n) - 1 < k" using r
	by simp
	then have False using kv by simp
	} then show ?thesis by clarsimp
	qed

	lemma alignUp_ar_helper:
	fixes a :: "'a :: len word"
	assumes al: "is_aligned x n"
	and sz: "n < LENGTH('a)"
	and sub: "{x..x + 2 ^ n - 1} \<subseteq> {a..b}"
	and anz: "a \<noteq> 0"
	shows "a \<le> alignUp a n \<and> alignUp a n + 2 ^ n - 1 \<le> b"
	proof
	from al have xl: "x \<le> x + 2 ^ n - 1" by (simp add: is_aligned_no_overflow)

	from xl sub have ax: "a \<le> x"
	by auto

	show "a \<le> alignUp a n"
	proof (rule alignUp_ge)
	show "alignUp a n \<noteq> 0" using al sz ax anz
	by (rule alignUp_is_aligned_nz)
	qed fact+

	show "alignUp a n + 2 ^ n - 1 \<le> b"
	proof (rule order_trans)
	from xl show tp: "x + 2 ^ n - 1 \<le> b" using sub
	by auto

	from ax have "alignUp a n \<le> x"
	by (rule alignUp_le_greater_al) fact+
	then have "alignUp a n + (2 ^ n - 1) \<le> x + (2 ^ n - 1)"
	using xl al is_aligned_no_overflow' olen_add_eqv word_plus_mcs_3 by blast
	then show "alignUp a n + 2 ^ n - 1 \<le> x + 2 ^ n - 1"
	by (simp add: field_simps)
	qed
	qed

	lemma alignUp_def2:
	"alignUp a sz = a + 2 ^ sz - 1 AND NOT (mask sz)"
	by (simp add: alignUp_def flip: mask_eq_decr_exp)

	lemma alignUp_def3:
	"alignUp a sz = 2^ sz + (a - 1 AND NOT (mask sz))"
	by (simp add: alignUp_def2 is_aligned_triv field_simps mask_out_add_aligned)

	lemma alignUp_plus:
	"is_aligned w us \<Longrightarrow> alignUp (w + a) us = w + alignUp a us"
	by (clarsimp simp: alignUp_def2 mask_out_add_aligned field_simps)

	lemma alignUp_distance:
	"alignUp (q :: 'a :: len word) sz - q \<le> mask sz"
	by (metis (no_types) add.commute add_diff_cancel_left alignUp_def2 diff_add_cancel
	mask_2pm1 subtract_mask(2) word_and_le1 word_sub_le_iff)

	lemma is_aligned_diff_neg_mask:
	"is_aligned p sz \<Longrightarrow> (p - q AND NOT (mask sz)) = (p - ((alignUp q sz) AND NOT (mask sz)))"
	apply (clarsimp simp only:word_and_le2 diff_conv_add_uminus)
	apply (subst mask_out_add_aligned[symmetric]; simp)
	apply (simp add: eq_neg_iff_add_eq_0)
	apply (subst add.commute)
	apply (simp add: alignUp_distance is_aligned_neg_mask_eq mask_out_add_aligned and_mask_eq_iff_le_mask flip: mask_eq_x_eq_0)
	done

	lemma word_clz_max:
	"word_clz w \<le> size (w::'a::len word)"
	unfolding word_clz_def
	by (metis length_takeWhile_le word_size_bl)

	lemma word_clz_nonzero_max:
	fixes w :: "'a::len word"
	assumes nz: "w \<noteq> 0"
	shows "word_clz w < size (w::'a::len word)"
	proof -
	{
	assume a: "word_clz w = size (w::'a::len word)"
	hence "length (takeWhile Not (to_bl w)) = length (to_bl w)"
	by (simp add: word_clz_def word_size)
	hence allj: "\<forall>j\<in>set(to_bl w). \<not> j"
	by (metis a length_takeWhile_less less_irrefl_nat word_clz_def)
	hence "to_bl w = replicate (length (to_bl w)) False"
	using eq_zero_set_bl nz by fastforce
	hence "w = 0"
	by (metis to_bl_0 word_bl.Rep_eqD word_bl_Rep')
	with nz have False by simp
	}
	thus ?thesis using word_clz_max
	by (fastforce intro: le_neq_trans)
	qed

	(* Sign extension from bit n. *)

	lemma bin_sign_extend_iff [bit_simps]:
	\<open>bit (sign_extend e w) i \<longleftrightarrow> bit w (min e i)\<close>
	if \<open>i < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
	using that by (simp add: sign_extend_def bit_simps min_def)

	lemma sign_extend_bitwise_if:
	"i < size w \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> (if i < e then bit w i else bit w e)"
	by (simp add: word_size bit_simps)

	lemma sign_extend_bitwise_if' [word_eqI_simps]:
	\<open>i < LENGTH('a) \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> (if i < e then bit w i else bit w e)\<close>
	for w :: \<open>'a::len word\<close>
	using sign_extend_bitwise_if [of i w e] by (simp add: word_size)

	lemma sign_extend_bitwise_disj:
	"i < size w \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> i \<le> e \<and> bit w i \<or> e \<le> i \<and> bit w e"
	by (auto simp: sign_extend_bitwise_if)

	lemma sign_extend_bitwise_cases:
	"i < size w \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> (i \<le> e \<longrightarrow> bit w i) \<and> (e \<le> i \<longrightarrow> bit w e)"
	by (auto simp: sign_extend_bitwise_if)

	lemmas sign_extend_bitwise_disj' = sign_extend_bitwise_disj[simplified word_size]
	lemmas sign_extend_bitwise_cases' = sign_extend_bitwise_cases[simplified word_size]

	(* Often, it is easier to reason about an operation which does not overwrite
	the bit which determines which mask operation to apply. *)
	lemma sign_extend_def':
	"sign_extend n w = (if bit w n then w OR NOT (mask (Suc n)) else w AND mask (Suc n))"
	by (rule bit_word_eqI) (auto simp add: bit_simps sign_extend_eq_signed_take_bit min_def less_Suc_eq_le)

	lemma sign_extended_sign_extend:
	"sign_extended n (sign_extend n w)"
	by (clarsimp simp: sign_extended_def word_size sign_extend_bitwise_if)

	lemma sign_extended_iff_sign_extend:
	"sign_extended n w \<longleftrightarrow> sign_extend n w = w"
	apply auto
	apply (auto simp add: bit_eq_iff)
	apply (simp_all add: bit_simps sign_extend_eq_signed_take_bit not_le min_def sign_extended_def word_size split: if_splits)
	using le_imp_less_or_eq apply auto
	done

	lemma sign_extended_weaken:
	"sign_extended n w \<Longrightarrow> n \<le> m \<Longrightarrow> sign_extended m w"
	unfolding sign_extended_def by (cases "n < m") auto

	lemma sign_extend_sign_extend_eq:
	"sign_extend m (sign_extend n w) = sign_extend (min m n) w"
	by (rule bit_word_eqI) (simp add: sign_extend_eq_signed_take_bit bit_simps)

	lemma sign_extended_high_bits:
	"\<lbrakk> sign_extended e p; j < size p; e \<le> i; i < j \<rbrakk> \<Longrightarrow> bit p i = bit p j"
	by (drule (1) sign_extended_weaken; simp add: sign_extended_def)

	lemma sign_extend_eq:
	"w AND mask (Suc n) = v AND mask (Suc n) \<Longrightarrow> sign_extend n w = sign_extend n v"
	by (simp flip: take_bit_eq_mask add: sign_extend_eq_signed_take_bit signed_take_bit_eq_iff_take_bit_eq)

	lemma sign_extended_add:
	assumes p: "is_aligned p n"
	assumes f: "f < 2 ^ n"
	assumes e: "n \<le> e"
	assumes "sign_extended e p"
	shows "sign_extended e (p + f)"
	proof (cases "e < size p")
	case True
	note and_or = is_aligned_add_or[OF p f]
	have "\<not> bit f e"
	using True e less_2p_is_upper_bits_unset[THEN iffD1, OF f]
	by (fastforce simp: word_size)
	hence i: "bit (p + f) e = bit p e"
	by (simp add: and_or bit_simps)
	have fm: "f AND mask e = f"
	by (fastforce intro: subst[where P="\<lambda>f. f AND mask e = f", OF less_mask_eq[OF f]]
	simp: mask_twice e)
	show ?thesis
	using assms
	apply (simp add: sign_extended_iff_sign_extend sign_extend_def i)
	apply (simp add: and_or word_bw_comms[of p f])
	apply (clarsimp simp: word_ao_dist fm word_bw_assocs split: if_splits)
	done
	next
	case False thus ?thesis
	by (simp add: sign_extended_def word_size)
	qed

	lemma sign_extended_neq_mask:
	"\<lbrakk>sign_extended n ptr; m \<le> n\<rbrakk> \<Longrightarrow> sign_extended n (ptr AND NOT (mask m))"
	by (fastforce simp: sign_extended_def word_size neg_mask_test_bit bit_simps)

	definition
	"limited_and (x :: 'a :: len word) y \<longleftrightarrow> (x AND y = x)"

	lemma limited_and_eq_0:
	"\<lbrakk> limited_and x z; y AND NOT z = y \<rbrakk> \<Longrightarrow> x AND y = 0"
	unfolding limited_and_def
	apply (subst arg_cong2[where f="(AND)"])
	apply (erule sym)+
	apply (simp(no_asm) add: word_bw_assocs word_bw_comms word_bw_lcs)
	done

	lemma limited_and_eq_id:
	"\<lbrakk> limited_and x z; y AND z = z \<rbrakk> \<Longrightarrow> x AND y = x"
	unfolding limited_and_def
	by (erule subst, fastforce simp: word_bw_lcs word_bw_assocs word_bw_comms)

	lemma lshift_limited_and:
	"limited_and x z \<Longrightarrow> limited_and (x << n) (z << n)"
	using push_bit_and [of n x z] by (simp add: limited_and_def shiftl_def)

	lemma rshift_limited_and:
	"limited_and x z \<Longrightarrow> limited_and (x >> n) (z >> n)"
	using drop_bit_and [of n x z] by (simp add: limited_and_def shiftr_def)

	lemmas limited_and_simps1 = limited_and_eq_0 limited_and_eq_id

	lemmas is_aligned_limited_and
	= is_aligned_neg_mask_eq[unfolded mask_eq_decr_exp, folded limited_and_def]

	lemmas limited_and_simps = limited_and_simps1
	limited_and_simps1[OF is_aligned_limited_and]
	limited_and_simps1[OF lshift_limited_and]
	limited_and_simps1[OF rshift_limited_and]
	limited_and_simps1[OF rshift_limited_and, OF is_aligned_limited_and]
	not_one_eq

	definition
	from_bool :: "bool \<Rightarrow> 'a::len word" where
	"from_bool b \<equiv> case b of True \<Rightarrow> of_nat 1
	\| False \<Rightarrow> of_nat 0"

	lemma from_bool_eq:
	\<open>from_bool = of_bool\<close>
	by (simp add: fun_eq_iff from_bool_def)

	lemma from_bool_0:
	"(from_bool x = 0) = (\<not> x)"
	by (simp add: from_bool_def split: bool.split)

	lemma from_bool_eq_if':
	"((if P then 1 else 0) = from_bool Q) = (P = Q)"
	by (cases Q) (simp_all add: from_bool_def)

	definition
	to_bool :: "'a::len word \<Rightarrow> bool" where
	"to_bool \<equiv> (\<noteq>) 0"

	lemma to_bool_and_1:
	"to_bool (x AND 1) \<longleftrightarrow> bit x 0"
	- by (simp add: to_bool_def and_one_eq mod_2_eq_odd)
	+ by (simp add: to_bool_def word_and_1)

	lemma to_bool_from_bool [simp]:
	"to_bool (from_bool r) = r"
	unfolding from_bool_def to_bool_def
	by (simp split: bool.splits)

	lemma from_bool_neq_0 [simp]:
	"(from_bool b \<noteq> 0) = b"
	by (simp add: from_bool_def split: bool.splits)

	lemma from_bool_mask_simp [simp]:
	"(from_bool r :: 'a::len word) AND 1 = from_bool r"
	unfolding from_bool_def
	by (clarsimp split: bool.splits)

	lemma from_bool_1 [simp]:
	"(from_bool P = 1) = P"
	by (simp add: from_bool_def split: bool.splits)

	lemma ge_0_from_bool [simp]:
	"(0 < from_bool P) = P"
	by (simp add: from_bool_def split: bool.splits)

	lemma limited_and_from_bool:
	"limited_and (from_bool b) 1"
	by (simp add: from_bool_def limited_and_def split: bool.split)

	lemma to_bool_1 [simp]: "to_bool 1" by (simp add: to_bool_def)
	lemma to_bool_0 [simp]: "\<not>to_bool 0" by (simp add: to_bool_def)

	lemma from_bool_eq_if:
	"(from_bool Q = (if P then 1 else 0)) = (P = Q)"
	by (cases Q) (simp_all add: from_bool_def)

	lemma to_bool_eq_0:
	"(\<not> to_bool x) = (x = 0)"
	by (simp add: to_bool_def)

	lemma to_bool_neq_0:
	"(to_bool x) = (x \<noteq> 0)"
	by (simp add: to_bool_def)

	lemma from_bool_all_helper:
	"(\<forall>bool. from_bool bool = val \<longrightarrow> P bool)
	= ((\<exists>bool. from_bool bool = val) \<longrightarrow> P (val \<noteq> 0))"
	by (auto simp: from_bool_0)

	lemma fold_eq_0_to_bool:
	"(v = 0) = (\<not> to_bool v)"
	by (simp add: to_bool_def)

	lemma from_bool_to_bool_iff:
	"w = from_bool b \<longleftrightarrow> to_bool w = b \<and> (w = 0 \<or> w = 1)"
	by (cases b) (auto simp: from_bool_def to_bool_def)

	lemma from_bool_eqI:
	"from_bool x = from_bool y \<Longrightarrow> x = y"
	unfolding from_bool_def
	by (auto split: bool.splits)

	lemma neg_mask_in_mask_range:
	"is_aligned ptr bits \<Longrightarrow> (ptr' AND NOT(mask bits) = ptr) = (ptr' \<in> mask_range ptr bits)"
	apply (erule is_aligned_get_word_bits)
	apply (rule iffI)
	apply (drule sym)
	apply (simp add: word_and_le2)
	apply (subst word_plus_and_or_coroll, word_eqI_solve)
	apply (metis bit.disj_ac(2) bit.disj_conj_distrib2 le_word_or2 word_and_max word_or_not)
	apply clarsimp
	apply (smt add.right_neutral eq_iff is_aligned_neg_mask_eq mask_out_add_aligned neg_mask_mono_le
	word_and_not)
	apply (simp add: power_overflow mask_eq_decr_exp)
	done

	lemma aligned_offset_in_range:
	"\<lbrakk> is_aligned (x :: 'a :: len word) m; y < 2 ^ m; is_aligned p n; n \<ge> m; n < LENGTH('a) \<rbrakk>
	\<Longrightarrow> (x + y \<in> {p .. p + mask n}) = (x \<in> mask_range p n)"
	apply (subst disjunctive_add)
	apply (simp add: bit_simps)
	apply (erule is_alignedE')
	apply (auto simp add: bit_simps not_le)[1]
	apply (metis less_2p_is_upper_bits_unset)
	apply (simp only: is_aligned_add_or word_ao_dist flip: neg_mask_in_mask_range)
	apply (subgoal_tac \<open>y AND NOT (mask n) = 0\<close>)
	apply simp
	apply (metis (full_types) is_aligned_mask is_aligned_neg_mask less_mask_eq word_bw_comms(1) word_bw_lcs(1))
	done

	lemma mask_range_to_bl':
	"\<lbrakk> is_aligned (ptr :: 'a :: len word) bits; bits < LENGTH('a) \<rbrakk>
	\<Longrightarrow> mask_range ptr bits
	= {x. take (LENGTH('a) - bits) (to_bl x) = take (LENGTH('a) - bits) (to_bl ptr)}"
	apply (rule set_eqI, rule iffI)
	apply clarsimp
	apply (subgoal_tac "\<exists>y. x = ptr + y \<and> y < 2 ^ bits")
	apply clarsimp
	apply (subst is_aligned_add_conv)
	apply assumption
	apply simp
	apply simp
	apply (rule_tac x="x - ptr" in exI)
	apply (simp add: add_diff_eq[symmetric])
	apply (simp only: word_less_sub_le[symmetric])
	apply (rule word_diff_ls')
	apply (simp add: field_simps mask_eq_decr_exp)
	apply assumption
	apply simp
	apply (subgoal_tac "\<exists>y. y < 2 ^ bits \<and> to_bl (ptr + y) = to_bl x")
	apply clarsimp
	apply (rule conjI)
	apply (erule(1) is_aligned_no_wrap')
	apply (simp only: add_diff_eq[symmetric] mask_eq_decr_exp)
	apply (rule word_plus_mono_right)
	apply simp
	apply (erule is_aligned_no_wrap')
	apply simp
	apply (rule_tac x="of_bl (drop (LENGTH('a) - bits) (to_bl x))" in exI)
	apply (rule context_conjI)
	apply (rule order_less_le_trans [OF of_bl_length])
	apply simp
	apply simp
	apply (subst is_aligned_add_conv)
	apply assumption
	apply simp
	apply (drule sym)
	apply (simp add: word_rep_drop)
	done

	lemma mask_range_to_bl:
	"is_aligned (ptr :: 'a :: len word) bits
	\<Longrightarrow> mask_range ptr bits
	= {x. take (LENGTH('a) - bits) (to_bl x) = take (LENGTH('a) - bits) (to_bl ptr)}"
	apply (erule is_aligned_get_word_bits)
	apply (erule(1) mask_range_to_bl')
	apply (rule set_eqI)
	apply (simp add: power_overflow mask_eq_decr_exp)
	done

	lemma aligned_mask_range_cases:
	"\<lbrakk> is_aligned (p :: 'a :: len word) n; is_aligned (p' :: 'a :: len word) n' \<rbrakk>
	\<Longrightarrow> mask_range p n \<inter> mask_range p' n' = {} \<or>
	mask_range p n \<subseteq> mask_range p' n' \<or>
	mask_range p n \<supseteq> mask_range p' n'"
	apply (simp add: mask_range_to_bl)
	apply (rule Meson.disj_comm, rule disjCI)
	apply auto
	apply (subgoal_tac "(\<exists>n''. LENGTH('a) - n = (LENGTH('a) - n') + n'')
	\<or> (\<exists>n''. LENGTH('a) - n' = (LENGTH('a) - n) + n'')")
	apply (fastforce simp: take_add)
	apply arith
	done

	lemma aligned_mask_range_offset_subset:
	assumes al: "is_aligned (ptr :: 'a :: len word) sz" and al': "is_aligned x sz'"
	and szv: "sz' \<le> sz"
	and xsz: "x < 2 ^ sz"
	shows "mask_range (ptr+x) sz' \<subseteq> mask_range ptr sz"
	using al
	proof (rule is_aligned_get_word_bits)
	assume p0: "ptr = 0" and szv': "LENGTH ('a) \<le> sz"
	then have "(2 ::'a word) ^ sz = 0" by simp
	show ?thesis using p0
	by (simp add: \<open>2 ^ sz = 0\<close> mask_eq_decr_exp)
	next
	assume szv': "sz < LENGTH('a)"

	hence blah: "2 ^ (sz - sz') < (2 :: nat) ^ LENGTH('a)"
	using szv by auto
	show ?thesis using szv szv'
	apply auto
	using al assms(4) is_aligned_no_wrap' apply blast
	apply (simp only: flip: add_diff_eq add_mask_fold)
	apply (subst add.assoc, rule word_plus_mono_right)
	using al' is_aligned_add_less_t2n xsz
	apply fastforce
	apply (simp add: field_simps szv al is_aligned_no_overflow)
	done
	qed

	lemma aligned_mask_ranges_disjoint:
	"\<lbrakk> is_aligned (p :: 'a :: len word) n; is_aligned (p' :: 'a :: len word) n';
	p AND NOT(mask n') \<noteq> p'; p' AND NOT(mask n) \<noteq> p \<rbrakk>
	\<Longrightarrow> mask_range p n \<inter> mask_range p' n' = {}"
	using aligned_mask_range_cases
	by (auto simp: neg_mask_in_mask_range)

	lemma aligned_mask_ranges_disjoint2:
	"\<lbrakk> is_aligned p n; is_aligned ptr bits; n \<ge> m; n < size p; m \<le> bits;
	(\<forall>y < 2 ^ (n - m). p + (y << m) \<notin> mask_range ptr bits) \<rbrakk>
	\<Longrightarrow> mask_range p n \<inter> mask_range ptr bits = {}"
	apply safe
	apply (simp only: flip: neg_mask_in_mask_range)
	apply (drule_tac x="x AND mask n >> m" in spec)
	apply (erule notE[OF mp])
	apply (simp flip: take_bit_eq_mask add: shiftr_def drop_bit_take_bit)
	apply transfer
	apply simp
	apply (simp add: word_size and_mask_less_size)
	apply (subst disjunctive_add)
	apply (auto simp add: bit_simps word_size intro!: bit_eqI)
	done

	lemma word_clz_sint_upper[simp]:
	"LENGTH('a) \<ge> 3 \<Longrightarrow> sint (of_nat (word_clz (w :: 'a :: len word)) :: 'a sword) \<le> int (LENGTH('a))"
	using word_clz_max [of w]
	apply (simp add: word_size signed_of_nat)
	apply (subst signed_take_bit_int_eq_self)
	apply simp_all
	apply (metis negative_zle of_nat_numeral semiring_1_class.of_nat_power)
	apply (drule small_powers_of_2)
	apply (erule le_less_trans)
	apply simp
	done

	lemma word_clz_sint_lower[simp]:
	"LENGTH('a) \<ge> 3
	\<Longrightarrow> - sint (of_nat (word_clz (w :: 'a :: len word)) :: 'a signed word) \<le> int (LENGTH('a))"
	apply (subst sint_eq_uint)
	using word_clz_max [of w]
	apply (simp_all add: word_size unsigned_of_nat)
	apply (rule not_msb_from_less)
	apply (simp add: word_less_nat_alt unsigned_of_nat)
	apply (subst take_bit_nat_eq_self)
	apply (simp add: le_less_trans)
	apply (drule small_powers_of_2)
	apply (erule le_less_trans)
	apply simp
	done

	lemma mask_range_subsetD:
	"\<lbrakk> p' \<in> mask_range p n; x' \<in> mask_range p' n'; n' \<le> n; is_aligned p n; is_aligned p' n' \<rbrakk> \<Longrightarrow>
	x' \<in> mask_range p n"
	using aligned_mask_step by fastforce

	lemma add_mult_in_mask_range:
	"\<lbrakk> is_aligned (base :: 'a :: len word) n; n < LENGTH('a); bits \<le> n; x < 2 ^ (n - bits) \<rbrakk>
	\<Longrightarrow> base + x * 2^bits \<in> mask_range base n"
	by (simp add: is_aligned_no_wrap' mask_2pm1 nasty_split_lt word_less_power_trans2
	word_plus_mono_right)

	lemma from_to_bool_last_bit:
	"from_bool (to_bool (x AND 1)) = x AND 1"
	by (metis from_bool_to_bool_iff word_and_1)

	lemma sint_ctz:
	\<open>0 \<le> sint (of_nat (word_ctz (x :: 'a :: len word)) :: 'a signed word)
	\<and> sint (of_nat (word_ctz x) :: 'a signed word) \<le> int (LENGTH('a))\<close> (is \<open>?P \<and> ?Q\<close>)
	if \<open>LENGTH('a) > 2\<close>
	proof
	have *: \<open>word_ctz x < 2 ^ (LENGTH('a) - Suc 0)\<close>
	using word_ctz_le apply (rule le_less_trans)
	using that small_powers_of_2 [of \<open>LENGTH('a)\<close>] apply simp
	done
	have \<open>int (word_ctz x) div 2 ^ (LENGTH('a) - Suc 0) = 0\<close>
	apply (rule div_pos_pos_trivial)
	apply (simp_all add: *)
	done
	then show ?P by (simp add: signed_of_nat bit_iff_odd)
	show ?Q
	apply (auto simp add: signed_of_nat)
	apply (subst signed_take_bit_int_eq_self)
	apply (auto simp add: word_ctz_le * minus_le_iff [of _ \<open>int (word_ctz x)\<close>])
	apply (rule order.trans [of _ 0])
	apply simp_all
	done
	qed

	lemma unat_of_nat_word_log2:
	"LENGTH('a) < 2 ^ LENGTH('b)
	\<Longrightarrow> unat (of_nat (word_log2 (n :: 'a :: len word)) :: 'b :: len word) = word_log2 n"
	by (metis less_trans unat_of_nat_eq word_log2_max word_size)

	lemma aligned_mask_diff:
	"\<lbrakk> is_aligned (dest :: 'a :: len word) bits; is_aligned (ptr :: 'a :: len word) sz;
	bits \<le> sz; sz < LENGTH('a); dest < ptr \<rbrakk>
	\<Longrightarrow> mask bits + dest < ptr"
	apply (frule_tac p' = ptr in aligned_mask_range_cases, assumption)
	apply (elim disjE)
	apply (drule_tac is_aligned_no_overflow_mask, simp)+
	apply (simp add: algebra_split_simps word_le_not_less)
	apply (drule is_aligned_no_overflow_mask; fastforce)
	apply (simp add: is_aligned_weaken algebra_split_simps)
	apply (auto simp add: not_le)
	using is_aligned_no_overflow_mask leD apply blast
	apply (meson aligned_add_mask_less_eq is_aligned_weaken le_less_trans)
	done

	end

	end
	\ No newline at end of file
	diff --git a/thys/Word_Lib/ROOT b/thys/Word_Lib/ROOT
	--- a/thys/Word_Lib/ROOT
	+++ b/thys/Word_Lib/ROOT
	@@ -1,20 +1,19 @@
	chapter AFP

	session Word_Lib (AFP) = HOL +
	options [timeout = 300]
	sessions
	"HOL-Library"
	"HOL-Eisbach"
	theories [document=false]
	More_Arithmetic
	Even_More_List
	More_Sublist
	More_Misc
	Strict_part_mono
	Many_More
	- Ancient_Numeral
	Examples
	theories
	Guide
	document_files
	"root.tex"
	diff --git a/thys/Word_Lib/Reversed_Bit_Lists.thy b/thys/Word_Lib/Reversed_Bit_Lists.thy
	--- a/thys/Word_Lib/Reversed_Bit_Lists.thy
	+++ b/thys/Word_Lib/Reversed_Bit_Lists.thy
	@@ -1,2240 +1,2232 @@
	(*
	* Copyright Data61, CSIRO (ABN 41 687 119 230)
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	(* Author: Jeremy Dawson, NICTA *)

	section \<open>Bit values as reversed lists of bools\<close>

	theory Reversed_Bit_Lists
	imports
	"HOL-Library.Word"
	Typedef_Morphisms
	Least_significant_bit
	Most_significant_bit
	Even_More_List
	"HOL-Library.Sublist"
	Aligned
	Singleton_Bit_Shifts
	Legacy_Aliases
	begin

	context
	includes bit_operations_syntax
	begin

	lemma horner_sum_of_bool_2_concat:
	\<open>horner_sum of_bool 2 (concat (map (\<lambda>x. map (bit x) [0..<LENGTH('a)]) ws)) = horner_sum uint (2 ^ LENGTH('a)) ws\<close>
	for ws :: \<open>'a::len word list\<close>
	proof (induction ws)
	case Nil
	then show ?case
	by simp
	next
	case (Cons w ws)
	moreover have \<open>horner_sum of_bool 2 (map (bit w) [0..<LENGTH('a)]) = uint w\<close>
	proof transfer
	fix k :: int
	have \<open>map (\<lambda>n. n < LENGTH('a) \<and> bit k n) [0..<LENGTH('a)]
	= map (bit k) [0..<LENGTH('a)]\<close>
	by simp
	then show \<open>horner_sum of_bool 2 (map (\<lambda>n. n < LENGTH('a) \<and> bit k n) [0..<LENGTH('a)])
	= take_bit LENGTH('a) k\<close>
	by (simp only: horner_sum_bit_eq_take_bit)
	qed
	ultimately show ?case
	by (simp add: horner_sum_append)
	qed


	subsection \<open>Implicit augmentation of list prefixes\<close>

	primrec takefill :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
	where
	Z: "takefill fill 0 xs = []"
	\| Suc: "takefill fill (Suc n) xs =
	(case xs of
	[] \<Rightarrow> fill # takefill fill n xs
	\| y # ys \<Rightarrow> y # takefill fill n ys)"

	lemma nth_takefill: "m < n \<Longrightarrow> takefill fill n l ! m = (if m < length l then l ! m else fill)"
	apply (induct n arbitrary: m l)
	apply clarsimp
	apply clarsimp
	apply (case_tac m)
	apply (simp split: list.split)
	apply (simp split: list.split)
	done

	lemma takefill_alt: "takefill fill n l = take n l @ replicate (n - length l) fill"
	by (induct n arbitrary: l) (auto split: list.split)

	lemma takefill_replicate [simp]: "takefill fill n (replicate m fill) = replicate n fill"
	by (simp add: takefill_alt replicate_add [symmetric])

	lemma takefill_le': "n = m + k \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
	by (induct m arbitrary: l n) (auto split: list.split)

	lemma length_takefill [simp]: "length (takefill fill n l) = n"
	by (simp add: takefill_alt)

	lemma take_takefill': "n = k + m \<Longrightarrow> take k (takefill fill n w) = takefill fill k w"
	by (induct k arbitrary: w n) (auto split: list.split)

	lemma drop_takefill: "drop k (takefill fill (m + k) w) = takefill fill m (drop k w)"
	by (induct k arbitrary: w) (auto split: list.split)

	lemma takefill_le [simp]: "m \<le> n \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
	by (auto simp: le_iff_add takefill_le')

	lemma take_takefill [simp]: "m \<le> n \<Longrightarrow> take m (takefill fill n w) = takefill fill m w"
	by (auto simp: le_iff_add take_takefill')

	lemma takefill_append: "takefill fill (m + length xs) (xs @ w) = xs @ (takefill fill m w)"
	by (induct xs) auto

	lemma takefill_same': "l = length xs \<Longrightarrow> takefill fill l xs = xs"
	by (induct xs arbitrary: l) auto

	lemmas takefill_same [simp] = takefill_same' [OF refl]

	lemma tf_rev:
	"n + k = m + length bl \<Longrightarrow> takefill x m (rev (takefill y n bl)) =
	rev (takefill y m (rev (takefill x k (rev bl))))"
	apply (rule nth_equalityI)
	apply (auto simp add: nth_takefill rev_nth)
	apply (rule_tac f = "\<lambda>n. bl ! n" in arg_cong)
	apply arith
	done

	lemma takefill_minus: "0 < n \<Longrightarrow> takefill fill (Suc (n - 1)) w = takefill fill n w"
	by auto

	lemmas takefill_Suc_cases =
	list.cases [THEN takefill.Suc [THEN trans]]

	lemmas takefill_Suc_Nil = takefill_Suc_cases (1)
	lemmas takefill_Suc_Cons = takefill_Suc_cases (2)

	lemmas takefill_minus_simps = takefill_Suc_cases [THEN [2]
	takefill_minus [symmetric, THEN trans]]

	lemma takefill_numeral_Nil [simp]:
	"takefill fill (numeral k) [] = fill # takefill fill (pred_numeral k) []"
	by (simp add: numeral_eq_Suc)

	lemma takefill_numeral_Cons [simp]:
	"takefill fill (numeral k) (x # xs) = x # takefill fill (pred_numeral k) xs"
	by (simp add: numeral_eq_Suc)


	subsection \<open>Range projection\<close>

	definition bl_of_nth :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list"
	where "bl_of_nth n f = map f (rev [0..<n])"

	lemma bl_of_nth_simps [simp, code]:
	"bl_of_nth 0 f = []"
	"bl_of_nth (Suc n) f = f n # bl_of_nth n f"
	by (simp_all add: bl_of_nth_def)

	lemma length_bl_of_nth [simp]: "length (bl_of_nth n f) = n"
	by (simp add: bl_of_nth_def)

	lemma nth_bl_of_nth [simp]: "m < n \<Longrightarrow> rev (bl_of_nth n f) ! m = f m"
	by (simp add: bl_of_nth_def rev_map)

	lemma bl_of_nth_inj: "(\<And>k. k < n \<Longrightarrow> f k = g k) \<Longrightarrow> bl_of_nth n f = bl_of_nth n g"
	by (simp add: bl_of_nth_def)

	lemma bl_of_nth_nth_le: "n \<le> length xs \<Longrightarrow> bl_of_nth n (nth (rev xs)) = drop (length xs - n) xs"
	apply (induct n arbitrary: xs)
	apply clarsimp
	apply clarsimp
	apply (rule trans [OF _ hd_Cons_tl])
	apply (frule Suc_le_lessD)
	apply (simp add: rev_nth trans [OF drop_Suc drop_tl, symmetric])
	apply (subst hd_drop_conv_nth)
	apply force
	apply simp_all
	apply (rule_tac f = "\<lambda>n. drop n xs" in arg_cong)
	apply simp
	done

	lemma bl_of_nth_nth [simp]: "bl_of_nth (length xs) ((!) (rev xs)) = xs"
	by (simp add: bl_of_nth_nth_le)


	subsection \<open>More\<close>

	definition rotater1 :: "'a list \<Rightarrow> 'a list"
	where "rotater1 ys =
	(case ys of [] \<Rightarrow> [] \| x # xs \<Rightarrow> last ys # butlast ys)"

	definition rotater :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
	where "rotater n = rotater1 ^^ n"

	lemmas rotater_0' [simp] = rotater_def [where n = "0", simplified]

	lemma rotate1_rl': "rotater1 (l @ [a]) = a # l"
	by (cases l) (auto simp: rotater1_def)

	lemma rotate1_rl [simp] : "rotater1 (rotate1 l) = l"
	apply (unfold rotater1_def)
	apply (cases "l")
	apply (case_tac [2] "list")
	apply auto
	done

	lemma rotate1_lr [simp] : "rotate1 (rotater1 l) = l"
	by (cases l) (auto simp: rotater1_def)

	lemma rotater1_rev': "rotater1 (rev xs) = rev (rotate1 xs)"
	by (cases "xs") (simp add: rotater1_def, simp add: rotate1_rl')

	lemma rotater_rev': "rotater n (rev xs) = rev (rotate n xs)"
	by (induct n) (auto simp: rotater_def intro: rotater1_rev')

	lemma rotater_rev: "rotater n ys = rev (rotate n (rev ys))"
	using rotater_rev' [where xs = "rev ys"] by simp

	lemma rotater_drop_take:
	"rotater n xs =
	drop (length xs - n mod length xs) xs @
	take (length xs - n mod length xs) xs"
	by (auto simp: rotater_rev rotate_drop_take rev_take rev_drop)

	lemma rotater_Suc [simp]: "rotater (Suc n) xs = rotater1 (rotater n xs)"
	unfolding rotater_def by auto

	lemma nth_rotater:
	\<open>rotater m xs ! n = xs ! ((n + (length xs - m mod length xs)) mod length xs)\<close> if \<open>n < length xs\<close>
	using that by (simp add: rotater_drop_take nth_append not_less less_diff_conv ac_simps le_mod_geq)

	lemma nth_rotater1:
	\<open>rotater1 xs ! n = xs ! ((n + (length xs - 1)) mod length xs)\<close> if \<open>n < length xs\<close>
	using that nth_rotater [of n xs 1] by simp

	lemma rotate_inv_plus [rule_format]:
	"\<forall>k. k = m + n \<longrightarrow> rotater k (rotate n xs) = rotater m xs \<and>
	rotate k (rotater n xs) = rotate m xs \<and>
	rotater n (rotate k xs) = rotate m xs \<and>
	rotate n (rotater k xs) = rotater m xs"
	by (induct n) (auto simp: rotater_def rotate_def intro: funpow_swap1 [THEN trans])

	lemmas rotate_inv_rel = le_add_diff_inverse2 [symmetric, THEN rotate_inv_plus]

	lemmas rotate_inv_eq = order_refl [THEN rotate_inv_rel, simplified]

	lemmas rotate_lr [simp] = rotate_inv_eq [THEN conjunct1]
	lemmas rotate_rl [simp] = rotate_inv_eq [THEN conjunct2, THEN conjunct1]

	lemma rotate_gal: "rotater n xs = ys \<longleftrightarrow> rotate n ys = xs"
	by auto

	lemma rotate_gal': "ys = rotater n xs \<longleftrightarrow> xs = rotate n ys"
	by auto

	lemma length_rotater [simp]: "length (rotater n xs) = length xs"
	by (simp add : rotater_rev)

	lemma rotate_eq_mod: "m mod length xs = n mod length xs \<Longrightarrow> rotate m xs = rotate n xs"
	apply (rule box_equals)
	defer
	apply (rule rotate_conv_mod [symmetric])+
	apply simp
	done

	lemma restrict_to_left: "x = y \<Longrightarrow> x = z \<longleftrightarrow> y = z"
	by simp

	lemmas rotate_eqs =
	trans [OF rotate0 [THEN fun_cong] id_apply]
	rotate_rotate [symmetric]
	rotate_id
	rotate_conv_mod
	rotate_eq_mod

	lemmas rrs0 = rotate_eqs [THEN restrict_to_left,
	simplified rotate_gal [symmetric] rotate_gal' [symmetric]]
	lemmas rrs1 = rrs0 [THEN refl [THEN rev_iffD1]]
	lemmas rotater_eqs = rrs1 [simplified length_rotater]
	lemmas rotater_0 = rotater_eqs (1)
	lemmas rotater_add = rotater_eqs (2)

	lemma butlast_map: "xs \<noteq> [] \<Longrightarrow> butlast (map f xs) = map f (butlast xs)"
	by (induct xs) auto

	lemma rotater1_map: "rotater1 (map f xs) = map f (rotater1 xs)"
	by (cases xs) (auto simp: rotater1_def last_map butlast_map)

	lemma rotater_map: "rotater n (map f xs) = map f (rotater n xs)"
	by (induct n) (auto simp: rotater_def rotater1_map)

	lemma but_last_zip [rule_format] :
	"\<forall>ys. length xs = length ys \<longrightarrow> xs \<noteq> [] \<longrightarrow>
	last (zip xs ys) = (last xs, last ys) \<and>
	butlast (zip xs ys) = zip (butlast xs) (butlast ys)"
	apply (induct xs)
	apply auto
	apply ((case_tac ys, auto simp: neq_Nil_conv)[1])+
	done

	lemma but_last_map2 [rule_format] :
	"\<forall>ys. length xs = length ys \<longrightarrow> xs \<noteq> [] \<longrightarrow>
	last (map2 f xs ys) = f (last xs) (last ys) \<and>
	butlast (map2 f xs ys) = map2 f (butlast xs) (butlast ys)"
	apply (induct xs)
	apply auto
	apply ((case_tac ys, auto simp: neq_Nil_conv)[1])+
	done

	lemma rotater1_zip:
	"length xs = length ys \<Longrightarrow>
	rotater1 (zip xs ys) = zip (rotater1 xs) (rotater1 ys)"
	apply (unfold rotater1_def)
	apply (cases xs)
	apply auto
	apply ((case_tac ys, auto simp: neq_Nil_conv but_last_zip)[1])+
	done

	lemma rotater1_map2:
	"length xs = length ys \<Longrightarrow>
	rotater1 (map2 f xs ys) = map2 f (rotater1 xs) (rotater1 ys)"
	by (simp add: rotater1_map rotater1_zip)

	lemmas lrth =
	box_equals [OF asm_rl length_rotater [symmetric]
	length_rotater [symmetric],
	THEN rotater1_map2]

	lemma rotater_map2:
	"length xs = length ys \<Longrightarrow>
	rotater n (map2 f xs ys) = map2 f (rotater n xs) (rotater n ys)"
	by (induct n) (auto intro!: lrth)

	lemma rotate1_map2:
	"length xs = length ys \<Longrightarrow>
	rotate1 (map2 f xs ys) = map2 f (rotate1 xs) (rotate1 ys)"
	by (cases xs; cases ys) auto

	lemmas lth = box_equals [OF asm_rl length_rotate [symmetric]
	length_rotate [symmetric], THEN rotate1_map2]

	lemma rotate_map2:
	"length xs = length ys \<Longrightarrow>
	rotate n (map2 f xs ys) = map2 f (rotate n xs) (rotate n ys)"
	by (induct n) (auto intro!: lth)


	subsection \<open>Explicit bit representation of \<^typ>\<open>int\<close>\<close>

	primrec bl_to_bin_aux :: "bool list \<Rightarrow> int \<Rightarrow> int"
	where
	Nil: "bl_to_bin_aux [] w = w"
	\| Cons: "bl_to_bin_aux (b # bs) w = bl_to_bin_aux bs (of_bool b + 2 * w)"

	definition bl_to_bin :: "bool list \<Rightarrow> int"
	where "bl_to_bin bs = bl_to_bin_aux bs 0"

	primrec bin_to_bl_aux :: "nat \<Rightarrow> int \<Rightarrow> bool list \<Rightarrow> bool list"
	where
	Z: "bin_to_bl_aux 0 w bl = bl"
	\| Suc: "bin_to_bl_aux (Suc n) w bl = bin_to_bl_aux n (w div 2) (odd w # bl)"

	definition bin_to_bl :: "nat \<Rightarrow> int \<Rightarrow> bool list"
	where "bin_to_bl n w = bin_to_bl_aux n w []"

	lemma bin_to_bl_aux_zero_minus_simp [simp]:
	"0 < n \<Longrightarrow> bin_to_bl_aux n 0 bl = bin_to_bl_aux (n - 1) 0 (False # bl)"
	by (cases n) auto

	lemma bin_to_bl_aux_minus1_minus_simp [simp]:
	"0 < n \<Longrightarrow> bin_to_bl_aux n (- 1) bl = bin_to_bl_aux (n - 1) (- 1) (True # bl)"
	by (cases n) auto

	lemma bin_to_bl_aux_one_minus_simp [simp]:
	"0 < n \<Longrightarrow> bin_to_bl_aux n 1 bl = bin_to_bl_aux (n - 1) 0 (True # bl)"
	by (cases n) auto

	lemma bin_to_bl_aux_Bit0_minus_simp [simp]:
	"0 < n \<Longrightarrow>
	bin_to_bl_aux n (numeral (Num.Bit0 w)) bl = bin_to_bl_aux (n - 1) (numeral w) (False # bl)"
	by (cases n) simp_all

	lemma bin_to_bl_aux_Bit1_minus_simp [simp]:
	"0 < n \<Longrightarrow>
	bin_to_bl_aux n (numeral (Num.Bit1 w)) bl = bin_to_bl_aux (n - 1) (numeral w) (True # bl)"
	by (cases n) simp_all

	lemma bl_to_bin_aux_append: "bl_to_bin_aux (bs @ cs) w = bl_to_bin_aux cs (bl_to_bin_aux bs w)"
	by (induct bs arbitrary: w) auto

	lemma bin_to_bl_aux_append: "bin_to_bl_aux n w bs @ cs = bin_to_bl_aux n w (bs @ cs)"
	by (induct n arbitrary: w bs) auto

	lemma bl_to_bin_append: "bl_to_bin (bs @ cs) = bl_to_bin_aux cs (bl_to_bin bs)"
	unfolding bl_to_bin_def by (rule bl_to_bin_aux_append)

	lemma bin_to_bl_aux_alt: "bin_to_bl_aux n w bs = bin_to_bl n w @ bs"
	by (simp add: bin_to_bl_def bin_to_bl_aux_append)

	lemma bin_to_bl_0 [simp]: "bin_to_bl 0 bs = []"
	by (auto simp: bin_to_bl_def)

	lemma size_bin_to_bl_aux: "length (bin_to_bl_aux n w bs) = n + length bs"
	by (induct n arbitrary: w bs) auto

	lemma size_bin_to_bl [simp]: "length (bin_to_bl n w) = n"
	by (simp add: bin_to_bl_def size_bin_to_bl_aux)

	lemma bl_bin_bl': "bin_to_bl (n + length bs) (bl_to_bin_aux bs w) = bin_to_bl_aux n w bs"
	apply (induct bs arbitrary: w n)
	apply auto
	apply (simp_all only: add_Suc [symmetric])
	apply (auto simp add: bin_to_bl_def)
	done

	lemma bl_bin_bl [simp]: "bin_to_bl (length bs) (bl_to_bin bs) = bs"
	unfolding bl_to_bin_def
	apply (rule box_equals)
	apply (rule bl_bin_bl')
	prefer 2
	apply (rule bin_to_bl_aux.Z)
	apply simp
	done

	lemma bl_to_bin_inj: "bl_to_bin bs = bl_to_bin cs \<Longrightarrow> length bs = length cs \<Longrightarrow> bs = cs"
	apply (rule_tac box_equals)
	defer
	apply (rule bl_bin_bl)
	apply (rule bl_bin_bl)
	apply simp
	done

	lemma bl_to_bin_False [simp]: "bl_to_bin (False # bl) = bl_to_bin bl"
	by (auto simp: bl_to_bin_def)

	lemma bl_to_bin_Nil [simp]: "bl_to_bin [] = 0"
	by (auto simp: bl_to_bin_def)

	lemma bin_to_bl_zero_aux: "bin_to_bl_aux n 0 bl = replicate n False @ bl"
	by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)

	lemma bin_to_bl_zero: "bin_to_bl n 0 = replicate n False"
	by (simp add: bin_to_bl_def bin_to_bl_zero_aux)

	lemma bin_to_bl_minus1_aux: "bin_to_bl_aux n (- 1) bl = replicate n True @ bl"
	by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)

	lemma bin_to_bl_minus1: "bin_to_bl n (- 1) = replicate n True"
	by (simp add: bin_to_bl_def bin_to_bl_minus1_aux)


	subsection \<open>Semantic interpretation of \<^typ>\<open>bool list\<close> as \<^typ>\<open>int\<close>\<close>

	lemma bin_bl_bin': "bl_to_bin (bin_to_bl_aux n w bs) = bl_to_bin_aux bs (take_bit n w)"
	by (induct n arbitrary: w bs) (auto simp: bl_to_bin_def take_bit_Suc ac_simps mod_2_eq_odd)

	lemma bin_bl_bin [simp]: "bl_to_bin (bin_to_bl n w) = take_bit n w"
	by (auto simp: bin_to_bl_def bin_bl_bin')

	lemma bl_to_bin_rep_F: "bl_to_bin (replicate n False @ bl) = bl_to_bin bl"
	by (simp add: bin_to_bl_zero_aux [symmetric] bin_bl_bin') (simp add: bl_to_bin_def)

	lemma bin_to_bl_trunc [simp]: "n \<le> m \<Longrightarrow> bin_to_bl n (take_bit m w) = bin_to_bl n w"
	by (auto intro: bl_to_bin_inj)

	lemma bin_to_bl_aux_bintr:
	"bin_to_bl_aux n (take_bit m bin) bl =
	replicate (n - m) False @ bin_to_bl_aux (min n m) bin bl"
	apply (induct n arbitrary: m bin bl)
	apply clarsimp
	apply clarsimp
	apply (case_tac "m")
	apply (clarsimp simp: bin_to_bl_zero_aux)
	apply (erule thin_rl)
	apply (induct_tac n)
	apply (auto simp add: take_bit_Suc)
	done

	lemma bin_to_bl_bintr:
	"bin_to_bl n (take_bit m bin) = replicate (n - m) False @ bin_to_bl (min n m) bin"
	unfolding bin_to_bl_def by (rule bin_to_bl_aux_bintr)

	lemma bl_to_bin_rep_False: "bl_to_bin (replicate n False) = 0"
	by (induct n) auto

	lemma len_bin_to_bl_aux: "length (bin_to_bl_aux n w bs) = n + length bs"
	by (fact size_bin_to_bl_aux)

	lemma len_bin_to_bl: "length (bin_to_bl n w) = n"
	by (fact size_bin_to_bl) (* FIXME: duplicate *)

	lemma sign_bl_bin': "bin_sign (bl_to_bin_aux bs w) = bin_sign w"
	by (induction bs arbitrary: w) (simp_all add: bin_sign_def)

	lemma sign_bl_bin: "bin_sign (bl_to_bin bs) = 0"
	by (simp add: bl_to_bin_def sign_bl_bin')

	lemma bl_sbin_sign_aux: "hd (bin_to_bl_aux (Suc n) w bs) = (bin_sign (signed_take_bit n w) = -1)"
	by (induction n arbitrary: w bs) (auto simp add: bin_sign_def even_iff_mod_2_eq_zero bit_Suc)

	lemma bl_sbin_sign: "hd (bin_to_bl (Suc n) w) = (bin_sign (signed_take_bit n w) = -1)"
	unfolding bin_to_bl_def by (rule bl_sbin_sign_aux)

	lemma bin_nth_of_bl_aux:
	"bit (bl_to_bin_aux bl w) n =
	(n < size bl \<and> rev bl ! n \<or> n \<ge> length bl \<and> bit w (n - size bl))"
	apply (induction bl arbitrary: w)
	apply simp_all
	apply safe
	apply (simp_all add: not_le nth_append bit_double_iff even_bit_succ_iff split: if_splits)
	done

	lemma bin_nth_of_bl: "bit (bl_to_bin bl) n = (n < length bl \<and> rev bl ! n)"
	by (simp add: bl_to_bin_def bin_nth_of_bl_aux)

	lemma bin_nth_bl: "n < m \<Longrightarrow> bit w n = nth (rev (bin_to_bl m w)) n"
	- apply (induct n arbitrary: m w)
	- apply clarsimp
	- apply (case_tac m, clarsimp)
	- apply (clarsimp simp: bin_to_bl_def)
	- apply (simp add: bin_to_bl_aux_alt)
	- apply (case_tac m, clarsimp)
	- apply (clarsimp simp: bin_to_bl_def)
	- apply (simp add: bin_to_bl_aux_alt bit_Suc)
	- done
	+ by (metis bin_bl_bin bin_nth_of_bl nth_bintr size_bin_to_bl)

	lemma nth_bin_to_bl_aux:
	"n < m + length bl \<Longrightarrow> (bin_to_bl_aux m w bl) ! n =
	(if n < m then bit w (m - 1 - n) else bl ! (n - m))"
	apply (induction bl arbitrary: w)
	apply simp_all
	apply (simp add: bin_nth_bl [of \<open>m - Suc n\<close> m] rev_nth flip: bin_to_bl_def)
	apply (metis One_nat_def Suc_pred add_diff_cancel_left'
	add_diff_cancel_right' bin_to_bl_aux_alt bin_to_bl_def
	diff_Suc_Suc diff_is_0_eq diff_zero less_Suc_eq_0_disj
	less_antisym less_imp_Suc_add list.size(3) nat_less_le nth_append size_bin_to_bl_aux)
	done

	lemma nth_bin_to_bl: "n < m \<Longrightarrow> (bin_to_bl m w) ! n = bit w (m - Suc n)"
	by (simp add: bin_to_bl_def nth_bin_to_bl_aux)

	lemma takefill_bintrunc: "takefill False n bl = rev (bin_to_bl n (bl_to_bin (rev bl)))"
	apply (rule nth_equalityI)
	apply simp
	apply (clarsimp simp: nth_takefill rev_nth nth_bin_to_bl bin_nth_of_bl)
	done

	lemma bl_bin_bl_rtf: "bin_to_bl n (bl_to_bin bl) = rev (takefill False n (rev bl))"
	by (simp add: takefill_bintrunc)

	lemma bl_to_bin_lt2p_aux: "bl_to_bin_aux bs w < (w + 1) * (2 ^ length bs)"
	proof (induction bs arbitrary: w)
	case Nil
	then show ?case
	by simp
	next
	case (Cons b bs)
	from Cons.IH [of \<open>1 + 2 * w\<close>] Cons.IH [of \<open>2 * w\<close>]
	show ?case
	apply (auto simp add: algebra_simps)
	apply (subst mult_2 [of \<open>2 ^ length bs\<close>])
	apply (simp only: add.assoc)
	apply (rule pos_add_strict)
	apply simp_all
	done
	qed

	lemma bl_to_bin_lt2p_drop: "bl_to_bin bs < 2 ^ length (dropWhile Not bs)"
	proof (induct bs)
	case Nil
	then show ?case by simp
	next
	case (Cons b bs)
	with bl_to_bin_lt2p_aux[where w=1] show ?case
	by (simp add: bl_to_bin_def)
	qed

	lemma bl_to_bin_lt2p: "bl_to_bin bs < 2 ^ length bs"
	by (metis bin_bl_bin bintr_lt2p bl_bin_bl)

	lemma bl_to_bin_ge2p_aux: "bl_to_bin_aux bs w \<ge> w * (2 ^ length bs)"
	proof (induction bs arbitrary: w)
	case Nil
	then show ?case
	by simp
	next
	case (Cons b bs)
	from Cons.IH [of \<open>1 + 2 * w\<close>] Cons.IH [of \<open>2 * w\<close>]
	show ?case
	apply (auto simp add: algebra_simps)
	apply (rule add_le_imp_le_left [of \<open>2 ^ length bs\<close>])
	apply (rule add_increasing)
	apply simp_all
	done
	qed

	lemma bl_to_bin_ge0: "bl_to_bin bs \<ge> 0"
	apply (unfold bl_to_bin_def)
	apply (rule xtrans(4))
	apply (rule bl_to_bin_ge2p_aux)
	apply simp
	done

	lemma butlast_rest_bin: "butlast (bin_to_bl n w) = bin_to_bl (n - 1) (w div 2)"
	apply (unfold bin_to_bl_def)
	apply (cases n, clarsimp)
	apply clarsimp
	apply (auto simp add: bin_to_bl_aux_alt)
	done

	lemma butlast_bin_rest: "butlast bl = bin_to_bl (length bl - Suc 0) (bl_to_bin bl div 2)"
	using butlast_rest_bin [where w="bl_to_bin bl" and n="length bl"] by simp

	lemma butlast_rest_bl2bin_aux:
	"bl \<noteq> [] \<Longrightarrow> bl_to_bin_aux (butlast bl) w = bl_to_bin_aux bl w div 2"
	by (induct bl arbitrary: w) auto

	lemma butlast_rest_bl2bin: "bl_to_bin (butlast bl) = bl_to_bin bl div 2"
	by (cases bl) (auto simp: bl_to_bin_def butlast_rest_bl2bin_aux)

	lemma trunc_bl2bin_aux:
	"take_bit m (bl_to_bin_aux bl w) =
	bl_to_bin_aux (drop (length bl - m) bl) (take_bit (m - length bl) w)"
	proof (induct bl arbitrary: w)
	case Nil
	show ?case by simp
	next
	case (Cons b bl)
	show ?case
	proof (cases "m - length bl")
	case 0
	then have "Suc (length bl) - m = Suc (length bl - m)" by simp
	with Cons show ?thesis by simp
	next
	case (Suc n)
	then have "m - Suc (length bl) = n" by simp
	with Cons Suc show ?thesis by (simp add: take_bit_Suc ac_simps)
	qed
	qed

	lemma trunc_bl2bin: "take_bit m (bl_to_bin bl) = bl_to_bin (drop (length bl - m) bl)"
	by (simp add: bl_to_bin_def trunc_bl2bin_aux)

	lemma trunc_bl2bin_len [simp]: "take_bit (length bl) (bl_to_bin bl) = bl_to_bin bl"
	by (simp add: trunc_bl2bin)

	lemma bl2bin_drop: "bl_to_bin (drop k bl) = take_bit (length bl - k) (bl_to_bin bl)"
	apply (rule trans)
	prefer 2
	apply (rule trunc_bl2bin [symmetric])
	apply (cases "k \<le> length bl")
	apply auto
	done

	lemma take_rest_power_bin: "m \<le> n \<Longrightarrow> take m (bin_to_bl n w) = bin_to_bl m (((\<lambda>w. w div 2) ^^ (n - m)) w)"
	apply (rule nth_equalityI)
	apply simp
	apply (clarsimp simp add: nth_bin_to_bl nth_rest_power_bin)
	done

	lemma last_bin_last': "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> odd (bl_to_bin_aux xs w)"
	by (induct xs arbitrary: w) auto

	lemma last_bin_last: "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> odd (bl_to_bin xs)"
	unfolding bl_to_bin_def by (erule last_bin_last')

	lemma bin_last_last: "odd w \<longleftrightarrow> last (bin_to_bl (Suc n) w)"
	by (simp add: bin_to_bl_def) (auto simp: bin_to_bl_aux_alt)

	lemma drop_bin2bl_aux:
	"drop m (bin_to_bl_aux n bin bs) =
	bin_to_bl_aux (n - m) bin (drop (m - n) bs)"
	apply (induction n arbitrary: m bin bs)
	apply auto
	apply (case_tac "m \<le> n")
	apply (auto simp add: not_le Suc_diff_le)
	apply (case_tac "m - n")
	apply auto
	apply (use Suc_diff_Suc in fastforce)
	done

	lemma drop_bin2bl: "drop m (bin_to_bl n bin) = bin_to_bl (n - m) bin"
	by (simp add: bin_to_bl_def drop_bin2bl_aux)

	lemma take_bin2bl_lem1: "take m (bin_to_bl_aux m w bs) = bin_to_bl m w"
	apply (induct m arbitrary: w bs)
	apply clarsimp
	apply clarsimp
	apply (simp add: bin_to_bl_aux_alt)
	apply (simp add: bin_to_bl_def)
	apply (simp add: bin_to_bl_aux_alt)
	done

	lemma take_bin2bl_lem: "take m (bin_to_bl_aux (m + n) w bs) = take m (bin_to_bl (m + n) w)"
	by (induct n arbitrary: w bs) (simp_all (no_asm) add: bin_to_bl_def take_bin2bl_lem1, simp)

	lemma bin_split_take: "bin_split n c = (a, b) \<Longrightarrow> bin_to_bl m a = take m (bin_to_bl (m + n) c)"
	apply (induct n arbitrary: b c)
	apply clarsimp
	apply (clarsimp simp: Let_def split: prod.split_asm)
	apply (simp add: bin_to_bl_def)
	apply (simp add: take_bin2bl_lem drop_bit_Suc)
	done

	lemma bin_to_bl_drop_bit:
	"k = m + n \<Longrightarrow> bin_to_bl m (drop_bit n c) = take m (bin_to_bl k c)"
	using bin_split_take by simp

	lemma bin_split_take1:
	"k = m + n \<Longrightarrow> bin_split n c = (a, b) \<Longrightarrow> bin_to_bl m a = take m (bin_to_bl k c)"
	using bin_split_take by simp

	lemma bl_bin_bl_rep_drop:
	"bin_to_bl n (bl_to_bin bl) =
	replicate (n - length bl) False @ drop (length bl - n) bl"
	by (simp add: bl_to_bin_inj bl_to_bin_rep_F trunc_bl2bin)

	lemma bl_to_bin_aux_cat:
	"bl_to_bin_aux bs (concat_bit nv v w) =
	concat_bit (nv + length bs) (bl_to_bin_aux bs v) w"
	by (rule bit_eqI)
	(auto simp add: bin_nth_of_bl_aux bin_nth_cat algebra_simps)

	lemma bin_to_bl_aux_cat:
	"bin_to_bl_aux (nv + nw) (concat_bit nw w v) bs =
	bin_to_bl_aux nv v (bin_to_bl_aux nw w bs)"
	by (induction nw arbitrary: w bs) (simp_all add: concat_bit_Suc)

	lemma bl_to_bin_aux_alt: "bl_to_bin_aux bs w = concat_bit (length bs) (bl_to_bin bs) w"
	using bl_to_bin_aux_cat [where nv = "0" and v = "0"]
	by (simp add: bl_to_bin_def [symmetric])

	lemma bin_to_bl_cat:
	"bin_to_bl (nv + nw) (concat_bit nw w v) =
	bin_to_bl_aux nv v (bin_to_bl nw w)"
	by (simp add: bin_to_bl_def bin_to_bl_aux_cat)

	lemmas bl_to_bin_aux_app_cat =
	trans [OF bl_to_bin_aux_append bl_to_bin_aux_alt]

	lemmas bin_to_bl_aux_cat_app =
	trans [OF bin_to_bl_aux_cat bin_to_bl_aux_alt]

	lemma bl_to_bin_app_cat:
	"bl_to_bin (bsa @ bs) = concat_bit (length bs) (bl_to_bin bs) (bl_to_bin bsa)"
	by (simp only: bl_to_bin_aux_app_cat bl_to_bin_def)

	lemma bin_to_bl_cat_app:
	"bin_to_bl (n + nw) (concat_bit nw wa w) = bin_to_bl n w @ bin_to_bl nw wa"
	by (simp only: bin_to_bl_def bin_to_bl_aux_cat_app)

	text \<open>\<open>bl_to_bin_app_cat_alt\<close> and \<open>bl_to_bin_app_cat\<close> are easily interderivable.\<close>
	lemma bl_to_bin_app_cat_alt: "concat_bit n w (bl_to_bin cs) = bl_to_bin (cs @ bin_to_bl n w)"
	by (simp add: bl_to_bin_app_cat)

	lemma mask_lem: "(bl_to_bin (True # replicate n False)) = bl_to_bin (replicate n True) + 1"
	apply (unfold bl_to_bin_def)
	apply (induct n)
	apply simp
	apply (simp only: Suc_eq_plus1 replicate_add append_Cons [symmetric] bl_to_bin_aux_append)
	apply simp
	done

	lemma bin_exhaust:
	"(\<And>x b. bin = of_bool b + 2 * x \<Longrightarrow> Q) \<Longrightarrow> Q" for bin :: int
	apply (cases \<open>even bin\<close>)
	apply (auto elim!: evenE oddE)
	apply fastforce
	apply fastforce
	done

	primrec rbl_succ :: "bool list \<Rightarrow> bool list"
	where
	Nil: "rbl_succ Nil = Nil"
	\| Cons: "rbl_succ (x # xs) = (if x then False # rbl_succ xs else True # xs)"

	primrec rbl_pred :: "bool list \<Rightarrow> bool list"
	where
	Nil: "rbl_pred Nil = Nil"
	\| Cons: "rbl_pred (x # xs) = (if x then False # xs else True # rbl_pred xs)"

	primrec rbl_add :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
	where \<comment> \<open>result is length of first arg, second arg may be longer\<close>
	Nil: "rbl_add Nil x = Nil"
	\| Cons: "rbl_add (y # ys) x =
	(let ws = rbl_add ys (tl x)
	in (y \<noteq> hd x) # (if hd x \<and> y then rbl_succ ws else ws))"

	primrec rbl_mult :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
	where \<comment> \<open>result is length of first arg, second arg may be longer\<close>
	Nil: "rbl_mult Nil x = Nil"
	\| Cons: "rbl_mult (y # ys) x =
	(let ws = False # rbl_mult ys x
	in if y then rbl_add ws x else ws)"

	lemma size_rbl_pred: "length (rbl_pred bl) = length bl"
	by (induct bl) auto

	lemma size_rbl_succ: "length (rbl_succ bl) = length bl"
	by (induct bl) auto

	lemma size_rbl_add: "length (rbl_add bl cl) = length bl"
	by (induct bl arbitrary: cl) (auto simp: Let_def size_rbl_succ)

	lemma size_rbl_mult: "length (rbl_mult bl cl) = length bl"
	by (induct bl arbitrary: cl) (auto simp add: Let_def size_rbl_add)

	lemmas rbl_sizes [simp] =
	size_rbl_pred size_rbl_succ size_rbl_add size_rbl_mult

	lemmas rbl_Nils =
	rbl_pred.Nil rbl_succ.Nil rbl_add.Nil rbl_mult.Nil

	lemma rbl_add_app2: "length blb \<ge> length bla \<Longrightarrow> rbl_add bla (blb @ blc) = rbl_add bla blb"
	apply (induct bla arbitrary: blb)
	apply simp
	apply clarsimp
	apply (case_tac blb, clarsimp)
	apply (clarsimp simp: Let_def)
	done

	lemma rbl_add_take2:
	"length blb \<ge> length bla \<Longrightarrow> rbl_add bla (take (length bla) blb) = rbl_add bla blb"
	apply (induct bla arbitrary: blb)
	apply simp
	apply clarsimp
	apply (case_tac blb, clarsimp)
	apply (clarsimp simp: Let_def)
	done

	lemma rbl_mult_app2: "length blb \<ge> length bla \<Longrightarrow> rbl_mult bla (blb @ blc) = rbl_mult bla blb"
	apply (induct bla arbitrary: blb)
	apply simp
	apply clarsimp
	apply (case_tac blb, clarsimp)
	apply (clarsimp simp: Let_def rbl_add_app2)
	done

	lemma rbl_mult_take2:
	"length blb \<ge> length bla \<Longrightarrow> rbl_mult bla (take (length bla) blb) = rbl_mult bla blb"
	apply (rule trans)
	apply (rule rbl_mult_app2 [symmetric])
	apply simp
	apply (rule_tac f = "rbl_mult bla" in arg_cong)
	apply (rule append_take_drop_id)
	done

	lemma rbl_add_split:
	"P (rbl_add (y # ys) (x # xs)) =
	(\<forall>ws. length ws = length ys \<longrightarrow> ws = rbl_add ys xs \<longrightarrow>
	(y \<longrightarrow> ((x \<longrightarrow> P (False # rbl_succ ws)) \<and> (\<not> x \<longrightarrow> P (True # ws)))) \<and>
	(\<not> y \<longrightarrow> P (x # ws)))"
	by (cases y) (auto simp: Let_def)

	lemma rbl_mult_split:
	"P (rbl_mult (y # ys) xs) =
	(\<forall>ws. length ws = Suc (length ys) \<longrightarrow> ws = False # rbl_mult ys xs \<longrightarrow>
	(y \<longrightarrow> P (rbl_add ws xs)) \<and> (\<not> y \<longrightarrow> P ws))"
	by (auto simp: Let_def)

	lemma rbl_pred: "rbl_pred (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin - 1))"
	proof (unfold bin_to_bl_def, induction n arbitrary: bin)
	case 0
	then show ?case
	by simp
	next
	case (Suc n)
	obtain b k where \<open>bin = of_bool b + 2 * k\<close>
	using bin_exhaust by blast
	moreover have \<open>(2 * k - 1) div 2 = k - 1\<close>
	using even_succ_div_2 [of \<open>2 * (k - 1)\<close>]
	by simp
	ultimately show ?case
	using Suc [of \<open>bin div 2\<close>]
	by simp (auto simp add: bin_to_bl_aux_alt)
	qed

	lemma rbl_succ: "rbl_succ (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin + 1))"
	apply (unfold bin_to_bl_def)
	apply (induction n arbitrary: bin)
	apply simp_all
	apply (case_tac bin rule: bin_exhaust)
	apply (simp_all add: bin_to_bl_aux_alt ac_simps)
	done

	lemma rbl_add:
	"\<And>bina binb. rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
	rev (bin_to_bl n (bina + binb))"
	apply (unfold bin_to_bl_def)
	apply (induct n)
	apply simp
	apply clarsimp
	apply (case_tac bina rule: bin_exhaust)
	apply (case_tac binb rule: bin_exhaust)
	apply (case_tac b)
	apply (case_tac [!] "ba")
	apply (auto simp: rbl_succ bin_to_bl_aux_alt Let_def ac_simps)
	done

	lemma rbl_add_long:
	"m \<ge> n \<Longrightarrow> rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
	rev (bin_to_bl n (bina + binb))"
	apply (rule box_equals [OF _ rbl_add_take2 rbl_add])
	apply (rule_tac f = "rbl_add (rev (bin_to_bl n bina))" in arg_cong)
	apply (rule rev_swap [THEN iffD1])
	apply (simp add: rev_take drop_bin2bl)
	apply simp
	done

	lemma rbl_mult_gt1:
	"m \<ge> length bl \<Longrightarrow>
	rbl_mult bl (rev (bin_to_bl m binb)) =
	rbl_mult bl (rev (bin_to_bl (length bl) binb))"
	apply (rule trans)
	apply (rule rbl_mult_take2 [symmetric])
	apply simp_all
	apply (rule_tac f = "rbl_mult bl" in arg_cong)
	apply (rule rev_swap [THEN iffD1])
	apply (simp add: rev_take drop_bin2bl)
	done

	lemma rbl_mult_gt:
	"m > n \<Longrightarrow>
	rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
	rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb))"
	by (auto intro: trans [OF rbl_mult_gt1])

	lemmas rbl_mult_Suc = lessI [THEN rbl_mult_gt]

	lemma rbbl_Cons: "b # rev (bin_to_bl n x) = rev (bin_to_bl (Suc n) (of_bool b + 2 * x))"
	by (simp add: bin_to_bl_def) (simp add: bin_to_bl_aux_alt)

	lemma rbl_mult:
	"rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
	rev (bin_to_bl n (bina * binb))"
	apply (induct n arbitrary: bina binb)
	apply simp_all
	apply (unfold bin_to_bl_def)
	apply clarsimp
	apply (case_tac bina rule: bin_exhaust)
	apply (case_tac binb rule: bin_exhaust)
	apply (simp_all add: bin_to_bl_aux_alt)
	apply (simp_all add: rbbl_Cons rbl_mult_Suc rbl_add algebra_simps)
	done

	lemma sclem: "size (concat (map (bin_to_bl n) xs)) = length xs * n"
	by (simp add: length_concat comp_def sum_list_triv)

	lemma bin_cat_foldl_lem:
	"foldl (\<lambda>u k. concat_bit n k u) x xs =
	concat_bit (size xs * n) (foldl (\<lambda>u k. concat_bit n k u) y xs) x"
	apply (induct xs arbitrary: x)
	apply simp
	apply (simp (no_asm))
	apply (frule asm_rl)
	apply (drule meta_spec)
	apply (erule trans)
	apply (drule_tac x = "concat_bit n a y" in meta_spec)
	apply (simp add: bin_cat_assoc_sym)
	done

	lemma bin_rcat_bl: "bin_rcat n wl = bl_to_bin (concat (map (bin_to_bl n) wl))"
	apply (unfold bin_rcat_eq_foldl)
	apply (rule sym)
	apply (induct wl)
	apply (auto simp add: bl_to_bin_append)
	apply (simp add: bl_to_bin_aux_alt sclem)
	apply (simp add: bin_cat_foldl_lem [symmetric])
	done

	lemma bin_last_bl_to_bin: "odd (bl_to_bin bs) \<longleftrightarrow> bs \<noteq> [] \<and> last bs"
	by(cases "bs = []")(auto simp add: bl_to_bin_def last_bin_last'[where w=0])

	lemma bin_rest_bl_to_bin: "bl_to_bin bs div 2 = bl_to_bin (butlast bs)"
	by(cases "bs = []")(simp_all add: bl_to_bin_def butlast_rest_bl2bin_aux)

	lemma bl_xor_aux_bin:
	"map2 (\<lambda>x y. x \<noteq> y) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
	bin_to_bl_aux n (v XOR w) (map2 (\<lambda>x y. x \<noteq> y) bs cs)"
	apply (induction n arbitrary: v w bs cs)
	apply auto
	apply (case_tac v rule: bin_exhaust)
	apply (case_tac w rule: bin_exhaust)
	apply clarsimp
	done

	lemma bl_or_aux_bin:
	"map2 (\<or>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
	bin_to_bl_aux n (v OR w) (map2 (\<or>) bs cs)"
	by (induct n arbitrary: v w bs cs) simp_all

	lemma bl_and_aux_bin:
	"map2 (\<and>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
	bin_to_bl_aux n (v AND w) (map2 (\<and>) bs cs)"
	by (induction n arbitrary: v w bs cs) simp_all

	lemma bl_not_aux_bin: "map Not (bin_to_bl_aux n w cs) = bin_to_bl_aux n (NOT w) (map Not cs)"
	by (induct n arbitrary: w cs) auto

	lemma bl_not_bin: "map Not (bin_to_bl n w) = bin_to_bl n (NOT w)"
	by (simp add: bin_to_bl_def bl_not_aux_bin)

	lemma bl_and_bin: "map2 (\<and>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v AND w)"
	by (simp add: bin_to_bl_def bl_and_aux_bin)

	lemma bl_or_bin: "map2 (\<or>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v OR w)"
	by (simp add: bin_to_bl_def bl_or_aux_bin)

	lemma bl_xor_bin: "map2 (\<noteq>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v XOR w)"
	using bl_xor_aux_bin by (simp add: bin_to_bl_def)


	subsection \<open>Type \<^typ>\<open>'a word\<close>\<close>

	lift_definition of_bl :: \<open>bool list \<Rightarrow> 'a::len word\<close>
	is bl_to_bin .

	lift_definition to_bl :: \<open>'a::len word \<Rightarrow> bool list\<close>
	is \<open>bin_to_bl LENGTH('a)\<close>
	by (simp add: bl_to_bin_inj)

	lemma to_bl_eq:
	\<open>to_bl w = bin_to_bl (LENGTH('a)) (uint w)\<close>
	for w :: \<open>'a::len word\<close>
	by transfer simp

	lemma bit_of_bl_iff [bit_simps]:
	\<open>bit (of_bl bs :: 'a word) n \<longleftrightarrow> rev bs ! n \<and> n < LENGTH('a::len) \<and> n < length bs\<close>
	by transfer (simp add: bin_nth_of_bl ac_simps)

	lemma rev_to_bl_eq:
	\<open>rev (to_bl w) = map (bit w) [0..<LENGTH('a)]\<close>
	for w :: \<open>'a::len word\<close>
	apply (rule nth_equalityI)
	apply (simp add: to_bl.rep_eq)
	apply (simp add: bin_nth_bl bit_word.rep_eq to_bl.rep_eq)
	done

	lemma to_bl_eq_rev:
	\<open>to_bl w = map (bit w) (rev [0..<LENGTH('a)])\<close>
	for w :: \<open>'a::len word\<close>
	using rev_to_bl_eq [of w]
	apply (subst rev_is_rev_conv [symmetric])
	apply (simp add: rev_map)
	done

	lemma of_bl_rev_eq:
	\<open>of_bl (rev bs) = horner_sum of_bool 2 bs\<close>
	apply (rule bit_word_eqI)
	apply (simp add: bit_of_bl_iff)
	apply transfer
	apply (simp add: bit_horner_sum_bit_iff ac_simps)
	done

	lemma of_bl_eq:
	\<open>of_bl bs = horner_sum of_bool 2 (rev bs)\<close>
	using of_bl_rev_eq [of \<open>rev bs\<close>] by simp

	lemma bshiftr1_eq:
	\<open>bshiftr1 b w = of_bl (b # butlast (to_bl w))\<close>
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps to_bl_eq_rev nth_append rev_nth nth_butlast not_less simp flip: bit_Suc)
	apply (metis Suc_pred len_gt_0 less_eq_decr_length_iff not_bit_length verit_la_disequality)
	done

	lemma length_to_bl_eq:
	\<open>length (to_bl w) = LENGTH('a)\<close>
	for w :: \<open>'a::len word\<close>
	by transfer simp

	lemma word_rotr_eq:
	\<open>word_rotr n w = of_bl (rotater n (to_bl w))\<close>
	apply (rule bit_word_eqI)
	subgoal for n
	apply (cases \<open>n < LENGTH('a)\<close>)
	apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff rotater_rev length_to_bl_eq nth_rotate rev_to_bl_eq ac_simps)
	done
	done

	lemma word_rotl_eq:
	\<open>word_rotl n w = of_bl (rotate n (to_bl w))\<close>
	proof -
	have \<open>rotate n (to_bl w) = rev (rotater n (rev (to_bl w)))\<close>
	by (simp add: rotater_rev')
	then show ?thesis
	apply (simp add: word_rotl_eq_word_rotr bit_of_bl_iff length_to_bl_eq rev_to_bl_eq)
	apply (rule bit_word_eqI)
	subgoal for n
	apply (cases \<open>n < LENGTH('a)\<close>)
	apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff nth_rotater)
	done
	done
	qed

	lemma to_bl_def': "(to_bl :: 'a::len word \<Rightarrow> bool list) = bin_to_bl (LENGTH('a)) \<circ> uint"
	by transfer (simp add: fun_eq_iff)

	\<comment> \<open>type definitions theorem for in terms of equivalent bool list\<close>
	lemma td_bl:
	"type_definition
	(to_bl :: 'a::len word \<Rightarrow> bool list)
	of_bl
	{bl. length bl = LENGTH('a)}"
	apply (standard; transfer)
	apply (auto dest: sym)
	done

	global_interpretation word_bl:
	type_definition
	"to_bl :: 'a::len word \<Rightarrow> bool list"
	of_bl
	"{bl. length bl = LENGTH('a::len)}"
	by (fact td_bl)

	lemmas word_bl_Rep' = word_bl.Rep [unfolded mem_Collect_eq, iff]

	lemma word_size_bl: "size w = size (to_bl w)"
	by (auto simp: word_size)

	lemma to_bl_use_of_bl: "to_bl w = bl \<longleftrightarrow> w = of_bl bl \<and> length bl = length (to_bl w)"
	by (fastforce elim!: word_bl.Abs_inverse [unfolded mem_Collect_eq])

	lemma length_bl_gt_0 [iff]: "0 < length (to_bl x)"
	for x :: "'a::len word"
	unfolding word_bl_Rep' by (rule len_gt_0)

	lemma bl_not_Nil [iff]: "to_bl x \<noteq> []"
	for x :: "'a::len word"
	by (fact length_bl_gt_0 [unfolded length_greater_0_conv])

	lemma length_bl_neq_0 [iff]: "length (to_bl x) \<noteq> 0"
	for x :: "'a::len word"
	by (fact length_bl_gt_0 [THEN gr_implies_not0])

	lemma hd_to_bl_iff:
	\<open>hd (to_bl w) \<longleftrightarrow> bit w (LENGTH('a) - 1)\<close>
	for w :: \<open>'a::len word\<close>
	by (simp add: to_bl_eq_rev hd_map hd_rev)

	lemma hd_bl_sign_sint: "hd (to_bl w) = (bin_sign (sint w) = -1)"
	by (simp add: hd_to_bl_iff bit_last_iff bin_sign_def)

	lemma of_bl_drop':
	"lend = length bl - LENGTH('a::len) \<Longrightarrow>
	of_bl (drop lend bl) = (of_bl bl :: 'a word)"
	by transfer (simp flip: trunc_bl2bin)

	lemma test_bit_of_bl:
	"bit (of_bl bl::'a::len word) n = (rev bl ! n \<and> n < LENGTH('a) \<and> n < length bl)"
	by transfer (simp add: bin_nth_of_bl ac_simps)

	lemma no_of_bl: "(numeral bin ::'a::len word) = of_bl (bin_to_bl (LENGTH('a)) (numeral bin))"
	by transfer simp

	lemma uint_bl: "to_bl w = bin_to_bl (size w) (uint w)"
	by transfer simp

	lemma to_bl_bin: "bl_to_bin (to_bl w) = uint w"
	by (simp add: uint_bl word_size)

	lemma to_bl_of_bin: "to_bl (word_of_int bin::'a::len word) = bin_to_bl (LENGTH('a)) bin"
	by (auto simp: uint_bl word_ubin.eq_norm word_size)

	lemma to_bl_numeral [simp]:
	"to_bl (numeral bin::'a::len word) =
	bin_to_bl (LENGTH('a)) (numeral bin)"
	unfolding word_numeral_alt by (rule to_bl_of_bin)

	lemma to_bl_neg_numeral [simp]:
	"to_bl (- numeral bin::'a::len word) =
	bin_to_bl (LENGTH('a)) (- numeral bin)"
	unfolding word_neg_numeral_alt by (rule to_bl_of_bin)

	lemma to_bl_to_bin [simp] : "bl_to_bin (to_bl w) = uint w"
	by (simp add: uint_bl word_size)

	lemma uint_bl_bin: "bl_to_bin (bin_to_bl (LENGTH('a)) (uint x)) = uint x"
	for x :: "'a::len word"
	by (rule trans [OF bin_bl_bin word_ubin.norm_Rep])

	lemma ucast_bl: "ucast w = of_bl (to_bl w)"
	by transfer simp

	lemma ucast_down_bl:
	\<open>(ucast :: 'a::len word \<Rightarrow> 'b::len word) (of_bl bl) = of_bl bl\<close>
	if \<open>is_down (ucast :: 'a::len word \<Rightarrow> 'b::len word)\<close>
	using that by transfer simp

	lemma of_bl_append_same: "of_bl (X @ to_bl w) = w"
	by transfer (simp add: bl_to_bin_app_cat)

	lemma ucast_of_bl_up:
	\<open>ucast (of_bl bl :: 'a::len word) = of_bl bl\<close>
	if \<open>size bl \<le> size (of_bl bl :: 'a::len word)\<close>
	using that
	apply transfer
	apply (rule bit_eqI)
	apply (auto simp add: bit_take_bit_iff)
	apply (subst (asm) trunc_bl2bin_len [symmetric])
	apply (auto simp only: bit_take_bit_iff)
	done

	lemma word_rev_tf:
	"to_bl (of_bl bl::'a::len word) =
	rev (takefill False (LENGTH('a)) (rev bl))"
	by transfer (simp add: bl_bin_bl_rtf)

	lemma word_rep_drop:
	"to_bl (of_bl bl::'a::len word) =
	replicate (LENGTH('a) - length bl) False @
	drop (length bl - LENGTH('a)) bl"
	by (simp add: word_rev_tf takefill_alt rev_take)

	lemma to_bl_ucast:
	"to_bl (ucast (w::'b::len word) ::'a::len word) =
	replicate (LENGTH('a) - LENGTH('b)) False @
	drop (LENGTH('b) - LENGTH('a)) (to_bl w)"
	apply (unfold ucast_bl)
	apply (rule trans)
	apply (rule word_rep_drop)
	apply simp
	done

	lemma ucast_up_app:
	\<open>to_bl (ucast w :: 'b::len word) = replicate n False @ (to_bl w)\<close>
	if \<open>source_size (ucast :: 'a word \<Rightarrow> 'b word) + n = target_size (ucast :: 'a word \<Rightarrow> 'b word)\<close>
	for w :: \<open>'a::len word\<close>
	using that
	by (auto simp add : source_size target_size to_bl_ucast)

	lemma ucast_down_drop [OF refl]:
	"uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow>
	to_bl (uc w) = drop n (to_bl w)"
	by (auto simp add : source_size target_size to_bl_ucast)

	lemma scast_down_drop [OF refl]:
	"sc = scast \<Longrightarrow> source_size sc = target_size sc + n \<Longrightarrow>
	to_bl (sc w) = drop n (to_bl w)"
	apply (subgoal_tac "sc = ucast")
	apply safe
	apply simp
	apply (erule ucast_down_drop)
	apply (rule down_cast_same [symmetric])
	apply (simp add : source_size target_size is_down)
	done

	lemma word_0_bl [simp]: "of_bl [] = 0"
	by transfer simp

	lemma word_1_bl: "of_bl [True] = 1"
	by transfer (simp add: bl_to_bin_def)

	lemma of_bl_0 [simp]: "of_bl (replicate n False) = 0"
	by transfer (simp add: bl_to_bin_rep_False)

	lemma to_bl_0 [simp]: "to_bl (0::'a::len word) = replicate (LENGTH('a)) False"
	by (simp add: uint_bl word_size bin_to_bl_zero)

	\<comment> \<open>links with \<open>rbl\<close> operations\<close>
	lemma word_succ_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_succ w) = rev (rbl_succ (rev bl))"
	by transfer (simp add: rbl_succ)

	lemma word_pred_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_pred w) = rev (rbl_pred (rev bl))"
	by transfer (simp add: rbl_pred)

	lemma word_add_rbl:
	"to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
	to_bl (v + w) = rev (rbl_add (rev vbl) (rev wbl))"
	apply transfer
	apply (drule sym)
	apply (drule sym)
	apply (simp add: rbl_add)
	done

	lemma word_mult_rbl:
	"to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
	to_bl (v * w) = rev (rbl_mult (rev vbl) (rev wbl))"
	apply transfer
	apply (drule sym)
	apply (drule sym)
	apply (simp add: rbl_mult)
	done

	lemma rtb_rbl_ariths:
	"rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_succ w)) = rbl_succ ys"
	"rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_pred w)) = rbl_pred ys"
	"rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v * w)) = rbl_mult ys xs"
	"rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v + w)) = rbl_add ys xs"
	by (auto simp: rev_swap [symmetric] word_succ_rbl word_pred_rbl word_mult_rbl word_add_rbl)

	lemma of_bl_length_less:
	\<open>(of_bl x :: 'a::len word) < 2 ^ k\<close>
	if \<open>length x = k\<close> \<open>k < LENGTH('a)\<close>
	proof -
	from that have \<open>length x < LENGTH('a)\<close>
	by simp
	then have \<open>(of_bl x :: 'a::len word) < 2 ^ length x\<close>
	apply (simp add: of_bl_eq)
	apply transfer
	apply (simp add: take_bit_horner_sum_bit_eq)
	apply (subst length_rev [symmetric])
	apply (simp only: horner_sum_of_bool_2_less)
	done
	with that show ?thesis
	by simp
	qed

	lemma word_eq_rbl_eq: "x = y \<longleftrightarrow> rev (to_bl x) = rev (to_bl y)"
	by simp

	lemma bl_word_not: "to_bl (NOT w) = map Not (to_bl w)"
	by transfer (simp add: bl_not_bin)

	lemma bl_word_xor: "to_bl (v XOR w) = map2 (\<noteq>) (to_bl v) (to_bl w)"
	by transfer (simp flip: bl_xor_bin)

	lemma bl_word_or: "to_bl (v OR w) = map2 (\<or>) (to_bl v) (to_bl w)"
	by transfer (simp flip: bl_or_bin)

	lemma bl_word_and: "to_bl (v AND w) = map2 (\<and>) (to_bl v) (to_bl w)"
	by transfer (simp flip: bl_and_bin)

	lemma bin_nth_uint': "bit (uint w) n \<longleftrightarrow> rev (bin_to_bl (size w) (uint w)) ! n \<and> n < size w"
	apply (unfold word_size)
	apply (safe elim!: bin_nth_uint_imp)
	apply (frule bin_nth_uint_imp)
	apply (fast dest!: bin_nth_bl)+
	done

	lemmas bin_nth_uint = bin_nth_uint' [unfolded word_size]

	lemma test_bit_bl: "bit w n \<longleftrightarrow> rev (to_bl w) ! n \<and> n < size w"
	by transfer (auto simp add: bin_nth_bl)

	lemma to_bl_nth: "n < size w \<Longrightarrow> to_bl w ! n = bit w (size w - Suc n)"
	by (simp add: word_size rev_nth test_bit_bl)

	lemma map_bit_interval_eq:
	\<open>map (bit w) [0..<n] = takefill False n (rev (to_bl w))\<close> for w :: \<open>'a::len word\<close>
	proof (rule nth_equalityI)
	show \<open>length (map (bit w) [0..<n]) =
	length (takefill False n (rev (to_bl w)))\<close>
	by simp
	fix m
	assume \<open>m < length (map (bit w) [0..<n])\<close>
	then have \<open>m < n\<close>
	by simp
	then have \<open>bit w m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
	by (auto simp add: nth_takefill not_less rev_nth to_bl_nth word_size dest: bit_imp_le_length)
	with \<open>m < n \<close>show \<open>map (bit w) [0..<n] ! m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
	by simp
	qed

	lemma to_bl_unfold:
	\<open>to_bl w = rev (map (bit w) [0..<LENGTH('a)])\<close> for w :: \<open>'a::len word\<close>
	by (simp add: map_bit_interval_eq takefill_bintrunc to_bl_def flip: bin_to_bl_def)

	lemma nth_rev_to_bl:
	\<open>rev (to_bl w) ! n \<longleftrightarrow> bit w n\<close>
	if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
	using that by (simp add: to_bl_unfold)

	lemma nth_to_bl:
	\<open>to_bl w ! n \<longleftrightarrow> bit w (LENGTH('a) - Suc n)\<close>
	if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
	using that by (simp add: to_bl_unfold rev_nth)

	lemma of_bl_rep_False: "of_bl (replicate n False @ bs) = of_bl bs"
	by (auto simp: of_bl_def bl_to_bin_rep_F)

	lemma [code abstract]:
	\<open>Word.the_int (of_bl bs :: 'a word) = horner_sum of_bool 2 (take LENGTH('a::len) (rev bs))\<close>
	apply (simp add: of_bl_eq flip: take_bit_horner_sum_bit_eq)
	apply transfer
	apply simp
	done

	lemma [code]:
	\<open>to_bl w = map (bit w) (rev [0..<LENGTH('a::len)])\<close>
	for w :: \<open>'a::len word\<close>
	by (fact to_bl_eq_rev)

	lemma word_reverse_eq_of_bl_rev_to_bl:
	\<open>word_reverse w = of_bl (rev (to_bl w))\<close>
	by (rule bit_word_eqI)
	(auto simp add: bit_word_reverse_iff bit_of_bl_iff nth_to_bl)

	lemmas word_reverse_no_def [simp] =
	word_reverse_eq_of_bl_rev_to_bl [of "numeral w"] for w

	lemma to_bl_word_rev: "to_bl (word_reverse w) = rev (to_bl w)"
	by (rule nth_equalityI) (simp_all add: nth_rev_to_bl word_reverse_def word_rep_drop flip: of_bl_eq)

	lemma to_bl_n1 [simp]: "to_bl (-1::'a::len word) = replicate (LENGTH('a)) True"
	apply (rule word_bl.Abs_inverse')
	apply simp
	apply (rule word_eqI)
	apply (clarsimp simp add: word_size)
	apply (auto simp add: word_bl.Abs_inverse test_bit_bl word_size)
	done

	lemma rbl_word_or: "rev (to_bl (x OR y)) = map2 (\<or>) (rev (to_bl x)) (rev (to_bl y))"
	by (simp add: zip_rev bl_word_or rev_map)

	lemma rbl_word_and: "rev (to_bl (x AND y)) = map2 (\<and>) (rev (to_bl x)) (rev (to_bl y))"
	by (simp add: zip_rev bl_word_and rev_map)

	lemma rbl_word_xor: "rev (to_bl (x XOR y)) = map2 (\<noteq>) (rev (to_bl x)) (rev (to_bl y))"
	by (simp add: zip_rev bl_word_xor rev_map)

	lemma rbl_word_not: "rev (to_bl (NOT x)) = map Not (rev (to_bl x))"
	by (simp add: bl_word_not rev_map)

	lemma bshiftr1_numeral [simp]:
	\<open>bshiftr1 b (numeral w :: 'a word) = of_bl (b # butlast (bin_to_bl LENGTH('a::len) (numeral w)))\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps rev_nth nth_append nth_butlast nth_bin_to_bl simp flip: bit_Suc)

	lemma bshiftr1_bl: "to_bl (bshiftr1 b w) = b # butlast (to_bl w)"
	unfolding bshiftr1_eq by (rule word_bl.Abs_inverse) simp

	lemma shiftl1_of_bl: "shiftl1 (of_bl bl) = of_bl (bl @ [False])"
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps)
	subgoal for n
	apply (cases n)
	apply simp_all
	done
	done

	lemma shiftl1_bl: "shiftl1 w = of_bl (to_bl w @ [False])"
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps)
	subgoal for n
	apply (cases n)
	apply (simp_all add: nth_rev_to_bl)
	done
	done

	lemma bl_shiftl1: "to_bl (shiftl1 w) = tl (to_bl w) @ [False]"
	for w :: "'a::len word"
	by (simp add: shiftl1_bl word_rep_drop drop_Suc drop_Cons') (fast intro!: Suc_leI)

	lemma to_bl_double_eq:
	\<open>to_bl (2 * w) = tl (to_bl w) @ [False]\<close>
	using bl_shiftl1 [of w] by (simp add: shiftl1_def ac_simps)

	\<comment> \<open>Generalized version of \<open>bl_shiftl1\<close>. Maybe this one should replace it?\<close>
	lemma bl_shiftl1': "to_bl (shiftl1 w) = tl (to_bl w @ [False])"
	by (simp add: shiftl1_bl word_rep_drop drop_Suc del: drop_append)

	lemma shiftr1_bl:
	\<open>shiftr1 w = of_bl (butlast (to_bl w))\<close>
	proof (rule bit_word_eqI)
	fix n
	assume \<open>n < LENGTH('a)\<close>
	show \<open>bit (shiftr1 w) n \<longleftrightarrow> bit (of_bl (butlast (to_bl w)) :: 'a word) n\<close>
	proof (cases \<open>n = LENGTH('a) - 1\<close>)
	case True
	then show ?thesis
	by (simp add: bit_shiftr1_iff bit_of_bl_iff)
	next
	case False
	with \<open>n < LENGTH('a)\<close>
	have \<open>n < LENGTH('a) - 1\<close>
	by simp
	with \<open>n < LENGTH('a)\<close> show ?thesis
	by (simp add: bit_shiftr1_iff bit_of_bl_iff rev_nth nth_butlast
	word_size to_bl_nth)
	qed
	qed

	lemma bl_shiftr1: "to_bl (shiftr1 w) = False # butlast (to_bl w)"
	for w :: "'a::len word"
	by (simp add: shiftr1_bl word_rep_drop len_gt_0 [THEN Suc_leI])

	\<comment> \<open>Generalized version of \<open>bl_shiftr1\<close>. Maybe this one should replace it?\<close>
	lemma bl_shiftr1': "to_bl (shiftr1 w) = butlast (False # to_bl w)"
	apply (rule word_bl.Abs_inverse')
	apply (simp del: butlast.simps)
	apply (simp add: shiftr1_bl of_bl_def)
	done

	lemma bl_sshiftr1: "to_bl (sshiftr1 w) = hd (to_bl w) # butlast (to_bl w)"
	for w :: "'a::len word"
	proof (rule nth_equalityI)
	fix n
	assume \<open>n < length (to_bl (sshiftr1 w))\<close>
	then have \<open>n < LENGTH('a)\<close>
	by simp
	then show \<open>to_bl (sshiftr1 w) ! n \<longleftrightarrow> (hd (to_bl w) # butlast (to_bl w)) ! n\<close>
	apply (cases n)
	apply (simp_all add: to_bl_nth word_size hd_conv_nth bit_sshiftr1_iff nth_butlast Suc_diff_Suc nth_to_bl)
	done
	qed simp

	lemma drop_shiftr: "drop n (to_bl (w >> n)) = take (size w - n) (to_bl w)"
	for w :: "'a::len word"
	apply (rule nth_equalityI)
	apply (simp_all add: word_size to_bl_nth bit_simps)
	done

	lemma drop_sshiftr: "drop n (to_bl (w >>> n)) = take (size w - n) (to_bl w)"
	for w :: "'a::len word"
	apply (rule nth_equalityI)
	apply (simp_all add: word_size nth_to_bl bit_simps)
	done

	lemma take_shiftr: "n \<le> size w \<Longrightarrow> take n (to_bl (w >> n)) = replicate n False"
	apply (rule nth_equalityI)
	apply (auto simp add: word_size to_bl_nth bit_simps dest: bit_imp_le_length)
	done

	lemma take_sshiftr':
	"n \<le> size w \<Longrightarrow> hd (to_bl (w >>> n)) = hd (to_bl w) \<and>
	take n (to_bl (w >>> n)) = replicate n (hd (to_bl w))"
	for w :: "'a::len word"
	apply (cases n)
	apply (auto simp add: hd_to_bl_iff bit_simps not_less word_size)
	apply (rule nth_equalityI)
	apply (auto simp add: nth_to_bl bit_simps nth_Cons split: nat.split)
	done

	lemmas hd_sshiftr = take_sshiftr' [THEN conjunct1]
	lemmas take_sshiftr = take_sshiftr' [THEN conjunct2]

	lemma atd_lem: "take n xs = t \<Longrightarrow> drop n xs = d \<Longrightarrow> xs = t @ d"
	by (auto intro: append_take_drop_id [symmetric])

	lemmas bl_shiftr = atd_lem [OF take_shiftr drop_shiftr]
	lemmas bl_sshiftr = atd_lem [OF take_sshiftr drop_sshiftr]

	lemma shiftl_of_bl: "of_bl bl << n = of_bl (bl @ replicate n False)"
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps nth_append)
	done

	lemma shiftl_bl: "w << n = of_bl (to_bl w @ replicate n False)"
	for w :: "'a::len word"
	by (simp flip: shiftl_of_bl)

	lemma bl_shiftl: "to_bl (w << n) = drop n (to_bl w) @ replicate (min (size w) n) False"
	by (simp add: shiftl_bl word_rep_drop word_size)

	lemma shiftr1_bl_of:
	"length bl \<le> LENGTH('a) \<Longrightarrow>
	shiftr1 (of_bl bl::'a::len word) = of_bl (butlast bl)"
	apply (rule bit_word_eqI)
	apply (simp add: bit_simps)
	apply (cases bl rule: rev_cases)
	apply auto
	done

	lemma shiftr_bl_of:
	"length bl \<le> LENGTH('a) \<Longrightarrow>
	(of_bl bl::'a::len word) >> n = of_bl (take (length bl - n) bl)"
	by (rule bit_word_eqI) (auto simp add: bit_simps rev_nth)

	lemma shiftr_bl: "x >> n \<equiv> of_bl (take (LENGTH('a) - n) (to_bl x))"
	for x :: "'a::len word"
	using shiftr_bl_of [where 'a='a, of "to_bl x"] by simp

	lemma aligned_bl_add_size [OF refl]:
	"size x - n = m \<Longrightarrow> n \<le> size x \<Longrightarrow> drop m (to_bl x) = replicate n False \<Longrightarrow>
	take m (to_bl y) = replicate m False \<Longrightarrow>
	to_bl (x + y) = take m (to_bl x) @ drop m (to_bl y)" for x :: \<open>'a::len word\<close>
	apply (subgoal_tac "x AND y = 0")
	prefer 2
	apply (rule word_bl.Rep_eqD)
	apply (simp add: bl_word_and)
	apply (rule align_lem_and [THEN trans])
	apply (simp_all add: word_size)[5]
	apply simp
	apply (subst word_plus_and_or [symmetric])
	apply (simp add : bl_word_or)
	apply (rule align_lem_or)
	apply (simp_all add: word_size)
	done

	lemma mask_bl: "mask n = of_bl (replicate n True)"
	by (auto simp add: bit_simps intro!: word_eqI)

	lemma bl_and_mask':
	"to_bl (w AND mask n :: 'a::len word) =
	replicate (LENGTH('a) - n) False @
	drop (LENGTH('a) - n) (to_bl w)"
	apply (rule nth_equalityI)
	apply simp
	apply (clarsimp simp add: to_bl_nth word_size bit_simps)
	apply (auto simp add: word_size test_bit_bl nth_append rev_nth)
	done

	lemma slice1_eq_of_bl:
	\<open>(slice1 n w :: 'b::len word) = of_bl (takefill False n (to_bl w))\<close>
	for w :: \<open>'a::len word\<close>
	proof (rule bit_word_eqI)
	fix m
	assume \<open>m < LENGTH('b)\<close>
	show \<open>bit (slice1 n w :: 'b::len word) m \<longleftrightarrow> bit (of_bl (takefill False n (to_bl w)) :: 'b word) m\<close>
	by (cases \<open>m \<ge> n\<close>; cases \<open>LENGTH('a) \<ge> n\<close>)
	(auto simp add: bit_slice1_iff bit_of_bl_iff not_less rev_nth not_le nth_takefill nth_to_bl algebra_simps)
	qed

	lemma slice1_no_bin [simp]:
	"slice1 n (numeral w :: 'b word) = of_bl (takefill False n (bin_to_bl (LENGTH('b::len)) (numeral w)))"
	by (simp add: slice1_eq_of_bl) (* TODO: neg_numeral *)

	lemma slice_no_bin [simp]:
	"slice n (numeral w :: 'b word) = of_bl (takefill False (LENGTH('b::len) - n)
	(bin_to_bl (LENGTH('b::len)) (numeral w)))"
	by (simp add: slice_def) (* TODO: neg_numeral *)

	lemma slice_take': "slice n w = of_bl (take (size w - n) (to_bl w))"
	by (simp add: slice_def word_size slice1_eq_of_bl takefill_alt)

	lemmas slice_take = slice_take' [unfolded word_size]

	\<comment> \<open>shiftr to a word of the same size is just slice,
	slice is just shiftr then ucast\<close>
	lemmas shiftr_slice = trans [OF shiftr_bl [THEN meta_eq_to_obj_eq] slice_take [symmetric]]

	lemma slice1_down_alt':
	"sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs + k = n \<Longrightarrow>
	to_bl sl = takefill False fs (drop k (to_bl w))"
	apply (simp add: slice1_eq_of_bl)
	apply transfer
	apply (simp add: bl_bin_bl_rep_drop)
	using drop_takefill
	apply force
	done

	lemma slice1_up_alt':
	"sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs = n + k \<Longrightarrow>
	to_bl sl = takefill False fs (replicate k False @ (to_bl w))"
	apply (simp add: slice1_eq_of_bl)
	apply transfer
	apply (simp add: bl_bin_bl_rep_drop flip: takefill_append)
	apply (metis diff_add_inverse)
	done

	lemmas sd1 = slice1_down_alt' [OF refl refl, unfolded word_size]
	lemmas su1 = slice1_up_alt' [OF refl refl, unfolded word_size]
	lemmas slice1_down_alt = le_add_diff_inverse [THEN sd1]
	lemmas slice1_up_alts =
	le_add_diff_inverse [symmetric, THEN su1]
	le_add_diff_inverse2 [symmetric, THEN su1]

	lemma slice1_tf_tf':
	"to_bl (slice1 n w :: 'a::len word) =
	rev (takefill False (LENGTH('a)) (rev (takefill False n (to_bl w))))"
	unfolding slice1_eq_of_bl by (rule word_rev_tf)

	lemmas slice1_tf_tf = slice1_tf_tf' [THEN word_bl.Rep_inverse', symmetric]

	lemma revcast_eq_of_bl:
	\<open>(revcast w :: 'b::len word) = of_bl (takefill False (LENGTH('b)) (to_bl w))\<close>
	for w :: \<open>'a::len word\<close>
	by (simp add: revcast_def slice1_eq_of_bl)

	lemmas revcast_no_def [simp] = revcast_eq_of_bl [where w="numeral w", unfolded word_size] for w

	lemma to_bl_revcast:
	"to_bl (revcast w :: 'a::len word) = takefill False (LENGTH('a)) (to_bl w)"
	apply (rule nth_equalityI)
	apply simp
	apply (cases \<open>LENGTH('a) \<le> LENGTH('b)\<close>)
	apply (auto simp add: nth_to_bl nth_takefill bit_revcast_iff)
	done

	lemma word_cat_bl: "word_cat a b = of_bl (to_bl a @ to_bl b)"
	apply (rule bit_word_eqI)
	apply (simp add: bit_word_cat_iff bit_of_bl_iff nth_append not_less nth_rev_to_bl)
	apply (meson bit_word.rep_eq less_diff_conv2 nth_rev_to_bl)
	done

	lemma of_bl_append:
	"(of_bl (xs @ ys) :: 'a::len word) = of_bl xs * 2^(length ys) + of_bl ys"
	apply transfer
	apply (simp add: bl_to_bin_app_cat bin_cat_num)
	done

	lemma of_bl_False [simp]: "of_bl (False#xs) = of_bl xs"
	by (rule word_eqI) (auto simp: test_bit_of_bl nth_append)

	lemma of_bl_True [simp]: "(of_bl (True # xs) :: 'a::len word) = 2^length xs + of_bl xs"
	by (subst of_bl_append [where xs="[True]", simplified]) (simp add: word_1_bl)

	lemma of_bl_Cons: "of_bl (x#xs) = of_bool x * 2^length xs + of_bl xs"
	by (cases x) simp_all

	lemma word_split_bl':
	"std = size c - size b \<Longrightarrow> (word_split c = (a, b)) \<Longrightarrow>
	(a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c)))"
	apply (simp add: word_split_def)
	apply transfer
	apply (cases \<open>LENGTH('b) \<le> LENGTH('a)\<close>)
	apply (auto simp add: drop_bit_take_bit drop_bin2bl bin_to_bl_drop_bit [symmetric, of \<open>LENGTH('a)\<close> \<open>LENGTH('a) - LENGTH('b)\<close> \<open>LENGTH('b)\<close>] min_absorb2)
	done

	lemma word_split_bl: "std = size c - size b \<Longrightarrow>
	(a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c))) \<longleftrightarrow>
	word_split c = (a, b)"
	apply (rule iffI)
	defer
	apply (erule (1) word_split_bl')
	apply (case_tac "word_split c")
	apply (auto simp add: word_size)
	apply (frule word_split_bl' [rotated])
	apply (auto simp add: word_size)
	done

	lemma word_split_bl_eq:
	"(word_split c :: ('c::len word \<times> 'd::len word)) =
	(of_bl (take (LENGTH('a::len) - LENGTH('d::len)) (to_bl c)),
	of_bl (drop (LENGTH('a) - LENGTH('d)) (to_bl c)))"
	for c :: "'a::len word"
	apply (rule word_split_bl [THEN iffD1])
	apply (unfold word_size)
	apply (rule refl conjI)+
	done

	lemma word_rcat_bl:
	\<open>word_rcat wl = of_bl (concat (map to_bl wl))\<close>
	proof -
	define ws where \<open>ws = rev wl\<close>
	moreover have \<open>word_rcat (rev ws) = of_bl (concat (map to_bl (rev ws)))\<close>
	apply (simp add: word_rcat_def of_bl_eq rev_concat rev_map comp_def rev_to_bl_eq flip: horner_sum_of_bool_2_concat)
	apply transfer
	apply simp
	done
	ultimately show ?thesis
	by simp
	qed

	lemma size_rcat_lem': "size (concat (map to_bl wl)) = length wl * size (hd wl)"
	by (induct wl) (auto simp: word_size)

	lemmas size_rcat_lem = size_rcat_lem' [unfolded word_size]

	lemma nth_rcat_lem:
	"n < length (wl::'a word list) * LENGTH('a::len) \<Longrightarrow>
	rev (concat (map to_bl wl)) ! n =
	rev (to_bl (rev wl ! (n div LENGTH('a)))) ! (n mod LENGTH('a))"
	apply (induct wl)
	apply clarsimp
	apply (clarsimp simp add : nth_append size_rcat_lem)
	apply (simp flip: mult_Suc minus_div_mult_eq_mod add: less_Suc_eq_le not_less)
	apply (metis (no_types, lifting) diff_is_0_eq div_le_mono len_not_eq_0 less_Suc_eq less_mult_imp_div_less nonzero_mult_div_cancel_right not_le nth_Cons_0)
	done

	lemma foldl_eq_foldr: "foldl (+) x xs = foldr (+) (x # xs) 0"
	for x :: "'a::comm_monoid_add"
	by (induct xs arbitrary: x) (auto simp: add.assoc)

	lemmas word_cat_bl_no_bin [simp] =
	word_cat_bl [where a="numeral a" and b="numeral b", unfolded to_bl_numeral]
	for a b (* FIXME: negative numerals, 0 and 1 *)

	lemmas word_split_bl_no_bin [simp] =
	word_split_bl_eq [where c="numeral c", unfolded to_bl_numeral] for c

	lemmas word_rot_defs = word_roti_eq_word_rotr_word_rotl word_rotr_eq word_rotl_eq

	lemma to_bl_rotl: "to_bl (word_rotl n w) = rotate n (to_bl w)"
	by (simp add: word_rotl_eq to_bl_use_of_bl)

	lemmas blrs0 = rotate_eqs [THEN to_bl_rotl [THEN trans]]

	lemmas word_rotl_eqs =
	blrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotl [symmetric]]

	lemma to_bl_rotr: "to_bl (word_rotr n w) = rotater n (to_bl w)"
	by (simp add: word_rotr_eq to_bl_use_of_bl)

	lemmas brrs0 = rotater_eqs [THEN to_bl_rotr [THEN trans]]

	lemmas word_rotr_eqs =
	brrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotr [symmetric]]

	declare word_rotr_eqs (1) [simp]
	declare word_rotl_eqs (1) [simp]

	lemmas abl_cong = arg_cong [where f = "of_bl"]

	end

	locale word_rotate
	begin

	lemmas word_rot_defs' = to_bl_rotl to_bl_rotr

	lemmas blwl_syms [symmetric] = bl_word_not bl_word_and bl_word_or bl_word_xor

	lemmas lbl_lbl = trans [OF word_bl_Rep' word_bl_Rep' [symmetric]]

	lemmas ths_map2 [OF lbl_lbl] = rotate_map2 rotater_map2

	lemmas ths_map [where xs = "to_bl v"] = rotate_map rotater_map for v

	lemmas th1s [simplified word_rot_defs' [symmetric]] = ths_map2 ths_map

	end

	lemmas bl_word_rotl_dt = trans [OF to_bl_rotl rotate_drop_take,
	simplified word_bl_Rep']

	lemmas bl_word_rotr_dt = trans [OF to_bl_rotr rotater_drop_take,
	simplified word_bl_Rep']

	lemma bl_word_roti_dt':
	"n = nat ((- i) mod int (size (w :: 'a::len word))) \<Longrightarrow>
	to_bl (word_roti i w) = drop n (to_bl w) @ take n (to_bl w)"
	apply (unfold word_roti_eq_word_rotr_word_rotl)
	apply (simp add: bl_word_rotl_dt bl_word_rotr_dt word_size)
	apply safe
	apply (simp add: zmod_zminus1_eq_if)
	apply safe
	apply (simp add: nat_mult_distrib)
	apply (simp add: nat_diff_distrib [OF pos_mod_sign pos_mod_conj
	[THEN conjunct2, THEN order_less_imp_le]]
	nat_mod_distrib)
	apply (simp add: nat_mod_distrib)
	done

	lemmas bl_word_roti_dt = bl_word_roti_dt' [unfolded word_size]

	lemmas word_rotl_dt = bl_word_rotl_dt [THEN word_bl.Rep_inverse' [symmetric]]
	lemmas word_rotr_dt = bl_word_rotr_dt [THEN word_bl.Rep_inverse' [symmetric]]
	lemmas word_roti_dt = bl_word_roti_dt [THEN word_bl.Rep_inverse' [symmetric]]

	lemmas word_rotr_dt_no_bin' [simp] =
	word_rotr_dt [where w="numeral w", unfolded to_bl_numeral] for w
	(* FIXME: negative numerals, 0 and 1 *)

	lemmas word_rotl_dt_no_bin' [simp] =
	word_rotl_dt [where w="numeral w", unfolded to_bl_numeral] for w
	(* FIXME: negative numerals, 0 and 1 *)

	lemma max_word_bl: "to_bl (- 1::'a::len word) = replicate LENGTH('a) True"
	by (fact to_bl_n1)

	lemma to_bl_mask:
	"to_bl (mask n :: 'a::len word) =
	replicate (LENGTH('a) - n) False @
	replicate (min (LENGTH('a)) n) True"
	by (simp add: mask_bl word_rep_drop min_def)

	lemma map_replicate_True:
	"n = length xs \<Longrightarrow>
	map (\<lambda>(x,y). x \<and> y) (zip xs (replicate n True)) = xs"
	by (induct xs arbitrary: n) auto

	lemma map_replicate_False:
	"n = length xs \<Longrightarrow> map (\<lambda>(x,y). x \<and> y)
	(zip xs (replicate n False)) = replicate n False"
	by (induct xs arbitrary: n) auto

	context
	includes bit_operations_syntax
	begin

	lemma bl_and_mask:
	fixes w :: "'a::len word"
	and n :: nat
	defines "n' \<equiv> LENGTH('a) - n"
	shows "to_bl (w AND mask n) = replicate n' False @ drop n' (to_bl w)"
	proof -
	note [simp] = map_replicate_True map_replicate_False
	have "to_bl (w AND mask n) = map2 (\<and>) (to_bl w) (to_bl (mask n::'a::len word))"
	by (simp add: bl_word_and)
	also have "to_bl w = take n' (to_bl w) @ drop n' (to_bl w)"
	by simp
	also have "map2 (\<and>) \<dots> (to_bl (mask n::'a::len word)) =
	replicate n' False @ drop n' (to_bl w)"
	unfolding to_bl_mask n'_def by (subst zip_append) auto
	finally show ?thesis .
	qed

	lemma drop_rev_takefill:
	"length xs \<le> n \<Longrightarrow>
	drop (n - length xs) (rev (takefill False n (rev xs))) = xs"
	by (simp add: takefill_alt rev_take)

	declare bin_to_bl_def [simp]

	lemmas of_bl_reasoning = to_bl_use_of_bl of_bl_append

	lemma uint_of_bl_is_bl_to_bin_drop:
	"length (dropWhile Not l) \<le> LENGTH('a) \<Longrightarrow> uint (of_bl l :: 'a::len word) = bl_to_bin l"
	apply transfer
	apply (simp add: take_bit_eq_mod)
	apply (rule Divides.mod_less)
	apply (rule bl_to_bin_ge0)
	using bl_to_bin_lt2p_drop apply (rule order.strict_trans2)
	apply simp
	done

	corollary uint_of_bl_is_bl_to_bin:
	"length l\<le>LENGTH('a) \<Longrightarrow> uint ((of_bl::bool list\<Rightarrow> ('a :: len) word) l) = bl_to_bin l"
	apply(rule uint_of_bl_is_bl_to_bin_drop)
	using le_trans length_dropWhile_le by blast

	lemma bin_to_bl_or:
	"bin_to_bl n (a OR b) = map2 (\<or>) (bin_to_bl n a) (bin_to_bl n b)"
	using bl_or_aux_bin[where n=n and v=a and w=b and bs="[]" and cs="[]"]
	by simp

	lemma word_and_1_bl:
	fixes x::"'a::len word"
	shows "(x AND 1) = of_bl [bit x 0]"
	- by (simp add: mod_2_eq_odd and_one_eq)
	+ by (simp add: word_and_1)

	lemma word_1_and_bl:
	fixes x::"'a::len word"
	shows "(1 AND x) = of_bl [bit x 0]"
	- by (simp add: mod_2_eq_odd one_and_eq)
	+ using word_and_1_bl [of x] by (simp add: ac_simps)

	lemma of_bl_drop:
	"of_bl (drop n xs) = (of_bl xs AND mask (length xs - n))"
	apply (rule bit_word_eqI)
	apply (auto simp: rev_nth bit_simps cong: rev_conj_cong)
	done

	lemma to_bl_1:
	"to_bl (1::'a::len word) = replicate (LENGTH('a) - 1) False @ [True]"
	by (rule nth_equalityI) (auto simp add: to_bl_unfold nth_append rev_nth bit_1_iff not_less not_le)

	lemma eq_zero_set_bl:
	"(w = 0) = (True \<notin> set (to_bl w))"
	apply (auto simp add: to_bl_unfold)
	apply (rule bit_word_eqI)
	apply auto
	done

	lemma of_drop_to_bl:
	"of_bl (drop n (to_bl x)) = (x AND mask (size x - n))"
	by (simp add: of_bl_drop word_size_bl)

	lemma unat_of_bl_length:
	"unat (of_bl xs :: 'a::len word) < 2 ^ (length xs)"
	proof (cases "length xs < LENGTH('a)")
	case True
	then have "(of_bl xs::'a::len word) < 2 ^ length xs"
	by (simp add: of_bl_length_less)
	with True
	show ?thesis
	by (simp add: word_less_nat_alt unat_of_nat)
	next
	case False
	have "unat (of_bl xs::'a::len word) < 2 ^ LENGTH('a)"
	by (simp split: unat_split)
	also
	from False
	have "LENGTH('a) \<le> length xs" by simp
	then have "2 ^ LENGTH('a) \<le> (2::nat) ^ length xs"
	by (rule power_increasing) simp
	finally
	show ?thesis .
	qed

	lemma word_msb_alt: "msb w \<longleftrightarrow> hd (to_bl w)"
	for w :: "'a::len word"
	apply (simp add: msb_word_eq)
	apply (subst hd_conv_nth)
	apply simp
	apply (subst nth_to_bl)
	apply simp
	apply simp
	done

	lemma word_lsb_last:
	\<open>lsb w \<longleftrightarrow> last (to_bl w)\<close>
	for w :: \<open>'a::len word\<close>
	using nth_to_bl [of \<open>LENGTH('a) - Suc 0\<close> w]
	- by (simp add: lsb_odd last_conv_nth)
	+ by (simp add: last_conv_nth bit_0 lsb_odd)

	lemma is_aligned_to_bl:
	"is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
	by (simp add: is_aligned_mask eq_zero_set_bl bl_and_mask word_size)

	lemma is_aligned_replicate:
	fixes w::"'a::len word"
	assumes aligned: "is_aligned w n"
	and nv: "n \<le> LENGTH('a)"
	shows "to_bl w = (take (LENGTH('a) - n) (to_bl w)) @ replicate n False"
	apply (rule nth_equalityI)
	using assms apply (simp_all add: nth_append not_less word_size to_bl_nth is_aligned_imp_not_bit)
	done

	lemma is_aligned_drop:
	fixes w::"'a::len word"
	assumes "is_aligned w n" "n \<le> LENGTH('a)"
	shows "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
	proof -
	have "to_bl w = take (LENGTH('a) - n) (to_bl w) @ replicate n False"
	by (rule is_aligned_replicate) fact+
	then have "drop (LENGTH('a) - n) (to_bl w) = drop (LENGTH('a) - n) \<dots>" by simp
	also have "\<dots> = replicate n False" by simp
	finally show ?thesis .
	qed

	lemma less_is_drop_replicate:
	fixes x::"'a::len word"
	assumes lt: "x < 2 ^ n"
	shows "to_bl x = replicate (LENGTH('a) - n) False @ drop (LENGTH('a) - n) (to_bl x)"
	by (metis assms bl_and_mask' less_mask_eq)

	lemma is_aligned_add_conv:
	fixes off::"'a::len word"
	assumes aligned: "is_aligned w n"
	and offv: "off < 2 ^ n"
	shows "to_bl (w + off) =
	(take (LENGTH('a) - n) (to_bl w)) @ (drop (LENGTH('a) - n) (to_bl off))"
	proof cases
	assume nv: "n \<le> LENGTH('a)"
	show ?thesis
	proof (subst aligned_bl_add_size, simp_all only: word_size)
	show "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
	by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)

	from offv show "take (LENGTH('a) - n) (to_bl off) =
	replicate (LENGTH('a) - n) False"
	by (subst less_is_drop_replicate, assumption) simp
	qed fact
	next
	assume "\<not> n \<le> LENGTH('a)"
	with offv show ?thesis by (simp add: power_overflow)
	qed

	lemma is_aligned_replicateI:
	"to_bl p = addr @ replicate n False \<Longrightarrow> is_aligned (p::'a::len word) n"
	apply (simp add: is_aligned_to_bl word_size)
	apply (subgoal_tac "length addr = LENGTH('a) - n")
	apply (simp add: replicate_not_True)
	apply (drule arg_cong [where f=length])
	apply simp
	done

	lemma to_bl_2p:
	"n < LENGTH('a) \<Longrightarrow>
	to_bl ((2::'a::len word) ^ n) =
	replicate (LENGTH('a) - Suc n) False @ True # replicate n False"
	apply (rule nth_equalityI)
	apply (auto simp add: nth_append to_bl_nth word_size bit_simps not_less nth_Cons le_diff_conv)
	subgoal for i
	apply (cases \<open>Suc (i + n) - LENGTH('a)\<close>)
	apply simp_all
	done
	done

	lemma xor_2p_to_bl:
	fixes x::"'a::len word"
	shows "to_bl (x XOR 2^n) =
	(if n < LENGTH('a)
	then take (LENGTH('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (LENGTH('a)-n) (to_bl x)
	else to_bl x)"
	apply (auto simp add: to_bl_eq_rev take_map drop_map take_rev drop_rev bit_simps)
	apply (rule nth_equalityI)
	apply (auto simp add: bit_simps rev_nth nth_append Suc_diff_Suc)
	done

	lemma is_aligned_replicateD:
	"\<lbrakk> is_aligned (w::'a::len word) n; n \<le> LENGTH('a) \<rbrakk>
	\<Longrightarrow> \<exists>xs. to_bl w = xs @ replicate n False
	\<and> length xs = size w - n"
	apply (subst is_aligned_replicate, assumption+)
	apply (rule exI, rule conjI, rule refl)
	apply (simp add: word_size)
	done

	text \<open>right-padding a word to a certain length\<close>

	definition
	"bl_pad_to bl sz \<equiv> bl @ (replicate (sz - length bl) False)"

	lemma bl_pad_to_length:
	assumes lbl: "length bl \<le> sz"
	shows "length (bl_pad_to bl sz) = sz"
	using lbl by (simp add: bl_pad_to_def)

	lemma bl_pad_to_prefix:
	"prefix bl (bl_pad_to bl sz)"
	by (simp add: bl_pad_to_def)


	lemma of_bl_length:
	"length xs < LENGTH('a) \<Longrightarrow> of_bl xs < (2 :: 'a::len word) ^ length xs"
	by (simp add: of_bl_length_less)

	lemma of_bl_mult_and_not_mask_eq:
	"\<lbrakk>is_aligned (a :: 'a::len word) n; length b + m \<le> n\<rbrakk>
	\<Longrightarrow> a + of_bl b * (2^m) AND NOT(mask n) = a"
	apply (simp flip: push_bit_eq_mult subtract_mask(1) take_bit_eq_mask)
	apply (subst disjunctive_add)
	apply (auto simp add: bit_simps not_le not_less)
	apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
	apply (erule is_alignedE')
	apply (simp add: take_bit_push_bit)
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps)
	done

	lemma bin_to_bl_of_bl_eq:
	"\<lbrakk>is_aligned (a::'a::len word) n; length b + c \<le> n; length b + c < LENGTH('a)\<rbrakk>
	\<Longrightarrow> bin_to_bl (length b) (uint ((a + of_bl b * 2^c) >> c)) = b"
	apply (simp flip: push_bit_eq_mult take_bit_eq_mask)
	apply (subst disjunctive_add)
	apply (auto simp add: bit_simps not_le not_less unsigned_or_eq unsigned_drop_bit_eq
	unsigned_push_bit_eq bin_to_bl_or simp flip: bin_to_bl_def)
	apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
	apply (erule is_alignedE')
	apply (rule nth_equalityI)
	apply (auto simp add: nth_bin_to_bl bit_simps rev_nth simp flip: bin_to_bl_def)
	done

	(* casting a long word to a shorter word and casting back to the long word
	is equal to the original long word -- if the word is small enough.
	'l is the longer word.
	's is the shorter word.
	*)
	lemma bl_cast_long_short_long_ingoreLeadingZero_generic:
	"\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
	(of_bl :: _ \<Rightarrow> 'l::len word) (to_bl ((of_bl::_ \<Rightarrow> 's::len word) (to_bl w))) = w"
	by (rule word_uint_eqI) (simp add: uint_of_bl_is_bl_to_bin uint_of_bl_is_bl_to_bin_drop)

	(*
	Casting between longer and shorter word.
	'l is the longer word.
	's is the shorter word.
	For example: 'l::len word is 128 word (full ipv6 address)
	's::len word is 16 word (address piece of ipv6 address in colon-text-representation)
	*)
	corollary ucast_short_ucast_long_ingoreLeadingZero:
	"\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
	(ucast:: 's::len word \<Rightarrow> 'l::len word) ((ucast:: 'l::len word \<Rightarrow> 's::len word) w) = w"
	apply (subst ucast_bl)+
	apply (rule bl_cast_long_short_long_ingoreLeadingZero_generic; simp)
	done

	lemma length_drop_mask:
	fixes w::"'a::len word"
	shows "length (dropWhile Not (to_bl (w AND mask n))) \<le> n"
	proof -
	have "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
	for ls n by(subst takeWhile_append2) simp+
	then show ?thesis
	unfolding bl_and_mask by (simp add: dropWhile_eq_drop)
	qed

	lemma map_bits_rev_to_bl:
	"map (bit x) [0..<size x] = rev (to_bl x)"
	by (auto simp: list_eq_iff_nth_eq test_bit_bl word_size)

	lemma of_bl_length2:
	"length xs + c < LENGTH('a) \<Longrightarrow> of_bl xs * 2^c < (2::'a::len word) ^ (length xs + c)"
	by (simp add: of_bl_length word_less_power_trans2)

	lemma of_bl_max:
	"(of_bl xs :: 'a::len word) \<le> mask (length xs)"
	proof -
	define ys where \<open>ys = rev xs\<close>
	have \<open>take_bit (length ys) (horner_sum of_bool 2 ys :: 'a word) = horner_sum of_bool 2 ys\<close>
	by transfer (simp add: take_bit_horner_sum_bit_eq min_def)
	then have \<open>(of_bl (rev ys) :: 'a word) \<le> mask (length ys)\<close>
	by (simp only: of_bl_rev_eq less_eq_mask_iff_take_bit_eq_self)
	with ys_def show ?thesis
	by simp
	qed

	text\<open>Some auxiliaries for sign-shifting by the entire word length or more\<close>

	lemma sshiftr_clamp_pos:
	assumes
	"LENGTH('a) \<le> n"
	"0 \<le> sint x"
	shows "(x::'a::len word) >>> n = 0"
	apply (rule bit_word_eqI)
	using assms
	apply (auto simp add: bit_simps bit_last_iff)
	done

	lemma sshiftr_clamp_neg:
	assumes
	"LENGTH('a) \<le> n"
	"sint x < 0"
	shows "(x::'a::len word) >>> n = -1"
	apply (rule bit_word_eqI)
	using assms
	apply (auto simp add: bit_simps bit_last_iff)
	done

	lemma sshiftr_clamp:
	assumes "LENGTH('a) \<le> n"
	shows "(x::'a::len word) >>> n = x >>> LENGTH('a)"
	apply (rule bit_word_eqI)
	using assms
	apply (auto simp add: bit_simps bit_last_iff)
	done

	text\<open>
	Like @{thm shiftr1_bl_of}, but the precondition is stronger because we need to pick the msb out of
	the list.
	\<close>
	lemma sshiftr1_bl_of:
	"length bl = LENGTH('a) \<Longrightarrow>
	sshiftr1 (of_bl bl::'a::len word) = of_bl (hd bl # butlast bl)"
	apply (rule word_bl.Rep_eqD)
	apply (subst bl_sshiftr1[of "of_bl bl :: 'a word"])
	by (simp add: word_bl.Abs_inverse)

	text\<open>
	Like @{thm sshiftr1_bl_of}, with a weaker precondition.
	We still get a direct equation for @{term \<open>sshiftr1 (of_bl bl)\<close>}, it's just uglier.
	\<close>
	lemma sshiftr1_bl_of':
	"LENGTH('a) \<le> length bl \<Longrightarrow>
	sshiftr1 (of_bl bl::'a::len word) =
	of_bl (hd (drop (length bl - LENGTH('a)) bl) # butlast (drop (length bl - LENGTH('a)) bl))"
	apply (subst of_bl_drop'[symmetric, of "length bl - LENGTH('a)"])
	using sshiftr1_bl_of[of "drop (length bl - LENGTH('a)) bl"]
	by auto

	text\<open>
	Like @{thm shiftr_bl_of}.
	\<close>
	lemma sshiftr_bl_of:
	assumes "length bl = LENGTH('a)"
	shows "(of_bl bl::'a::len word) >>> n = of_bl (replicate n (hd bl) @ take (length bl - n) bl)"
	proof -
	from assms obtain b bs where \<open>bl = b # bs\<close>
	by (cases bl) simp_all
	then have *: \<open>bl ! 0 \<longleftrightarrow> b\<close> \<open>hd bl \<longleftrightarrow> b\<close>
	by simp_all
	show ?thesis
	apply (rule bit_word_eqI)
	using assms * by (auto simp add: bit_simps nth_append rev_nth not_less)
	qed

	text\<open>Like @{thm shiftr_bl}\<close>
	lemma sshiftr_bl: "x >>> n \<equiv> of_bl (replicate n (msb x) @ take (LENGTH('a) - n) (to_bl x))"
	for x :: "'a::len word"
	unfolding word_msb_alt
	by (smt (z3) length_to_bl_eq sshiftr_bl_of word_bl.Rep_inverse)

	end

	lemma of_bl_drop_eq_take_bit:
	\<open>of_bl (drop n xs) = take_bit (length xs - n) (of_bl xs)\<close>
	by (simp add: of_bl_drop take_bit_eq_mask)

	lemma of_bl_take_to_bl_eq_drop_bit:
	\<open>of_bl (take n (to_bl w)) = drop_bit (LENGTH('a) - n) w\<close>
	if \<open>n \<le> LENGTH('a)\<close>
	for w :: \<open>'a::len word\<close>
	using that shiftr_bl [of w \<open>LENGTH('a) - n\<close>] by (simp add: shiftr_def)

	end
	diff --git a/thys/Word_Lib/Word_Lemmas.thy b/thys/Word_Lib/Word_Lemmas.thy
	--- a/thys/Word_Lib/Word_Lemmas.thy
	+++ b/thys/Word_Lib/Word_Lemmas.thy
	@@ -1,1891 +1,1888 @@
	(*
	* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
	*
	* SPDX-License-Identifier: BSD-2-Clause
	*)

	section "Lemmas with Generic Word Length"

	theory Word_Lemmas
	imports
	Type_Syntax
	Signed_Division_Word
	Signed_Words
	More_Word
	Most_significant_bit
	Enumeration_Word
	Aligned
	Bit_Shifts_Infix_Syntax
	Word_EqI
	begin

	context
	includes bit_operations_syntax
	begin

	lemma ucast_le_ucast_eq:
	fixes x y :: "'a::len word"
	assumes x: "x < 2 ^ n"
	assumes y: "y < 2 ^ n"
	assumes n: "n = LENGTH('b::len)"
	shows "(UCAST('a \<rightarrow> 'b) x \<le> UCAST('a \<rightarrow> 'b) y) = (x \<le> y)"
	apply (rule iffI)
	apply (cases "LENGTH('b) < LENGTH('a)")
	apply (subst less_mask_eq[OF x, symmetric])
	apply (subst less_mask_eq[OF y, symmetric])
	apply (unfold n)
	apply (subst ucast_ucast_mask[symmetric])+
	apply (simp add: ucast_le_ucast)+
	apply (erule ucast_mono_le[OF _ y[unfolded n]])
	done

	lemma ucast_zero_is_aligned:
	\<open>is_aligned w n\<close> if \<open>UCAST('a::len \<rightarrow> 'b::len) w = 0\<close> \<open>n \<le> LENGTH('b)\<close>
	proof (rule is_aligned_bitI)
	fix q
	assume \<open>q < n\<close>
	moreover have \<open>bit (UCAST('a::len \<rightarrow> 'b::len) w) q = bit 0 q\<close>
	using that by simp
	with \<open>q < n\<close> \<open>n \<le> LENGTH('b)\<close> show \<open>\<not> bit w q\<close>
	by (simp add: bit_simps)
	qed

	lemma unat_ucast_eq_unat_and_mask:
	"unat (UCAST('b::len \<rightarrow> 'a::len) w) = unat (w AND mask LENGTH('a))"
	apply (simp flip: take_bit_eq_mask)
	apply transfer
	apply (simp add: ac_simps)
	done

	lemma le_max_word_ucast_id:
	\<open>UCAST('b \<rightarrow> 'a) (UCAST('a \<rightarrow> 'b) x) = x\<close>
	if \<open>x \<le> UCAST('b::len \<rightarrow> 'a) (- 1)\<close>
	for x :: \<open>'a::len word\<close>
	proof -
	from that have a1: \<open>x \<le> word_of_int (uint (word_of_int (2 ^ LENGTH('b) - 1) :: 'b word))\<close>
	by (simp add: of_int_mask_eq)
	have f2: "((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
	\<not> (0::int) \<le> - 1 + 2 ^ LENGTH('b) \<or> (0::int) \<le> - 1 + 2 ^ LENGTH('b) + - 1 * 2 ^ LENGTH('b) \<or>
	(- (1::int) + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b) =
	- 1 + 2 ^ LENGTH('b)) = ((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
	\<not> (1::int) \<le> 2 ^ LENGTH('b) \<or>
	2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)) = 1)"
	by force
	have f3: "\<forall>i ia. \<not> (0::int) \<le> i \<or> 0 \<le> i + - 1 * ia \<or> i mod ia = i"
	using mod_pos_pos_trivial by force
	have "(1::int) \<le> 2 ^ LENGTH('b)"
	by simp
	then have "2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ len_of TYPE ('b)) = 1"
	using f3 f2 by blast
	then have f4: "- (1::int) + 2 ^ LENGTH('b) = (- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)"
	by linarith
	have f5: "x \<le> word_of_int (uint (word_of_int (- 1 + 2 ^ LENGTH('b))::'b word))"
	using a1 by force
	have f6: "2 ^ LENGTH('b) + - (1::int) = - 1 + 2 ^ LENGTH('b)"
	by force
	have f7: "- (1::int) * 1 = - 1"
	by auto
	have "\<forall>x0 x1. (x1::int) - x0 = x1 + - 1 * x0"
	by force
	then have "x \<le> 2 ^ LENGTH('b) - 1"
	using f7 f6 f5 f4 by (metis uint_word_of_int wi_homs(2) word_arith_wis(8) word_of_int_2p)
	then have \<open>uint x \<le> uint (2 ^ LENGTH('b) - (1 :: 'a word))\<close>
	by (simp add: word_le_def)
	then have \<open>uint x \<le> 2 ^ LENGTH('b) - 1\<close>
	by (simp add: uint_word_ariths)
	(metis \<open>1 \<le> 2 ^ LENGTH('b)\<close> \<open>uint x \<le> uint (2 ^ LENGTH('b) - 1)\<close> linorder_not_less lt2p_lem uint_1 uint_minus_simple_alt uint_power_lower word_le_def zle_diff1_eq)
	then show ?thesis
	apply (simp add: unsigned_ucast_eq take_bit_word_eq_self_iff)
	apply (meson \<open>x \<le> 2 ^ LENGTH('b) - 1\<close> not_le word_less_sub_le)
	done
	qed

	lemma uint_shiftr_eq:
	\<open>uint (w >> n) = uint w div 2 ^ n\<close>
	by word_eqI

	lemma bit_shiftl_word_iff [bit_simps]:
	\<open>bit (w << m) n \<longleftrightarrow> m \<le> n \<and> n < LENGTH('a) \<and> bit w (n - m)\<close>
	for w :: \<open>'a::len word\<close>
	by (simp add: bit_simps)

	lemma bit_shiftr_word_iff:
	\<open>bit (w >> m) n \<longleftrightarrow> bit w (m + n)\<close>
	for w :: \<open>'a::len word\<close>
	by (simp add: bit_simps)

	lemma uint_sshiftr_eq:
	\<open>uint (w >>> n) = take_bit LENGTH('a) (sint w div 2 ^ n)\<close>
	for w :: \<open>'a::len word\<close>
	by (word_eqI_solve dest: test_bit_lenD)

	lemma sshiftr_n1: "-1 >>> n = -1"
	by (simp add: sshiftr_def)

	lemma nth_sshiftr:
	"bit (w >>> m) n = (n < size w \<and> (if n + m \<ge> size w then bit w (size w - 1) else bit w (n + m)))"
	apply (auto simp add: bit_simps word_size ac_simps not_less)
	apply (meson bit_imp_le_length bit_shiftr_word_iff leD)
	done

	lemma sshiftr_numeral:
	\<open>(numeral k >>> numeral n :: 'a::len word) =
	word_of_int (signed_take_bit (LENGTH('a) - 1) (numeral k) >> numeral n)\<close>
	using signed_drop_bit_word_numeral [of n k] by (simp add: sshiftr_def shiftr_def)

	lemma sshiftr_div_2n: "sint (w >>> n) = sint w div 2 ^ n"
	by word_eqI (cases \<open>n < LENGTH('a)\<close>; fastforce simp: le_diff_conv2)

	lemma mask_eq:
	\<open>mask n = (1 << n) - (1 :: 'a::len word)\<close>
	by (simp add: mask_eq_exp_minus_1 shiftl_def)

	lemma nth_shiftl': "bit (w << m) n \<longleftrightarrow> n < size w \<and> n >= m \<and> bit w (n - m)"
	for w :: "'a::len word"
	by (simp add: bit_simps word_size ac_simps)

	lemmas nth_shiftl = nth_shiftl' [unfolded word_size]

	lemma nth_shiftr: "bit (w >> m) n = bit w (n + m)"
	for w :: "'a::len word"
	by (simp add: bit_simps ac_simps)

	lemma shiftr_div_2n: "uint (shiftr w n) = uint w div 2 ^ n"
	by (fact uint_shiftr_eq)

	lemma shiftl_rev: "shiftl w n = word_reverse (shiftr (word_reverse w) n)"
	by word_eqI_solve

	lemma rev_shiftl: "word_reverse w << n = word_reverse (w >> n)"
	by (simp add: shiftl_rev)

	lemma shiftr_rev: "w >> n = word_reverse (word_reverse w << n)"
	by (simp add: rev_shiftl)

	lemma rev_shiftr: "word_reverse w >> n = word_reverse (w << n)"
	by (simp add: shiftr_rev)

	lemmas ucast_up =
	rc1 [simplified rev_shiftr [symmetric] revcast_ucast [symmetric]]
	lemmas ucast_down =
	rc2 [simplified rev_shiftr revcast_ucast [symmetric]]

	lemma shiftl_zero_size: "size x \<le> n \<Longrightarrow> x << n = 0"
	for x :: "'a::len word"
	by (simp add: shiftl_def word_size)

	lemma shiftl_t2n: "shiftl w n = 2 ^ n * w"
	for w :: "'a::len word"
	by (simp add: shiftl_def push_bit_eq_mult)

	lemma word_shift_by_2:
	"x * 4 = (x::'a::len word) << 2"
	by (simp add: shiftl_t2n)

	lemma word_shift_by_3:
	"x * 8 = (x::'a::len word) << 3"
	by (simp add: shiftl_t2n)

	lemma slice_shiftr: "slice n w = ucast (w >> n)"
	by word_eqI (cases \<open>n \<le> LENGTH('b)\<close>; fastforce simp: ac_simps dest: bit_imp_le_length)

	lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = 0"
	for x :: "'a :: len word"
	by word_eqI

	lemma shiftr_x_0 [simp]: "x >> 0 = x"
	for x :: "'a::len word"
	by (simp add: shiftr_def)

	lemma shiftl_x_0 [simp]: "x << 0 = x"
	for x :: "'a::len word"
	by (simp add: shiftl_def)

	lemmas shiftl0 = shiftl_x_0

	lemma shiftr_1 [simp]: "(1::'a::len word) >> n = (if n = 0 then 1 else 0)"
	by (simp add: shiftr_def)

	lemma and_not_mask:
	"w AND NOT (mask n) = (w >> n) << n"
	for w :: \<open>'a::len word\<close>
	by word_eqI_solve

	lemma and_mask:
	"w AND mask n = (w << (size w - n)) >> (size w - n)"
	for w :: \<open>'a::len word\<close>
	by word_eqI_solve

	lemma shiftr_div_2n_w: "w >> n = w div (2^n :: 'a :: len word)"
	by (fact shiftr_eq_div)

	lemma le_shiftr:
	"u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len word) >> n"
	apply (unfold shiftr_def)
	apply transfer
	apply (simp add: take_bit_drop_bit)
	apply (simp add: drop_bit_eq_div zdiv_mono1)
	done

	lemma le_shiftr':
	"\<lbrakk> u >> n \<le> v >> n ; u >> n \<noteq> v >> n \<rbrakk> \<Longrightarrow> (u::'a::len word) \<le> v"
	by (metis le_cases le_shiftr verit_la_disequality)

	lemma shiftr_mask_le:
	"n <= m \<Longrightarrow> mask n >> m = (0 :: 'a::len word)"
	by word_eqI

	lemma shiftr_mask [simp]:
	\<open>mask m >> m = (0::'a::len word)\<close>
	by (rule shiftr_mask_le) simp

	lemma le_mask_iff:
	"(w \<le> mask n) = (w >> n = 0)"
	for w :: \<open>'a::len word\<close>
	apply safe
	apply (rule word_le_0_iff [THEN iffD1])
	apply (rule xtrans(3))
	apply (erule_tac [2] le_shiftr)
	apply simp
	apply (rule word_leI)
	apply (rename_tac n')
	apply (drule_tac x = "n' - n" in word_eqD)
	apply (simp add : nth_shiftr word_size bit_simps)
	apply (case_tac "n <= n'")
	by auto

	lemma and_mask_eq_iff_shiftr_0:
	"(w AND mask n = w) = (w >> n = 0)"
	for w :: \<open>'a::len word\<close>
	by (simp flip: take_bit_eq_mask add: shiftr_def take_bit_eq_self_iff_drop_bit_eq_0)

	lemma mask_shiftl_decompose:
	"mask m << n = mask (m + n) AND NOT (mask n :: 'a::len word)"
	by word_eqI_solve

	lemma shiftl_over_and_dist:
	fixes a::"'a::len word"
	shows "(a AND b) << c = (a << c) AND (b << c)"
	by (unfold shiftl_def) (fact push_bit_and)

	lemma shiftr_over_and_dist:
	fixes a::"'a::len word"
	shows "a AND b >> c = (a >> c) AND (b >> c)"
	by (unfold shiftr_def) (fact drop_bit_and)

	lemma sshiftr_over_and_dist:
	fixes a::"'a::len word"
	shows "a AND b >>> c = (a >>> c) AND (b >>> c)"
	by word_eqI

	lemma shiftl_over_or_dist:
	fixes a::"'a::len word"
	shows "a OR b << c = (a << c) OR (b << c)"
	by (unfold shiftl_def) (fact push_bit_or)

	lemma shiftr_over_or_dist:
	fixes a::"'a::len word"
	shows "a OR b >> c = (a >> c) OR (b >> c)"
	by (unfold shiftr_def) (fact drop_bit_or)

	lemma sshiftr_over_or_dist:
	fixes a::"'a::len word"
	shows "a OR b >>> c = (a >>> c) OR (b >>> c)"
	by word_eqI

	lemmas shift_over_ao_dists =
	shiftl_over_or_dist shiftr_over_or_dist
	sshiftr_over_or_dist shiftl_over_and_dist
	shiftr_over_and_dist sshiftr_over_and_dist

	lemma shiftl_shiftl:
	fixes a::"'a::len word"
	shows "a << b << c = a << (b + c)"
	by (word_eqI_solve simp: add.commute add.left_commute)

	lemma shiftr_shiftr:
	fixes a::"'a::len word"
	shows "a >> b >> c = a >> (b + c)"
	by word_eqI (simp add: add.left_commute add.commute)

	lemma shiftl_shiftr1:
	fixes a::"'a::len word"
	shows "c \<le> b \<Longrightarrow> a << b >> c = a AND (mask (size a - b)) << (b - c)"
	by word_eqI (auto simp: ac_simps)

	lemma shiftl_shiftr2:
	fixes a::"'a::len word"
	shows "b < c \<Longrightarrow> a << b >> c = (a >> (c - b)) AND (mask (size a - c))"
	by word_eqI_solve

	lemma shiftr_shiftl1:
	fixes a::"'a::len word"
	shows "c \<le> b \<Longrightarrow> a >> b << c = (a >> (b - c)) AND (NOT (mask c))"
	by word_eqI_solve

	lemma shiftr_shiftl2:
	fixes a::"'a::len word"
	shows "b < c \<Longrightarrow> a >> b << c = (a << (c - b)) AND (NOT (mask c))"
	by word_eqI (auto simp: ac_simps)

	lemmas multi_shift_simps =
	shiftl_shiftl shiftr_shiftr
	shiftl_shiftr1 shiftl_shiftr2
	shiftr_shiftl1 shiftr_shiftl2

	lemma shiftr_mask2:
	"n \<le> LENGTH('a) \<Longrightarrow> (mask n >> m :: ('a :: len) word) = mask (n - m)"
	by word_eqI_solve

	lemma word_shiftl_add_distrib:
	fixes x :: "'a :: len word"
	shows "(x + y) << n = (x << n) + (y << n)"
	by (simp add: shiftl_t2n ring_distribs)

	lemma mask_shift:
	"(x AND NOT (mask y)) >> y = x >> y"
	for x :: \<open>'a::len word\<close>
	by word_eqI

	lemma shiftr_div_2n':
	"unat (w >> n) = unat w div 2 ^ n"
	by word_eqI

	lemma shiftl_shiftr_id:
	"\<lbrakk> n < LENGTH('a); x < 2 ^ (LENGTH('a) - n) \<rbrakk> \<Longrightarrow> x << n >> n = (x::'a::len word)"
	by word_eqI (metis add.commute less_diff_conv)

	lemma ucast_shiftl_eq_0:
	fixes w :: "'a :: len word"
	shows "\<lbrakk> n \<ge> LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (w << n) = (0 :: 'b :: len word)"
	by (transfer fixing: n) (simp add: take_bit_push_bit)

	lemma word_shift_nonzero:
	"\<lbrakk> (x::'a::len word) \<le> 2 ^ m; m + n < LENGTH('a::len); x \<noteq> 0\<rbrakk>
	\<Longrightarrow> x << n \<noteq> 0"
	apply (simp only: word_neq_0_conv word_less_nat_alt
	shiftl_t2n mod_0 unat_word_ariths
	unat_power_lower word_le_nat_alt)
	apply (subst mod_less)
	apply (rule order_le_less_trans)
	apply (erule mult_le_mono2)
	apply (subst power_add[symmetric])
	apply (rule power_strict_increasing)
	apply simp
	apply simp
	apply simp
	done

	lemma word_shiftr_lt:
	fixes w :: "'a::len word"
	shows "unat (w >> n) < (2 ^ (LENGTH('a) - n))"
	apply (subst shiftr_div_2n')
	apply transfer
	apply (simp flip: drop_bit_eq_div add: drop_bit_nat_eq drop_bit_take_bit)
	done

	lemma shiftr_less_t2n':
	"\<lbrakk> x AND mask (n + m) = x; m < LENGTH('a) \<rbrakk> \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
	apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
	apply transfer
	apply (simp add: take_bit_drop_bit ac_simps)
	done

	lemma shiftr_less_t2n:
	"x < 2 ^ (n + m) \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
	apply (rule shiftr_less_t2n')
	apply (erule less_mask_eq)
	apply (rule ccontr)
	apply (simp add: not_less)
	apply (subst (asm) p2_eq_0[symmetric])
	apply (simp add: power_add)
	done

	lemma shiftr_eq_0:
	"n \<ge> LENGTH('a) \<Longrightarrow> ((w::'a::len word) >> n) = 0"
	apply (cut_tac shiftr_less_t2n'[of w n 0], simp)
	apply (simp add: mask_eq_iff)
	apply (simp add: lt2p_lem)
	apply simp
	done

	lemma shiftl_less_t2n:
	fixes x :: "'a :: len word"
	shows "\<lbrakk> x < (2 ^ (m - n)); m < LENGTH('a) \<rbrakk> \<Longrightarrow> (x << n) < 2 ^ m"
	apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
	apply transfer
	apply (simp add: take_bit_push_bit)
	done

	lemma shiftl_less_t2n':
	"(x::'a::len word) < 2 ^ m \<Longrightarrow> m+n < LENGTH('a) \<Longrightarrow> x << n < 2 ^ (m + n)"
	by (rule shiftl_less_t2n) simp_all

	lemma scast_bit_test [simp]:
	"scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
	by word_eqI

	lemma signed_shift_guard_to_word:
	\<open>unat x * 2 ^ y < 2 ^ n \<longleftrightarrow> x = 0 \<or> x < 1 << n >> y\<close>
	if \<open>n < LENGTH('a)\<close> \<open>0 < n\<close>
	for x :: \<open>'a::len word\<close>
	proof (cases \<open>x = 0\<close>)
	case True
	then show ?thesis
	by simp
	next
	case False
	then have \<open>unat x \<noteq> 0\<close>
	by (simp add: unat_eq_0)
	then have \<open>unat x \<ge> 1\<close>
	by simp
	show ?thesis
	proof (cases \<open>y < n\<close>)
	case False
	then have \<open>n \<le> y\<close>
	by simp
	then obtain q where \<open>y = n + q\<close>
	using le_Suc_ex by blast
	moreover have \<open>(2 :: nat) ^ n >> n + q \<le> 1\<close>
	by (simp add: drop_bit_eq_div power_add shiftr_def)
	ultimately show ?thesis
	using \<open>x \<noteq> 0\<close> \<open>unat x \<ge> 1\<close> \<open>n < LENGTH('a)\<close>
	by (simp add: power_add not_less word_le_nat_alt unat_drop_bit_eq shiftr_def shiftl_def)
	next
	case True
	with that have \<open>y < LENGTH('a)\<close>
	by simp
	show ?thesis
	proof (cases \<open>2 ^ n = unat x * 2 ^ y\<close>)
	case True
	moreover have \<open>unat x * 2 ^ y < 2 ^ LENGTH('a)\<close>
	using \<open>n < LENGTH('a)\<close> by (simp flip: True)
	moreover have \<open>(word_of_nat (2 ^ n) :: 'a word) = word_of_nat (unat x * 2 ^ y)\<close>
	using True by simp
	then have \<open>2 ^ n = x * 2 ^ y\<close>
	by simp
	ultimately show ?thesis
	using \<open>y < LENGTH('a)\<close>
	by (auto simp add: drop_bit_eq_div word_less_nat_alt unat_div unat_word_ariths
	shiftr_def shiftl_def)
	next
	case False
	with \<open>y < n\<close> have *: \<open>unat x \<noteq> 2 ^ n div 2 ^ y\<close>
	by (auto simp flip: power_sub power_add)
	have \<open>unat x * 2 ^ y < 2 ^ n \<longleftrightarrow> unat x * 2 ^ y \<le> 2 ^ n\<close>
	using False by (simp add: less_le)
	also have \<open>\<dots> \<longleftrightarrow> unat x \<le> 2 ^ n div 2 ^ y\<close>
	by (simp add: less_eq_div_iff_mult_less_eq)
	also have \<open>\<dots> \<longleftrightarrow> unat x < 2 ^ n div 2 ^ y\<close>
	using * by (simp add: less_le)
	finally show ?thesis
	using that \<open>x \<noteq> 0\<close> by (simp flip: push_bit_eq_mult drop_bit_eq_div
	add: shiftr_def shiftl_def unat_drop_bit_eq word_less_iff_unsigned [where ?'a = nat])
	qed
	qed
	qed

	lemma shiftr_not_mask_0:
	"n+m \<ge> LENGTH('a :: len) \<Longrightarrow> ((w::'a::len word) >> n) AND NOT (mask m) = 0"
	by word_eqI

	lemma shiftl_mask_is_0[simp]:
	"(x << n) AND mask n = 0"
	for x :: \<open>'a::len word\<close>
	by (simp flip: take_bit_eq_mask add: take_bit_push_bit shiftl_def)

	lemma rshift_sub_mask_eq:
	"(a >> (size a - b)) AND mask b = a >> (size a - b)"
	for a :: \<open>'a::len word\<close>
	using shiftl_shiftr2[where a=a and b=0 and c="size a - b"]
	apply (cases "b < size a")
	apply simp
	apply (simp add: linorder_not_less mask_eq_decr_exp word_size
	p2_eq_0[THEN iffD2])
	done

	lemma shiftl_shiftr3:
	"b \<le> c \<Longrightarrow> a << b >> c = (a >> c - b) AND mask (size a - c)"
	for a :: \<open>'a::len word\<close>
	apply (cases "b = c")
	apply (simp add: shiftl_shiftr1)
	apply (simp add: shiftl_shiftr2)
	done

	lemma and_mask_shiftr_comm:
	"m \<le> size w \<Longrightarrow> (w AND mask m) >> n = (w >> n) AND mask (m-n)"
	for w :: \<open>'a::len word\<close>
	by (simp add: and_mask shiftr_shiftr) (simp add: word_size shiftl_shiftr3)

	lemma and_mask_shiftl_comm:
	"m+n \<le> size w \<Longrightarrow> (w AND mask m) << n = (w << n) AND mask (m+n)"
	for w :: \<open>'a::len word\<close>
	by (simp add: and_mask word_size shiftl_shiftl) (simp add: shiftl_shiftr1)

	lemma le_mask_shiftl_le_mask: "s = m + n \<Longrightarrow> x \<le> mask n \<Longrightarrow> x << m \<le> mask s"
	for x :: \<open>'a::len word\<close>
	by (simp add: le_mask_iff shiftl_shiftr3)

	lemma word_and_1_shiftl:
	"x AND (1 << n) = (if bit x n then (1 << n) else 0)" for x :: "'a :: len word"
	by word_eqI_solve

	lemmas word_and_1_shiftls'
	= word_and_1_shiftl[where n=0]
	word_and_1_shiftl[where n=1]
	word_and_1_shiftl[where n=2]

	lemmas word_and_1_shiftls = word_and_1_shiftls' [simplified]

	lemma word_and_mask_shiftl:
	"x AND (mask n << m) = ((x >> m) AND mask n) << m"
	for x :: \<open>'a::len word\<close>
	by word_eqI_solve

	lemma shift_times_fold:
	"(x :: 'a :: len word) * (2 ^ n) << m = x << (m + n)"
	by (simp add: shiftl_t2n ac_simps power_add)

	lemma of_bool_nth:
	"of_bool (bit x v) = (x >> v) AND 1"
	for x :: \<open>'a::len word\<close>
	by (simp add: bit_iff_odd_drop_bit word_and_1 shiftr_def)

	lemma shiftr_mask_eq:
	"(x >> n) AND mask (size x - n) = x >> n" for x :: "'a :: len word"
	by (word_eqI_solve dest: test_bit_lenD)

	lemma shiftr_mask_eq':
	"m = (size x - n) \<Longrightarrow> (x >> n) AND mask m = x >> n" for x :: "'a :: len word"
	by (simp add: shiftr_mask_eq)

	lemma and_eq_0_is_nth:
	fixes x :: "'a :: len word"
	shows "y = 1 << n \<Longrightarrow> ((x AND y) = 0) = (\<not> (bit x n))"
	by (simp add: and_exp_eq_0_iff_not_bit shiftl_def)

	lemma word_shift_zero:
	"\<lbrakk> x << n = 0; x \<le> 2^m; m + n < LENGTH('a)\<rbrakk> \<Longrightarrow> (x::'a::len word) = 0"
	apply (rule ccontr)
	apply (drule (2) word_shift_nonzero)
	apply simp
	done

	lemma mask_shift_and_negate[simp]:"(w AND mask n << m) AND NOT (mask n << m) = 0"
	for w :: \<open>'a::len word\<close>
	by word_eqI

	(* The seL4 bitfield generator produces functions containing mask and shift operations, such that
	* invoking two of them consecutively can produce something like the following.
	*)
	lemma bitfield_op_twice:
	"(x AND NOT (mask n << m) OR ((y AND mask n) << m)) AND NOT (mask n << m) = x AND NOT (mask n << m)"
	for x :: \<open>'a::len word\<close>
	by word_eqI_solve

	lemma bitfield_op_twice'':
	"\<lbrakk>NOT a = b << c; \<exists>x. b = mask x\<rbrakk> \<Longrightarrow> (x AND a OR (y AND b << c)) AND a = x AND a"
	for a b :: \<open>'a::len word\<close>
	by word_eqI_solve

	lemma shiftr1_unfold: "x div 2 = x >> 1"
	by (simp add: drop_bit_eq_div shiftr_def)

	lemma shiftr1_is_div_2: "(x::('a::len) word) >> 1 = x div 2"
	by (simp add: drop_bit_eq_div shiftr_def)

	lemma shiftl1_is_mult: "(x << 1) = (x :: 'a::len word) * 2"
	by (metis One_nat_def mult_2 mult_2_right one_add_one
	power_0 power_Suc shiftl_t2n)

	lemma shiftr1_lt:"x \<noteq> 0 \<Longrightarrow> (x::('a::len) word) >> 1 < x"
	apply (subst shiftr1_is_div_2)
	apply (rule div_less_dividend_word)
	apply simp+
	done

	lemma shiftr1_0_or_1:"(x::('a::len) word) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x = 1"
	apply (subst (asm) shiftr1_is_div_2)
	apply (drule word_less_div)
	apply (case_tac "LENGTH('a) = 1")
	apply (simp add:degenerate_word)
	apply (erule disjE)
	apply (subgoal_tac "(2::'a word) \<noteq> 0")
	apply simp
	apply (rule not_degenerate_imp_2_neq_0)
	apply (subgoal_tac "LENGTH('a) \<noteq> 0")
	apply arith
	apply simp
	apply (rule x_less_2_0_1', simp+)
	done

	lemma shiftr1_irrelevant_lsb: "bit (x::('a::len) word) 0 \<or> x >> 1 = (x + 1) >> 1"
	- apply (cases \<open>LENGTH('a)\<close>; transfer)
	- apply (simp_all add: take_bit_drop_bit)
	- apply (simp add: drop_bit_take_bit drop_bit_Suc)
	- done
	+ by (auto simp add: bit_0 shiftr_def drop_bit_Suc ac_simps elim: evenE)

	lemma shiftr1_0_imp_only_lsb:"((x::('a::len) word) + 1) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x + 1 = 0"
	by (metis One_nat_def shiftr1_0_or_1 word_less_1 word_overflow)

	lemma shiftr1_irrelevant_lsb': "\<not> (bit (x::('a::len) word) 0) \<Longrightarrow> x >> 1 = (x + 1) >> 1"
	- by (metis shiftr1_irrelevant_lsb)
	+ using shiftr1_irrelevant_lsb [of x] by simp

	(* Perhaps this one should be a simp lemma, but it seems a little dangerous. *)
	lemma cast_chunk_assemble_id:
	"\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
	(((ucast ((ucast (x::'b word))::'a word))::'b word) OR (((ucast ((ucast (x >> n))::'a word))::'b word) << n)) = x"
	apply (subgoal_tac "((ucast ((ucast (x >> n))::'a word))::'b word) = x >> n")
	apply clarsimp
	apply (subst and_not_mask[symmetric])
	apply (subst ucast_ucast_mask)
	apply (subst word_ao_dist2[symmetric])
	apply clarsimp
	apply (rule ucast_ucast_len)
	apply (rule shiftr_less_t2n')
	apply (subst and_mask_eq_iff_le_mask)
	apply (simp_all add: mask_eq_decr_exp flip: mult_2_right)
	apply (metis add_diff_cancel_left' len_gt_0 mult_2_right zero_less_diff)
	done

	lemma cast_chunk_scast_assemble_id:
	"\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
	(((ucast ((scast (x::'b word))::'a word))::'b word) OR
	(((ucast ((scast (x >> n))::'a word))::'b word) << n)) = x"
	apply (subgoal_tac "((scast x)::'a word) = ((ucast x)::'a word)")
	apply (subgoal_tac "((scast (x >> n))::'a word) = ((ucast (x >> n))::'a word)")
	apply (simp add:cast_chunk_assemble_id)
	apply (subst down_cast_same[symmetric], subst is_down, arith, simp)+
	done

	lemma unat_shiftr_less_t2n:
	fixes x :: "'a :: len word"
	shows "unat x < 2 ^ (n + m) \<Longrightarrow> unat (x >> n) < 2 ^ m"
	by (simp add: shiftr_div_2n' power_add mult.commute less_mult_imp_div_less)

	lemma ucast_less_shiftl_helper:
	"\<lbrakk> LENGTH('b) + 2 < LENGTH('a); 2 ^ (LENGTH('b) + 2) \<le> n\<rbrakk>
	\<Longrightarrow> (ucast (x :: 'b::len word) << 2) < (n :: 'a::len word)"
	apply (erule order_less_le_trans[rotated])
	using ucast_less[where x=x and 'a='a]
	apply (simp only: shiftl_t2n field_simps)
	apply (rule word_less_power_trans2; simp)
	done

	(* negating a mask which has been shifted to the very left *)
	lemma NOT_mask_shifted_lenword:
	"NOT (mask len << (LENGTH('a) - len) ::'a::len word) = mask (LENGTH('a) - len)"
	by word_eqI_solve

	(* Comparisons between different word sizes. *)

	lemma shiftr_less:
	"(w::'a::len word) < k \<Longrightarrow> w >> n < k"
	by (metis div_le_dividend le_less_trans shiftr_div_2n' unat_arith_simps(2))

	lemma word_and_notzeroD:
	"w AND w' \<noteq> 0 \<Longrightarrow> w \<noteq> 0 \<and> w' \<noteq> 0"
	by auto

	lemma shiftr_le_0:
	"unat (w::'a::len word) < 2 ^ n \<Longrightarrow> w >> n = (0::'a::len word)"
	by (auto simp add: take_bit_word_eq_self_iff word_less_nat_alt shiftr_def
	simp flip: take_bit_eq_self_iff_drop_bit_eq_0 intro: ccontr)

	lemma of_nat_shiftl:
	"(of_nat x << n) = (of_nat (x * 2 ^ n) :: ('a::len) word)"
	proof -
	have "(of_nat x::'a word) << n = of_nat (2 ^ n) * of_nat x"
	using shiftl_t2n by (metis word_unat_power)
	thus ?thesis by simp
	qed

	lemma shiftl_1_not_0:
	"n < LENGTH('a) \<Longrightarrow> (1::'a::len word) << n \<noteq> 0"
	by (simp add: shiftl_t2n)

	(* continue sorting out from here *)

	(* usually: x,y = (len_of TYPE ('a)) *)
	lemma bitmagic_zeroLast_leq_or1Last:
	"(a::('a::len) word) AND (mask len << x - len) \<le> a OR mask (y - len)"
	by (meson le_word_or2 order_trans word_and_le2)

	lemma zero_base_lsb_imp_set_eq_as_bit_operation:
	fixes base ::"'a::len word"
	assumes valid_prefix: "mask (LENGTH('a) - len) AND base = 0"
	shows "(base = NOT (mask (LENGTH('a) - len)) AND a) \<longleftrightarrow>
	(a \<in> {base .. base OR mask (LENGTH('a) - len)})"
	proof
	have helper3: "x OR y = x OR y AND NOT x" for x y ::"'a::len word" by (simp add: word_oa_dist2)
	from assms show "base = NOT (mask (LENGTH('a) - len)) AND a \<Longrightarrow>
	a \<in> {base..base OR mask (LENGTH('a) - len)}"
	apply(simp add: word_and_le1)
	apply(metis helper3 le_word_or2 word_bw_comms(1) word_bw_comms(2))
	done
	next
	assume "a \<in> {base..base OR mask (LENGTH('a) - len)}"
	hence a: "base \<le> a \<and> a \<le> base OR mask (LENGTH('a) - len)" by simp
	show "base = NOT (mask (LENGTH('a) - len)) AND a"
	proof -
	have f2: "\<forall>x\<^sub>0. base AND NOT (mask x\<^sub>0) \<le> a AND NOT (mask x\<^sub>0)"
	using a neg_mask_mono_le by blast
	have f3: "\<forall>x\<^sub>0. a AND NOT (mask x\<^sub>0) \<le> (base OR mask (LENGTH('a) - len)) AND NOT (mask x\<^sub>0)"
	using a neg_mask_mono_le by blast
	have f4: "base = base AND NOT (mask (LENGTH('a) - len))"
	using valid_prefix by (metis mask_eq_0_eq_x word_bw_comms(1))
	hence f5: "\<forall>x\<^sub>6. (base OR x\<^sub>6) AND NOT (mask (LENGTH('a) - len)) =
	base OR x\<^sub>6 AND NOT (mask (LENGTH('a) - len))"
	using word_ao_dist by (metis)
	have f6: "\<forall>x\<^sub>2 x\<^sub>3. a AND NOT (mask x\<^sub>2) \<le> x\<^sub>3 \<or>
	\<not> (base OR mask (LENGTH('a) - len)) AND NOT (mask x\<^sub>2) \<le> x\<^sub>3"
	using f3 dual_order.trans by auto
	have "base = (base OR mask (LENGTH('a) - len)) AND NOT (mask (LENGTH('a) - len))"
	using f5 by auto
	hence "base = a AND NOT (mask (LENGTH('a) - len))"
	using f2 f4 f6 by (metis eq_iff)
	thus "base = NOT (mask (LENGTH('a) - len)) AND a"
	by (metis word_bw_comms(1))
	qed
	qed

	lemma of_nat_eq_signed_scast:
	"(of_nat x = (y :: ('a::len) signed word))
	= (of_nat x = (scast y :: 'a word))"
	by (metis scast_of_nat scast_scast_id(2))

	lemma word_aligned_add_no_wrap_bounded:
	"\<lbrakk> w + 2^n \<le> x; w + 2^n \<noteq> 0; is_aligned w n \<rbrakk> \<Longrightarrow> (w::'a::len word) < x"
	by (blast dest: is_aligned_no_overflow le_less_trans word_leq_le_minus_one)

	lemma mask_Suc:
	"mask (Suc n) = (2 :: 'a::len word) ^ n + mask n"
	by (simp add: mask_eq_decr_exp)

	lemma mask_mono:
	"sz' \<le> sz \<Longrightarrow> mask sz' \<le> (mask sz :: 'a::len word)"
	by (simp add: le_mask_iff shiftr_mask_le)

	lemma aligned_mask_disjoint:
	"\<lbrakk> is_aligned (a :: 'a :: len word) n; b \<le> mask n \<rbrakk> \<Longrightarrow> a AND b = 0"
	by (metis and_zero_eq is_aligned_mask le_mask_imp_and_mask word_bw_lcs(1))

	lemma word_and_or_mask_aligned:
	"\<lbrakk> is_aligned a n; b \<le> mask n \<rbrakk> \<Longrightarrow> a + b = a OR b"
	by (simp add: aligned_mask_disjoint word_plus_and_or_coroll)

	lemma word_and_or_mask_aligned2:
	\<open>is_aligned b n \<Longrightarrow> a \<le> mask n \<Longrightarrow> a + b = a OR b\<close>
	using word_and_or_mask_aligned [of b n a] by (simp add: ac_simps)

	lemma is_aligned_ucastI:
	"is_aligned w n \<Longrightarrow> is_aligned (ucast w) n"
	by (simp add: bit_ucast_iff is_aligned_nth)

	lemma ucast_le_maskI:
	"a \<le> mask n \<Longrightarrow> UCAST('a::len \<rightarrow> 'b::len) a \<le> mask n"
	by (metis and_mask_eq_iff_le_mask ucast_and_mask)

	lemma ucast_add_mask_aligned:
	"\<lbrakk> a \<le> mask n; is_aligned b n \<rbrakk> \<Longrightarrow> UCAST ('a::len \<rightarrow> 'b::len) (a + b) = ucast a + ucast b"
	by (metis add.commute is_aligned_ucastI ucast_le_maskI ucast_or_distrib word_and_or_mask_aligned)

	lemma ucast_shiftl:
	"LENGTH('b) \<le> LENGTH ('a) \<Longrightarrow> UCAST ('a::len \<rightarrow> 'b::len) x << n = ucast (x << n)"
	by word_eqI_solve

	lemma ucast_leq_mask:
	"LENGTH('a) \<le> n \<Longrightarrow> ucast (x::'a::len word) \<le> mask n"
	apply (simp add: less_eq_mask_iff_take_bit_eq_self)
	apply transfer
	apply (simp add: ac_simps)
	done

	lemma shiftl_inj:
	\<open>x = y\<close>
	if \<open>x << n = y << n\<close> \<open>x \<le> mask (LENGTH('a) - n)\<close> \<open>y \<le> mask (LENGTH('a) - n)\<close>
	for x y :: \<open>'a::len word\<close>
	proof (cases \<open>n < LENGTH('a)\<close>)
	case False
	with that show ?thesis
	by simp
	next
	case True
	moreover from that have \<open>take_bit (LENGTH('a) - n) x = x\<close> \<open>take_bit (LENGTH('a) - n) y = y\<close>
	by (simp_all add: less_eq_mask_iff_take_bit_eq_self)
	ultimately show ?thesis
	using \<open>x << n = y << n\<close> by (metis diff_less gr_implies_not0 linorder_cases linorder_not_le shiftl_shiftr_id shiftl_x_0 take_bit_word_eq_self_iff)
	qed

	lemma distinct_word_add_ucast_shift_inj:
	\<open>p' = p \<and> off' = off\<close>
	if *: \<open>p + (UCAST('a::len \<rightarrow> 'b::len) off << n) = p' + (ucast off' << n)\<close>
	and \<open>is_aligned p n'\<close> \<open>is_aligned p' n'\<close> \<open>n' = n + LENGTH('a)\<close> \<open>n' < LENGTH('b)\<close>
	proof -
	from \<open>n' = n + LENGTH('a)\<close>
	have [simp]: \<open>n' - n = LENGTH('a)\<close> \<open>n + LENGTH('a) = n'\<close>
	by simp_all
	from \<open>is_aligned p n'\<close> obtain q
	where p: \<open>p = push_bit n' (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('b) - n')\<close>
	by (rule is_alignedE')
	from \<open>is_aligned p' n'\<close> obtain q'
	where p': \<open>p' = push_bit n' (word_of_nat q')\<close> \<open>q' < 2 ^ (LENGTH('b) - n')\<close>
	by (rule is_alignedE')
	define m :: nat where \<open>m = unat off\<close>
	then have off: \<open>off = word_of_nat m\<close>
	by simp
	define m' :: nat where \<open>m' = unat off'\<close>
	then have off': \<open>off' = word_of_nat m'\<close>
	by simp
	have \<open>push_bit n' q + take_bit n' (push_bit n m) < 2 ^ LENGTH('b)\<close>
	by (metis id_apply is_aligned_no_wrap''' of_nat_eq_id of_nat_push_bit p(1) p(2) take_bit_nat_eq_self_iff take_bit_nat_less_exp take_bit_push_bit that(2) that(5) unsigned_of_nat)
	moreover have \<open>push_bit n' q' + take_bit n' (push_bit n m') < 2 ^ LENGTH('b)\<close>
	by (metis \<open>n' - n = LENGTH('a)\<close> id_apply is_aligned_no_wrap''' m'_def of_nat_eq_id of_nat_push_bit off' p'(1) p'(2) take_bit_nat_eq_self_iff take_bit_push_bit that(3) that(5) unsigned_of_nat)
	ultimately have \<open>push_bit n' q + take_bit n' (push_bit n m) = push_bit n' q' + take_bit n' (push_bit n m')\<close>
	using * by (simp add: p p' off off' push_bit_of_nat push_bit_take_bit word_of_nat_inj unsigned_of_nat shiftl_def flip: of_nat_add)
	then have \<open>int (push_bit n' q + take_bit n' (push_bit n m))
	= int (push_bit n' q' + take_bit n' (push_bit n m'))\<close>
	by simp
	then have \<open>concat_bit n' (int (push_bit n m)) (int q)
	= concat_bit n' (int (push_bit n m')) (int q')\<close>
	by (simp add: of_nat_push_bit of_nat_take_bit concat_bit_eq)
	then show ?thesis
	by (simp add: p p' off off' take_bit_of_nat take_bit_push_bit word_of_nat_eq_iff concat_bit_eq_iff)
	(simp add: push_bit_eq_mult)
	qed

	lemma word_upto_Nil:
	"y < x \<Longrightarrow> [x .e. y ::'a::len word] = []"
	by (simp add: upto_enum_red not_le word_less_nat_alt)

	lemma word_enum_decomp_elem:
	assumes "[x .e. (y ::'a::len word)] = as @ a # bs"
	shows "x \<le> a \<and> a \<le> y"
	proof -
	have "set as \<subseteq> set [x .e. y] \<and> a \<in> set [x .e. y]"
	using assms by (auto dest: arg_cong[where f=set])
	then show ?thesis by auto
	qed

	lemma word_enum_prefix:
	"[x .e. (y ::'a::len word)] = as @ a # bs \<Longrightarrow> as = (if x < a then [x .e. a - 1] else [])"
	apply (induct as arbitrary: x; clarsimp)
	apply (case_tac "x < y")
	prefer 2
	apply (case_tac "x = y", simp)
	apply (simp add: not_less)
	apply (drule (1) dual_order.not_eq_order_implies_strict)
	apply (simp add: word_upto_Nil)
	apply (simp add: word_upto_Cons_eq)
	apply (case_tac "x < y")
	prefer 2
	apply (case_tac "x = y", simp)
	apply (simp add: not_less)
	apply (drule (1) dual_order.not_eq_order_implies_strict)
	apply (simp add: word_upto_Nil)
	apply (clarsimp simp: word_upto_Cons_eq)
	apply (frule word_enum_decomp_elem)
	apply clarsimp
	apply (rule conjI)
	prefer 2
	apply (subst word_Suc_le[symmetric]; clarsimp)
	apply (drule meta_spec)
	apply (drule (1) meta_mp)
	apply clarsimp
	apply (rule conjI; clarsimp)
	apply (subst (2) word_upto_Cons_eq)
	apply unat_arith
	apply simp
	done

	lemma word_enum_decomp_set:
	"[x .e. (y ::'a::len word)] = as @ a # bs \<Longrightarrow> a \<notin> set as"
	by (metis distinct_append distinct_enum_upto' not_distinct_conv_prefix)

	lemma word_enum_decomp:
	assumes "[x .e. (y ::'a::len word)] = as @ a # bs"
	shows "x \<le> a \<and> a \<le> y \<and> a \<notin> set as \<and> (\<forall>z \<in> set as. x \<le> z \<and> z \<le> y)"
	proof -
	from assms
	have "set as \<subseteq> set [x .e. y] \<and> a \<in> set [x .e. y]"
	by (auto dest: arg_cong[where f=set])
	with word_enum_decomp_set[OF assms]
	show ?thesis by auto
	qed

	lemma of_nat_unat_le_mask_ucast:
	"\<lbrakk>of_nat (unat t) = w; t \<le> mask LENGTH('a)\<rbrakk> \<Longrightarrow> t = UCAST('a::len \<rightarrow> 'b::len) w"
	by (clarsimp simp: ucast_nat_def ucast_ucast_mask simp flip: and_mask_eq_iff_le_mask)

	lemma less_diff_gt0:
	"a < b \<Longrightarrow> (0 :: 'a :: len word) < b - a"
	by unat_arith

	lemma unat_plus_gt:
	"unat ((a :: 'a :: len word) + b) \<le> unat a + unat b"
	by (clarsimp simp: unat_plus_if_size)

	lemma const_less:
	"\<lbrakk> (a :: 'a :: len word) - 1 < b; a \<noteq> b \<rbrakk> \<Longrightarrow> a < b"
	by (metis less_1_simp word_le_less_eq)

	lemma add_mult_aligned_neg_mask:
	\<open>(x + y * m) AND NOT(mask n) = (x AND NOT(mask n)) + y * m\<close>
	if \<open>m AND (2 ^ n - 1) = 0\<close>
	for x y m :: \<open>'a::len word\<close>
	by (metis (no_types, opaque_lifting)
	add.assoc add.commute add.right_neutral add_uminus_conv_diff
	mask_eq_decr_exp mask_eqs(2) mask_eqs(6) mult.commute mult_zero_left
	subtract_mask(1) that)

	lemma unat_of_nat_minus_1:
	"\<lbrakk> n < 2 ^ LENGTH('a); n \<noteq> 0 \<rbrakk> \<Longrightarrow> unat ((of_nat n:: 'a :: len word) - 1) = n - 1"
	by (simp add: of_nat_diff unat_eq_of_nat)

	lemma word_eq_zeroI:
	"a \<le> a - 1 \<Longrightarrow> a = 0" for a :: "'a :: len word"
	by (simp add: word_must_wrap)

	lemma word_add_format:
	"(-1 :: 'a :: len word) + b + c = b + (c - 1)"
	by simp

	lemma upto_enum_word_nth:
	"\<lbrakk> i \<le> j; k \<le> unat (j - i) \<rbrakk> \<Longrightarrow> [i .e. j] ! k = i + of_nat k"
	apply (clarsimp simp: upto_enum_def nth_append)
	apply (clarsimp simp: word_le_nat_alt[symmetric])
	apply (rule conjI, clarsimp)
	apply (subst toEnum_of_nat, unat_arith)
	apply unat_arith
	apply (clarsimp simp: not_less unat_sub[symmetric])
	apply unat_arith
	done

	lemma upto_enum_step_nth:
	"\<lbrakk> a \<le> c; n \<le> unat ((c - a) div (b - a)) \<rbrakk>
	\<Longrightarrow> [a, b .e. c] ! n = a + of_nat n * (b - a)"
	by (clarsimp simp: upto_enum_step_def not_less[symmetric] upto_enum_word_nth)

	lemma upto_enum_inc_1_len:
	"a < - 1 \<Longrightarrow> [(0 :: 'a :: len word) .e. 1 + a] = [0 .e. a] @ [1 + a]"
	apply (simp add: upto_enum_word)
	apply (subgoal_tac "unat (1+a) = 1 + unat a")
	apply simp
	apply (subst unat_plus_simple[THEN iffD1])
	apply (metis add.commute no_plus_overflow_neg olen_add_eqv)
	apply unat_arith
	done

	lemma neg_mask_add:
	"y AND mask n = 0 \<Longrightarrow> x + y AND NOT(mask n) = (x AND NOT(mask n)) + y"
	for x y :: \<open>'a::len word\<close>
	by (clarsimp simp: mask_out_sub_mask mask_eqs(7)[symmetric] mask_twice)

	lemma shiftr_shiftl_shiftr[simp]:
	"(x :: 'a :: len word) >> a << a >> a = x >> a"
	by (word_eqI_solve dest: bit_imp_le_length)

	lemma add_right_shift:
	"\<lbrakk> x AND mask n = 0; y AND mask n = 0; x \<le> x + y \<rbrakk>
	\<Longrightarrow> (x + y :: ('a :: len) word) >> n = (x >> n) + (y >> n)"
	apply (simp add: no_olen_add_nat is_aligned_mask[symmetric])
	apply (simp add: unat_arith_simps shiftr_div_2n' split del: if_split)
	apply (subst if_P)
	apply (erule order_le_less_trans[rotated])
	apply (simp add: add_mono)
	apply (simp add: shiftr_div_2n' is_aligned_iff_dvd_nat)
	done

	lemma sub_right_shift:
	"\<lbrakk> x AND mask n = 0; y AND mask n = 0; y \<le> x \<rbrakk>
	\<Longrightarrow> (x - y) >> n = (x >> n :: 'a :: len word) - (y >> n)"
	using add_right_shift[where x="x - y" and y=y and n=n]
	by (simp add: aligned_sub_aligned is_aligned_mask[symmetric] word_sub_le)

	lemma and_and_mask_simple:
	"y AND mask n = mask n \<Longrightarrow> (x AND y) AND mask n = x AND mask n"
	by (simp add: ac_simps)

	lemma and_and_mask_simple_not:
	"y AND mask n = 0 \<Longrightarrow> (x AND y) AND mask n = 0"
	by (simp add: ac_simps)

	lemma word_and_le':
	"b \<le> c \<Longrightarrow> (a :: 'a :: len word) AND b \<le> c"
	by (metis word_and_le1 order_trans)

	lemma word_and_less':
	"b < c \<Longrightarrow> (a :: 'a :: len word) AND b < c"
	by transfer simp

	lemma shiftr_w2p:
	"x < LENGTH('a) \<Longrightarrow> 2 ^ x = (2 ^ (LENGTH('a) - 1) >> (LENGTH('a) - 1 - x) :: 'a :: len word)"
	by word_eqI_solve

	lemma t2p_shiftr:
	"\<lbrakk> b \<le> a; a < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ a >> b = 2 ^ (a - b)"
	by word_eqI_solve

	lemma scast_1[simp]:
	"scast (1 :: 'a :: len signed word) = (1 :: 'a word)"
	by simp

	lemma unsigned_uminus1 [simp]:
	\<open>(unsigned (-1::'b::len word)::'c::len word) = mask LENGTH('b)\<close>
	by (fact unsigned_minus_1_eq_mask)

	lemma ucast_ucast_mask_eq:
	"\<lbrakk> UCAST('a::len \<rightarrow> 'b::len) x = y; x AND mask LENGTH('b) = x \<rbrakk> \<Longrightarrow> x = ucast y"
	by (drule sym) (simp flip: take_bit_eq_mask add: unsigned_ucast_eq)

	lemma ucast_up_eq:
	"\<lbrakk> ucast x = (ucast y::'b::len word); LENGTH('a) \<le> LENGTH ('b) \<rbrakk>
	\<Longrightarrow> ucast x = (ucast y::'a::len word)"
	by (simp add: word_eq_iff bit_simps)

	lemma ucast_up_neq:
	"\<lbrakk> ucast x \<noteq> (ucast y::'b::len word); LENGTH('b) \<le> LENGTH ('a) \<rbrakk>
	\<Longrightarrow> ucast x \<noteq> (ucast y::'a::len word)"
	by (fastforce dest: ucast_up_eq)

	lemma mask_AND_less_0:
	"\<lbrakk> x AND mask n = 0; m \<le> n \<rbrakk> \<Longrightarrow> x AND mask m = 0"
	for x :: \<open>'a::len word\<close>
	by (metis mask_twice2 word_and_notzeroD)

	lemma mask_len_id [simp]:
	"(x :: 'a :: len word) AND mask LENGTH('a) = x"
	using uint_lt2p [of x] by (simp add: mask_eq_iff)

	lemma scast_ucast_down_same:
	"LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> SCAST('a \<rightarrow> 'b) = UCAST('a::len \<rightarrow> 'b::len)"
	by (simp add: down_cast_same is_down)

	lemma word_aligned_0_sum:
	"\<lbrakk> a + b = 0; is_aligned (a :: 'a :: len word) n; b \<le> mask n; n < LENGTH('a) \<rbrakk>
	\<Longrightarrow> a = 0 \<and> b = 0"
	by (simp add: word_plus_and_or_coroll aligned_mask_disjoint word_or_zero)

	lemma mask_eq1_nochoice:
	"\<lbrakk> LENGTH('a) > 1; (x :: 'a :: len word) AND 1 = x \<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
	by (metis word_and_1)

	lemma shiftr_and_eq_shiftl:
	"(w >> n) AND x = y \<Longrightarrow> w AND (x << n) = (y << n)" for y :: "'a:: len word"
	apply (drule sym)
	apply simp
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps)
	done

	lemma add_mask_lower_bits':
	"\<lbrakk> len = LENGTH('a); is_aligned (x :: 'a :: len word) n;
	\<forall>n' \<ge> n. n' < len \<longrightarrow> \<not> bit p n' \<rbrakk>
	\<Longrightarrow> x + p AND NOT(mask n) = x"
	using add_mask_lower_bits by auto

	lemma leq_mask_shift:
	"(x :: 'a :: len word) \<le> mask (low_bits + high_bits) \<Longrightarrow> (x >> low_bits) \<le> mask high_bits"
	by (simp add: le_mask_iff shiftr_shiftr ac_simps)

	lemma ucast_ucast_eq_mask_shift:
	"(x :: 'a :: len word) \<le> mask (low_bits + LENGTH('b))
	\<Longrightarrow> ucast((ucast (x >> low_bits)) :: 'b :: len word) = x >> low_bits"
	by (meson and_mask_eq_iff_le_mask eq_ucast_ucast_eq not_le_imp_less shiftr_less_t2n'
	ucast_ucast_len)

	lemma const_le_unat:
	"\<lbrakk> b < 2 ^ LENGTH('a); of_nat b \<le> a \<rbrakk> \<Longrightarrow> b \<le> unat (a :: 'a :: len word)"
	by (simp add: word_le_nat_alt unsigned_of_nat take_bit_nat_eq_self)

	lemma upt_enum_offset_trivial:
	"\<lbrakk> x < 2 ^ LENGTH('a) - 1 ; n \<le> unat x \<rbrakk>
	\<Longrightarrow> ([(0 :: 'a :: len word) .e. x] ! n) = of_nat n"
	apply (induct x arbitrary: n)
	apply simp
	by (simp add: upto_enum_word_nth)

	lemma word_le_mask_out_plus_2sz:
	"x \<le> (x AND NOT(mask sz)) + 2 ^ sz - 1"
	for x :: \<open>'a::len word\<close>
	by (metis add_diff_eq word_neg_and_le)

	lemma ucast_add:
	"ucast (a + (b :: 'a :: len word)) = ucast a + (ucast b :: ('a signed word))"
	by transfer (simp add: take_bit_add)

	lemma ucast_minus:
	"ucast (a - (b :: 'a :: len word)) = ucast a - (ucast b :: ('a signed word))"
	apply (insert ucast_add[where a=a and b="-b"])
	apply (metis (no_types, opaque_lifting) add_diff_eq diff_add_cancel ucast_add)
	done

	lemma scast_ucast_add_one [simp]:
	"scast (ucast (x :: 'a::len word) + (1 :: 'a signed word)) = x + 1"
	apply (subst ucast_1[symmetric])
	apply (subst ucast_add[symmetric])
	apply clarsimp
	done

	lemma word_and_le_plus_one:
	"a > 0 \<Longrightarrow> (x :: 'a :: len word) AND (a - 1) < a"
	by (simp add: gt0_iff_gem1 word_and_less')

	lemma unat_of_ucast_then_shift_eq_unat_of_shift[simp]:
	"LENGTH('b) \<ge> LENGTH('a)
	\<Longrightarrow> unat ((ucast (x :: 'a :: len word) :: 'b :: len word) >> n) = unat (x >> n)"
	by (simp add: shiftr_div_2n' unat_ucast_up_simp)

	lemma unat_of_ucast_then_mask_eq_unat_of_mask[simp]:
	"LENGTH('b) \<ge> LENGTH('a)
	\<Longrightarrow> unat ((ucast (x :: 'a :: len word) :: 'b :: len word) AND mask m) = unat (x AND mask m)"
	by (metis ucast_and_mask unat_ucast_up_simp)

	lemma shiftr_less_t2n3:
	"\<lbrakk> (2 :: 'a word) ^ (n + m) = 0; m < LENGTH('a) \<rbrakk>
	\<Longrightarrow> (x :: 'a :: len word) >> n < 2 ^ m"
	by (fastforce intro: shiftr_less_t2n' simp: mask_eq_decr_exp power_overflow)

	lemma unat_shiftr_le_bound:
	"\<lbrakk> 2 ^ (LENGTH('a :: len) - n) - 1 \<le> bnd; 0 < n \<rbrakk>
	\<Longrightarrow> unat ((x :: 'a word) >> n) \<le> bnd"
	apply transfer
	apply (simp add: take_bit_drop_bit)
	apply (simp add: drop_bit_take_bit)
	apply (rule order_trans)
	defer
	apply assumption
	apply (simp add: nat_le_iff of_nat_diff)
	done

	lemma shiftr_eqD:
	"\<lbrakk> x >> n = y >> n; is_aligned x n; is_aligned y n \<rbrakk>
	\<Longrightarrow> x = y"
	by (metis is_aligned_shiftr_shiftl)

	lemma word_shiftr_shiftl_shiftr_eq_shiftr:
	"a \<ge> b \<Longrightarrow> (x :: 'a :: len word) >> a << b >> b = x >> a"
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps dest: bit_imp_le_length)
	done

	lemma of_int_uint_ucast:
	"of_int (uint (x :: 'a::len word)) = (ucast x :: 'b::len word)"
	by (fact Word.of_int_uint)

	lemma mod_mask_drop:
	"\<lbrakk> m = 2 ^ n; 0 < m; mask n AND msk = mask n \<rbrakk>
	\<Longrightarrow> (x mod m) AND msk = x mod m"
	for x :: \<open>'a::len word\<close>
	by (simp add: word_mod_2p_is_mask word_bw_assocs)

	lemma mask_eq_ucast_eq:
	"\<lbrakk> x AND mask LENGTH('a) = (x :: ('c :: len word));
	LENGTH('a) \<le> LENGTH('b)\<rbrakk>
	\<Longrightarrow> ucast (ucast x :: ('a :: len word)) = (ucast x :: ('b :: len word))"
	by (metis ucast_and_mask ucast_id ucast_ucast_mask ucast_up_eq)

	lemma of_nat_less_t2n:
	"of_nat i < (2 :: ('a :: len) word) ^ n \<Longrightarrow> n < LENGTH('a) \<and> unat (of_nat i :: 'a word) < 2 ^ n"
	by (metis order_less_trans p2_gt_0 unat_less_power word_neq_0_conv)

	lemma two_power_increasing_less_1:
	"\<lbrakk> n \<le> m; m \<le> LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ n - 1 \<le> 2 ^ m - 1"
	by (metis diff_diff_cancel le_m1_iff_lt less_imp_diff_less p2_gt_0 two_power_increasing
	word_1_le_power word_le_minus_mono_left word_less_sub_1)

	lemma word_sub_mono4:
	"\<lbrakk> y + x \<le> z + x; y \<le> y + x; z \<le> z + x \<rbrakk> \<Longrightarrow> y \<le> z" for y :: "'a :: len word"
	by (simp add: word_add_le_iff2)

	lemma eq_or_less_helperD:
	"\<lbrakk> n = unat (2 ^ m - 1 :: 'a :: len word) \<or> n < unat (2 ^ m - 1 :: 'a word); m < LENGTH('a) \<rbrakk>
	\<Longrightarrow> n < 2 ^ m"
	by (meson le_less_trans nat_less_le unat_less_power word_power_less_1)

	lemma mask_sub:
	"n \<le> m \<Longrightarrow> mask m - mask n = mask m AND NOT(mask n :: 'a::len word)"
	by (metis (full_types) and_mask_eq_iff_shiftr_0 mask_out_sub_mask shiftr_mask_le word_bw_comms(1))

	lemma neg_mask_diff_bound:
	"sz'\<le> sz \<Longrightarrow> (ptr AND NOT(mask sz')) - (ptr AND NOT(mask sz)) \<le> 2 ^ sz - 2 ^ sz'"
	(is "_ \<Longrightarrow> ?lhs \<le> ?rhs")
	for ptr :: \<open>'a::len word\<close>
	proof -
	assume lt: "sz' \<le> sz"
	hence "?lhs = ptr AND (mask sz AND NOT(mask sz'))"
	by (metis add_diff_cancel_left' multiple_mask_trivia)
	also have "\<dots> \<le> ?rhs" using lt
	by (metis (mono_tags) add_diff_eq diff_eq_eq eq_iff mask_2pm1 mask_sub word_and_le')
	finally show ?thesis by simp
	qed

	lemma mask_out_eq_0:
	"\<lbrakk> idx < 2 ^ sz; sz < LENGTH('a) \<rbrakk> \<Longrightarrow> (of_nat idx :: 'a :: len word) AND NOT(mask sz) = 0"
	by (simp add: of_nat_power less_mask_eq mask_eq_0_eq_x)

	lemma is_aligned_neg_mask_eq':
	"is_aligned ptr sz = (ptr AND NOT(mask sz) = ptr)"
	using is_aligned_mask mask_eq_0_eq_x by blast

	lemma neg_mask_mask_unat:
	"sz < LENGTH('a)
	\<Longrightarrow> unat ((ptr :: 'a :: len word) AND NOT(mask sz)) + unat (ptr AND mask sz) = unat ptr"
	by (metis AND_NOT_mask_plus_AND_mask_eq unat_plus_simple word_and_le2)

	lemma unat_pow_le_intro:
	"LENGTH('a) \<le> n \<Longrightarrow> unat (x :: 'a :: len word) < 2 ^ n"
	by (metis lt2p_lem not_le of_nat_le_iff of_nat_numeral semiring_1_class.of_nat_power uint_nat)

	lemma unat_shiftl_less_t2n:
	\<open>unat (x << n) < 2 ^ m\<close>
	if \<open>unat (x :: 'a :: len word) < 2 ^ (m - n)\<close> \<open>m < LENGTH('a)\<close>
	proof (cases \<open>n \<le> m\<close>)
	case False
	with that show ?thesis
	apply (transfer fixing: m n)
	apply (simp add: not_le take_bit_push_bit)
	apply (metis diff_le_self order_le_less_trans push_bit_of_0 take_bit_0 take_bit_int_eq_self
	take_bit_int_less_exp take_bit_nonnegative take_bit_tightened)
	done
	next
	case True
	moreover define q r where \<open>q = m - n\<close> and \<open>r = LENGTH('a) - n - q\<close>
	ultimately have \<open>m - n = q\<close> \<open>m = n + q\<close> \<open>LENGTH('a) = r + q + n\<close>
	using that by simp_all
	with that show ?thesis
	apply (transfer fixing: m n q r)
	apply (simp add: not_le take_bit_push_bit)
	apply (simp add: push_bit_eq_mult power_add)
	using take_bit_tightened_less_eq_int [of \<open>r + q\<close> \<open>r + q + n\<close>]
	apply (rule le_less_trans)
	apply simp_all
	done
	qed

	lemma unat_is_aligned_add:
	"\<lbrakk> is_aligned p n; unat d < 2 ^ n \<rbrakk>
	\<Longrightarrow> unat (p + d AND mask n) = unat d \<and> unat (p + d AND NOT(mask n)) = unat p"
	by (metis add.right_neutral and_mask_eq_iff_le_mask and_not_mask le_mask_iff mask_add_aligned
	mask_out_add_aligned mult_zero_right shiftl_t2n shiftr_le_0)

	lemma unat_shiftr_shiftl_mask_zero:
	"\<lbrakk> c + a \<ge> LENGTH('a) + b ; c < LENGTH('a) \<rbrakk>
	\<Longrightarrow> unat (((q :: 'a :: len word) >> a << b) AND NOT(mask c)) = 0"
	by (fastforce intro: unat_is_aligned_add[where p=0 and n=c, simplified, THEN conjunct2]
	unat_shiftl_less_t2n unat_shiftr_less_t2n unat_pow_le_intro)

	lemmas of_nat_ucast = ucast_of_nat[symmetric]

	lemma shift_then_mask_eq_shift_low_bits:
	"x \<le> mask (low_bits + high_bits) \<Longrightarrow> (x >> low_bits) AND mask high_bits = x >> low_bits"
	for x :: \<open>'a::len word\<close>
	by (simp add: leq_mask_shift le_mask_imp_and_mask)

	lemma leq_low_bits_iff_zero:
	"\<lbrakk> x \<le> mask (low bits + high bits); x >> low_bits = 0 \<rbrakk> \<Longrightarrow> (x AND mask low_bits = 0) = (x = 0)"
	for x :: \<open>'a::len word\<close>
	using and_mask_eq_iff_shiftr_0 by force

	lemma unat_less_iff:
	"\<lbrakk> unat (a :: 'a :: len word) = b; c < 2 ^ LENGTH('a) \<rbrakk> \<Longrightarrow> (a < of_nat c) = (b < c)"
	using unat_ucast_less_no_overflow_simp by blast

	lemma is_aligned_no_overflow3:
	"\<lbrakk> is_aligned (a :: 'a :: len word) n; n < LENGTH('a); b < 2 ^ n; c \<le> 2 ^ n; b < c \<rbrakk>
	\<Longrightarrow> a + b \<le> a + (c - 1)"
	by (meson is_aligned_no_wrap' le_m1_iff_lt not_le word_less_sub_1 word_plus_mono_right)

	lemma mask_add_aligned_right:
	"is_aligned p n \<Longrightarrow> (q + p) AND mask n = q AND mask n"
	by (simp add: mask_add_aligned add.commute)

	lemma leq_high_bits_shiftr_low_bits_leq_bits_mask:
	"x \<le> mask high_bits \<Longrightarrow> (x :: 'a :: len word) << low_bits \<le> mask (low_bits + high_bits)"
	by (metis le_mask_shiftl_le_mask)

	lemma word_two_power_neg_ineq:
	"2 ^ m \<noteq> (0 :: 'a word) \<Longrightarrow> 2 ^ n \<le> - (2 ^ m :: 'a :: len word)"
	apply (cases "n < LENGTH('a)"; simp add: power_overflow)
	apply (cases "m < LENGTH('a)"; simp add: power_overflow)
	apply (simp add: word_le_nat_alt unat_minus word_size)
	apply (cases "LENGTH('a)"; simp)
	apply (simp add: less_Suc_eq_le)
	apply (drule power_increasing[where a=2 and n=n] power_increasing[where a=2 and n=m], simp)+
	apply (drule(1) add_le_mono)
	apply simp
	done

	lemma unat_shiftl_absorb:
	"\<lbrakk> x \<le> 2 ^ p; p + k < LENGTH('a) \<rbrakk> \<Longrightarrow> unat (x :: 'a :: len word) * 2 ^ k = unat (x * 2 ^ k)"
	by (smt add_diff_cancel_right' add_lessD1 le_add2 le_less_trans mult.commute nat_le_power_trans
	unat_lt2p unat_mult_lem unat_power_lower word_le_nat_alt)

	lemma word_plus_mono_right_split:
	"\<lbrakk> unat ((x :: 'a :: len word) AND mask sz) + unat z < 2 ^ sz; sz < LENGTH('a) \<rbrakk>
	\<Longrightarrow> x \<le> x + z"
	apply (subgoal_tac "(x AND NOT(mask sz)) + (x AND mask sz) \<le> (x AND NOT(mask sz)) + ((x AND mask sz) + z)")
	apply (simp add:word_plus_and_or_coroll2 field_simps)
	apply (rule word_plus_mono_right)
	apply (simp add: less_le_trans no_olen_add_nat)
	using of_nat_power is_aligned_no_wrap' by force

	lemma mul_not_mask_eq_neg_shiftl:
	"NOT(mask n :: 'a::len word) = -1 << n"
	by (simp add: NOT_mask shiftl_t2n)

	lemma shiftr_mul_not_mask_eq_and_not_mask:
	"(x >> n) * NOT(mask n) = - (x AND NOT(mask n))"
	for x :: \<open>'a::len word\<close>
	by (metis NOT_mask and_not_mask mult_minus_left semiring_normalization_rules(7) shiftl_t2n)

	lemma mask_eq_n1_shiftr:
	"n \<le> LENGTH('a) \<Longrightarrow> (mask n :: 'a :: len word) = -1 >> (LENGTH('a) - n)"
	by (metis diff_diff_cancel eq_refl mask_full shiftr_mask2)

	lemma is_aligned_mask_out_add_eq:
	"is_aligned p n \<Longrightarrow> (p + x) AND NOT(mask n) = p + (x AND NOT(mask n))"
	by (simp add: mask_out_sub_mask mask_add_aligned)

	lemmas is_aligned_mask_out_add_eq_sub
	= is_aligned_mask_out_add_eq[where x="a - b" for a b, simplified field_simps]

	lemma aligned_bump_down:
	"is_aligned x n \<Longrightarrow> (x - 1) AND NOT(mask n) = x - 2 ^ n"
	by (drule is_aligned_mask_out_add_eq[where x="-1"]) (simp add: NOT_mask)

	lemma unat_2tp_if:
	"unat (2 ^ n :: ('a :: len) word) = (if n < LENGTH ('a) then 2 ^ n else 0)"
	by (split if_split, simp_all add: power_overflow)

	lemma mask_of_mask:
	"mask (n::nat) AND mask (m::nat) = (mask (min m n) :: 'a::len word)"
	by word_eqI_solve

	lemma unat_signed_ucast_less_ucast:
	"LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> unat (ucast (x :: 'a :: len word) :: 'b :: len signed word) = unat x"
	by (simp add: unat_ucast_up_simp)

	lemma toEnum_of_ucast:
	"LENGTH('b) \<le> LENGTH('a) \<Longrightarrow>
	(toEnum (unat (b::'b :: len word))::'a :: len word) = of_nat (unat b)"
	by (simp add: unat_pow_le_intro)

	lemma plus_mask_AND_NOT_mask_eq:
	"x AND NOT(mask n) = x \<Longrightarrow> (x + mask n) AND NOT(mask n) = x" for x::\<open>'a::len word\<close>
	apply (subst word_plus_and_or_coroll; word_eqI; fastforce?)
	apply (erule allE, drule (1) iffD2)
	apply clarsimp
	done

	lemmas unat_ucast_mask = unat_ucast_eq_unat_and_mask[where w=a for a]

	lemma t2n_mask_eq_if:
	"2 ^ n AND mask m = (if n < m then 2 ^ n else (0 :: 'a::len word))"
	by word_eqI_solve

	lemma unat_ucast_le:
	"unat (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> unat x"
	by (simp add: ucast_nat_def word_unat_less_le)

	lemma ucast_le_up_down_iff:
	"\<lbrakk> LENGTH('a) \<le> LENGTH('b); (x :: 'b :: len word) \<le> ucast (- 1 :: 'a :: len word) \<rbrakk>
	\<Longrightarrow> (ucast x \<le> (y :: 'a word)) = (x \<le> ucast y)"
	using le_max_word_ucast_id ucast_le_ucast by metis

	lemma ucast_ucast_mask_shift:
	"a \<le> LENGTH('a) + b
	\<Longrightarrow> ucast (ucast (p AND mask a >> b) :: 'a :: len word) = p AND mask a >> b"
	by (metis add.commute le_mask_iff shiftr_mask_le ucast_ucast_eq_mask_shift word_and_le')

	lemma unat_ucast_mask_shift:
	"a \<le> LENGTH('a) + b
	\<Longrightarrow> unat (ucast (p AND mask a >> b) :: 'a :: len word) = unat (p AND mask a >> b)"
	by (metis linear ucast_ucast_mask_shift unat_ucast_up_simp)

	lemma mask_overlap_zero:
	"a \<le> b \<Longrightarrow> (p AND mask a) AND NOT(mask b) = 0"
	for p :: \<open>'a::len word\<close>
	by (metis NOT_mask_AND_mask mask_lower_twice2 max_def)

	lemma mask_shifl_overlap_zero:
	"a + c \<le> b \<Longrightarrow> (p AND mask a << c) AND NOT(mask b) = 0"
	for p :: \<open>'a::len word\<close>
	by (metis and_mask_0_iff_le_mask mask_mono mask_shiftl_decompose order_trans shiftl_over_and_dist word_and_le' word_and_le2)

	lemma mask_overlap_zero':
	"a \<ge> b \<Longrightarrow> (p AND NOT(mask a)) AND mask b = 0"
	for p :: \<open>'a::len word\<close>
	using mask_AND_NOT_mask mask_AND_less_0 by blast

	lemma mask_rshift_mult_eq_rshift_lshift:
	"((a :: 'a :: len word) >> b) * (1 << c) = (a >> b << c)"
	by (simp add: shiftl_t2n)

	lemma shift_alignment:
	"a \<ge> b \<Longrightarrow> is_aligned (p >> a << a) b"
	using is_aligned_shift is_aligned_weaken by blast

	lemma mask_split_sum_twice:
	"a \<ge> b \<Longrightarrow> (p AND NOT(mask a)) + ((p AND mask a) AND NOT(mask b)) + (p AND mask b) = p"
	for p :: \<open>'a::len word\<close>
	by (simp add: add.commute multiple_mask_trivia word_bw_comms(1) word_bw_lcs(1) word_plus_and_or_coroll2)

	lemma mask_shift_eq_mask_mask:
	"(p AND mask a >> b << b) = (p AND mask a) AND NOT(mask b)"
	for p :: \<open>'a::len word\<close>
	by (simp add: and_not_mask)

	lemma mask_shift_sum:
	"\<lbrakk> a \<ge> b; unat n = unat (p AND mask b) \<rbrakk>
	\<Longrightarrow> (p AND NOT(mask a)) + (p AND mask a >> b) * (1 << b) + n = (p :: 'a :: len word)"
	apply (simp add: shiftl_def shiftr_def flip: push_bit_eq_mult take_bit_eq_mask word_unat_eq_iff)
	apply (subst disjunctive_add)
	apply (auto simp add: bit_simps)
	apply (subst disjunctive_add)
	apply (auto simp add: bit_simps)
	apply (rule bit_word_eqI)
	apply (auto simp add: bit_simps)
	done

	lemma is_up_compose:
	"\<lbrakk> is_up uc; is_up uc' \<rbrakk> \<Longrightarrow> is_up (uc' \<circ> uc)"
	unfolding is_up_def by (simp add: Word.target_size Word.source_size)

	lemma of_int_sint_scast:
	"of_int (sint (x :: 'a :: len word)) = (scast x :: 'b :: len word)"
	by (fact Word.of_int_sint)

	lemma scast_of_nat_to_signed [simp]:
	"scast (of_nat x :: 'a :: len word) = (of_nat x :: 'a signed word)"
	by (rule bit_word_eqI) (simp add: bit_simps)

	lemma scast_of_nat_signed_to_unsigned_add:
	"scast (of_nat x + of_nat y :: 'a :: len signed word) = (of_nat x + of_nat y :: 'a :: len word)"
	by (metis of_nat_add scast_of_nat)

	lemma scast_of_nat_unsigned_to_signed_add:
	"(scast (of_nat x + of_nat y :: 'a :: len word)) = (of_nat x + of_nat y :: 'a :: len signed word)"
	by (metis Abs_fnat_hom_add scast_of_nat_to_signed)

	lemma and_mask_cases:
	fixes x :: "'a :: len word"
	assumes len: "n < LENGTH('a)"
	shows "x AND mask n \<in> of_nat ` set [0 ..< 2 ^ n]"
	apply (simp flip: take_bit_eq_mask)
	apply (rule image_eqI [of _ _ \<open>unat (take_bit n x)\<close>])
	using len apply simp_all
	apply transfer
	apply simp
	done

	lemma sint_eq_uint_2pl:
	"\<lbrakk> (a :: 'a :: len word) < 2 ^ (LENGTH('a) - 1) \<rbrakk>
	\<Longrightarrow> sint a = uint a"
	by (simp add: not_msb_from_less sint_eq_uint word_2p_lem word_size)

	lemma pow_sub_less:
	"\<lbrakk> a + b \<le> LENGTH('a); unat (x :: 'a :: len word) = 2 ^ a \<rbrakk>
	\<Longrightarrow> unat (x * 2 ^ b - 1) < 2 ^ (a + b)"
	by (smt (z3) eq_or_less_helperD le_add2 le_eq_less_or_eq le_trans power_add unat_mult_lem unat_pow_le_intro unat_power_lower word_eq_unatI)

	lemma sle_le_2pl:
	"\<lbrakk> (b :: 'a :: len word) < 2 ^ (LENGTH('a) - 1); a \<le> b \<rbrakk> \<Longrightarrow> a <=s b"
	by (simp add: not_msb_from_less word_sle_msb_le)

	lemma sless_less_2pl:
	"\<lbrakk> (b :: 'a :: len word) < 2 ^ (LENGTH('a) - 1); a < b \<rbrakk> \<Longrightarrow> a <s b"
	using not_msb_from_less word_sless_msb_less by blast

	lemma and_mask2:
	"w << n >> n = w AND mask (size w - n)"
	for w :: \<open>'a::len word\<close>
	by (rule bit_word_eqI) (auto simp add: bit_simps word_size)

	lemma aligned_sub_aligned_simple:
	"\<lbrakk> is_aligned a n; is_aligned b n \<rbrakk> \<Longrightarrow> is_aligned (a - b) n"
	by (simp add: aligned_sub_aligned)

	lemma minus_one_shift:
	"- (1 << n) = (-1 << n :: 'a::len word)"
	by (simp add: shiftl_def minus_exp_eq_not_mask)

	lemma ucast_eq_mask:
	"(UCAST('a::len \<rightarrow> 'b::len) x = UCAST('a \<rightarrow> 'b) y) =
	(x AND mask LENGTH('b) = y AND mask LENGTH('b))"
	by transfer (simp flip: take_bit_eq_mask add: ac_simps)

	context
	fixes w :: "'a::len word"
	begin

	private lemma sbintrunc_uint_ucast:
	"Suc n = LENGTH('b::len) \<Longrightarrow> signed_take_bit n (uint (ucast w :: 'b word)) = signed_take_bit n (uint w)"
	by word_eqI

	private lemma test_bit_sbintrunc:
	assumes "i < LENGTH('a)"
	shows "bit (word_of_int (signed_take_bit n (uint w)) :: 'a word) i
	= (if n < i then bit w n else bit w i)"
	using assms by (simp add: bit_simps)

	private lemma test_bit_sbintrunc_ucast:
	assumes len_a: "i < LENGTH('a)"
	shows "bit (word_of_int (signed_take_bit (LENGTH('b) - 1) (uint (ucast w :: 'b word))) :: 'a word) i
	= (if LENGTH('b::len) \<le> i then bit w (LENGTH('b) - 1) else bit w i)"
	using len_a by (auto simp add: sbintrunc_uint_ucast bit_simps)

	lemma scast_ucast_high_bits:
	\<open>scast (ucast w :: 'b::len word) = w
	\<longleftrightarrow> (\<forall> i \<in> {LENGTH('b) ..< size w}. bit w i = bit w (LENGTH('b) - 1))\<close>
	proof (cases \<open>LENGTH('a) \<le> LENGTH('b)\<close>)
	case True
	moreover define m where \<open>m = LENGTH('b) - LENGTH('a)\<close>
	ultimately have \<open>LENGTH('b) = m + LENGTH('a)\<close>
	by simp
	then show ?thesis
	by (simp add: signed_ucast_eq word_size) word_eqI
	next
	case False
	define q where \<open>q = LENGTH('b) - 1\<close>
	then have \<open>LENGTH('b) = Suc q\<close>
	by simp
	moreover define m where \<open>m = Suc LENGTH('a) - LENGTH('b)\<close>
	with False \<open>LENGTH('b) = Suc q\<close> have \<open>LENGTH('a) = m + q\<close>
	by (simp add: not_le)
	ultimately show ?thesis
	apply (simp add: signed_ucast_eq word_size)
	apply (transfer fixing: m q)
	apply (simp add: signed_take_bit_take_bit)
	apply (rule impI)
	apply (subst bit_eq_iff)
	apply (simp add: bit_take_bit_iff bit_signed_take_bit_iff min_def)
	apply (auto simp add: Suc_le_eq)
	using less_imp_le_nat apply blast
	using less_imp_le_nat apply blast
	done
	qed

	lemma scast_ucast_mask_compare:
	"scast (ucast w :: 'b::len word) = w
	\<longleftrightarrow> (w \<le> mask (LENGTH('b) - 1) \<or> NOT(mask (LENGTH('b) - 1)) \<le> w)"
	apply (clarsimp simp: le_mask_high_bits neg_mask_le_high_bits scast_ucast_high_bits word_size)
	apply (rule iffI; clarsimp)
	apply (rename_tac i j; case_tac "i = LENGTH('b) - 1"; case_tac "j = LENGTH('b) - 1")
	by auto

	lemma ucast_less_shiftl_helper':
	"\<lbrakk> LENGTH('b) + (a::nat) < LENGTH('a); 2 ^ (LENGTH('b) + a) \<le> n\<rbrakk>
	\<Longrightarrow> (ucast (x :: 'b::len word) << a) < (n :: 'a::len word)"
	apply (erule order_less_le_trans[rotated])
	using ucast_less[where x=x and 'a='a]
	apply (simp only: shiftl_t2n field_simps)
	apply (rule word_less_power_trans2; simp)
	done

	end

	lemma ucast_ucast_mask2:
	"is_down (UCAST ('a \<rightarrow> 'b)) \<Longrightarrow>
	UCAST ('b::len \<rightarrow> 'c::len) (UCAST ('a::len \<rightarrow> 'b::len) x) = UCAST ('a \<rightarrow> 'c) (x AND mask LENGTH('b))"
	by word_eqI_solve

	lemma ucast_NOT:
	"ucast (NOT x) = NOT(ucast x) AND mask (LENGTH('a))" for x::"'a::len word"
	by word_eqI_solve

	lemma ucast_NOT_down:
	"is_down UCAST('a::len \<rightarrow> 'b::len) \<Longrightarrow> UCAST('a \<rightarrow> 'b) (NOT x) = NOT(UCAST('a \<rightarrow> 'b) x)"
	by word_eqI

	lemma upto_enum_step_shift:
	"is_aligned p n \<Longrightarrow> ([p , p + 2 ^ m .e. p + 2 ^ n - 1]) = map ((+) p) [0, 2 ^ m .e. 2 ^ n - 1]"
	apply (erule is_aligned_get_word_bits)
	prefer 2
	apply (simp add: map_idI)
	apply (clarsimp simp: upto_enum_step_def)
	apply (frule is_aligned_no_overflow)
	apply (simp add: linorder_not_le [symmetric])
	done

	lemma upto_enum_step_shift_red:
	"\<lbrakk> is_aligned p sz; sz < LENGTH('a); us \<le> sz \<rbrakk>
	\<Longrightarrow> [p :: 'a :: len word, p + 2 ^ us .e. p + 2 ^ sz - 1]
	= map (\<lambda>x. p + of_nat x * 2 ^ us) [0 ..< 2 ^ (sz - us)]"
	apply (subst upto_enum_step_shift, assumption)
	apply (simp add: upto_enum_step_red)
	done

	lemma upto_enum_step_subset:
	"set [x, y .e. z] \<subseteq> {x .. z}"
	apply (clarsimp simp: upto_enum_step_def linorder_not_less)
	apply (drule div_to_mult_word_lt)
	apply (rule conjI)
	apply (erule word_random[rotated])
	apply simp
	apply (rule order_trans)
	apply (erule word_plus_mono_right)
	apply simp
	apply simp
	done

	lemma ucast_distrib:
	fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
	fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
	fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
	assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y) mod 2 ^ LENGTH('a)"
	assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y) mod 2 ^ LENGTH('b)"
	assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
	= (L x y) mod (2 ^ LENGTH('b))"
	assumes is_down: "is_down (ucast :: 'a word \<Rightarrow> 'b word)"
	shows "ucast (M a b) = M' (ucast a) (ucast b)"
	apply (simp only: ucast_eq)
	apply (subst lift_M)
	apply (subst of_int_uint [symmetric], subst lift_M')
	apply (metis local.distrib local.is_down take_bit_eq_mod ucast_down_wi uint_word_of_int_eq word_of_int_uint)
	done

	lemma ucast_down_add:
	"is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow> ucast ((a :: 'a::len word) + b) = (ucast a + ucast b :: 'b::len word)"
	by (rule ucast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)

	lemma ucast_down_minus:
	"is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow> ucast ((a :: 'a::len word) - b) = (ucast a - ucast b :: 'b::len word)"
	apply (rule ucast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
	apply (metis mod_diff_left_eq mod_diff_right_eq)
	apply simp
	done

	lemma ucast_down_mult:
	"is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow> ucast ((a :: 'a::len word) * b) = (ucast a * ucast b :: 'b::len word)"
	apply (rule ucast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
	apply (metis mod_mult_eq)
	apply simp
	done

	lemma scast_distrib:
	fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
	fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
	fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
	assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y) mod 2 ^ LENGTH('a)"
	assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y) mod 2 ^ LENGTH('b)"
	assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
	= (L x y) mod (2 ^ LENGTH('b))"
	assumes is_down: "is_down (scast :: 'a word \<Rightarrow> 'b word)"
	shows "scast (M a b) = M' (scast a) (scast b)"
	apply (subst (1 2 3) down_cast_same [symmetric])
	apply (insert is_down)
	apply (clarsimp simp: is_down_def target_size source_size is_down)
	apply (rule ucast_distrib [where L=L, OF lift_M lift_M' distrib])
	apply (insert is_down)
	apply (clarsimp simp: is_down_def target_size source_size is_down)
	done

	lemma scast_down_add:
	"is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow> scast ((a :: 'a::len word) + b) = (scast a + scast b :: 'b::len word)"
	by (rule scast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)

	lemma scast_down_minus:
	"is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow> scast ((a :: 'a::len word) - b) = (scast a - scast b :: 'b::len word)"
	apply (rule scast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
	apply (metis mod_diff_left_eq mod_diff_right_eq)
	apply simp
	done

	lemma scast_down_mult:
	"is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow> scast ((a :: 'a::len word) * b) = (scast a * scast b :: 'b::len word)"
	apply (rule scast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
	apply (metis mod_mult_eq)
	apply simp
	done

	lemma scast_ucast_1:
	"\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
	by (metis down_cast_same ucast_eq ucast_down_wi)

	lemma scast_ucast_3:
	"\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
	by (metis down_cast_same ucast_eq ucast_down_wi)

	lemma scast_ucast_4:
	"\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
	by (metis down_cast_same ucast_eq ucast_down_wi)

	lemma scast_scast_b:
	"\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
	(scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
	by (metis scast_eq sint_up_scast)

	lemma ucast_scast_1:
	"\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
	by (metis scast_eq ucast_down_wi)

	lemma ucast_scast_3:
	"\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
	by (metis scast_eq ucast_down_wi)

	lemma ucast_scast_4:
	"\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
	by (metis down_cast_same scast_eq sint_up_scast)

	lemma ucast_ucast_a:
	"\<lbrakk> is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
	by (metis down_cast_same ucast_eq ucast_down_wi)

	lemma ucast_ucast_b:
	"\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
	(ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
	by (metis ucast_up_ucast)

	lemma scast_scast_a:
	"\<lbrakk> is_down (scast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
	(scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
	apply (simp only: scast_eq)
	apply (metis down_cast_same is_up_down scast_eq ucast_down_wi)
	done

	lemma scast_down_wi [OF refl]:
	"uc = scast \<Longrightarrow> is_down uc \<Longrightarrow> uc (word_of_int x) = word_of_int x"
	by (metis down_cast_same is_up_down ucast_down_wi)

	lemmas cast_simps =
	is_down is_up
	scast_down_add scast_down_minus scast_down_mult
	ucast_down_add ucast_down_minus ucast_down_mult
	scast_ucast_1 scast_ucast_3 scast_ucast_4
	ucast_scast_1 ucast_scast_3 ucast_scast_4
	ucast_ucast_a ucast_ucast_b
	scast_scast_a scast_scast_b
	ucast_down_wi scast_down_wi
	ucast_of_nat scast_of_nat
	uint_up_ucast sint_up_scast
	up_scast_surj up_ucast_surj

	lemma sdiv_word_max:
	"(sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word) < (2 ^ (size a - 1))) =
	((a \<noteq> - (2 ^ (size a - 1)) \<or> (b \<noteq> -1)))"
	(is "?lhs = (\<not> ?a_int_min \<or> \<not> ?b_minus1)")
	proof (rule classical)
	assume not_thesis: "\<not> ?thesis"

	have not_zero: "b \<noteq> 0"
	using not_thesis
	by (clarsimp)

	let ?range = \<open>{- (2 ^ (size a - 1))..<2 ^ (size a - 1)} :: int set\<close>

	have result_range: "sint a sdiv sint b \<in> ?range \<union> {2 ^ (size a - 1)}"
	using sdiv_word_min [of a b] sdiv_word_max [of a b] by auto

	have result_range_overflow: "(sint a sdiv sint b = 2 ^ (size a - 1)) = (?a_int_min \<and> ?b_minus1)"
	apply (rule iffI [rotated])
	apply (clarsimp simp: signed_divide_int_def sgn_if word_size sint_int_min)
	apply (rule classical)
	apply (case_tac "?a_int_min")
	apply (clarsimp simp: word_size sint_int_min)
	apply (metis diff_0_right
	int_sdiv_negated_is_minus1 minus_diff_eq minus_int_code(2)
	power_eq_0_iff sint_minus1 zero_neq_numeral)
	apply (subgoal_tac "abs (sint a) < 2 ^ (size a - 1)")
	apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
	apply (clarsimp simp: word_size)
	apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
	apply auto
	apply (cases \<open>size a\<close>)
	apply simp_all
	apply (smt (z3) One_nat_def diff_Suc_1 signed_word_eqI sint_int_min sint_range_size wsst_TYs(3))
	done

	have result_range_simple: "(sint a sdiv sint b \<in> ?range) \<Longrightarrow> ?thesis"
	apply (insert sdiv_int_range [where a="sint a" and b="sint b"])
	apply (clarsimp simp: word_size sint_int_min)
	done

	show ?thesis
	apply (rule UnE [OF result_range result_range_simple])
	apply simp
	apply (clarsimp simp: word_size)
	using result_range_overflow
	apply (clarsimp simp: word_size)
	done
	qed

	lemmas sdiv_word_min' = sdiv_word_min [simplified word_size, simplified]
	lemmas sdiv_word_max' = sdiv_word_max [simplified word_size, simplified]

	lemma signed_arith_ineq_checks_to_eq:
	"((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
	= (sint a + sint b = sint (a + b ))"
	"((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
	= (sint a - sint b = sint (a - b))"
	"((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
	= ((- sint a) = sint (- a))"
	"((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
	= (sint a * sint b = sint (a * b))"
	"((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
	= (sint a sdiv sint b = sint (a sdiv b))"
	"((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
	= (sint a smod sint b = sint (a smod b))"
	by (auto simp: sint_word_ariths word_size signed_div_arith signed_mod_arith signed_take_bit_int_eq_self_iff intro: sym dest: sym)

	lemma signed_arith_sint:
	"((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
	\<Longrightarrow> sint (a + b) = (sint a + sint b)"
	"((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
	\<Longrightarrow> sint (a - b) = (sint a - sint b)"
	"((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
	\<Longrightarrow> sint (- a) = (- sint a)"
	"((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
	\<Longrightarrow> sint (a * b) = (sint a * sint b)"
	"((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
	\<Longrightarrow> sint (a sdiv b) = (sint a sdiv sint b)"
	"((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
	\<Longrightarrow> sint (a smod b) = (sint a smod sint b)"
	by (subst (asm) signed_arith_ineq_checks_to_eq; simp)+

	lemma nasty_split_lt:
	\<open>x * 2 ^ n + (2 ^ n - 1) \<le> 2 ^ m - 1\<close>
	if \<open>x < 2 ^ (m - n)\<close> \<open>n \<le> m\<close> \<open>m < LENGTH('a::len)\<close>
	for x :: \<open>'a::len word\<close>
	proof -
	define q where \<open>q = m - n\<close>
	with \<open>n \<le> m\<close> have \<open>m = q + n\<close>
	by simp
	with \<open>x < 2 ^ (m - n)\<close> have *: \<open>i < q\<close> if \<open>bit x i\<close> for i
	using that by simp (metis bit_take_bit_iff take_bit_word_eq_self_iff)
	from \<open>m = q + n\<close> have \<open>push_bit n x OR mask n \<le> mask m\<close>
	by (auto simp add: le_mask_high_bits word_size bit_simps dest!: *)
	then have \<open>push_bit n x + mask n \<le> mask m\<close>
	by (simp add: disjunctive_add bit_simps)
	then show ?thesis
	by (simp add: mask_eq_exp_minus_1 push_bit_eq_mult)
	qed

	lemma nasty_split_less:
	"\<lbrakk>m \<le> n; n \<le> nm; nm < LENGTH('a::len); x < 2 ^ (nm - n)\<rbrakk>
	\<Longrightarrow> (x :: 'a word) * 2 ^ n + (2 ^ m - 1) < 2 ^ nm"
	apply (simp only: word_less_sub_le[symmetric])
	apply (rule order_trans [OF _ nasty_split_lt])
	apply (rule word_plus_mono_right)
	apply (rule word_sub_mono)
	apply (simp add: word_le_nat_alt)
	apply simp
	apply (simp add: word_sub_1_le[OF power_not_zero])
	apply (simp add: word_sub_1_le[OF power_not_zero])
	apply (rule is_aligned_no_wrap')
	apply (rule is_aligned_mult_triv2)
	apply simp
	apply (erule order_le_less_trans, simp)
	apply simp+
	done

	end

	end
	diff --git a/thys/Youngs_Inequality/ROOT b/thys/Youngs_Inequality/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Youngs_Inequality/ROOT
	@@ -0,0 +1,10 @@
	+chapter AFP
	+
	+session Youngs_Inequality (AFP) = "HOL-Analysis" +
	+ options [timeout = 300]
	+ theories
	+ Youngs
	+ document_files
	+ "root.tex"
	+ "root.bib"
	+
	diff --git a/thys/Youngs_Inequality/Youngs.thy b/thys/Youngs_Inequality/Youngs.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Youngs_Inequality/Youngs.thy
	@@ -0,0 +1,870 @@
	+section \<open>Young's Inequality for Increasing Functions\<close>
	+
	+text \<open>From the following paper:
	+Cunningham, F., and Nathaniel Grossman. “On Young’s Inequality.”
	+The American Mathematical Monthly 78, no. 7 (1971): 781–83.
	+\url{https://doi.org/10.2307/2318018}\<close>
	+
	+theory Youngs imports
	+ "HOL-Analysis.Analysis"
	+
	+begin
	+
	+subsection \<open>Library Extras: already added to the repository\<close>
	+
	+text \<open>In fact, strict inequality is required only at a single point within the box.\<close>
	+lemma integral_less:
	+ fixes f :: "'n::euclidean_space \<Rightarrow> real"
	+ assumes cont: "continuous_on (cbox a b) f" "continuous_on (cbox a b) g" and ne: "box a b \<noteq> {}"
	+ and fg: "\<And>x. x \<in> box a b \<Longrightarrow> f x < g x"
	+ shows "integral (cbox a b) f < integral (cbox a b) g"
	+proof -
	+ obtain int: "f integrable_on (cbox a b)" "g integrable_on (cbox a b)"
	+ using cont integrable_continuous by blast
	+ then have "integral (cbox a b) f \<le> integral (cbox a b) g"
	+ by (metis fg integrable_on_open_interval integral_le integral_open_interval less_eq_real_def)
	+ moreover have "integral (cbox a b) f \<noteq> integral (cbox a b) g"
	+ proof (rule ccontr)
	+ assume "\<not> integral (cbox a b) f \<noteq> integral (cbox a b) g"
	+ then have 0: "((\<lambda>x. g x - f x) has_integral 0) (cbox a b)"
	+ by (metis (full_types) cancel_comm_monoid_add_class.diff_cancel has_integral_diff int
	+ integrable_integral)
	+ have cgf: "continuous_on (cbox a b) (\<lambda>x. g x - f x)"
	+ using cont continuous_on_diff by blast
	+ show False
	+ using has_integral_0_cbox_imp_0 [OF cgf _ 0] ne box_subset_cbox fg by fastforce
	+ qed
	+ ultimately show ?thesis
	+ by linarith
	+qed
	+
	+lemma integral_less_real:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes "continuous_on {a..b} f" "continuous_on {a..b} g" and "{a<..<b} \<noteq> {}"
	+ and "\<And>x. x \<in> {a<..<b} \<Longrightarrow> f x < g x"
	+ shows "integral {a..b} f < integral {a..b} g"
	+ by (metis assms box_real integral_less)
	+
	+lemma has_integral_UN:
	+ fixes f :: "'n::euclidean_space \<Rightarrow> 'a::banach"
	+ assumes "finite I"
	+ and int: "\<And>i. i \<in> I \<Longrightarrow> (f has_integral (g i)) (\<T> i)"
	+ and neg: "pairwise (\<lambda>i i'. negligible (\<T> i \<inter> \<T> i')) I"
	+ shows "(f has_integral (sum g I)) (\<Union>i\<in>I. \<T> i)"
	+proof -
	+ let ?\<U> = "((\<lambda>(a,b). \<T> a \<inter> \<T> b) ` {(a,b). a \<in> I \<and> b \<in> I-{a}})"
	+ have "((\<lambda>x. if x \<in> (\<Union>i\<in>I. \<T> i) then f x else 0) has_integral sum g I) UNIV"
	+ proof (rule has_integral_spike)
	+ show "negligible (\<Union>?\<U>)"
	+ proof (rule negligible_Union)
	+ have "finite (I \<times> I)"
	+ by (simp add: \<open>finite I\<close>)
	+ moreover have "{(a,b). a \<in> I \<and> b \<in> I-{a}} \<subseteq> I \<times> I"
	+ by auto
	+ ultimately show "finite ?\<U>"
	+ by (simp add: finite_subset)
	+ show "\<And>t. t \<in> ?\<U> \<Longrightarrow> negligible t"
	+ using neg unfolding pairwise_def by auto
	+ qed
	+ next
	+ show "(if x \<in> (\<Union>i\<in>I. \<T> i) then f x else 0) = (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)"
	+ if "x \<in> UNIV - (\<Union>?\<U>)" for x
	+ proof clarsimp
	+ fix i assume i: "i \<in> I" "x \<in> \<T> i"
	+ then have "\<forall>j\<in>I. x \<in> \<T> j \<longleftrightarrow> j = i"
	+ using that by blast
	+ with i show "f x = (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)"
	+ by (simp add: sum.delta[OF \<open>finite I\<close>])
	+ qed
	+ next
	+ show "((\<lambda>x. (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)) has_integral sum g I) UNIV"
	+ using int by (simp add: has_integral_restrict_UNIV has_integral_sum[OF \<open>finite I\<close>])
	+ qed
	+ then show ?thesis
	+ using has_integral_restrict_UNIV by blast
	+qed
	+
	+lemma integrable_mono_on_nonneg:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes mon: "mono_on f {a..b}" and 0: "\<And>x. 0 \<le> f x"
	+ shows "integrable (lebesgue_on {a..b}) f"
	+proof -
	+ have "space lborel = space lebesgue" "sets borel \<subseteq> sets lebesgue"
	+ by force+
	+ then have fborel: "f \<in> borel_measurable (lebesgue_on {a..b})"
	+ by (metis mon borel_measurable_mono_on_fnc borel_measurable_subalgebra mono_restrict_space
	+ space_lborel space_restrict_space)
	+ then obtain g where g: "incseq g" and simple: "\<And>i. simple_function (lebesgue_on {a..b}) (g i)"
	+ and bdd: " (\<forall>x. bdd_above (range (\<lambda>i. g i x)))" and nonneg: "\<forall>i x. 0 \<le> g i x"
	+ and fsup: "f = (SUP i. g i)"
	+ by (metis borel_measurable_implies_simple_function_sequence_real 0)
	+ have "f ` {a..b} \<subseteq> {f a..f b}"
	+ using assms by (auto simp: mono_on_def)
	+ have g_le_f: "g i x \<le> f x" for i x
	+ proof -
	+ have "bdd_above ((\<lambda>h. h x) ` range g)"
	+ using bdd cSUP_lessD linorder_not_less by fastforce
	+ then show ?thesis
	+ by (metis SUP_apply UNIV_I bdd cSUP_upper fsup)
	+ qed
	+ then have gfb: "g i x \<le> f b" if "x \<in> {a..b}" for i x
	+ by (smt (verit, best) mon atLeastAtMost_iff mono_on_def that)
	+ have g_le: "g i x \<le> g j x" if "i\<le>j" for i j x
	+ using g by (simp add: incseq_def le_funD that)
	+ show "integrable (lebesgue_on {a..b}) ( f)"
	+ proof (rule integrable_dominated_convergence)
	+ show "f \<in> borel_measurable (lebesgue_on {a..b})"
	+ using fborel by blast
	+ have "\<And>x. (\<lambda>i. g i x) \<longlonglongrightarrow> (SUP h \<in> range g. h x)"
	+ proof (rule order_tendstoI)
	+ show "\<forall>\<^sub>F i in sequentially. y < g i x"
	+ if "y < (SUP h\<in>range g. h x)" for x y
	+ proof -
	+ from that obtain h where h: "h \<in> range g" "y < h x"
	+ using g_le_f by (subst (asm)less_cSUP_iff) fastforce+
	+ then show ?thesis
	+ by (smt (verit, ccfv_SIG) eventually_sequentially g_le imageE)
	+ qed
	+ show "\<forall>\<^sub>F i in sequentially. g i x < y"
	+ if "(SUP h\<in>range g. h x) < y" for x y
	+ by (smt (verit, best) that Sup_apply g_le_f always_eventually fsup image_cong)
	+ qed
	+ then show "AE x in lebesgue_on {a..b}. (\<lambda>i. g i x) \<longlonglongrightarrow> f x"
	+ by (simp add: fsup)
	+ fix i
	+ show "g i \<in> borel_measurable (lebesgue_on {a..b})"
	+ using borel_measurable_simple_function simple by blast
	+ show "AE x in lebesgue_on {a..b}. norm (g i x) \<le> f b"
	+ by (simp add: gfb nonneg Measure_Space.AE_I' [of "{}"])
	+ qed auto
	+qed
	+
	+lemma integrable_mono_on:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes "mono_on f {a..b}"
	+ shows "integrable (lebesgue_on {a..b}) f"
	+proof -
	+ define f' where "f' \<equiv> \<lambda>x. if x \<in> {a..b} then f x - f a else 0"
	+ have "mono_on f' {a..b}"
	+ by (smt (verit, best) assms f'_def mono_on_def)
	+ moreover have 0: "\<And>x. 0 \<le> f' x"
	+ by (smt (verit, best) assms atLeastAtMost_iff f'_def mono_on_def)
	+ ultimately have "integrable (lebesgue_on {a..b}) f'"
	+ using integrable_mono_on_nonneg by presburger
	+ then have "integrable (lebesgue_on {a..b}) (\<lambda>x. f' x + f a)"
	+ by force
	+ moreover have "space lborel = space lebesgue" "sets borel \<subseteq> sets lebesgue"
	+ by force+
	+ then have fborel: "f \<in> borel_measurable (lebesgue_on {a..b})"
	+ using borel_measurable_mono_on_fnc [OF assms]
	+ by (metis borel_measurable_subalgebra mono_restrict_space space_lborel space_restrict_space)
	+ ultimately show ?thesis
	+ by (rule integrable_cong_AE_imp) (auto simp: f'_def)
	+qed
	+
	+lemma integrable_on_mono_on:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes "mono_on f {a..b}"
	+ shows "f integrable_on {a..b}"
	+ by (simp add: assms integrable_mono_on integrable_on_lebesgue_on)
	+
	+lemma strict_mono_image_endpoints:
	+ fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
	+ assumes "strict_mono_on f {a..b}" and f: "continuous_on {a..b} f" and "a \<le> b"
	+ shows "f ` {a..b} = {f a..f b}"
	+proof
	+ show "f ` {a..b} \<subseteq> {f a..f b}"
	+ using assms(1) strict_mono_on_leD by fastforce
	+ show "{f a..f b} \<subseteq> f ` {a..b}"
	+ using assms IVT'[OF _ _ _ f] by (force simp: Bex_def)
	+qed
	+
	+subsection \<open>Toward Young's inequality\<close>
	+
	+text \<open>Generalisations of the type of @{term f} are not obvious\<close>
	+lemma strict_mono_continuous_invD:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes sm: "strict_mono_on f {a..}" and contf: "continuous_on {a..} f"
	+ and fim: "f ` {a..} = {f a..}" and g: "\<And>x. x \<ge> a \<Longrightarrow> g (f x) = x"
	+ shows "continuous_on {f a..} g"
	+proof (clarsimp simp add: continuous_on_eq_continuous_within)
	+ fix y
	+ assume "f a \<le> y"
	+ then obtain u where u: "y+1 = f u" "u \<ge> a"
	+ by (smt (verit, best) atLeast_iff fim imageE)
	+ have "continuous_on {f a..y+1} g"
	+ proof -
	+ obtain "continuous_on {a..u} f" "strict_mono_on f {a..u}"
	+ using contf sm continuous_on_subset by (force simp add: strict_mono_on_def)
	+ moreover have "continuous_on (f ` {a..u}) g"
	+ using assms continuous_on_subset
	+ by (intro continuous_on_inv) fastforce+
	+ ultimately show ?thesis
	+ using strict_mono_image_endpoints [of f]
	+ by (simp add: strict_mono_image_endpoints u)
	+ qed
	+ then have *: "continuous (at y within {f a..y+1}) g"
	+ by (simp add: \<open>f a \<le> y\<close> continuous_on_imp_continuous_within)
	+ show "continuous (at y within {f a..}) g"
	+ proof (clarsimp simp add: continuous_within_topological Ball_def)
	+ fix B
	+ assume "open B" and "g y \<in> B"
	+ with * obtain A where A: "open A" "y \<in> A" and "\<And>x. f a \<le> x \<and> x \<le> y+1 \<Longrightarrow> x \<in> A \<longrightarrow> g x \<in> B"
	+ by (force simp: continuous_within_topological)
	+ then have "\<forall>x\<ge>f a. x \<in> A \<inter> ball y 1 \<longrightarrow> g x \<in> B"
	+ by (smt (verit, ccfv_threshold) IntE dist_norm mem_ball real_norm_def)
	+ then show "\<exists>A. open A \<and> y \<in> A \<and> (\<forall>x\<ge>f a. x \<in> A \<longrightarrow> g x \<in> B)"
	+ by (metis Elementary_Metric_Spaces.open_ball Int_iff A centre_in_ball open_Int zero_less_one)
	+ qed
	+qed
	+
	+subsection \<open>Regular divisions\<close>
	+
	+text \<open>Our lack of the Riemann integral forces us to construct explicitly
	+the step functions mentioned in the text.\<close>
	+
	+definition "segment \<equiv> \<lambda>n k. {real k / real n..(1 + k) / real n}"
	+
	+lemma segment_nonempty: "segment n k \<noteq> {}"
	+ by (auto simp: segment_def divide_simps)
	+
	+lemma segment_Suc: "segment n ` {..<Suc k} = insert {k/n..(1 + real k) / n} (segment n ` {..<k})"
	+ by (simp add: segment_def lessThan_Suc)
	+
	+lemma Union_segment_image: "\<Union> (segment n ` {..<k}) = (if k=0 then {} else {0..real k/real n})"
	+proof (induction k)
	+ case (Suc k)
	+ then show ?case
	+ by (simp add: divide_simps segment_Suc Un_commute ivl_disj_un_two_touch split: if_split_asm)
	+qed (auto simp: segment_def)
	+
	+definition "segments \<equiv> \<lambda>n. segment n ` {..<n}"
	+
	+lemma card_segments [simp]: "card (segments n) = n"
	+ by (simp add: segments_def segment_def card_image divide_right_mono inj_on_def)
	+
	+lemma segments_0 [simp]: "segments 0 = {}"
	+ by (simp add: segments_def)
	+
	+lemma Union_segments: "\<Union> (segments n) = (if n=0 then {} else {0..1})"
	+ by (simp add: segments_def Union_segment_image)
	+
	+definition "regular_division \<equiv> \<lambda>a b n. (image ((+) a \<circ> (*) (b-a))) ` (segments n)"
	+
	+lemma translate_scale_01:
	+ assumes "a \<le> b"
	+ shows "(\<lambda>x. a + (b - a) * x) ` {0..1} = {a..b::real}"
	+ using closed_segment_real_eq [of a b] assms closed_segment_eq_real_ivl by auto
	+
	+lemma finite_regular_division [simp]: "finite (regular_division a b n)"
	+ by (simp add: regular_division_def segments_def)
	+
	+lemma card_regular_division [simp]:
	+ assumes "a<b"
	+ shows "card (regular_division a b n) = n"
	+proof -
	+ have "inj_on ((`) ((+) a \<circ> (*) (b - a))) (segments n)"
	+ proof
	+ fix x y
	+ assume "((+) a \<circ> () (b - a)) ` x = ((+) a \<circ> () (b - a)) ` y"
	+ then have "(+) (-a) ` ((+) a \<circ> () (b - a)) ` x = (+) (-a) ` ((+) a \<circ> () (b - a)) ` y"
	+ by simp
	+ then have "(() (b - a)) ` x = (() (b - a)) ` y"
	+ by (simp add: image_comp)
	+ then have "() (inverse(b - a)) ` () (b - a) ` x = () (inverse(b - a)) ` () (b - a) ` y"
	+ by simp
	+ then show "x = y"
	+ using assms by (simp add: image_comp mult_ac)
	+ qed
	+ then show ?thesis
	+ by (metis card_image card_segments regular_division_def)
	+qed
	+
	+lemma Union_regular_division:
	+ assumes "a \<le> b"
	+ shows "\<Union>(regular_division a b n) = (if n=0 then {} else {a..b})"
	+ using assms
	+ by (auto simp: regular_division_def Union_segments translate_scale_01 simp flip: image_Union)
	+
	+lemma regular_division_eqI:
	+ assumes K: "K = {a + (b-a)(real k / n) .. a + (b-a)((1 + real k) / n)}"
	+ and "a<b" "k < n"
	+ shows "K \<in> regular_division a b n"
	+ unfolding regular_division_def segments_def image_comp
	+proof
	+ have "K = (\<lambda>x. (b-a) * x + a) ` {real k / real n..(1 + real k) / real n}"
	+ using K \<open>a<b\<close> by (simp add: image_affinity_atLeastAtMost divide_simps)
	+ then show "K = ((`) ((+) a \<circ> (*) (b - a)) \<circ> segment n) k"
	+ by (simp add: segment_def add.commute)
	+qed (use assms in auto)
	+
	+lemma regular_divisionE:
	+ assumes "K \<in> regular_division a b n" "a<b"
	+ obtains k where "k<n" "K = {a + (b-a)(real k / n) .. a + (b-a)((1 + real k) / n)}"
	+proof -
	+ have eq: "(\<lambda>x. a + (b - a) * x) = (\<lambda>x. a + x) \<circ> (\<lambda>x. (b - a) * x)"
	+ by (simp add: o_def)
	+ obtain k where "k<n" "K = ((\<lambda>x. a+x) \<circ> (\<lambda>x. (b-a) * x)) ` {k/n .. (1 + real k) / n}"
	+ using assms by (auto simp: regular_division_def segments_def segment_def)
	+ with that \<open>a<b\<close> show ?thesis
	+ unfolding image_comp [symmetric] by auto
	+qed
	+
	+lemma regular_division_division_of:
	+ assumes "a < b" "n>0"
	+ shows "(regular_division a b n) division_of {a..b}"
	+proof (rule division_ofI)
	+ show "finite (regular_division a b n)"
	+ by (simp add: regular_division_def segments_def)
	+ show \<section>: "\<Union> (regular_division a b n) = {a..b}"
	+ using Union_regular_division assms by simp
	+ fix K
	+ assume K: "K \<in> regular_division a b n"
	+ then obtain k where Keq: "K = {a + (b-a)(k/n) .. a + (b-a)((1 + real k) / n)}"
	+ using \<open>a<b\<close> regular_divisionE by meson
	+ show "K \<subseteq> {a..b}"
	+ using K Union_regular_division \<open>n>0\<close> by (metis Union_upper \<section>)
	+ show "K \<noteq> {}"
	+ using K by (auto simp: regular_division_def segment_nonempty segments_def)
	+ show "\<exists>a b. K = cbox a b"
	+ by (metis K \<open>a<b\<close> box_real(2) regular_divisionE)
	+ fix K'
	+ assume K': "K' \<in> regular_division a b n" and "K \<noteq> K'"
	+ then obtain k' where Keq': "K' = {a + (b-a)(k'/n) .. a + (b-a)((1 + real k') / n)}"
	+ using K \<open>a<b\<close> regular_divisionE by meson
	+ consider "1 + real k \<le> k'" \| "1 + real k' \<le> k"
	+ using Keq Keq' \<open>K \<noteq> K'\<close> by force
	+ then show "interior K \<inter> interior K' = {}"
	+ proof cases
	+ case 1
	+ then show ?thesis
	+ by (simp add: Keq Keq' min_def max_def divide_right_mono assms)
	+ next
	+ case 2
	+ then have "interior K' \<inter> interior K = {}"
	+ by (simp add: Keq Keq' min_def max_def divide_right_mono assms)
	+ then show ?thesis
	+ by (simp add: inf_commute)
	+ qed
	+qed
	+
	+subsection \<open>Special cases of Young's inequality\<close>
	+
	+lemma weighted_nesting_sum:
	+ fixes g :: "nat \<Rightarrow> 'a::comm_ring_1"
	+ shows "(\<Sum>k<n. (1 + of_nat k) * (g (Suc k) - g k)) = of_nat n * g n - (\<Sum>i<n. g i)"
	+ by (induction n) (auto simp: algebra_simps)
	+
	+theorem Youngs_exact:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes sm: "strict_mono_on f {0..}" and cont: "continuous_on {0..} f" and a: "a\<ge>0"
	+ and f: "f 0 = 0" "f a = b"
	+ and g: "\<And>x. \<lbrakk>0 \<le> x; x \<le> a\<rbrakk> \<Longrightarrow> g (f x) = x"
	+ shows "a*b = integral {0..a} f + integral {0..b} g"
	+proof (cases "a=0")
	+ case False
	+ with \<open>a \<ge> 0\<close> have "a > 0" by linarith
	+ then have "b \<ge> 0"
	+ by (smt (verit, best) atLeast_iff f sm strict_mono_onD)
	+ have sm_0a: "strict_mono_on f {0..a}"
	+ by (metis atLeastAtMost_iff atLeast_iff sm strict_mono_on_def)
	+ have cont_0a: "continuous_on {0..a} f"
	+ using cont continuous_on_subset by fastforce
	+ with sm_0a have "continuous_on {0..b} g"
	+ by (metis a atLeastAtMost_iff compact_Icc continuous_on_inv f g strict_mono_image_endpoints)
	+ then have intgb_g: "g integrable_on {0..b}"
	+ using integrable_continuous_interval by blast
	+ have intgb_f: "f integrable_on {0..a}"
	+ using cont_0a integrable_continuous_real by blast
	+
	+ have f_iff [simp]: "f x < f y \<longleftrightarrow> x < y" "f x \<le> f y \<longleftrightarrow> x \<le> y"
	+ if "x \<ge> 0" "y \<ge> 0" for x y
	+ using that by (smt (verit, best) atLeast_iff sm strict_mono_onD)+
	+ have fim: "f ` {0..a} = {0..b}"
	+ by (simp add: \<open>a \<ge> 0\<close> cont_0a strict_mono_image_endpoints strict_mono_on_def f)
	+ have "uniformly_continuous_on {0..a} f"
	+ using compact_uniformly_continuous cont_0a by blast
	+ then obtain del where del_gt0: "\<And>e. e>0 \<Longrightarrow> del e > 0"
	+ and del: "\<And>e x x'. \<lbrakk>\<bar>x'-x\<bar> < del e; e>0; x \<in> {0..a}; x' \<in> {0..a}\<rbrakk> \<Longrightarrow> \<bar>f x' - f x\<bar> < e"
	+ unfolding uniformly_continuous_on_def dist_real_def by metis
	+
	+ have : "\<bar>a b - integral {0..a} f - integral {0..b} g\<bar> < 2*\<epsilon>" if "\<epsilon> > 0" for \<epsilon>
	+ proof -
	+ define \<delta> where "\<delta> = min a (del (\<epsilon>/a)) / 2"
	+ have "\<delta> > 0" "\<delta> \<le> a"
	+ using \<open>a > 0\<close> \<open>\<epsilon> > 0\<close> del_gt0 by (auto simp: \<delta>_def)
	+ define n where "n \<equiv> nat\<lfloor>a / \<delta>\<rfloor>"
	+ define a_seg where "a_seg \<equiv> \<lambda>u::real. u * a/n"
	+ have "n > 0"
	+ using \<open>a > 0\<close> \<open>\<delta> > 0\<close> \<open>\<delta> \<le> a\<close> by (simp add: n_def)
	+ have a_seg_ge_0 [simp]: "a_seg x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
	+ and a_seg_le_a [simp]: "a_seg x \<le> a \<longleftrightarrow> x \<le> n" for x
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: a_seg_def zero_le_mult_iff divide_simps)
	+ have a_seg_le_iff [simp]: "a_seg x \<le> a_seg y \<longleftrightarrow> x \<le> y"
	+ and a_seg_less_iff [simp]: "a_seg x < a_seg y \<longleftrightarrow> x < y" for x y
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: a_seg_def zero_le_mult_iff divide_simps)
	+ have "strict_mono a_seg"
	+ by (simp add: strict_mono_def)
	+ have a_seg_eq_a_iff: "a_seg x = a \<longleftrightarrow> x=n" for x
	+ using \<open>0 < n\<close> \<open>a > 0\<close> by (simp add: a_seg_def nonzero_divide_eq_eq)
	+ have fa_eq_b: "f (a_seg n) = b"
	+ using a_seg_eq_a_iff f by fastforce
	+
	+ have "a/d < real_of_int \<lfloor>a * 2 / min a d\<rfloor>" if "d>0" for d
	+ by (smt (verit) \<open>0 < \<delta>\<close> \<open>\<delta> \<le> a\<close> add_divide_distrib divide_less_eq_1_pos floor_eq_iff that)
	+ then have an_less_del: "a/n < del (\<epsilon>/a)"
	+ using \<open>a > 0\<close> \<open>\<epsilon> > 0\<close> del_gt0 by (simp add: n_def \<delta>_def field_simps)
	+
	+ define lower where "lower \<equiv> \<lambda>x. a_seg\<lfloor>(real n * x) / a\<rfloor>"
	+ define f1 where "f1 \<equiv> f \<circ> lower"
	+ have f1_lower: "f1 x \<le> f x" if "0 \<le> x" "x \<le> a" for x
	+ proof -
	+ have "lower x \<le> x"
	+ using \<open>n > 0\<close> floor_divide_lower [OF \<open>a > 0\<close>]
	+ by (auto simp: lower_def a_seg_def field_simps)
	+ moreover have "lower x \<ge> 0"
	+ unfolding lower_def using \<open>n > 0\<close> \<open>a \<ge> 0\<close> \<open>0 \<le> x\<close> by force
	+ ultimately show ?thesis
	+ using sm strict_mono_on_leD by (fastforce simp add: f1_def)
	+ qed
	+ define upper where "upper \<equiv> \<lambda>x. a_seg\<lceil>real n * x / a\<rceil>"
	+ define f2 where "f2 \<equiv> f \<circ> upper"
	+ have f2_upper: "f2 x \<ge> f x" if "0 \<le> x" "x \<le> a" for x
	+ proof -
	+ have "x \<le> upper x"
	+ using \<open>n > 0\<close> ceiling_divide_upper [OF \<open>a > 0\<close>] by (simp add: upper_def a_seg_def field_simps)
	+ then show ?thesis
	+ using sm strict_mono_on_leD \<open>0 \<le> x\<close> by (force simp: f2_def)
	+ qed
	+ let ?\<D> = "regular_division 0 a n"
	+ have div: "?\<D> division_of {0..a}"
	+ using \<open>a > 0\<close> \<open>n > 0\<close> regular_division_division_of zero_less_nat_eq by presburger
	+
	+ have int_f1_D: "(f1 has_integral f(Inf K) * (a/n)) K"
	+ and int_f2_D: "(f2 has_integral f(Sup K) * (a/n)) K" and less: "\<bar>f(Sup K) - f(Inf K)\<bar> < \<epsilon>/a"
	+ if "K\<in>?\<D>" for K
	+ proof -
	+ from regular_divisionE [OF that] \<open>a > 0\<close>
	+ obtain k where "k<n" and k: "K = {a_seg(real k)..a_seg(Suc k)}"
	+ by (auto simp: a_seg_def mult.commute)
	+ define u where "u \<equiv> a_seg k"
	+ define v where "v \<equiv> a_seg (Suc k)"
	+ have "u < v" "0 \<le> u" "0 \<le> v" "u \<le> a" "v \<le> a" and Kuv: "K = {u..v}"
	+ using \<open>n > 0\<close> \<open>k < n\<close> \<open>a > 0\<close> by (auto simp: k u_def v_def divide_simps)
	+ have InfK: "Inf K = u" and SupK: "Sup K = v"
	+ using Kuv \<open>u < v\<close> apply force
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: divide_right_mono k u_def v_def)
	+ have f1: "f1 x = f (Inf K)" if "x \<in> K - {v}" for x
	+ proof -
	+ have "x \<in> {u..<v}"
	+ using that Kuv atLeastLessThan_eq_atLeastAtMost_diff by blast
	+ then have "\<lfloor>real_of_int n * x / a\<rfloor> = int k"
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: field_simps u_def v_def a_seg_def floor_eq_iff)
	+ then show ?thesis
	+ by (simp add: InfK f1_def lower_def a_seg_def mult.commute u_def)
	+ qed
	+ have "((\<lambda>x. f (Inf K)) has_integral (f (Inf K) * (a/n))) K"
	+ using has_integral_const_real [of "f (Inf K)" u v]
	+ \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: Kuv field_simps a_seg_def u_def v_def)
	+ then show "(f1 has_integral (f (Inf K) * (a/n))) K"
	+ using has_integral_spike_finite_eq [of "{v}" K "\<lambda>x. f (Inf K)" f1] f1 by simp
	+ have f2: "f2 x = f (Sup K)" if "x \<in> K - {u}" for x
	+ proof -
	+ have "x \<in> {u<..v}"
	+ using that Kuv greaterThanAtMost_eq_atLeastAtMost_diff by blast
	+ then have "\<lceil>x * real_of_int n / a\<rceil> = 1 + int k"
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: field_simps u_def v_def a_seg_def ceiling_eq_iff)
	+ then show ?thesis
	+ by (simp add: mult.commute f2_def upper_def a_seg_def SupK v_def)
	+ qed
	+ have "((\<lambda>x. f (Sup K)) has_integral (f (Sup K) * (a/n))) K"
	+ using \<open>n > 0\<close> \<open>a > 0\<close> has_integral_const_real [of "f (Sup K)" u v]
	+ by (simp add: Kuv field_simps u_def v_def a_seg_def)
	+ then show "(f2 has_integral (f (Sup K) * (a/n))) K"
	+ using has_integral_spike_finite_eq [of "{u}" K "\<lambda>x. f (Sup K)" f2] f2 by simp
	+ have "\<bar>v - u\<bar> < del (\<epsilon>/a)"
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: v_def u_def a_seg_def field_simps an_less_del)
	+ then have "\<bar>f v - f u\<bar> < \<epsilon>/a"
	+ using \<open>\<epsilon> > 0\<close> \<open>a > 0\<close> \<open>0 \<le> u\<close> \<open>u \<le> a\<close> \<open>0 \<le> v\<close> \<open>v \<le> a\<close>
	+ by (intro del) auto
	+ then show "\<bar>f(Sup K) - f(Inf K)\<bar> < \<epsilon>/a"
	+ using InfK SupK by blast
	+ qed
	+
	+ have int_21_D: "((\<lambda>x. f2 x - f1 x) has_integral (f(Sup K) - f(Inf K)) * (a/n)) K" if "K\<in>?\<D>" for K
	+ using that has_integral_diff [OF int_f2_D int_f1_D] by (simp add: algebra_simps)
	+
	+ have D_ne: "?\<D> \<noteq> {}"
	+ by (metis \<open>0 < a\<close> \<open>n > 0\<close> card_gt_0_iff card_regular_division)
	+ have f12: "((\<lambda>x. f2 x - f1 x) has_integral (\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n))) {0..a}"
	+ by (intro div int_21_D has_integral_combine_division)
	+ moreover have "(\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n)) < \<epsilon>"
	+ proof -
	+ have "(\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n)) \<le> (\<Sum>K\<in>?\<D>. \<bar>f(Sup K) - f(Inf K)\<bar> * (a/n))"
	+ using \<open>n > 0\<close> \<open>a > 0\<close>
	+ by (smt (verit) divide_pos_pos of_nat_0_less_iff sum_mono zero_le_mult_iff)
	+ also have "\<dots> < (\<Sum>K\<in>?\<D>. \<epsilon>/n)"
	+ using \<open>n > 0\<close> \<open>a > 0\<close> less
	+ by (intro sum_strict_mono finite_regular_division D_ne) (simp add: field_simps)
	+ also have "\<dots> = \<epsilon>"
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by simp
	+ finally show ?thesis .
	+ qed
	+ ultimately have f2_near_f1: "integral {0..a} (\<lambda>x. f2 x - f1 x) < \<epsilon>"
	+ by (simp add: integral_unique)
	+
	+ define yidx where "yidx \<equiv> \<lambda>y. LEAST k. y < f (a_seg (Suc k))"
	+ have fa_yidx_le: "f (a_seg (yidx y)) \<le> y" and yidx_gt: "y < f (a_seg (Suc (yidx y)))"
	+ if "y \<in> {0..b}" for y
	+ proof -
	+ obtain x where x: "f x = y" "x \<in> {0..a}"
	+ using Topological_Spaces.IVT' [OF _ _ _ cont_0a] assms
	+ by (metis \<open>y \<in> {0..b}\<close> atLeastAtMost_iff)
	+ define k where "k \<equiv> nat \<lfloor>x/a * n\<rfloor>"
	+ have x_lims: "a_seg k \<le> x" "x < a_seg (Suc k)"
	+ using \<open>n > 0\<close> \<open>0 < a\<close> floor_divide_lower floor_divide_upper [of a "x*n"] x
	+ by (auto simp: k_def a_seg_def field_simps)
	+ with that x obtain f_lims: "f (a_seg k) \<le> y" "y < f (a_seg (Suc k))"
	+ using strict_mono_onD [OF sm] by force
	+ then have "a_seg (yidx y) \<le> a_seg k"
	+ by (simp add: Least_le \<open>strict_mono a_seg\<close> strict_mono_less_eq yidx_def)
	+ then have "f (a_seg (yidx y)) \<le> f (a_seg k)"
	+ using strict_mono_onD [OF sm] by simp
	+ then show "f (a_seg (yidx y)) \<le> y"
	+ using f_lims by linarith
	+ show "y < f (a_seg (Suc (yidx y)))"
	+ by (metis LeastI f_lims(2) yidx_def)
	+ qed
	+
	+ have yidx_equality: "yidx y = k" if "y \<in> {0..b}" "y \<in> {f (a_seg k)..<f (a_seg (Suc k))}" for y k
	+ proof (rule antisym)
	+ show "yidx y \<le> k"
	+ unfolding yidx_def by (metis atLeastLessThan_iff that(2) Least_le)
	+ have "(a_seg (real k)) < a_seg (1 + real (yidx y))"
	+ using yidx_gt [OF that(1)] that(2) strict_mono_onD [OF sm] order_le_less_trans by fastforce
	+ then have "real k < 1 + real (yidx y)"
	+ by (simp add: \<open>strict_mono a_seg\<close> strict_mono_less)
	+ then show "k \<le> yidx y"
	+ by simp
	+ qed
	+ have "yidx b = n"
	+ proof -
	+ have "a < (1 + real n) * a / real n"
	+ using \<open>0 < n\<close> \<open>0 < a\<close> by (simp add: divide_simps)
	+ then have "b < f (a_seg (1 + real n))"
	+ using f \<open>a \<ge> 0\<close> a_seg_def sm strict_mono_onD by fastforce
	+ then show ?thesis
	+ using \<open>0 \<le> b\<close> by (auto simp: f a_seg_def yidx_equality)
	+ qed
	+ moreover have yidx_less_n: "yidx y < n" if "y < b" for y
	+ by (metis \<open>0 < n\<close> fa_eq_b gr0_conv_Suc less_Suc_eq_le that Least_le yidx_def)
	+ ultimately have yidx_le_n: "yidx y \<le> n" if "y \<le> b" for y
	+ by (metis dual_order.order_iff_strict that)
	+
	+ have zero_to_b_eq: "{0..b} = (\<Union>k<n. {f(a_seg k)..f(a_seg (Suc k))})" (is "?lhs = ?rhs")
	+ proof
	+ show "?lhs \<subseteq> ?rhs"
	+ proof
	+ fix y assume y: "y \<in> {0..b}"
	+ have fn: "f (a_seg n) = b"
	+ using a_seg_eq_a_iff \<open>f a = b\<close> by fastforce
	+ show "y \<in> ?rhs"
	+ proof (cases "y=b")
	+ case True
	+ with fn \<open>n>0\<close> show ?thesis
	+ by (rule_tac a="n-1" in UN_I) auto
	+ next
	+ case False
	+ with y show ?thesis
	+ apply (simp add: subset_iff Bex_def)
	+ by (metis atLeastAtMost_iff of_nat_Suc order_le_less yidx_gt fa_yidx_le yidx_less_n)
	+ qed
	+ qed
	+ show "?rhs \<subseteq> ?lhs"
	+ apply clarsimp
	+ by (smt (verit, best) a_seg_ge_0 a_seg_le_a f f_iff(2) nat_less_real_le of_nat_0_le_iff)
	+ qed
	+
	+ define g1 where "g1 \<equiv> \<lambda>y. if y=b then a else a_seg (Suc (yidx y))"
	+ define g2 where "g2 \<equiv> \<lambda>y. if y=0 then 0 else a_seg (yidx y)"
	+ have g1: "g1 y \<in> {0..a}" if "y \<in> {0..b}" for y
	+ using that \<open>a > 0\<close> yidx_less_n [of y] by (auto simp: g1_def a_seg_def divide_simps)
	+ have g2: "g2 y \<in> {0..a}" if "y \<in> {0..b}" for y
	+ using that \<open>a > 0\<close> yidx_le_n [of y] by (simp add: g2_def a_seg_def divide_simps)
	+
	+ have g2_le_g: "g2 y \<le> g y" if "y \<in> {0..b}" for y
	+ proof -
	+ have "f (g2 y) \<le> y"
	+ using \<open>f 0 = 0\<close> g2_def that fa_yidx_le by presburger
	+ then have "f (g2 y) \<le> f (g y)"
	+ using that g by (smt (verit, best) atLeastAtMost_iff fim image_iff)
	+ then show ?thesis
	+ by (smt (verit, best) atLeastAtMost_iff fim g g2 imageE sm_0a strict_mono_onD that)
	+ qed
	+ have g_le_g1: "g y \<le> g1 y" if "y \<in> {0..b}" for y
	+ proof -
	+ have "y \<le> f (g1 y)"
	+ by (smt (verit, best) \<open>f a = b\<close> g1_def that yidx_gt)
	+ then have "f (g y) \<le> f (g1 y)"
	+ using that g by (smt (verit, best) atLeastAtMost_iff fim image_iff)
	+ then show ?thesis
	+ by (smt (verit, ccfv_threshold) atLeastAtMost_iff f_iff(1) g1 that)
	+ qed
	+
	+ define DN where "DN \<equiv> \<lambda>K. nat \<lfloor>Inf K * real n / a\<rfloor>"
	+ have [simp]: "DN {a * real k / n..a * (1 + real k) / n} = k" for k
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: DN_def divide_simps)
	+ have DN: "bij_betw DN ?\<D> {..<n}"
	+ proof (intro bij_betw_imageI)
	+ show "inj_on DN (regular_division 0 a n)"
	+ proof
	+ fix K K'
	+ assume "K \<in> regular_division 0 a n"
	+ with \<open>a > 0\<close> obtain k where k: "K = {a * (real k / n) .. a * (1 + real k) / n}"
	+ by (force elim: regular_divisionE)
	+ assume "K' \<in> regular_division 0 a n"
	+ with \<open>a > 0\<close> obtain k' where k': "K' = {a * (real k' / n) .. a * (1 + real k') / n}"
	+ by (force elim: regular_divisionE)
	+ assume "DN K = DN K'"
	+ then show "K = K'" by (simp add: k k')
	+ qed
	+ have "\<exists>K\<in>regular_division 0 a n. k = nat \<lfloor>Inf K * real n / a\<rfloor>" if "k < n" for k
	+ using \<open>n > 0\<close> \<open>a > 0\<close> that
	+ by (force simp: divide_simps intro: regular_division_eqI [OF refl])
	+ with \<open>a>0\<close> show "DN ` regular_division 0 a n = {..<n}"
	+ by (auto simp: DN_def bij_betw_def image_iff frac_le elim!: regular_divisionE)
	+ qed
	+
	+ have int_f1: "(f1 has_integral (\<Sum>k<n. f(a_seg k)) * (a/n)) {0..a}"
	+ proof -
	+ have "a_seg (real (DN K)) = Inf K" if "K \<in> ?\<D>" for K
	+ using that \<open>a>0\<close> by (auto simp: DN_def field_simps a_seg_def elim: regular_divisionE)
	+ then have "(\<Sum>K\<in>?\<D>. f(Inf K) * (a/n)) = (\<Sum>k<n. (f(a_seg k)) * (a/n))"
	+ by (simp flip: sum.reindex_bij_betw [OF DN])
	+ moreover have "(f1 has_integral (\<Sum>K\<in>?\<D>. f(Inf K) * (a/n))) {0..a}"
	+ by (intro div int_f1_D has_integral_combine_division)
	+ ultimately show ?thesis
	+ by (metis sum_distrib_right)
	+ qed
	+ text \<open>The claim @{term "(f2 has_integral (\<Sum>k<n. f(a_seg(Suc k))) * (a/n)) {0..a}"} can similarly be proved\<close>
	+
	+ have int_g1_D: "(g1 has_integral a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))
	+ {f(a_seg k)..f(a_seg (Suc k))}"
	+ and int_g2_D: "(g2 has_integral a_seg k * (f (a_seg (Suc k)) - f (a_seg k)))
	+ {f(a_seg k)..f(a_seg (Suc k))}"
	+ if "k < n" for k
	+ proof -
	+ define u where "u \<equiv> f (a_seg k)"
	+ define v where "v \<equiv> f (a_seg (Suc k))"
	+ obtain "u < v" "0 \<le> u" "0 \<le> v"
	+ unfolding u_def v_def assms
	+ by (smt (verit, best) a_seg_ge_0 a_seg_le_iff f(1) f_iff(1) of_nat_0_le_iff of_nat_Suc)
	+ have "u \<le> b" "v \<le> b"
	+ using \<open>k < n\<close> \<open>a \<ge> 0\<close> by (simp_all add: u_def v_def flip: \<open>f a = b\<close>)
	+ have yidx_eq: "yidx x = k" if "x \<in> {u..<v}" for x
	+ using \<open>0 \<le> u\<close> \<open>v \<le> b\<close> that u_def v_def yidx_equality by auto
	+
	+ have "g1 x = a_seg (Suc k)" if "x \<in> {u..<v}" for x
	+ using that \<open>v \<le> b\<close> by (simp add: g1_def yidx_eq)
	+ moreover have "((\<lambda>x. a_seg (Suc k)) has_integral (a_seg (Suc k) * (v-u))) {u..v}"
	+ using has_integral_const_real \<open>u < v\<close>
	+ by (metis content_real_if less_eq_real_def mult.commute real_scaleR_def)
	+ ultimately show "(g1 has_integral (a_seg (Suc k) * (v-u))) {u..v}"
	+ using has_integral_spike_finite_eq [of "{v}" "{u..v}" "\<lambda>x. a_seg (Suc k)" g1] by simp
	+
	+ have g2: "g2 x = a_seg k" if "x \<in> {u<..<v}" for x
	+ using that \<open>0 \<le> u\<close> by (simp add: g2_def yidx_eq)
	+ moreover have "((\<lambda>x. a_seg k) has_integral (a_seg k * (v-u))) {u..v}"
	+ using has_integral_const_real \<open>u < v\<close>
	+ by (metis content_real_if less_eq_real_def mult.commute real_scaleR_def)
	+ ultimately show "(g2 has_integral (a_seg k * (v-u))) {u..v}"
	+ using has_integral_spike_finite_eq [of "{u,v}" "{u..v}" "\<lambda>x. a_seg k" g2] by simp
	+ qed
	+
	+ have int_g1: "(g1 has_integral (\<Sum>k<n. a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))) {0..b}"
	+ and int_g2: "(g2 has_integral (\<Sum>k<n. a_seg k * (f (a_seg (Suc k)) - f (a_seg k)))) {0..b}"
	+ unfolding zero_to_b_eq using int_g1_D int_g2_D
	+ by (auto simp: min_def pairwise_def intro!: has_integral_UN negligible_atLeastAtMostI)
	+
	+ have "(\<Sum>k<n. a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))
	+ = (\<Sum>k<n. (Suc k) * (f (a_seg (Suc k)) - f (a_seg k))) * (a/n)"
	+ unfolding a_seg_def sum_distrib_right sum_divide_distrib by (simp add: mult_ac)
	+ also have "\<dots> = (n * f (a_seg n) - (\<Sum>k<n. f (a_seg k))) * a / n"
	+ using weighted_nesting_sum [where g = "f o a_seg"] by simp
	+ also have "\<dots> = a * b - (\<Sum>k<n. f (a_seg k)) * a / n"
	+ using \<open>n > 0\<close> by (simp add: fa_eq_b field_simps)
	+ finally have int_g1': "(g1 has_integral a * b - (\<Sum>k<n. f (a_seg k)) * a / n) {0..b}"
	+ using int_g1 by simp
	+ text \<open>The claim @{term "(g2 has_integral a * b - (\<Sum>k<n. f (a_seg (Suc k))) * a / n) {0..b}"} can similarly be proved.\<close>
	+
	+ have a_seg_diff: "a_seg (Suc k) - a_seg k = a/n" for k
	+ by (simp add: a_seg_def field_split_simps)
	+ have f_a_seg_diff: "\<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> < \<epsilon>/a" if "k<n" for k
	+ using that \<open>a > 0\<close> a_seg_diff an_less_del \<open>\<epsilon> > 0\<close>
	+ by (intro del) auto
	+
	+ have "((\<lambda>x. g1 x - g2 x) has_integral (\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n))) {0..b}"
	+ using has_integral_diff [OF int_g1 int_g2] a_seg_diff
	+ apply (simp flip: sum_subtractf left_diff_distrib)
	+ apply (simp add: field_simps)
	+ done
	+ moreover have "(\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n)) < \<epsilon>"
	+ proof -
	+ have "(\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n))
	+ \<le> (\<Sum>k<n. \<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> * (a/n))"
	+ by simp
	+ also have "\<dots> < (\<Sum>k<n. (\<epsilon>/a) * (a/n))"
	+ proof (rule sum_strict_mono)
	+ fix k assume "k \<in> {..<n}"
	+ with \<open>n > 0\<close> \<open>a > 0\<close> divide_strict_right_mono f_a_seg_diff pos_less_divide_eq
	+ show "\<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> * (a/n) < \<epsilon>/a * (a/n)" by fastforce
	+ qed (use \<open>n > 0\<close> in auto)
	+ also have "\<dots> = \<epsilon>"
	+ using \<open>n > 0\<close> \<open>a > 0\<close> by simp
	+ finally show ?thesis .
	+ qed
	+ ultimately have g2_near_g1: "integral {0..b} (\<lambda>x. g1 x - g2 x) < \<epsilon>"
	+ by (simp add: integral_unique)
	+
	+ have ab1: "integral {0..a} f1 + integral {0..b} g1 = a*b"
	+ using int_f1 int_g1' by (simp add: integral_unique)
	+
	+ have "integral {0..a} (\<lambda>x. f x - f1 x) \<le> integral {0..a} (\<lambda>x. f2 x - f1 x)"
	+ proof (rule integral_le)
	+ show "(\<lambda>x. f x - f1 x) integrable_on {0..a}" "(\<lambda>x. f2 x - f1 x) integrable_on {0..a}"
	+ using Henstock_Kurzweil_Integration.integrable_diff int_f1 intgb_f f12 by blast+
	+ qed (auto simp: f2_upper)
	+ with f2_near_f1 have "integral {0..a} (\<lambda>x. f x - f1 x) < \<epsilon>"
	+ by simp
	+ moreover have "integral {0..a} f1 \<le> integral {0..a} f"
	+ by (intro integral_le has_integral_integral intgb_f has_integral_integrable [OF int_f1])
	+ (simp add: f1_lower)
	+ ultimately have f_error: "\<bar>integral {0..a} f - integral {0..a} f1\<bar> < \<epsilon>"
	+ using Henstock_Kurzweil_Integration.integral_diff int_f1 intgb_f by fastforce
	+
	+ have "integral {0..b} (\<lambda>x. g1 x - g x) \<le> integral {0..b} (\<lambda>x. g1 x - g2 x)"
	+ proof (rule integral_le)
	+ show "(\<lambda>x. g1 x - g x) integrable_on {0..b}" "(\<lambda>x. g1 x - g2 x) integrable_on {0..b}"
	+ using Henstock_Kurzweil_Integration.integrable_diff int_g1 int_g2 intgb_g by blast+
	+ qed (auto simp: g2_le_g)
	+ with g2_near_g1 have "integral {0..b} (\<lambda>x. g1 x - g x) < \<epsilon>"
	+ by simp
	+ moreover have "integral {0..b} g \<le> integral {0..b} g1"
	+ by (intro integral_le has_integral_integral intgb_g has_integral_integrable [OF int_g1])
	+ (simp add: g_le_g1)
	+ ultimately have g_error: "\<bar>integral {0..b} g1 - integral {0..b} g\<bar> < \<epsilon>"
	+ using integral_diff int_g1 intgb_g by fastforce
	+ show ?thesis
	+ using f_error g_error ab1 by linarith
	+ qed
	+ show ?thesis
	+ using * [of "\<bar>a * b - integral {0..a} f - integral {0..b} g\<bar> / 2"] by fastforce
	+qed (use assms in force)
	+
	+
	+
	+corollary Youngs_strict:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes sm: "strict_mono_on f {0..}" and cont: "continuous_on {0..} f" and "a>0" "b\<ge>0"
	+ and f: "f 0 = 0" "f a \<noteq> b" and fim: "f ` {0..} = {0..}"
	+ and g: "\<And>x. 0 \<le> x \<Longrightarrow> g (f x) = x"
	+ shows "a*b < integral {0..a} f + integral {0..b} g"
	+proof -
	+ have f_iff [simp]: "f x < f y \<longleftrightarrow> x < y" "f x \<le> f y \<longleftrightarrow> x \<le> y"
	+ if "x \<ge> 0" "y \<ge> 0" for x y
	+ using that by (smt (verit, best) atLeast_iff sm strict_mono_onD)+
	+ let ?b' = "f a"
	+ have "?b' \<ge> 0"
	+ by (smt (verit, best) \<open>0 < a\<close> atLeast_iff f sm strict_mono_onD)
	+ then have sm_gx: "strict_mono_on g {0..}"
	+ unfolding strict_mono_on_def
	+ by (smt (verit, best) atLeast_iff f_iff(1) f_inv_into_f fim g inv_into_into)
	+ show ?thesis
	+ proof (cases "?b' < b")
	+ case True
	+ have gt_a: "a < g y" if "y \<in> {?b'<..b}" for y
	+ proof -
	+ have "a = g ?b'"
	+ using \<open>a > 0\<close> g by force
	+ also have "\<dots> < g y"
	+ using \<open>0 \<le> ?b'\<close> sm_gx strict_mono_onD that by fastforce
	+ finally show ?thesis .
	+ qed
	+ have "continuous_on {0..} g"
	+ by (metis cont f(1) fim g sm strict_mono_continuous_invD)
	+ then have contg: "continuous_on {?b'..b} g"
	+ by (meson Icc_subset_Ici_iff \<open>0 \<le> f a\<close> continuous_on_subset)
	+ have "mono_on g {0..}"
	+ by (simp add: sm_gx strict_mono_on_imp_mono_on)
	+ then have int_g0b: "g integrable_on {0..b}"
	+ by (simp add: integrable_on_mono_on mono_on_subset)
	+ then have int_gb'b: "g integrable_on {?b'..b}"
	+ by (simp add: \<open>0 \<le> ?b'\<close> integrable_on_subinterval)
	+ have "a * (b - ?b') = integral {?b'..b} (\<lambda>y. a)"
	+ using True by force
	+ also have "\<dots> < integral {?b'..b} g"
	+ using contg True gt_a by (intro integral_less_real) auto
	+ finally have : "a (b - ?b') < integral {?b'..b} g" .
	+ have "ab = a ?b' + a * (b - ?b')"
	+ by (simp add: algebra_simps)
	+ also have "\<dots> = integral {0..a} f + integral {0..?b'} g + a * (b - ?b')"
	+ using Youngs_exact \<open>a > 0\<close> cont \<open>f 0 = 0\<close> g sm by force
	+ also have "\<dots> < integral {0..a} f + integral {0..?b'} g + integral {?b'..b} g"
	+ by (simp add: *)
	+ also have "\<dots> = integral {0..a} f + integral {0..b} g"
	+ by (smt (verit) Henstock_Kurzweil_Integration.integral_combine True \<open>0 \<le> ?b'\<close> int_g0b)
	+ finally show ?thesis .
	+ next
	+ case False
	+ with f have "b < ?b'" by force
	+ obtain a' where "f a' = b" "a' \<ge> 0"
	+ using fim \<open>b \<ge> 0\<close> by force
	+ then have "a' < a"
	+ using \<open>b < f a\<close> \<open>a > 0\<close> by force
	+ have gt_b: "b < f x" if "x \<in> {a'<..a}" for x
	+ using \<open>0 \<le> a'\<close> \<open>f a' = b\<close> that by fastforce
	+ have int_f0a: "f integrable_on {0..a}"
	+ by (simp add: integrable_on_mono_on mono_on_def)
	+ then have int_fa'a: "f integrable_on {a'..a}"
	+ by (simp add: \<open>0 \<le> a'\<close> integrable_on_subinterval)
	+ have cont_f': "continuous_on {a'..a} f"
	+ by (meson Icc_subset_Ici_iff \<open>0 \<le> a'\<close> cont continuous_on_subset)
	+ have "b * (a - a') = integral {a'..a} (\<lambda>x. b)"
	+ using \<open>a' < a\<close> by simp
	+ also have "\<dots> < integral {a'..a} f"
	+ using cont_f' \<open>a' < a\<close> gt_b by (intro integral_less_real) auto
	+ finally have : "b (a - a') < integral {a'..a} f" .
	+ have "ab = a' b + b * (a - a')"
	+ by (simp add: algebra_simps)
	+ also have "\<dots> = integral {0..a'} f + integral {0..b} g + b * (a - a')"
	+ by (simp add: Youngs_exact \<open>0 \<le> a'\<close> \<open>f a' = b\<close> cont f g sm)
	+ also have "\<dots> < integral {0..a'} f + integral {0..b} g + integral {a'..a} f"
	+ by (simp add: *)
	+ also have "\<dots> = integral {0..a} f + integral {0..b} g"
	+ by (smt (verit) Henstock_Kurzweil_Integration.integral_combine \<open>0 \<le> a'\<close> \<open>a' < a\<close> int_f0a)
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+corollary Youngs_inequality:
	+ fixes f :: "real \<Rightarrow> real"
	+ assumes sm: "strict_mono_on f {0..}" and cont: "continuous_on {0..} f" and "a\<ge>0" "b\<ge>0"
	+ and f: "f 0 = 0" and fim: "f ` {0..} = {0..}"
	+ and g: "\<And>x. 0 \<le> x \<Longrightarrow> g (f x) = x"
	+ shows "a*b \<le> integral {0..a} f + integral {0..b} g"
	+proof (cases "a=0")
	+ case True
	+ have "g x \<ge> 0" if "x \<ge> 0" for x
	+ by (metis atLeast_iff fim g imageE that)
	+ then have "0 \<le> integral {0..b} g"
	+ by (metis Henstock_Kurzweil_Integration.integral_nonneg atLeastAtMost_iff
	+ not_integrable_integral order_refl)
	+ then show ?thesis
	+ by (simp add: True)
	+next
	+ case False
	+ then show ?thesis
	+ by (smt (verit) assms Youngs_exact Youngs_strict)
	+qed
	+
	+end
	diff --git a/thys/Youngs_Inequality/document/root.bib b/thys/Youngs_Inequality/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Youngs_Inequality/document/root.bib
	@@ -0,0 +1,35 @@
	+%% This BibTeX bibliography file was created using BibDesk.
	+%% http://bibdesk.sourceforge.net/
	+
	+
	+%% Created for Larry Paulson at 2022-01-28 15:00:12 +0000
	+
	+
	+%% Saved with string encoding Unicode (UTF-8)
	+
	+
	+
	+@article{cunningham-youngs,
	+ author = {F. Cunningham and Nathaniel Grossman},
	+ date-added = {2022-01-28 14:56:42 +0000},
	+ date-modified = {2022-01-28 15:00:12 +0000},
	+ issn = {00029890, 19300972},
	+ journal = {The American Mathematical Monthly},
	+ number = {7},
	+ pages = {781-783},
	+ publisher = {Mathematical Association of America},
	+ title = {On {Young's} Inequality},
	+ url = {http://www.jstor.org/stable/2318018},
	+ volume = {78},
	+ year = {1971},
	+ bdsk-url-1 = {http://www.jstor.org/stable/2318018}}
	+
	+@book{aigner-proofs,
	+ author = {M. Aigner and G. M. Ziegler},
	+ booktitle = {Proofs from THE BOOK},
	+ date-added = {2022-01-06 11:42:58 +0000},
	+ date-modified = {2022-01-06 13:07:25 +0000},
	+ edition = {6th},
	+ publisher = {Springer},
	+ title = {Proofs from THE BOOK},
	+ year = {2018}}
	diff --git a/thys/Youngs_Inequality/document/root.tex b/thys/Youngs_Inequality/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Youngs_Inequality/document/root.tex
	@@ -0,0 +1,43 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage[T1]{fontenc}
	+\usepackage{amsmath}
	+\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{Young's Inequality for Increasing Functions}
	+\author{Lawrence C. Paulson}
	+\maketitle
	+
	+\begin{abstract}
	+Young's inequality states that
	+$$ ab \leq \int_0^a f(x)dx + \int_0^b f^{-1}(y) dy $$
	+where $a\geq 0$, $b\geq 0$ and $f$ is strictly increasing and continuous.
	+Its proof is formalised following the development by Cunningham and Grossman~\cite{cunningham-youngs}.
	+Their idea is to make the intuitive, geometric folklore proof rigorous by reasoning about step functions.
	+The lack of the Riemann integral makes the development longer than one would like, but their argument is reproduced faithfully.
	+\end{abstract}
	+
	+\newpage
	+\tableofcontents
	+
	+\paragraph*{Acknowledgements}
	+The author was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178) funded by the European Research Council.
	+
	+\newpage
	+
	+% include generated text of all theories
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/ZFC_in_HOL/General_Cardinals.thy b/thys/ZFC_in_HOL/General_Cardinals.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/ZFC_in_HOL/General_Cardinals.thy
	@@ -0,0 +1,268 @@
	+section \<open>Mapping Arbitrary Isabelle/HOL Sets into ZFC; their Cardinalities\<close>
	+
	+theory General_Cardinals
	+ imports ZFC_Typeclasses "HOL-Analysis.Continuum_Not_Denumerable"
	+
	+begin
	+
	+subsection \<open>Making the embedding from the type class explicit\<close>
	+
	+definition V_of :: "'a::embeddable \<Rightarrow> V"
	+ where "V_of \<equiv> SOME f. inj f"
	+
	+lemma inj_V_of: "inj V_of"
	+ unfolding V_of_def by (metis embeddable_class.ex_inj some_eq_imp)
	+
	+declare inv_f_f [OF inj_V_of, simp]
	+
	+lemma inv_V_of_image_eq [simp]: "inv V_of ` (V_of ` X) = X"
	+ by (auto simp: image_comp)
	+
	+lemma infinite_V_of: "infinite (UNIV::'a set) \<Longrightarrow> infinite (range (V_of::'a::embeddable\<Rightarrow>V))"
	+ using finite_imageD inj_V_of by blast
	+
	+lemma countable_V_of: "countable (range (V_of::'a::countable\<Rightarrow>V))"
	+ by blast
	+
	+lemma elts_set_V_of: "small X \<Longrightarrow> elts (ZFC_in_HOL.set (V_of ` X)) \<approx> X"
	+ by (metis inj_V_of inj_eq inj_on_def inj_on_image_eqpoll_self replacement set_of_elts small_iff)
	+
	+lemma V_of_image_times: "V_of ` (X \<times> Y) \<approx> (V_of ` X) \<times> (V_of ` Y)"
	+proof -
	+ have "V_of ` (X \<times> Y) \<approx> X \<times> Y"
	+ by (meson inj_V_of inj_eq inj_onI inj_on_image_eqpoll_self)
	+ also have "\<dots> \<approx> (V_of ` X) \<times> (V_of ` Y)"
	+ by (metis eqpoll_sym inj_V_of inj_eq inj_onI inj_on_image_eqpoll_self times_eqpoll_cong)
	+ finally show ?thesis .
	+qed
	+
	+subsection \<open>The cardinality of the continuum\<close>
	+
	+definition "Real_set \<equiv> ZFC_in_HOL.set (range (V_of::real\<Rightarrow>V))"
	+definition "Complex_set \<equiv> ZFC_in_HOL.set (range (V_of::complex\<Rightarrow>V))"
	+definition "C_continuum \<equiv> vcard Real_set"
	+
	+lemma V_of_Real_set: "bij_betw V_of (UNIV::real set) (elts Real_set)"
	+ by (simp add: Real_set_def bij_betw_def inj_V_of)
	+
	+lemma uncountable_Real_set: "uncountable (elts Real_set)"
	+ using V_of_Real_set countable_iff_bij uncountable_UNIV_real by blast
	+
	+lemma "Card C_continuum"
	+ by (simp add: C_continuum_def Card_def)
	+
	+lemma C_continuum_ge: "C_continuum \<ge> \<aleph>1"
	+proof -
	+ have "\<not> C_continuum < \<aleph>1"
	+ proof -
	+ have "\<not> vcard Real_set \<le> \<aleph>0"
	+ using countable_iff_le_Aleph0 uncountable_Real_set by presburger
	+ then show ?thesis
	+ by (simp add: C_continuum_def lt_csucc_iff one_V_def)
	+ qed
	+ then show ?thesis
	+ by (simp add: C_continuum_def Ord_not_less)
	+qed
	+
	+
	+lemma V_of_Complex_set: "bij_betw V_of (UNIV::complex set) (elts Complex_set)"
	+ by (simp add: Complex_set_def bij_betw_def inj_V_of)
	+
	+lemma uncountable_Complex_set: "uncountable (elts Complex_set)"
	+ using V_of_Complex_set countableI_bij2 uncountable_UNIV_complex by blast
	+
	+lemma Complex_vcard: "vcard Complex_set = C_continuum"
	+proof -
	+ define emb1 where "emb1 \<equiv> V_of o complex_of_real o inv V_of"
	+ have "elts Real_set \<approx> elts Complex_set"
	+ proof (rule lepoll_antisym)
	+ show "elts Real_set \<lesssim> elts Complex_set"
	+ unfolding lepoll_def
	+ proof (intro conjI exI)
	+ show "inj_on emb1 (elts Real_set)"
	+ unfolding emb1_def Real_set_def
	+ by (simp add: inj_V_of inj_compose inj_of_real inj_on_imageI)
	+ show "emb1 ` elts Real_set \<subseteq> elts Complex_set"
	+ by (simp add: emb1_def Real_set_def Complex_set_def image_subset_iff)
	+ qed
	+ define emb2 where "emb2 \<equiv> (\<lambda>z. (V_of (Re z), V_of (Im z))) o inv V_of"
	+ have "elts Complex_set \<lesssim> elts Real_set \<times> elts Real_set"
	+ unfolding lepoll_def
	+ proof (intro conjI exI)
	+ show "inj_on emb2 (elts Complex_set)"
	+ unfolding emb2_def Complex_set_def inj_on_def
	+ by (simp add: complex.expand inj_V_of inj_eq)
	+ show "emb2 ` elts Complex_set \<subseteq> elts Real_set \<times> elts Real_set"
	+ by (simp add: emb2_def Real_set_def Complex_set_def image_subset_iff)
	+ qed
	+ also have "\<dots> \<approx> elts Real_set"
	+ by (simp add: infinite_times_eqpoll_self uncountable_Real_set uncountable_infinite)
	+ finally show "elts Complex_set \<lesssim> elts Real_set" .
	+ qed
	+ then show ?thesis
	+ by (simp add: C_continuum_def cardinal_cong)
	+qed
	+
	+subsection \<open>Cardinality of an arbitrary HOL set\<close>
	+
	+definition gcard :: "'a::embeddable set \<Rightarrow> V"
	+ where "gcard X \<equiv> vcard (ZFC_in_HOL.set (V_of ` X))"
	+
	+lemma gcard_big_0: "\<not> small X \<Longrightarrow> gcard X = 0"
	+ by (metis elts_eq_empty_iff elts_of_set gcard_def inv_V_of_image_eq replacement vcard_0)
	+
	+lemma gcard_empty_0 [simp]: "gcard {} = 0"
	+ by (metis gcard_def image_is_empty vcard_0 zero_V_def)
	+
	+lemma gcard_single_1 [simp]: "gcard {x} = 1"
	+ by (simp add: gcard_def)
	+
	+lemma gcard_finite_set: "\<lbrakk>finite X; a \<notin> X\<rbrakk> \<Longrightarrow> gcard (insert a X) = succ (gcard X)"
	+ by (simp add: gcard_def inj_V_of inj_image_mem_iff finite_csucc vcard_finite_set)
	+
	+lemma gcard_eq_card: "finite X \<Longrightarrow> gcard X = ord_of_nat (card X)"
	+ by (induction X rule: finite_induct) (auto simp add: gcard_finite_set)
	+
	+lemma Card_gcard [iff]: "Card (gcard X)"
	+ by (simp add: Card_def gcard_def)
	+
	+lemma gcard_eq_vcard [simp]: "gcard (elts x) = vcard x"
	+ by (metis cardinal_cong elts_set_V_of gcard_def small_elts)
	+
	+lemma gcard_eqpoll: "small X \<Longrightarrow> elts (gcard X) \<approx> X"
	+ by (metis cardinal_eqpoll elts_set_V_of eqpoll_trans gcard_def)
	+
	+lemma gcard_image_le:
	+ assumes "small A"
	+ shows "gcard (f ` A) \<le> gcard A"
	+proof -
	+ have "(V_of ` f ` A) \<lesssim> (V_of ` A)"
	+ by (metis image_lepoll inv_V_of_image_eq lepoll_trans)
	+ then show ?thesis
	+ by (simp add: assms gcard_def lepoll_imp_Card_le)
	+qed
	+
	+lemma gcard_image: "inj_on f A \<Longrightarrow> gcard (f ` A) = gcard A"
	+ by (metis dual_order.antisym gcard_big_0 gcard_image_le small_image_iff the_inv_into_onto)
	+
	+lemma lepoll_imp_gcard_le:
	+ assumes "A \<lesssim> B" "small B"
	+ shows "gcard A \<le> gcard B"
	+proof -
	+ have "elts (ZFC_in_HOL.set (V_of ` A)) \<approx> A" "elts (ZFC_in_HOL.set (V_of ` B)) \<approx> B"
	+ by (meson assms elts_set_V_of lepoll_small)+
	+ with \<open>A \<lesssim> B\<close> show ?thesis
	+ unfolding gcard_def
	+ by (meson lepoll_imp_Card_le eqpoll_sym lepoll_iff_leqpoll lepoll_trans)
	+qed
	+
	+lemma subset_imp_gcard_le:
	+ assumes "A \<subseteq> B" "small B"
	+ shows "gcard A \<le> gcard B"
	+ by (simp add: assms lepoll_imp_gcard_le subset_imp_lepoll)
	+
	+lemma gcard_le_lepoll: "\<lbrakk>gcard A \<le> \<alpha>; small A\<rbrakk> \<Longrightarrow> A \<lesssim> elts \<alpha>"
	+ by (meson eqpoll_sym gcard_eqpoll lepoll_trans1 less_eq_V_def subset_imp_lepoll)
	+
	+lemma gcard_Union_le_cmult:
	+ assumes "small U" and \<kappa>: "\<And>x. x \<in> U \<Longrightarrow> gcard x \<le> \<kappa>" and sm: "\<And>x. x \<in> U \<Longrightarrow> small x"
	+ shows "gcard (\<Union>U) \<le> gcard U \<otimes> \<kappa>"
	+proof -
	+ have "\<exists>f. f \<in> x \<rightarrow> elts \<kappa> \<and> inj_on f x" if "x \<in> U" for x
	+ using \<kappa> [OF that] gcard_le_lepoll by (smt (verit) Pi_iff TC_small imageI lepoll_def subset_eq)
	+ then obtain \<phi> where \<phi>: "\<And>x. x \<in> U \<Longrightarrow> (\<phi> x) \<in> x \<rightarrow> elts \<kappa> \<and> inj_on (\<phi> x) x"
	+ by metis
	+ define u where "u \<equiv> \<lambda>y. @x. x \<in> U \<and> y \<in> x"
	+ have u: "u y \<in> U \<and> y \<in> (u y)" if "y \<in> \<Union>( U)" for y
	+ unfolding u_def using that by (fast intro!: someI2)
	+ define \<psi> where "\<psi> \<equiv> \<lambda>y. (u y, \<phi> (u y) y)"
	+ have U: "elts (gcard U) \<approx> U"
	+ by (simp add: gcard_eqpoll)
	+ have "\<Union>U \<lesssim> U \<times> elts \<kappa>"
	+ unfolding lepoll_def
	+ proof (intro exI conjI)
	+ show "inj_on \<psi> (\<Union> U)"
	+ using \<phi> u by (smt (verit) \<psi>_def inj_on_def prod.inject)
	+ show "\<psi> ` \<Union> U \<subseteq> U \<times> elts \<kappa>"
	+ using \<phi> u by (auto simp: \<psi>_def)
	+ qed
	+ also have "\<dots> \<approx> elts (gcard U \<otimes> \<kappa>)"
	+ using U elts_cmult eqpoll_sym eqpoll_trans times_eqpoll_cong by blast
	+ finally have " (\<Union>U) \<lesssim> elts (gcard U \<otimes> \<kappa>)" .
	+ then show ?thesis
	+ by (metis cardinal_idem cmult_def gcard_eq_vcard lepoll_imp_gcard_le small_elts)
	+qed
	+
	+lemma gcard_Times [simp]: "gcard (X \<times> Y) = gcard X \<otimes> gcard Y"
	+proof (cases "small X \<and> small Y")
	+ case True
	+ have "V_of ` (X \<times> Y) \<approx> (V_of ` X) \<times> (V_of ` Y)"
	+ by (metis V_of_image_times)
	+ also have "\<dots> \<approx> elts (vcard (ZFC_in_HOL.set (V_of ` X))) \<times> elts (vcard (ZFC_in_HOL.set (V_of ` Y)))"
	+ by (metis True cardinal_eqpoll eqpoll_sym replacement set_of_elts small_iff times_eqpoll_cong)
	+ also have "\<dots> \<approx> elts (vtimes (vcard (ZFC_in_HOL.set (V_of ` X))) (vcard (ZFC_in_HOL.set (V_of ` Y))))"
	+ using elts_VSigma by auto
	+ finally show ?thesis
	+ using True cardinal_cong by (simp add: gcard_def cmult_def)
	+next
	+ case False
	+ have "gcard (X \<times> Y) = 0"
	+ by (metis False Times_empty gcard_big_0 gcard_empty_0 small_Times_iff)
	+ then show ?thesis
	+ by (metis False cmult_0 cmult_commute gcard_big_0)
	+qed
	+
	+subsection \<open>Countable and uncountable sets\<close>
	+
	+lemma countable_iff_g_le_Aleph0: "small X \<Longrightarrow> countable X \<longleftrightarrow> gcard X \<le> \<aleph>0"
	+ unfolding gcard_def
	+ by (metis countable_iff_le_Aleph0 countable_image elts_of_set inv_V_of_image_eq replacement)
	+
	+lemma countable_imp_g_le_Aleph0: "countable X \<Longrightarrow> gcard X \<le> \<aleph>0"
	+ by (meson countable countable_iff_g_le_Aleph0)
	+
	+lemma finite_iff_g_le_Aleph0: "small X \<Longrightarrow> finite X \<longleftrightarrow> gcard X < \<aleph>0"
	+ by (metis Aleph_0 elts_set_V_of eqpoll_finite_iff finite_iff_less_Aleph0 gcard_def)
	+
	+lemma finite_imp_g_le_Aleph0: "finite X \<Longrightarrow> gcard X < \<aleph>0"
	+ by (meson finite_iff_g_le_Aleph0 finite_imp_small)
	+
	+lemma countable_infinite_gcard: "countable X \<and> infinite X \<longleftrightarrow> gcard X = \<aleph>0"
	+proof -
	+ have "gcard X = \<omega>"
	+ if "countable X" and "infinite X"
	+ using that countable countable_imp_g_le_Aleph0 finite_iff_g_le_Aleph0 less_V_def by auto
	+ moreover have "countable X" if "gcard X = \<omega>"
	+ by (metis Aleph_0 countable_iff_g_le_Aleph0 dual_order.refl gcard_big_0 omega_nonzero that)
	+ moreover have False if "gcard X = \<omega>" and "finite X"
	+ by (metis Aleph_0 dual_order.irrefl finite_iff_g_le_Aleph0 finite_imp_small that)
	+ ultimately show ?thesis
	+ by auto
	+qed
	+
	+lemma uncountable_gcard: "small X \<Longrightarrow> uncountable X \<longleftrightarrow> gcard X > \<aleph>0"
	+ by (simp add: Ord_not_le countable_iff_g_le_Aleph0 gcard_def)
	+
	+lemma uncountable_gcard_ge: "small X \<Longrightarrow> uncountable X \<longleftrightarrow> gcard X \<ge> \<aleph>1"
	+ by (simp add: uncountable_gcard csucc_le_Card_iff one_V_def)
	+
	+lemma subset_smaller_gcard:
	+ assumes \<kappa>: "\<kappa> \<le> gcard X" "Card \<kappa>"
	+ obtains Y where "Y \<subseteq> X" "gcard Y = \<kappa>"
	+proof (cases "small X")
	+ case True
	+ with subset_smaller_vcard [OF \<kappa> [unfolded gcard_def]] show ?thesis
	+ by (metis elts_of_set gcard_def less_eq_V_def replacement set_of_elts subset_imageE that)
	+next
	+ case False
	+ with assms show ?thesis
	+ by (metis antisym gcard_big_0 le_0 order_refl that)
	+qed
	+
	+lemma Real_gcard: "gcard (UNIV::real set) = C_continuum"
	+ by (metis C_continuum_def Real_set_def gcard_def)
	+
	+lemma Complex_gcard: "gcard (UNIV::complex set) = C_continuum"
	+ by (metis Complex_set_def Complex_vcard gcard_def)
	+
	+end
	diff --git a/thys/ZFC_in_HOL/ROOT b/thys/ZFC_in_HOL/ROOT
	--- a/thys/ZFC_in_HOL/ROOT
	+++ b/thys/ZFC_in_HOL/ROOT
	@@ -1,13 +1,14 @@
	chapter AFP

	session ZFC_in_HOL (AFP) = HOL +
	options [timeout = 600]
	sessions
	"HOL-Library"
	+ "HOL-Analysis"
	"HOL-Cardinals"
	theories
	Cantor_NF
	ZFC_Typeclasses
	document_files
	"root.tex"
	"root.bib"
	diff --git a/thys/ZFC_in_HOL/ZFC_Cardinals.thy b/thys/ZFC_in_HOL/ZFC_Cardinals.thy
	--- a/thys/ZFC_in_HOL/ZFC_Cardinals.thy
	+++ b/thys/ZFC_in_HOL/ZFC_Cardinals.thy
	@@ -1,2538 +1,2670 @@
	section \<open>Cartesian products, Disjoint Sums, Ranks, Cardinals\<close>

	theory ZFC_Cardinals
	imports ZFC_in_HOL

	begin

	declare [[coercion_enabled]]
	declare [[coercion "ord_of_nat :: nat \<Rightarrow> V"]]

	subsection \<open>Ordered Pairs\<close>

	lemma singleton_eq_iff [iff]: "set {a} = set {b} \<longleftrightarrow> a=b"
	by simp

	lemma doubleton_eq_iff: "set {a,b} = set {c,d} \<longleftrightarrow> (a=c \<and> b=d) \<or> (a=d \<and> b=c)"
	by (simp add: Set.doubleton_eq_iff)

	definition vpair :: "V \<Rightarrow> V \<Rightarrow> V"
	where "vpair a b = set {set {a},set {a,b}}"

	definition vfst :: "V \<Rightarrow> V"
	where "vfst p \<equiv> THE x. \<exists>y. p = vpair x y"

	definition vsnd :: "V \<Rightarrow> V"
	where "vsnd p \<equiv> THE y. \<exists>x. p = vpair x y"

	definition vsplit :: "[[V, V] \<Rightarrow> 'a, V] \<Rightarrow> 'a::{}" \<comment> \<open>for pattern-matching\<close>
	where "vsplit c \<equiv> \<lambda>p. c (vfst p) (vsnd p)"

	nonterminal Vs
	syntax (ASCII)
	"_Tuple" :: "[V, Vs] \<Rightarrow> V" ("<(_,/ _)>")
	"_hpattern" :: "[pttrn, patterns] \<Rightarrow> pttrn" ("<_,/ _>")
	syntax
	"" :: "V \<Rightarrow> Vs" ("_")
	"_Enum" :: "[V, Vs] \<Rightarrow> Vs" ("_,/ _")
	"_Tuple" :: "[V, Vs] \<Rightarrow> V" ("\<langle>(_,/ _)\<rangle>")
	"_hpattern" :: "[pttrn, patterns] \<Rightarrow> pttrn" ("\<langle>_,/ _\<rangle>")
	translations
	"<x, y, z>" \<rightleftharpoons> "<x, <y, z>>"
	"<x, y>" \<rightleftharpoons> "CONST vpair x y"
	"<x, y, z>" \<rightleftharpoons> "<x, <y, z>>"
	"\<lambda><x,y,zs>. b" \<rightleftharpoons> "CONST vsplit(\<lambda>x <y,zs>. b)"
	"\<lambda><x,y>. b" \<rightleftharpoons> "CONST vsplit(\<lambda>x y. b)"


	lemma vpair_def': "vpair a b = set {set {a,a},set {a,b}}"
	by (simp add: vpair_def)

	lemma vpair_iff [simp]: "vpair a b = vpair a' b' \<longleftrightarrow> a=a' \<and> b=b'"
	unfolding vpair_def' doubleton_eq_iff by auto

	lemmas vpair_inject = vpair_iff [THEN iffD1, THEN conjE, elim!]

	lemma vfst_conv [simp]: "vfst \<langle>a,b\<rangle> = a"
	by (simp add: vfst_def)

	lemma vsnd_conv [simp]: "vsnd \<langle>a,b\<rangle> = b"
	by (simp add: vsnd_def)

	lemma vsplit [simp]: "vsplit c \<langle>a,b\<rangle> = c a b"
	by (simp add: vsplit_def)

	lemma vpair_neq_fst: "\<langle>a,b\<rangle> \<noteq> a"
	by (metis elts_of_set insertI1 mem_not_sym small_upair vpair_def')

	lemma vpair_neq_snd: "\<langle>a,b\<rangle> \<noteq> b"
	by (metis elts_of_set insertI1 mem_not_sym small_upair subsetD subset_insertI vpair_def')

	lemma vpair_nonzero [simp]: "\<langle>x,y\<rangle> \<noteq> 0"
	by (metis elts_0 elts_of_set empty_not_insert small_upair vpair_def)

	lemma zero_notin_vpair: "0 \<notin> elts \<langle>x,y\<rangle>"
	by (auto simp: vpair_def)

	lemma inj_on_vpair [simp]: "inj_on (\<lambda>(x, y). \<langle>x, y\<rangle>) A"
	by (auto simp: inj_on_def)


	subsection \<open>Generalized Cartesian product\<close>

	definition VSigma :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
	where "VSigma A B \<equiv> set(\<Union>x \<in> elts A. \<Union>y \<in> elts (B x). {\<langle>x,y\<rangle>})"

	abbreviation vtimes where "vtimes A B \<equiv> VSigma A (\<lambda>x. B)"

	definition pairs :: "V \<Rightarrow> (V * V)set"
	where "pairs r \<equiv> {(x,y). \<langle>x,y\<rangle> \<in> elts r} "

	lemma pairs_iff_elts: "(x,y) \<in> pairs z \<longleftrightarrow> \<langle>x,y\<rangle> \<in> elts z"
	by (simp add: pairs_def)

	lemma VSigma_iff [simp]: "\<langle>a,b\<rangle> \<in> elts (VSigma A B) \<longleftrightarrow> a \<in> elts A \<and> b \<in> elts (B a)"
	by (auto simp: VSigma_def UNION_singleton_eq_range)

	lemma VSigmaI [intro!]: "\<lbrakk> a \<in> elts A; b \<in> elts (B a)\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> elts (VSigma A B)"
	by simp

	lemmas VSigmaD1 = VSigma_iff [THEN iffD1, THEN conjunct1]
	lemmas VSigmaD2 = VSigma_iff [THEN iffD1, THEN conjunct2]

	text \<open>The general elimination rule\<close>
	lemma VSigmaE [elim!]:
	assumes "c \<in> elts (VSigma A B)"
	obtains x y where "x \<in> elts A" "y \<in> elts (B x)" "c=\<langle>x,y\<rangle>"
	using assms by (auto simp: VSigma_def split: if_split_asm)

	lemma VSigmaE2 [elim!]:
	assumes "\<langle>a,b\<rangle> \<in> elts (VSigma A B)" obtains "a \<in> elts A" and "b \<in> elts (B a)"
	using assms by auto

	lemma VSigma_empty1 [simp]: "VSigma 0 B = 0"
	by auto

	lemma times_iff [simp]: "\<langle>a,b\<rangle> \<in> elts (vtimes A B) \<longleftrightarrow> a \<in> elts A \<and> b \<in> elts B"
	by simp

	lemma timesI [intro!]: "\<lbrakk>a \<in> elts A; b \<in> elts B\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> elts (vtimes A B)"
	by simp

	lemma times_empty2 [simp]: "vtimes A 0 = 0"
	using elts_0 by blast

	lemma times_empty_iff: "VSigma A B = 0 \<longleftrightarrow> A=0 \<or> (\<forall>x \<in> elts A. B x = 0)"
	by (metis VSigmaE VSigmaI elts_0 empty_iff trad_foundation)

	-lemma elts_VSigma: "elts (VSigma a b) = (\<lambda>(x,y). vpair x y) ` Sigma (elts a) (\<lambda>x. elts (b x))"
	+lemma elts_VSigma: "elts (VSigma A B) = (\<lambda>(x,y). vpair x y) ` Sigma (elts A) (\<lambda>x. elts (B x))"
	by auto
	+
	+lemma small_Sigma [simp]:
	+ assumes A: "small A" and B: "\<And>x. x \<in> A \<Longrightarrow> small (B x)"
	+ shows "small (Sigma A B)"
	+proof -
	+ obtain a where "elts a \<approx> A"
	+ by (meson assms small_eqpoll)
	+ then obtain f where f: "bij_betw f (elts a) A"
	+ using eqpoll_def by blast
	+ have "\<exists>y. elts y \<approx> B x" if "x \<in> A" for x
	+ using B small_eqpoll that by blast
	+ then obtain g where g: "\<And>x. x \<in> A \<Longrightarrow> elts (g x) \<approx> B x"
	+ by metis
	+ with f have "elts (VSigma a (g \<circ> f)) \<approx> Sigma A B"
	+ by (simp add: elts_VSigma Sigma_eqpoll_cong bij_betwE)
	+ then show ?thesis
	+ using small_eqpoll by blast
	+qed

	lemma small_Times [simp]:
	- assumes "small A" "small B"
	- shows "small (A \<times> 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 \<equiv> \<lambda>(x,y). \<langle>f x, g y\<rangle>"
	- show ?thesis
	- unfolding small_def
	- proof (intro exI conjI)
	- show "inj_on h (A \<times> B)"
	- using \<open>inj_on f A\<close> \<open>inj_on g B\<close> by (simp add: h_def inj_on_def)
	- have "h ` (A \<times> B) = elts (vtimes a b)"
	- using f g by (fastforce simp: h_def image_iff split: prod.split)
	- then show "h ` (A \<times> B) \<in> range elts"
	- by blast
	- qed
	+ assumes "small A" "small B" shows "small (A \<times> B)"
	+ by (simp add: assms)
	+
	+lemma small_Times_iff: "small (A \<times> B) \<longleftrightarrow> small A \<and> small B \<or> A={} \<or> B={}" (is "_ = ?rhs")
	+proof
	+ assume *: "small (A \<times> B)"
	+ { have "small A \<and> small B" if "x \<in> A" "y \<in> B" for x y
	+ proof -
	+ have "A \<subseteq> fst ` (A \<times> B)" "B \<subseteq> snd ` (A \<times> B)"
	+ using that by auto
	+ with that show ?thesis
	+ by (metis * replacement smaller_than_small)
	+ qed }
	+ then show ?rhs
	+ by (metis equals0I)
	+next
	+ assume ?rhs
	+ then show "small (A \<times> B)"
	+ by auto
	qed

	-
	subsection \<open>Disjoint Sum\<close>

	definition vsum :: "V \<Rightarrow> V \<Rightarrow> V" (infixl "\<Uplus>" 65) where
	"A \<Uplus> B \<equiv> (VSigma (set {0}) (\<lambda>x. A)) \<squnion> (VSigma (set {1}) (\<lambda>x. B))"

	definition Inl :: "V\<Rightarrow>V" where
	"Inl a \<equiv> \<langle>0,a\<rangle>"

	definition Inr :: "V\<Rightarrow>V" where
	"Inr b \<equiv> \<langle>1,b\<rangle>"

	lemmas sum_defs = vsum_def Inl_def Inr_def

	lemma Inl_nonzero [simp]:"Inl x \<noteq> 0"
	by (metis Inl_def vpair_nonzero)

	lemma Inr_nonzero [simp]:"Inr x \<noteq> 0"
	by (metis Inr_def vpair_nonzero)

	subsubsection\<open>Equivalences for the injections and an elimination rule\<close>

	lemma Inl_in_sum_iff [iff]: "Inl a \<in> elts (A \<Uplus> B) \<longleftrightarrow> a \<in> elts A"
	by (auto simp: sum_defs)

	lemma Inr_in_sum_iff [iff]: "Inr b \<in> elts (A \<Uplus> B) \<longleftrightarrow> b \<in> elts B"
	by (auto simp: sum_defs)

	lemma sumE [elim!]:
	assumes u: "u \<in> elts (A \<Uplus> B)"
	obtains x where "x \<in> elts A" "u=Inl x" \| y where "y \<in> elts B" "u=Inr y" using u
	by (auto simp: sum_defs)

	subsubsection \<open>Injection and freeness equivalences, for rewriting\<close>

	lemma Inl_iff [iff]: "Inl a=Inl b \<longleftrightarrow> a=b"
	by (simp add: sum_defs)

	lemma Inr_iff [iff]: "Inr a=Inr b \<longleftrightarrow> a=b"
	by (simp add: sum_defs)

	lemma inj_on_Inl [simp]: "inj_on Inl A"
	by (simp add: inj_on_def)

	lemma inj_on_Inr [simp]: "inj_on Inr A"
	by (simp add: inj_on_def)

	lemma Inl_Inr_iff [iff]: "Inl a=Inr b \<longleftrightarrow> False"
	by (simp add: sum_defs)

	lemma Inr_Inl_iff [iff]: "Inr b=Inl a \<longleftrightarrow> False"
	by (simp add: sum_defs)

	lemma sum_empty [simp]: "0 \<Uplus> 0 = 0"
	by auto

	lemma elts_vsum: "elts (a \<Uplus> b) = Inl ` (elts a) \<union> Inr ` (elts b)"
	by auto

	lemma sum_iff: "u \<in> elts (A \<Uplus> B) \<longleftrightarrow> (\<exists>x. x \<in> elts A \<and> u=Inl x) \<or> (\<exists>y. y \<in> elts B \<and> u=Inr y)"
	by blast

	lemma sum_subset_iff: "A\<Uplus>B \<le> C\<Uplus>D \<longleftrightarrow> A\<le>C \<and> B\<le>D"
	by (auto simp: less_eq_V_def)

	lemma sum_equal_iff:
	fixes A :: V shows "A\<Uplus>B = C\<Uplus>D \<longleftrightarrow> A=C \<and> B=D"
	by (simp add: eq_iff sum_subset_iff)

	definition is_sum :: "V \<Rightarrow> bool"
	where "is_sum z = (\<exists>x. z = Inl x \<or> z = Inr x)"

	definition sum_case :: "(V \<Rightarrow> 'a) \<Rightarrow> (V \<Rightarrow> 'a) \<Rightarrow> V \<Rightarrow> 'a"
	where
	"sum_case f g a \<equiv>
	THE z. (\<forall>x. a = Inl x \<longrightarrow> z = f x) \<and> (\<forall>y. a = Inr y \<longrightarrow> z = g y) \<and> (\<not> is_sum a \<longrightarrow> z = undefined)"

	lemma sum_case_Inl [simp]: "sum_case f g (Inl x) = f x"
	by (simp add: sum_case_def is_sum_def)

	lemma sum_case_Inr [simp]: "sum_case f g (Inr y) = g y"
	by (simp add: sum_case_def is_sum_def)

	lemma sum_case_non [simp]: "\<not> is_sum a \<Longrightarrow> sum_case f g a = undefined"
	by (simp add: sum_case_def is_sum_def)

	lemma is_sum_cases: "(\<exists>x. z = Inl x \<or> z = Inr x) \<or> \<not> is_sum z"
	by (auto simp: is_sum_def)

	lemma sum_case_split:
	"P (sum_case f g a) \<longleftrightarrow> (\<forall>x. a = Inl x \<longrightarrow> P(f x)) \<and> (\<forall>y. a = Inr y \<longrightarrow> P(g y)) \<and> (\<not> is_sum a \<longrightarrow> P undefined)"
	by (cases "is_sum a") (auto simp: is_sum_def)

	lemma sum_case_split_asm:
	"P (sum_case f g a) \<longleftrightarrow> \<not> ((\<exists>x. a = Inl x \<and> \<not> P(f x)) \<or> (\<exists>y. a = Inr y \<and> \<not> P(g y)) \<or> (\<not> is_sum a \<and> \<not> P undefined))"
	by (auto simp: sum_case_split)

	subsubsection \<open>Applications of disjoint sums and pairs: general union theorems for small sets\<close>

	lemma small_Un:
	assumes X: "small X" and Y: "small Y"
	shows "small (X \<union> Y)"
	proof -
	- obtain f g :: "'a\<Rightarrow>V" where f: "inj_on f X" and g: "inj_on g Y"
	- by (meson assms small_def)
	- define h where "h \<equiv> \<lambda>z. if z \<in> X then Inl (f z) else Inr (g z)"
	- show ?thesis
	- unfolding small_def
	- proof (intro exI conjI)
	- show "inj_on h (X \<union> Y)"
	- using f g by (auto simp add: inj_on_def h_def)
	- show "h ` (X \<union> Y) \<in> range elts"
	- by (metis X Y image_Un replacement small_iff_range small_sup_iff)
	- qed
	+ obtain x y where "elts x \<approx> X" "elts y \<approx> Y"
	+ by (meson assms small_eqpoll)
	+ then have "X \<union> Y \<lesssim> Inl ` (elts x) \<union> Inr ` (elts y)"
	+ by (metis (mono_tags, lifting) Inr_Inl_iff Un_lepoll_mono disjnt_iff eqpoll_imp_lepoll eqpoll_sym f_inv_into_f inj_on_Inl inj_on_Inr inj_on_image_lepoll_2)
	+ then show ?thesis
	+ by (metis lepoll_iff replacement small_elts small_sup_iff smaller_than_small)
	qed

	lemma small_UN [simp,intro]:
	- assumes X: "small X" and B: "\<And>x. x \<in> X \<Longrightarrow> small (B x)"
	- shows "small (\<Union>x\<in>X. B x)"
	+ assumes A: "small A" and B: "\<And>x. x \<in> A \<Longrightarrow> small (B x)"
	+ shows "small (\<Union>x\<in>A. B x)"
	proof -
	- obtain f :: "'a\<Rightarrow>V" where f: "inj_on f X"
	- by (meson assms small_def)
	- have "\<exists>g. inj_on g (B x) \<and> g ` (B x) \<in> range elts" if "x \<in> X" for x
	- using B small_def that by auto
	- then obtain g::"'a \<Rightarrow> 'b \<Rightarrow> V" where g: "\<And>x. x \<in> X \<Longrightarrow> inj_on (g x) (B x)"
	+ obtain a where "elts a \<approx> A"
	+ by (meson assms small_eqpoll)
	+ then obtain f where f: "bij_betw f (elts a) A"
	+ using eqpoll_def by blast
	+ have "\<exists>y. elts y \<approx> B x" if "x \<in> A" for x
	+ using B small_eqpoll that by blast
	+ then obtain g where g: "\<And>x. x \<in> A \<Longrightarrow> elts (g x) \<approx> B x"
	by metis
	- define \<phi> where "\<phi> \<equiv> \<lambda>y. @x. x \<in> X \<and> y \<in> B x"
	- have \<phi>: "\<phi> y \<in> X \<and> y \<in> B (\<phi> y)" if "y \<in> (\<Union>x\<in>X. B x)" for y
	- unfolding \<phi>_def by (metis (mono_tags, lifting) UN_E someI that)
	- define h where "h \<equiv> \<lambda>y. \<langle>f (\<phi> y), g (\<phi> y) y\<rangle>"
	- show ?thesis
	- unfolding small_def
	- proof (intro exI conjI)
	- show "inj_on h (\<Union> (B ` X))"
	- using f g \<phi> unfolding h_def inj_on_def by (metis vpair_inject)
	- have "small (h ` \<Union> (B ` X))"
	- by (simp add: B X image_UN)
	- then show "h ` \<Union> (B ` X) \<in> range elts"
	- using small_iff_range by blast
	- qed
	+ have sm: "small (Sigma (elts a) (elts \<circ> g \<circ> f))"
	+ by simp
	+ have "(\<Union>x\<in>A. B x) \<lesssim> Sigma A B"
	+ by (metis image_lepoll snd_image_Sigma)
	+ also have "... \<lesssim> Sigma (elts a) (elts \<circ> g \<circ> f)"
	+ by (smt (verit) Sigma_eqpoll_cong bij_betw_iff_bijections comp_apply eqpoll_imp_lepoll eqpoll_sym f g)
	+ finally show ?thesis
	+ using lepoll_small sm by blast
	qed

	lemma small_Union [simp,intro]:
	assumes "\<A> \<subseteq> Collect small" "small \<A>"
	shows "small (\<Union> \<A>)"
	using small_UN [of \<A> "\<lambda>x. x"] assms by (simp add: subset_iff)

	subsection\<open>Generalised function space and lambda\<close>

	definition VLambda :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
	where "VLambda A b \<equiv> set ((\<lambda>x. \<langle>x,b x\<rangle>) ` elts A)"

	definition app :: "[V,V] \<Rightarrow> V"
	where "app f x \<equiv> THE y. \<langle>x,y\<rangle> \<in> elts f"

	lemma beta [simp]:
	assumes "x \<in> elts A"
	shows "app (VLambda A b) x = b x"
	using assms by (auto simp: VLambda_def app_def)

	definition VPi :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
	where "VPi A B \<equiv> set {f \<in> elts (VPow(VSigma A B)). elts A \<le> Domain (pairs f) \<and> single_valued (pairs f)}"

	lemma VPi_I:
	assumes "\<And>x. x \<in> elts A \<Longrightarrow> b x \<in> elts (B x)"
	shows "VLambda A b \<in> elts (VPi A B)"
	proof (clarsimp simp: VPi_def, intro conjI impI)
	show "VLambda A b \<le> VSigma A B"
	by (auto simp: assms VLambda_def split: if_split_asm)
	show "elts A \<subseteq> Domain (pairs (VLambda A b))"
	by (force simp: VLambda_def pairs_iff_elts)
	show "single_valued (pairs (VLambda A b))"
	by (auto simp: VLambda_def single_valued_def pairs_iff_elts)
	show "small {f. f \<le> VSigma A B \<and> elts A \<subseteq> Domain (pairs f) \<and> single_valued (pairs f)}"
	by (metis (mono_tags, lifting) down VPow_iff mem_Collect_eq subsetI)
	qed

	lemma apply_pair:
	assumes f: "f \<in> elts (VPi A B)" and x: "x \<in> elts A"
	shows "\<langle>x, app f x\<rangle> \<in> elts f"
	proof -
	have "x \<in> Domain (pairs f)"
	by (metis (no_types, lifting) VPi_def assms elts_of_set empty_iff mem_Collect_eq subsetD)
	then obtain y where y: "\<langle>x,y\<rangle> \<in> elts f"
	using pairs_iff_elts by auto
	show ?thesis
	unfolding app_def
	proof (rule theI)
	show "\<langle>x, y\<rangle> \<in> elts f"
	by (rule y)
	show "z = y" if "\<langle>x, z\<rangle> \<in> elts f" for z
	using f unfolding VPi_def
	by (metis (mono_tags, lifting) that elts_of_set empty_iff mem_Collect_eq pairs_iff_elts single_valued_def y)
	qed
	qed

	lemma VPi_D:
	assumes f: "f \<in> elts (VPi A B)" and x: "x \<in> elts A"
	shows "app f x \<in> elts (B x)"
	proof -
	have "f \<le> VSigma A B"
	by (metis (no_types, lifting) VPi_def elts_of_set empty_iff f VPow_iff mem_Collect_eq)
	then show ?thesis
	using apply_pair [OF assms] by blast
	qed

	lemma VPi_memberD:
	assumes f: "f \<in> elts (VPi A B)" and p: "p \<in> elts f"
	obtains x where "x \<in> elts A" "p = \<langle>x, app f x\<rangle>"
	proof -
	have "f \<le> VSigma A B"
	by (metis (no_types, lifting) VPi_def elts_of_set empty_iff f VPow_iff mem_Collect_eq)
	then obtain x y where "p = \<langle>x,y\<rangle>" "x \<in> elts A"
	using p by blast
	then have "y = app f x"
	by (metis (no_types, lifting) VPi_def apply_pair elts_of_set equals0D f mem_Collect_eq p pairs_iff_elts single_valuedD)
	then show thesis
	using \<open>p = \<langle>x, y\<rangle>\<close> \<open>x \<in> elts A\<close> that by blast
	qed

	lemma fun_ext:
	assumes "f \<in> elts (VPi A B)" "g \<in> elts (VPi A B)" "\<And>x. x \<in> elts A \<Longrightarrow> app f x = app g x"
	shows "f = g"
	by (metis VPi_memberD V_equalityI apply_pair assms)

	lemma eta[simp]:
	assumes "f \<in> elts (VPi A B)"
	shows "VLambda A ((app)f) = f"
	proof (rule fun_ext [OF _ assms])
	show "VLambda A (app f) \<in> elts (VPi A B)"
	using VPi_D VPi_I assms by auto
	qed auto


	lemma fst_pairs_VLambda: "fst ` pairs (VLambda A f) = elts A"
	by (force simp: VLambda_def pairs_def)

	lemma snd_pairs_VLambda: "snd ` pairs (VLambda A f) = f ` elts A"
	by (force simp: VLambda_def pairs_def)

	lemma VLambda_eq_D1: "VLambda A f = VLambda B g \<Longrightarrow> A = B"
	by (metis ZFC_in_HOL.ext fst_pairs_VLambda)

	lemma VLambda_eq_D2: "\<lbrakk>VLambda A f = VLambda A g; x \<in> elts A\<rbrakk> \<Longrightarrow> f x = g x"
	by (metis beta)


	subsection\<open>Transitive closure of a set\<close>

	definition TC :: "V\<Rightarrow>V"
	where "TC \<equiv> transrec (\<lambda>f x. x \<squnion> \<Squnion> (f ` elts x))"

	lemma TC: "TC a = a \<squnion> \<Squnion> (TC ` elts a)"
	by (metis (no_types, lifting) SUP_cong TC_def restrict_apply' transrec)

	lemma TC_0 [simp]: "TC 0 = 0"
	by (metis TC ZFC_in_HOL.Sup_empty elts_0 image_is_empty sup_V_0_left)

	lemma arg_subset_TC: "a \<le> TC a"
	by (metis (no_types) TC sup_ge1)

	lemma Transset_TC: "Transset(TC a)"
	proof (induction a rule: eps_induct)
	case (step x)
	have 1: "v \<in> elts (TC x)" if "v \<in> elts u" "u \<in> elts x" for u v
	using that unfolding TC [of x]
	using arg_subset_TC by fastforce
	have 2: "v \<in> elts (TC x)" if "v \<in> elts u" "\<exists>x\<in>elts x. u \<in> elts (TC x)" for u v
	using that step unfolding TC [of x] Transset_def by auto
	show ?case
	unfolding Transset_def
	by (subst TC) (force intro: 1 2)
	qed

	lemma TC_least: "\<lbrakk>Transset x; a\<le>x\<rbrakk> \<Longrightarrow> TC a \<le> x"
	proof (induction a rule: eps_induct)
	case (step y)
	show ?case
	proof (cases "y=0")
	case True
	then show ?thesis
	by auto
	next
	case False
	have "\<Squnion> (TC ` elts y) \<le> x"
	proof (rule cSup_least)
	show "TC ` elts y \<noteq> {}"
	using False by auto
	show "z \<le> x" if "z \<in> TC ` elts y" for z
	using that by (metis Transset_def image_iff step.IH step.prems vsubsetD)
	qed
	then show ?thesis
	by (simp add: step TC [of y])
	qed
	qed

	definition less_TC (infix "\<sqsubset>" 50)
	where "x \<sqsubset> y \<equiv> x \<in> elts (TC y)"

	definition le_TC (infix "\<sqsubseteq>" 50)
	where "x \<sqsubseteq> y \<equiv> x \<sqsubset> y \<or> x=y"

	lemma less_TC_imp_not_le: "x \<sqsubset> a \<Longrightarrow> \<not> a \<le> x"
	proof (induction a arbitrary: x rule: eps_induct)
	case (step a)
	then show ?case
	unfolding TC[of a] less_TC_def
	using Transset_TC Transset_def by force
	qed

	lemma non_TC_less_0 [iff]: "\<not> (x \<sqsubset> 0)"
	using less_TC_imp_not_le by blast

	lemma less_TC_iff: "x \<sqsubset> y \<longleftrightarrow> (\<exists>z \<in> elts y. x \<sqsubseteq> z)"
	by (auto simp: less_TC_def le_TC_def TC [of y])

	lemma nonzero_less_TC: "x \<noteq> 0 \<Longrightarrow> 0 \<sqsubset> x"
	by (metis eps_induct le_TC_def less_TC_iff trad_foundation)

	lemma less_irrefl_TC [simp]: "\<not> x \<sqsubset> x"
	using less_TC_imp_not_le by blast

	lemma less_asym_TC: "\<lbrakk>x \<sqsubset> y; y \<sqsubset> x\<rbrakk> \<Longrightarrow> False"
	by (metis TC_least Transset_TC Transset_def antisym_conv less_TC_def less_TC_imp_not_le order_refl)

	lemma le_antisym_TC: "\<lbrakk>x \<sqsubset> y; y \<sqsubset> x\<rbrakk> \<Longrightarrow> x = y"
	using less_asym_TC by blast

	lemma less_imp_le_TC [iff]: "x \<sqsubset> y \<Longrightarrow> x \<sqsubseteq> y"
	by (simp add: le_TC_def)

	lemma le_TC_refl [iff]: "x \<sqsubseteq> x"
	by (simp add: le_TC_def)

	lemma less_TC_trans [trans]: "\<lbrakk>x \<sqsubset> y; y \<sqsubset> z\<rbrakk> \<Longrightarrow> x \<sqsubset> z"
	by (meson TC_least Transset_TC Transset_def less_TC_def less_eq_V_def subsetD)

	lemma less_le_TC_trans [trans]: "\<lbrakk>x \<sqsubset> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubset> z"
	using le_TC_def less_TC_trans by blast

	lemma le_less_TC_trans [trans]: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubset> z\<rbrakk> \<Longrightarrow> x \<sqsubset> z"
	using le_TC_def less_TC_trans by blast

	lemma le_TC_trans [trans]: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
	using le_TC_def le_less_TC_trans by blast

	lemma TC_sup_distrib: "TC (x \<squnion> y) = TC x \<squnion> TC y"
	by (simp add: Sup_Un_distrib TC [of "x \<squnion> y"] TC [of x] TC [of y] image_Un sup.assoc sup_left_commute)

	lemma TC_Sup_distrib:
	assumes "small X" shows "TC (\<Squnion>X) = \<Squnion>(TC ` X)"
	proof -
	+ have "\<Squnion>X \<le> \<Squnion> (TC ` X)"
	+ using arg_subset_TC by fastforce
	+ moreover have "\<Squnion> (\<Union>x\<in>X. TC ` elts x) \<le> \<Squnion> (TC ` X)"
	+ using assms
	+ by clarsimp (meson TC_least Transset_TC Transset_def arg_subset_TC replacement vsubsetD)
	+ ultimately
	have "\<Squnion> X \<squnion> \<Squnion> (\<Union>x\<in>X. TC ` elts x) \<le> \<Squnion> (TC ` X)"
	- using assms
	- apply (auto simp: Sup_le_iff)
	- using arg_subset_TC apply blast
	- by (metis TC_least Transset_TC Transset_def arg_subset_TC vsubsetD)
	+ by simp
	moreover have "\<Squnion> (TC ` X) \<le> \<Squnion> X \<squnion> \<Squnion> (\<Union>x\<in>X. TC ` elts x)"
	proof (clarsimp simp add: Sup_le_iff assms)
	show "\<exists>x\<in>X. y \<in> elts x"
	if "x \<in> X" "y \<in> elts (TC x)" "\<forall>x\<in>X. \<forall>u\<in>elts x. y \<notin> elts (TC u)" for x y
	using that by (auto simp: TC [of x])
	qed
	ultimately show ?thesis
	using Sup_Un_distrib TC [of "\<Squnion>X"] image_Union assms
	by (simp add: image_Union inf_sup_aci(5) sup.absorb_iff2)
	qed

	lemma TC': "TC x = x \<squnion> TC (\<Squnion> (elts x))"
	by (simp add: TC [of x] TC_Sup_distrib)

	lemma TC_eq_0_iff [simp]: "TC x = 0 \<longleftrightarrow> x=0"
	using arg_subset_TC by fastforce

	text\<open>A distinctive induction principle\<close>
	lemma TC_induct_down_lemma:
	assumes ab: "a \<sqsubset> b" and base: "b \<le> d"
	and step: "\<And>y z. \<lbrakk>y \<sqsubset> b; y \<in> elts d; z \<in> elts y\<rbrakk> \<Longrightarrow> z \<in> elts d"
	shows "a \<in> elts d"
	proof -
	have "Transset (TC b \<sqinter> d)"
	using Transset_TC
	unfolding Transset_def
	by (metis inf.bounded_iff less_TC_def less_eq_V_def local.step subsetI vsubsetD)
	moreover have "b \<le> TC b \<sqinter> d"
	by (simp add: arg_subset_TC base)
	ultimately show ?thesis
	using TC_least [THEN vsubsetD] ab unfolding less_TC_def
	by (meson TC_least le_inf_iff vsubsetD)
	qed

	lemma TC_induct_down [consumes 1, case_names base step small]:
	assumes "a \<sqsubset> b"
	and "\<And>y. y \<in> elts b \<Longrightarrow> P y"
	and "\<And>y z. \<lbrakk>y \<sqsubset> b; P y; z \<in> elts y\<rbrakk> \<Longrightarrow> P z"
	and "small (Collect P)"
	shows "P a"
	using TC_induct_down_lemma [of a b "set (Collect P)"] assms
	by (metis elts_of_set mem_Collect_eq vsubsetI)

	subsection\<open>Rank of a set\<close>

	definition rank :: "V\<Rightarrow>V"
	where "rank a \<equiv> transrec (\<lambda>f x. set (\<Union>y\<in>elts x. elts (succ(f y)))) a"

	lemma rank: "rank a = set(\<Union>y \<in> elts a. elts (succ(rank y)))"
	by (subst rank_def [THEN def_transrec], simp)

	lemma rank_Sup: "rank a = \<Squnion>((\<lambda>y. succ(rank y)) ` elts a)"
	by (metis elts_Sup image_image rank replacement set_of_elts small_elts)

	lemma Ord_rank [simp]: "Ord(rank a)"
	proof (induction a rule: eps_induct)
	case (step x)
	then show ?case
	unfolding rank_Sup [of x]
	by (metis (mono_tags, lifting) Ord_Sup Ord_succ imageE)
	qed

	lemma rank_of_Ord: "Ord i \<Longrightarrow> rank i = i"
	- apply (induction rule: Ord_induct)
	- by (metis (no_types, lifting) Ord_equality SUP_cong rank_Sup)
	+ by (induction rule: Ord_induct) (metis (no_types, lifting) Ord_equality SUP_cong rank_Sup)

	lemma Ord_iff_rank: "Ord x \<longleftrightarrow> rank x = x"
	using Ord_rank [of x] rank_of_Ord by fastforce

	lemma rank_lt: "a \<in> elts b \<Longrightarrow> rank a < rank b"
	- apply (subst rank [of b])
	- by (metis (no_types, lifting) Ord_mem_iff_lt Ord_rank small_UN UN_iff elts_of_set elts_succ insert_iff rank small_elts)
	+ by (metis Ord_linear2 Ord_rank ZFC_in_HOL.SUP_le_iff rank_Sup replacement small_elts succ_le_iff order.irrefl)

	lemma rank_0 [simp]: "rank 0 = 0"
	- unfolding rank_def
	- using transrec by fastforce
	+ using transrec Ord_0 rank_def rank_of_Ord by presburger

	lemma rank_succ [simp]: "rank(succ x) = succ(rank x)"
	proof (rule order_antisym)
	show "rank (succ x) \<le> succ (rank x)"
	- apply (subst rank [of "succ x"])
	- apply (metis (no_types, lifting) Sup_insert elts_of_set elts_succ equals0D image_insert rank small_sup_iff subset_insertI sup.orderE vsubsetI)
	- done
	+ by (metis (no_types, lifting) Sup_insert elts_of_set elts_succ image_insert rank small_UN small_elts subset_insertI sup.orderE vsubsetI)
	show "succ (rank x) \<le> rank (succ x)"
	by (metis (mono_tags, lifting) ZFC_in_HOL.Sup_upper elts_succ image_insert insertI1 rank_Sup replacement small_elts)
	qed

	lemma rank_mono: "a \<le> b \<Longrightarrow> rank a \<le> rank b"
	- apply (rule vsubsetI)
	- using rank [of a] rank [of b] small_UN by auto
	+ using rank [of a] rank [of b] small_UN by force

	lemma VsetI: "rank b \<sqsubset> i \<Longrightarrow> b \<in> elts (Vset i)"
	proof (induction i arbitrary: b rule: eps_induct)
	case (step x)
	then consider "rank b \<in> elts x" \| "(\<exists>y\<in>elts x. rank b \<in> elts (TC y))"
	using le_TC_def less_TC_def less_TC_iff by fastforce
	then have "\<exists>y\<in>elts x. b \<le> Vset y"
	proof cases
	case 1
	then have "b \<le> Vset (rank b)"
	unfolding less_eq_V_def subset_iff
	by (meson Ord_mem_iff_lt Ord_rank le_TC_refl less_TC_iff rank_lt step.IH)
	then show ?thesis
	using "1" by blast
	next
	case 2
	then show ?thesis
	using step.IH
	unfolding less_eq_V_def subset_iff less_TC_def
	by (meson Ord_mem_iff_lt Ord_rank Transset_TC Transset_def rank_lt vsubsetD)
	qed
	then show ?case
	by (simp add: Vset [of x])
	qed

	lemma Ord_VsetI: "\<lbrakk>Ord i; rank b < i\<rbrakk> \<Longrightarrow> b \<in> elts (Vset i)"
	by (meson Ord_mem_iff_lt Ord_rank VsetI arg_subset_TC less_TC_def vsubsetD)

	lemma arg_le_Vset_rank: "a \<le> Vset(rank a)"
	by (simp add: Ord_VsetI rank_lt vsubsetI)

	lemma two_in_Vset:
	obtains \<alpha> where "x \<in> elts (Vset \<alpha>)" "y \<in> elts (Vset \<alpha>)"
	by (metis Ord_rank Ord_VsetI elts_of_set insert_iff rank_lt small_elts small_insert_iff)

	lemma rank_eq_0_iff [simp]: "rank x = 0 \<longleftrightarrow> x=0"
	using arg_le_Vset_rank by fastforce

	lemma small_ranks_imp_small:
	assumes "small (rank ` A)" shows "small A"
	proof -
	define i where "i \<equiv> set (\<Union>(elts ` (rank ` A)))"
	have "Ord i"
	unfolding i_def using Ord_Union Ord_rank assms imageE by blast
	have *: "Vset (rank x) \<le> (Vset i)" if "x \<in> A" for x
	unfolding i_def by (metis Ord_rank Sup_V_def ZFC_in_HOL.Sup_upper Vfrom_mono assms imageI le_less that)
	have "A \<subseteq> elts (VPow (Vset i))"
	by (meson "*" VPow_iff arg_le_Vset_rank order.trans subsetI)
	then show ?thesis
	using down by blast
	qed

	lemma rank_Union: "rank(\<Squnion> A) = \<Squnion> (rank ` A)"
	proof (rule order_antisym)
	have "elts (\<Squnion>y\<in>elts (\<Squnion> A). succ (rank y)) \<subseteq> elts (\<Squnion> (rank ` A))"
	- apply auto(SLOW)
	- using Ord_mem_iff_lt Ord_rank rank_lt apply blast
	- by (meson less_le_not_le rank_lt vsubsetD)
	+ by clarsimp (meson Ord_mem_iff_lt Ord_rank less_V_def rank_lt vsubsetD)
	then show "rank (\<Squnion> A) \<le> \<Squnion> (rank ` A)"
	by (metis less_eq_V_def rank_Sup)
	show "\<Squnion> (rank ` A) \<le> rank (\<Squnion> A)"
	proof (cases "small A")
	case True
	then show ?thesis
	- by (metis (mono_tags, lifting) ZFC_in_HOL.Sup_least ZFC_in_HOL.Sup_upper image_iff rank_mono)
	+ by (simp add: ZFC_in_HOL.SUP_le_iff ZFC_in_HOL.Sup_upper rank_mono)
	next
	case False
	then have "\<not> small (rank ` A)"
	using small_ranks_imp_small by blast
	then show ?thesis
	by blast
	qed
	qed

	lemma small_bounded_rank: "small {x. rank x \<in> elts a}"
	proof -
	have "{x. rank x \<in> elts a} \<subseteq> {x. rank x \<sqsubset> a}"
	using less_TC_iff by auto
	also have "\<dots> \<subseteq> elts (Vset a)"
	using VsetI by blast
	finally show ?thesis
	using down by simp
	qed

	lemma small_bounded_rank_le: "small {x. rank x \<le> a}"
	using small_bounded_rank [of "VPow a"] VPow_iff [of _ a] by simp

	lemma TC_rank_lt: "a \<sqsubset> b \<Longrightarrow> rank a < rank b"
	proof (induction rule: TC_induct_down)
	case (base y)
	then show ?case
	by (simp add: rank_lt)
	next
	case (step y z)
	then show ?case
	using less_trans rank_lt by blast
	next
	case small
	show ?case
	- apply (rule smaller_than_small [OF small_bounded_rank_le [of "rank b"]])
	+ using smaller_than_small [OF small_bounded_rank_le [of "rank b"]]
	by (simp add: Collect_mono less_V_def)
	qed

	lemma TC_rank_mem: "x \<sqsubset> y \<Longrightarrow> rank x \<in> elts (rank y)"
	by (simp add: Ord_mem_iff_lt TC_rank_lt)

	lemma wf_TC_less: "wf {(x,y). x \<sqsubset> y}"
	proof (rule wf_subset [OF wf_inv_image [OF foundation, of rank]])
	show "{(x, y). x \<sqsubset> y} \<subseteq> inv_image {(x, y). x \<in> elts y} rank"
	by (auto simp: TC_rank_mem inv_image_def)
	qed

	lemma less_TC_minimal:
	assumes "P a"
	obtains x where "P x" "x \<sqsubseteq> a" "\<And>y. y \<sqsubset> x \<Longrightarrow> \<not> P y"
	using wfE_min' [OF wf_TC_less, of "{x. P x \<and> x \<sqsubseteq> a}"]
	by simp (metis le_TC_def less_le_TC_trans assms)

	lemma Vfrom_rank_eq: "Vfrom A (rank(x)) = Vfrom A x"
	proof (rule order_antisym)
	show "Vfrom A (rank x) \<le> Vfrom A x"
	proof (induction x rule: eps_induct)
	case (step x)
	have "(\<Squnion>j\<in>elts (rank x). VPow (Vfrom A j)) \<le> (\<Squnion>j\<in>elts x. VPow (Vfrom A j))"
	- apply (rule Sup_least, clarify)
	- apply (simp add: rank [of x])
	- using step.IH
	- by (metis Ord_rank OrdmemD Vfrom_mono2 dual_order.trans inf_sup_aci(5) less_V_def sup.orderE)
	+ apply (rule Sup_least)
	+ apply (clarsimp simp add: rank [of x])
	+ by (meson Ord_in_Ord Ord_rank OrdmemD Vfrom_mono order.trans less_imp_le order.refl step)
	then show ?case
	by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"] sup.coboundedI2)
	qed
	show "Vfrom A x \<le> Vfrom A (rank x)"
	proof (induction x rule: eps_induct)
	case (step x)
	have "(\<Squnion>j\<in>elts x. VPow (Vfrom A j)) \<le> (\<Squnion>j\<in>elts (rank x). VPow (Vfrom A j))"
	using step.IH TC_rank_mem less_TC_iff by force
	then show ?case
	by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"] sup.coboundedI2)
	qed
	qed

	lemma Vfrom_succ: "Vfrom A (succ(i)) = A \<squnion> VPow(Vfrom A i)"
	by (metis Ord_rank Vfrom_rank_eq Vfrom_succ_Ord rank_succ)

	lemma Vset_succ_TC:
	assumes "x \<in> elts (Vset (ZFC_in_HOL.succ k))" "u \<sqsubset> x"
	shows "u \<in> elts (Vset k)"
	using assms
	- apply (simp add: Vfrom_succ)
	- using TC_least Transset_Vfrom less_TC_def by auto
	+ using TC_least Transset_Vfrom Vfrom_succ less_TC_def by auto

	subsection\<open>Cardinal Numbers\<close>

	text\<open>We extend the membership relation to a wellordering\<close>
	definition VWO :: "(V \<times> V) set"
	where "VWO \<equiv> @r. {(x,y). x \<in> elts y} \<subseteq> r \<and> Well_order r \<and> Field r = UNIV"

	lemma VWO: "{(x,y). x \<in> elts y} \<subseteq> VWO \<and> Well_order VWO \<and> Field VWO = UNIV"
	unfolding VWO_def
	by (metis (mono_tags, lifting) VWO_def foundation someI_ex total_well_order_extension)

	lemma wf_VWO: "wf(VWO - Id)"
	using VWO well_order_on_def by blast

	lemma wf_Ord_less: "wf {(x, y). Ord y \<and> x < y}"
	by (metis (no_types, lifting) Ord_mem_iff_lt eps_induct wfPUNIVI wfP_def)

	lemma refl_VWO: "refl VWO"
	using VWO order_on_defs by fastforce

	lemma trans_VWO: "trans VWO"
	using VWO by (simp add: VWO wo_rel.TRANS wo_rel_def)

	lemma antisym_VWO: "antisym VWO"
	using VWO by (simp add: VWO wo_rel.ANTISYM wo_rel_def)

	lemma total_VWO: "total VWO"
	using VWO by (metis wo_rel.TOTAL wo_rel.intro)

	lemma total_VWOId: "total (VWO-Id)"
	by (simp add: total_VWO)

	lemma Linear_order_VWO: "Linear_order VWO"
	using VWO well_order_on_def by blast

	lemma wo_rel_VWO: "wo_rel VWO"
	using VWO wo_rel_def by blast

	subsubsection \<open>Transitive Closure and VWO\<close>

	lemma mem_imp_VWO: "x \<in> elts y \<Longrightarrow> (x,y) \<in> VWO"
	using VWO by blast

	lemma less_TC_imp_VWO: "x \<sqsubset> y \<Longrightarrow> (x,y) \<in> VWO"
	unfolding less_TC_def
	proof (induction y arbitrary: x rule: eps_induct)
	case (step y' u)
	then consider "u \<in> elts y'" \| v where "v \<in> elts y'" "u \<in> elts (TC v)"
	by (auto simp: TC [of y'])
	then show ?case
	proof cases
	case 2
	then show ?thesis
	by (meson mem_imp_VWO step.IH transD trans_VWO)
	qed (use mem_imp_VWO in blast)
	qed

	lemma le_TC_imp_VWO: "x \<sqsubseteq> y \<Longrightarrow> (x,y) \<in> VWO"
	- apply (auto simp: le_TC_def less_TC_imp_VWO)
	- by (metis Diff_iff Linear_order_VWO Linear_order_in_diff_Id UNIV_I VWO)
	+ by (metis Diff_iff Linear_order_VWO Linear_order_in_diff_Id UNIV_I VWO le_TC_def less_TC_imp_VWO)

	lemma le_TC_0_iff [simp]: "x \<sqsubseteq> 0 \<longleftrightarrow> x = 0"
	by (simp add: le_TC_def)

	lemma less_TC_succ: " x \<sqsubset> succ \<beta> \<longleftrightarrow> x \<sqsubset> \<beta> \<or> x = \<beta>"
	by (metis elts_succ insert_iff le_TC_def less_TC_iff)

	lemma le_TC_succ: "x \<sqsubseteq> succ \<beta> \<longleftrightarrow> x \<sqsubseteq> \<beta> \<or> x = succ \<beta>"
	by (simp add: le_TC_def less_TC_succ)

	lemma Transset_TC_eq [simp]: "Transset x \<Longrightarrow> TC x = x"
	by (simp add: TC_least arg_subset_TC eq_iff)

	lemma Ord_TC_less_iff: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> \<beta> \<sqsubset> \<alpha> \<longleftrightarrow> \<beta> < \<alpha>"
	by (metis Ord_def Ord_mem_iff_lt Transset_TC_eq less_TC_def)

	lemma Ord_mem_iff_less_TC: "Ord l \<Longrightarrow> k \<in> elts l \<longleftrightarrow> k \<sqsubset> l"
	by (simp add: Ord_def less_TC_def)

	lemma le_TC_Ord: "\<lbrakk>\<beta> \<sqsubseteq> \<alpha>; Ord \<alpha>\<rbrakk> \<Longrightarrow> Ord \<beta>"
	by (metis Ord_def Ord_in_Ord Transset_TC_eq le_TC_def less_TC_def)

	lemma Ord_less_TC_mem:
	assumes "Ord \<alpha>" "\<beta> \<sqsubset> \<alpha>" shows "\<beta> \<in> elts \<alpha>"
	using Ord_def assms less_TC_def by auto

	lemma VWO_TC_le: "\<lbrakk>Ord \<alpha>; Ord \<beta>; (\<beta>, \<alpha>) \<in> VWO\<rbrakk> \<Longrightarrow> \<beta> \<sqsubseteq> \<alpha>"
	proof (induct \<alpha> arbitrary: \<beta> rule: Ord_induct)
	case (step \<alpha>)
	then show ?case
	- by (metis Diff_iff Linear_order_VWO Linear_order_in_diff_Id Ord_TC_less_iff Ord_linear2 UNIV_I VWO le_TC_def le_less less_TC_imp_VWO pair_in_Id_conv)
	+ by (metis DiffI IdD Linear_order_VWO Linear_order_in_diff_Id Ord_linear Ord_mem_iff_less_TC VWO iso_tuple_UNIV_I le_TC_def mem_imp_VWO)
	qed

	lemma VWO_iff_Ord_le [simp]: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> (\<beta>, \<alpha>) \<in> VWO \<longleftrightarrow> \<beta> \<le> \<alpha>"
	by (metis VWO_TC_le Ord_TC_less_iff le_TC_def le_TC_imp_VWO le_less)

	lemma zero_TC_le [iff]: "0 \<sqsubseteq> y"
	using le_TC_def nonzero_less_TC by auto

	lemma succ_le_TC_iff: "Ord j \<Longrightarrow> succ i \<sqsubseteq> j \<longleftrightarrow> i \<sqsubset> j"
	by (metis Ord_in_Ord Ord_linear Ord_mem_iff_less_TC Ord_succ le_TC_def less_TC_succ less_asym_TC)

	lemma VWO_0_iff [simp]: "(x,0) \<in> VWO \<longleftrightarrow> x=0"
	proof
	show "x = 0" if "(x, 0) \<in> VWO"
	using zero_TC_le [of x] le_TC_imp_VWO that
	by (metis DiffI Linear_order_VWO Linear_order_in_diff_Id UNIV_I VWO pair_in_Id_conv)
	qed auto

	lemma VWO_antisym:
	assumes "(x,y) \<in> VWO" "(y,x) \<in> VWO" shows "x=y"
	by (metis Diff_iff IdD Linear_order_VWO Linear_order_in_diff_Id UNIV_I VWO assms)

	subsubsection \<open>Relation VWF\<close>

	definition VWF where "VWF \<equiv> VWO - Id"

	lemma wf_VWF [iff]: "wf VWF"
	by (simp add: VWF_def wf_VWO)

	lemma trans_VWF [iff]: "trans VWF"
	by (simp add: VWF_def antisym_VWO trans_VWO trans_diff_Id)

	lemma asym_VWF [iff]: "asym VWF"
	by (metis VWF_def asym.intros irrefl_diff_Id wf_VWF wf_not_sym)

	lemma total_VWF [iff]: "total VWF"
	using VWF_def total_VWOId by auto

	lemma total_on_VWF [iff]: "total_on A VWF"
	by (meson UNIV_I total_VWF total_on_def)

	lemma VWF_asym:
	assumes "(x,y) \<in> VWF" "(y,x) \<in> VWF" shows False
	using VWF_def assms wf_VWO wf_not_sym by fastforce

	lemma VWF_non_refl [iff]: "(x,x) \<notin> VWF"
	by simp

	lemma VWF_iff_Ord_less [simp]: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> (\<alpha>,\<beta>) \<in> VWF \<longleftrightarrow> \<alpha> < \<beta>"
	by (simp add: VWF_def less_V_def)

	lemma mem_imp_VWF: "x \<in> elts y \<Longrightarrow> (x,y) \<in> VWF"
	using VWF_def mem_imp_VWO by fastforce


	subsection\<open>Order types\<close>

	definition ordermap :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> V"
	where "ordermap A r \<equiv> wfrec r (\<lambda>f x. set (f ` {y \<in> A. (y,x) \<in> r}))"

	definition ordertype :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> V"
	where "ordertype A r \<equiv> set (ordermap A r ` A)"

	lemma ordermap_type:
	"small A \<Longrightarrow> ordermap A r \<in> A \<rightarrow> elts (ordertype A r)"
	by (simp add: ordertype_def)

	lemma ordermap_in_ordertype [intro]: "\<lbrakk>a \<in> A; small A\<rbrakk> \<Longrightarrow> ordermap A r a \<in> elts (ordertype A r)"
	by (simp add: ordertype_def)

	lemma ordermap: "wf r \<Longrightarrow> ordermap A r a = set (ordermap A r ` {y \<in> A. (y,a) \<in> r})"
	unfolding ordermap_def
	by (auto simp: wfrec_fixpoint adm_wf_def)

	lemma wf_Ord_ordermap [iff]: assumes "wf r" "trans r" shows "Ord (ordermap A r x)"
	using \<open>wf r\<close>
	proof (induction x rule: wf_induct_rule)
	case (less u)
	have "Transset (set (ordermap A r ` {y \<in> A. (y, u) \<in> r}))"
	proof (clarsimp simp add: Transset_def)
	show "x \<in> ordermap A r ` {y \<in> A. (y, u) \<in> r}"
	if "small (ordermap A r ` {y \<in> A. (y, u) \<in> r})"
	and x: "x \<in> elts (ordermap A r y)" and "y \<in> A" "(y, u) \<in> r" for x y
	proof -
	have "ordermap A r y = ZFC_in_HOL.set (ordermap A r ` {a \<in> A. (a, y) \<in> r})"
	using ordermap assms(1) by force
	then have "x \<in> ordermap A r ` {z \<in> A. (z, y) \<in> r}"
	by (metis (no_types, lifting) elts_of_set empty_iff x)
	then have "\<exists>v. v \<in> A \<and> (v, u) \<in> r \<and> x = ordermap A r v"
	using that transD [OF \<open>trans r\<close>] by blast
	then show ?thesis
	by blast
	qed
	qed
	moreover have "Ord x"
	if "x \<in> elts (set (ordermap A r ` {y \<in> A. (y, u) \<in> r}))" for x
	using that less by (auto simp: split: if_split_asm)
	ultimately show ?case
	by (metis (full_types) Ord_def ordermap assms(1))
	qed

	lemma wf_Ord_ordertype: assumes "wf r" "trans r" shows "Ord(ordertype A r)"
	proof -
	have "y \<le> set (ordermap A r ` A)"
	if "y = ordermap A r x" "x \<in> A" "small (ordermap A r ` A)" for x y
	using that by (auto simp: less_eq_V_def ordermap [OF \<open>wf r\<close>, of A x])
	moreover have "z \<le> y" if "y \<in> ordermap A r ` A" "z \<in> elts y" for y z
	by (metis wf_Ord_ordermap OrdmemD assms imageE order.strict_implies_order that)
	ultimately show ?thesis
	unfolding ordertype_def Ord_def Transset_def by simp
	qed

	lemma Ord_ordertype [simp]: "Ord(ordertype A VWF)"
	using wf_Ord_ordertype by blast

	lemma Ord_ordermap [simp]: "Ord (ordermap A VWF x)"
	by blast

	lemma ordertype_singleton [simp]:
	assumes "wf r"
	shows "ordertype {x} r = 1"
	proof -
	have \<dagger>: "{y. y = x \<and> (y, x) \<in> r} = {}"
	using assms by auto
	show ?thesis
	by (auto simp add: ordertype_def assms \<dagger> ordermap [where a=x])
	qed


	subsubsection\<open>@{term ordermap} preserves the orderings in both directions\<close>

	lemma ordermap_mono:
	assumes wx: "(w, x) \<in> r" and "wf r" "w \<in> A" "small A"
	shows "ordermap A r w \<in> elts (ordermap A r x)"
	proof -
	have "small {a \<in> A. (a, x) \<in> r} \<and> w \<in> A \<and> (w, x) \<in> r"
	by (simp add: assms)
	then show ?thesis
	using assms ordermap [of r A]
	by (metis (no_types, lifting) elts_of_set image_eqI mem_Collect_eq replacement)
	qed

	lemma converse_ordermap_mono:
	assumes "ordermap A r y \<in> elts (ordermap A r x)" "wf r" "total_on A r" "x \<in> A" "y \<in> A" "small A"
	shows "(y, x) \<in> r"
	proof (cases "x = y")
	case True
	then show ?thesis
	using assms(1) mem_not_refl by blast
	next
	case False
	then consider "(x,y) \<in> r" \| "(y,x) \<in> r"
	using \<open>total_on A r\<close> assms by (meson UNIV_I total_on_def)
	then show ?thesis
	by (meson ordermap_mono assms mem_not_sym)
	qed

	lemma converse_ordermap_mono_iff:
	assumes "wf r" "total_on A r" "x \<in> A" "y \<in> A" "small A"
	shows "ordermap A r y \<in> elts (ordermap A r x) \<longleftrightarrow> (y, x) \<in> r"
	by (metis assms converse_ordermap_mono ordermap_mono)

	lemma ordermap_surj: "elts (ordertype A r) \<subseteq> ordermap A r ` A"
	unfolding ordertype_def by simp

	lemma ordermap_bij:
	assumes "wf r" "total_on A r" "small A"
	shows "bij_betw (ordermap A r) A (elts (ordertype A r))"
	unfolding bij_betw_def
	proof (intro conjI)
	show "inj_on (ordermap A r) A"
	unfolding inj_on_def by (metis assms mem_not_refl ordermap_mono total_on_def)
	show "ordermap A r ` A = elts (ordertype A r)"
	by (metis ordertype_def \<open>small A\<close> elts_of_set replacement)
	qed

	lemma ordermap_eq_iff [simp]:
	"\<lbrakk>x \<in> A; y \<in> A; wf r; total_on A r; small A\<rbrakk> \<Longrightarrow> ordermap A r x = ordermap A r y \<longleftrightarrow> x = y"
	by (metis bij_betw_iff_bijections ordermap_bij)

	lemma inv_into_ordermap: "\<alpha> \<in> elts (ordertype A r) \<Longrightarrow> inv_into A (ordermap A r) \<alpha> \<in> A"
	by (meson in_mono inv_into_into ordermap_surj)

	lemma ordertype_nat_imp_finite:
	assumes "ordertype A r = ord_of_nat m" "small A" "wf r" "total_on A r"
	shows "finite A"
	proof -
	have "A \<approx> elts m"
	using eqpoll_def assms ordermap_bij by fastforce
	then show ?thesis
	using eqpoll_finite_iff finite_Ord_omega by blast
	qed

	lemma wf_ordertype_eqpoll:
	assumes "wf r" "total_on A r" "small A"
	shows "elts (ordertype A r) \<approx> A"
	using assms eqpoll_def eqpoll_sym ordermap_bij by blast

	lemma ordertype_eqpoll:
	assumes "small A"
	shows "elts (ordertype A VWF) \<approx> A"
	using assms wf_ordertype_eqpoll total_VWF wf_VWF
	by (simp add: wf_ordertype_eqpoll total_on_def)

	subsection \<open>More advanced @{term ordertype} and @{term ordermap} results\<close>

	lemma ordermap_VWF_0 [simp]: "ordermap A VWF 0 = 0"
	by (simp add: ordermap wf_VWO VWF_def)

	lemma ordertype_empty [simp]: "ordertype {} r = 0"
	by (simp add: ordertype_def)

	lemma ordertype_eq_0_iff [simp]: "\<lbrakk>small X; wf r\<rbrakk> \<Longrightarrow> ordertype X r = 0 \<longleftrightarrow> X = {}"
	by (metis ordertype_def elts_of_set replacement image_is_empty zero_V_def)

	lemma ordermap_mono_less:
	assumes "(w, x) \<in> r"
	and "wf r" "trans r"
	and "w \<in> A" "x \<in> A"
	and "small A"
	shows "ordermap A r w < ordermap A r x"
	by (simp add: OrdmemD assms ordermap_mono)

	lemma ordermap_mono_le:
	assumes "(w, x) \<in> r \<or> w=x"
	and "wf r" "trans r"
	and "w \<in> A" "x \<in> A"
	and "small A"
	shows "ordermap A r w \<le> ordermap A r x"
	by (metis assms dual_order.strict_implies_order eq_refl ordermap_mono_less)

	lemma converse_ordermap_le_mono:
	assumes "ordermap A r y \<le> ordermap A r x" "wf r" "total r" "x \<in> A" "small A"
	shows "(y, x) \<in> r \<or> y=x"
	by (meson UNIV_I assms mem_not_refl ordermap_mono total_on_def vsubsetD)

	lemma ordertype_mono:
	assumes "X \<subseteq> Y" and r: "wf r" "trans r" and "small Y"
	shows "ordertype X r \<le> ordertype Y r"
	proof -
	have "small X"
	using assms smaller_than_small by fastforce
	have *: "ordermap X r x \<le> ordermap Y r x" for x
	using \<open>wf r\<close>
	proof (induction x rule: wf_induct_rule)
	case (less x)
	have "ordermap X r z < ordermap Y r x" if "z \<in> X" and zx: "(z,x) \<in> r" for z
	using less [OF zx] assms
	by (meson Ord_linear2 OrdmemD wf_Ord_ordermap ordermap_mono in_mono leD that(1) vsubsetD zx)
	then show ?case
	by (auto simp add: ordermap [of _ X x] \<open>small X\<close> Ord_mem_iff_lt set_image_le_iff less_eq_V_def r)
	qed
	show ?thesis
	proof -
	have "ordermap Y r ` Y = elts (ordertype Y r)"
	by (metis ordertype_def \<open>small Y\<close> elts_of_set replacement)
	then have "ordertype Y r \<notin> ordermap X r ` X"
	using "*" \<open>X \<subseteq> Y\<close> by fastforce
	then show ?thesis
	by (metis Ord_linear2 Ord_mem_iff_lt ordertype_def wf_Ord_ordertype \<open>small X\<close> elts_of_set replacement r)
	qed
	qed

	corollary ordertype_VWF_mono:
	assumes "X \<subseteq> Y" "small Y"
	shows "ordertype X VWF \<le> ordertype Y VWF"
	using assms by (simp add: ordertype_mono)

	lemma ordertype_UNION_ge:
	assumes "A \<in> \<A>" "wf r" "trans r" "\<A> \<subseteq> Collect small" "small \<A>"
	shows "ordertype A r \<le> ordertype (\<Union>\<A>) r"
	by (rule ordertype_mono) (use assms in auto)

	lemma inv_ordermap_mono_less:
	assumes "(inv_into M (ordermap M r) \<alpha>, inv_into M (ordermap M r) \<beta>) \<in> r"
	and "small M" and \<alpha>: "\<alpha> \<in> elts (ordertype M r)" and \<beta>: "\<beta> \<in> elts (ordertype M r)"
	and "wf r" "trans r"
	shows "\<alpha> < \<beta>"
	proof -
	have "\<alpha> = ordermap M r (inv_into M (ordermap M r) \<alpha>)"
	by (metis \<alpha> f_inv_into_f ordermap_surj subset_eq)
	also have "\<dots> < ordermap M r (inv_into M (ordermap M r) \<beta>)"
	by (meson \<alpha> \<beta> assms in_mono inv_into_into ordermap_mono_less ordermap_surj)
	also have "\<dots> = \<beta>"
	by (meson \<beta> f_inv_into_f in_mono ordermap_surj)
	finally show ?thesis .
	qed

	lemma inv_ordermap_mono_eq:
	assumes "inv_into M (ordermap M r) \<alpha> = inv_into M (ordermap M r) \<beta>"
	and "\<alpha> \<in> elts (ordertype M r)" "\<beta> \<in> elts (ordertype M r)"
	shows "\<alpha> = \<beta>"
	by (metis assms f_inv_into_f ordermap_surj subsetD)

	lemma inv_ordermap_VWF_mono_le:
	assumes "inv_into M (ordermap M VWF) \<alpha> \<le> inv_into M (ordermap M VWF) \<beta>"
	and "M \<subseteq> ON" "small M" and \<alpha>: "\<alpha> \<in> elts (ordertype M VWF)" and \<beta>: "\<beta> \<in> elts (ordertype M VWF)"
	shows "\<alpha> \<le> \<beta>"
	proof -
	have "\<alpha> = ordermap M VWF (inv_into M (ordermap M VWF) \<alpha>)"
	by (metis \<alpha> f_inv_into_f ordermap_surj subset_eq)
	also have "\<dots> \<le> ordermap M VWF (inv_into M (ordermap M VWF) \<beta>)"
	by (metis ON_imp_Ord VWF_iff_Ord_less assms dual_order.strict_implies_order elts_of_set eq_refl inv_into_into order.not_eq_order_implies_strict ordermap_mono_less ordertype_def replacement trans_VWF wf_VWF)
	also have "\<dots> = \<beta>"
	by (meson \<beta> f_inv_into_f in_mono ordermap_surj)
	finally show ?thesis .
	qed

	lemma inv_ordermap_VWF_mono_iff:
	assumes "M \<subseteq> ON" "small M" and "\<alpha> \<in> elts (ordertype M VWF)" and "\<beta> \<in> elts (ordertype M VWF)"
	shows "inv_into M (ordermap M VWF) \<alpha> \<le> inv_into M (ordermap M VWF) \<beta> \<longleftrightarrow> \<alpha> \<le> \<beta>"
	by (metis ON_imp_Ord Ord_linear_le assms dual_order.eq_iff inv_into_ordermap inv_ordermap_VWF_mono_le)

	lemma inv_ordermap_VWF_strict_mono_iff:
	assumes "M \<subseteq> ON" "small M" and "\<alpha> \<in> elts (ordertype M VWF)" and "\<beta> \<in> elts (ordertype M VWF)"
	shows "inv_into M (ordermap M VWF) \<alpha> < inv_into M (ordermap M VWF) \<beta> \<longleftrightarrow> \<alpha> < \<beta>"
	by (simp add: assms inv_ordermap_VWF_mono_iff less_le_not_le)

	lemma strict_mono_on_ordertype:
	assumes "M \<subseteq> ON" "small M"
	obtains f where "f \<in> elts (ordertype M VWF) \<rightarrow> M" "strict_mono_on f (elts (ordertype M VWF))"
	proof
	show "inv_into M (ordermap M VWF) \<in> elts (ordertype M VWF) \<rightarrow> M"
	by (meson Pi_I' in_mono inv_into_into ordermap_surj)
	show "strict_mono_on (inv_into M (ordermap M VWF)) (elts (ordertype M VWF))"
	proof (clarsimp simp: strict_mono_on_def)
	fix x y
	assume "x \<in> elts (ordertype M VWF)" "y \<in> elts (ordertype M VWF)" "x < y"
	then show "inv_into M (ordermap M VWF) x < inv_into M (ordermap M VWF) y"
	using assms by (meson ON_imp_Ord Ord_linear2 inv_into_into inv_ordermap_VWF_mono_le leD ordermap_surj subsetD)
	qed
	qed

	lemma ordermap_inc_eq:
	assumes "x \<in> A" "small A"
	and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> s"
	and r: "wf r" "total_on A r" and "wf s"
	shows "ordermap (\<pi> ` A) s (\<pi> x) = ordermap A r x"
	using \<open>wf r\<close> \<open>x \<in> A\<close>
	proof (induction x rule: wf_induct_rule)
	case (less x)
	then have 1: "{y \<in> A. (y, x) \<in> r} = A \<inter> {y. (y, x) \<in> r}"
	using r by auto
	have 2: "{y \<in> \<pi> ` A. (y, \<pi> x) \<in> s} = \<pi> ` A \<inter> {y. (y, \<pi> x) \<in> s}"
	by auto
	have inv\<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (\<pi> x, \<pi> y) \<in> s\<rbrakk> \<Longrightarrow> (x, y) \<in> r"
	by (metis \<pi> \<open>wf s\<close> \<open>total_on A r\<close> total_on_def wf_not_sym)
	have eq: "f ` (\<pi> ` A \<inter> {y. (y, \<pi> x) \<in> s}) = (f \<circ> \<pi>) ` (A \<inter> {y. (y, x) \<in> r})" for f :: "'b \<Rightarrow> V"
	using less by (auto simp: image_subset_iff inv\<pi> \<pi>)
	show ?case
	using less
	by (simp add: ordermap [OF \<open>wf r\<close>, of _ x] ordermap [OF \<open>wf s\<close>, of _ "\<pi> x"] 1 2 eq)
	qed

	lemma ordertype_inc_eq:
	assumes "small A"
	and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> s"
	and r: "wf r" "total_on A r" and "wf s"
	shows "ordertype (\<pi> ` A) s = ordertype A r"
	proof -
	have "ordermap (\<pi> ` A) s (\<pi> x) = ordermap A r x" if "x \<in> A" for x
	using assms that by (auto simp: ordermap_inc_eq)
	then show ?thesis
	unfolding ordertype_def
	by (metis (no_types, lifting) image_cong image_image)
	qed

	lemma ordertype_inc_le:
	assumes "small A" "small B"
	and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> s"
	and r: "wf r" "total_on A r" and "wf s" "trans s"
	and "\<pi> ` A \<subseteq> B"
	shows "ordertype A r \<le> ordertype B s"
	by (metis assms ordertype_inc_eq ordertype_mono)

	corollary ordertype_VWF_inc_eq:
	assumes "A \<subseteq> ON" "\<pi> ` A \<subseteq> ON" "small A" and "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; x<y\<rbrakk> \<Longrightarrow> \<pi> x < \<pi> y"
	shows "ordertype (\<pi> ` A) VWF = ordertype A VWF"
	proof (rule ordertype_inc_eq)
	show "(\<pi> x, \<pi> y) \<in> VWF"
	if "x \<in> A" "y \<in> A" "(x, y) \<in> VWF" for x y
	using that ON_imp_Ord assms by auto
	show "total_on A VWF"
	by (meson UNIV_I total_VWF total_on_def)
	qed (use assms in auto)

	lemma ordertype_image_ordermap:
	assumes "small A" "X \<subseteq> A" "wf r" "trans r" "total_on X r"
	shows "ordertype (ordermap A r ` X) VWF = ordertype X r"
	proof (rule ordertype_inc_eq)
	show "small X"
	by (meson assms smaller_than_small)
	show "(ordermap A r x, ordermap A r y) \<in> VWF"
	if "x \<in> X" "y \<in> X" "(x, y) \<in> r" for x y
	by (meson that wf_Ord_ordermap VWF_iff_Ord_less assms ordermap_mono_less subsetD)
	qed (use assms in auto)

	lemma ordertype_map_image:
	assumes "B \<subseteq> A" "small A"
	shows "ordertype (ordermap A VWF ` A - ordermap A VWF ` B) VWF = ordertype (A - B) VWF"
	proof -
	have "ordermap A VWF ` A - ordermap A VWF ` B = ordermap A VWF ` (A - B)"
	using assms by auto
	then have "ordertype (ordermap A VWF ` A - ordermap A VWF ` B) VWF = ordertype (ordermap A VWF ` (A - B)) VWF"
	by simp
	also have "\<dots> = ordertype (A - B) VWF"
	using \<open>small A\<close> ordertype_image_ordermap by fastforce
	finally show ?thesis .
	qed

	proposition ordertype_le_ordertype:
	assumes r: "wf r" "total_on A r" and "small A"
	assumes s: "wf s" "total_on B s" "trans s" and "small B"
	shows "ordertype A r \<le> ordertype B s \<longleftrightarrow>
	(\<exists>f \<in> A \<rightarrow> B. inj_on f A \<and> (\<forall>x \<in> A. \<forall>y \<in> A. ((x,y) \<in> r \<longrightarrow> (f x, f y) \<in> s)))"
	(is "?lhs = ?rhs")
	proof
	assume L: ?lhs
	define f where "f \<equiv> inv_into B (ordermap B s) \<circ> ordermap A r"
	show ?rhs
	proof (intro bexI conjI ballI impI)
	have AB: "elts (ordertype A r) \<subseteq> ordermap B s ` B"
	by (metis L assms(7) ordertype_def replacement set_of_elts small_elts subset_iff_less_eq_V)
	have bijA: "bij_betw (ordermap A r) A (elts (ordertype A r))"
	using ordermap_bij \<open>small A\<close> r by blast
	have "inv_into B (ordermap B s) (ordermap A r i) \<in> B" if "i \<in> A" for i
	by (meson L \<open>small A\<close> inv_into_into ordermap_in_ordertype ordermap_surj subsetD that vsubsetD)
	then show "f \<in> A \<rightarrow> B"
	by (auto simp: Pi_iff f_def)
	show "inj_on f A"
	proof (clarsimp simp add: f_def inj_on_def)
	fix x y
	assume "x \<in> A" "y \<in> A"
	and "inv_into B (ordermap B s) (ordermap A r x) = inv_into B (ordermap B s) (ordermap A r y)"
	then have "ordermap A r x = ordermap A r y"
	by (meson AB \<open>small A\<close> inv_into_injective ordermap_in_ordertype subsetD)
	then show "x = y"
	by (metis \<open>x \<in> A\<close> \<open>y \<in> A\<close> bijA bij_betw_inv_into_left)
	qed
	next
	fix x y
	assume "x \<in> A" "y \<in> A" and "(x, y) \<in> r"
	have \<ddagger>: "ordermap A r y \<in> ordermap B s ` B"
	by (meson L \<open>y \<in> A\<close> \<open>small A\<close> in_mono ordermap_in_ordertype ordermap_surj vsubsetD)
	moreover have \<dagger>: "\<And>x. inv_into B (ordermap B s) (ordermap A r x) = f x"
	by (simp add: f_def)
	then have *: "ordermap B s (f y) = ordermap A r y"
	using \<ddagger> by (metis f_inv_into_f)
	moreover have "ordermap A r x \<in> ordermap B s ` B"
	by (meson L \<open>x \<in> A\<close> \<open>small A\<close> in_mono ordermap_in_ordertype ordermap_surj vsubsetD)
	moreover have "ordermap A r x < ordermap A r y"
	using * r s by (metis (no_types) wf_Ord_ordermap OrdmemD \<open>(x, y) \<in> r\<close> \<open>x \<in> A\<close> \<open>small A\<close> ordermap_mono)
	ultimately show "(f x, f y) \<in> s"
	using \<dagger> s by (metis assms(7) f_inv_into_f inv_into_into less_asym ordermap_mono_less total_on_def)
	qed
	next
	assume R: ?rhs
	then obtain f where f: "f\<in>A \<rightarrow> B" "inj_on f A" "\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> r \<longrightarrow> (f x, f y) \<in> s"
	by blast
	show ?lhs
	by (rule ordertype_inc_le [where \<pi>=f]) (use f assms in auto)
	qed

	lemma iso_imp_ordertype_eq_ordertype:
	assumes iso: "iso r r' f"
	and "wf r"
	and "Total r"
	and sm: "small (Field r)"
	shows "ordertype (Field r) r = ordertype (Field r') r'"
	by (metis (no_types, lifting) iso_forward iso_wf assms iso_Field ordertype_inc_eq sm)

	lemma ordertype_infinite_ge_\<omega>:
	assumes "infinite A" "small A"
	shows "ordertype A VWF \<ge> \<omega>"
	proof -
	have "inj_on (ordermap A VWF) A"
	by (meson ordermap_bij \<open>small A\<close> bij_betw_def total_on_VWF wf_VWF)
	then have "infinite (ordermap A VWF ` A)"
	using \<open>infinite A\<close> finite_image_iff by blast
	then show ?thesis
	using Ord_ordertype \<open>small A\<close> infinite_Ord_omega by (auto simp: ordertype_def)
	qed

	lemma ordertype_eqI:
	assumes "wf r" "total_on A r" "small A" "wf s"
	"bij_betw f A B" "(\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r)"
	shows "ordertype A r = ordertype B s"
	by (metis assms bij_betw_imp_surj_on ordertype_inc_eq)

	lemma ordermap_eq_self:
	assumes "Ord \<alpha>" and x: "x \<in> elts \<alpha>"
	shows "ordermap (elts \<alpha>) VWF x = x"
	using Ord_in_Ord [OF assms] x
	proof (induction x rule: Ord_induct)
	case (step x)
	have 1: "{y \<in> elts \<alpha>. (y, x) \<in> VWF} = elts x" (is "?A = _")
	proof
	show "?A \<subseteq> elts x"
	using \<open>Ord \<alpha>\<close> by clarify (meson Ord_in_Ord Ord_mem_iff_lt VWF_iff_Ord_less step.hyps)
	show "elts x \<subseteq> ?A"
	using \<open>Ord \<alpha>\<close> by clarify (meson Ord_in_Ord Ord_trans OrdmemD VWF_iff_Ord_less step.prems)
	qed
	show ?case
	using step
	by (simp add: ordermap [OF wf_VWF, of _ x] 1 Ord_trans [of _ _ \<alpha>] step.prems \<open>Ord \<alpha>\<close> cong: image_cong)
	qed

	lemma ordertype_eq_Ord [simp]:
	assumes "Ord \<alpha>"
	shows "ordertype (elts \<alpha>) VWF = \<alpha>"
	using assms ordermap_eq_self [OF assms] by (simp add: ordertype_def)


	proposition ordertype_eq_iff:
	assumes \<alpha>: "Ord \<alpha>" and r: "wf r" and "small A" "total_on A r" "trans r"
	shows "ordertype A r = \<alpha> \<longleftrightarrow>
	(\<exists>f. bij_betw f A (elts \<alpha>) \<and> (\<forall>x \<in> A. \<forall>y \<in> A. f x < f y \<longleftrightarrow> (x,y) \<in> r))"
	(is "?lhs = ?rhs")
	proof safe
	assume eq: "\<alpha> = ordertype A r"
	show "\<exists>f. bij_betw f A (elts (ordertype A r)) \<and> (\<forall>x\<in>A. \<forall>y\<in>A. f x < f y \<longleftrightarrow> ((x, y) \<in> r))"
	proof (intro exI conjI ballI)
	show "bij_betw (ordermap A r) A (elts (ordertype A r))"
	by (simp add: assms ordermap_bij)
	then show "ordermap A r x < ordermap A r y \<longleftrightarrow> (x, y) \<in> r"
	if "x \<in> A" "y \<in> A" for x y
	using that assms
	by (metis order.asym ordermap_mono_less total_on_def)
	qed
	next
	fix f
	assume f: "bij_betw f A (elts \<alpha>)" "\<forall>x\<in>A. \<forall>y\<in>A. f x < f y \<longleftrightarrow> (x, y) \<in> r"
	have "ordertype A r = ordertype (elts \<alpha>) VWF"
	proof (rule ordertype_eqI)
	show "\<forall>x\<in>A. \<forall>y\<in>A. ((f x, f y) \<in> VWF) = ((x, y) \<in> r)"
	by (meson Ord_in_Ord VWF_iff_Ord_less \<alpha> bij_betwE f)
	qed (use assms f in auto)
	then show ?lhs
	by (simp add: \<alpha>)
	qed

	corollary ordertype_VWF_eq_iff:
	assumes "Ord \<alpha>" "small A"
	shows "ordertype A VWF = \<alpha> \<longleftrightarrow>
	(\<exists>f. bij_betw f A (elts \<alpha>) \<and> (\<forall>x \<in> A. \<forall>y \<in> A. f x < f y \<longleftrightarrow> (x,y) \<in> VWF))"
	by (metis UNIV_I assms ordertype_eq_iff total_VWF total_on_def trans_VWF wf_VWF)


	lemma ordertype_le_Ord:
	assumes "Ord \<alpha>" "X \<subseteq> elts \<alpha>"
	shows "ordertype X VWF \<le> \<alpha>"
	by (metis assms ordertype_VWF_mono ordertype_eq_Ord small_elts)

	lemma ordertype_inc_le_Ord:
	assumes "small A" "Ord \<alpha>"
	and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> \<pi> x < \<pi> y"
	and "wf r" "total_on A r"
	and sub: "\<pi> ` A \<subseteq> elts \<alpha>"
	shows "ordertype A r \<le> \<alpha>"
	proof -
	have "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> VWF"
	by (meson Ord_in_Ord VWF_iff_Ord_less \<pi> \<open>Ord \<alpha>\<close> sub image_subset_iff)
	with assms show ?thesis
	by (metis ordertype_inc_eq ordertype_le_Ord wf_VWF)
	qed

	lemma le_ordertype_obtains_subset:
	assumes \<alpha>: "\<beta> \<le> \<alpha>" "ordertype H VWF = \<alpha>" and "small H" "Ord \<beta>"
	obtains G where "G \<subseteq> H" "ordertype G VWF = \<beta>"
	proof (intro exI conjI that)
	let ?f = "ordermap H VWF"
	show \<ddagger>: "inv_into H ?f ` elts \<beta> \<subseteq> H"
	unfolding image_subset_iff
	by (metis \<alpha> inv_into_into ordermap_surj subsetD vsubsetD)
	have "\<exists>f. bij_betw f (inv_into H ?f ` elts \<beta>) (elts \<beta>) \<and> (\<forall>x\<in>inv_into H ?f ` elts \<beta>. \<forall>y\<in>inv_into H ?f ` elts \<beta>. (f x < f y) = ((x, y) \<in> VWF))"
	proof (intro exI conjI ballI iffI)
	show "bij_betw ?f (inv_into H ?f ` elts \<beta>) (elts \<beta>)"
	using ordermap_bij [OF wf_VWF total_on_VWF \<open>small H\<close>] \<alpha>
	by (metis bij_betw_inv_into_RIGHT bij_betw_subset less_eq_V_def \<ddagger>)
	next
	fix x y
	assume x: "x \<in> inv_into H ?f ` elts \<beta>"
	and y: "y \<in> inv_into H ?f ` elts \<beta>"
	show "?f x < ?f y" if "(x,y) \<in> VWF"
	using that \<ddagger> \<open>small H\<close> in_mono ordermap_mono_less x y by fastforce
	show "(x,y) \<in> VWF" if "?f x < ?f y"
	using that \<ddagger> \<open>small H\<close> in_mono ordermap_mono_less [OF _ wf_VWF trans_VWF] x y
	by (metis UNIV_I less_imp_not_less total_VWF total_on_def)
	qed
	then show "ordertype (inv_into H ?f ` elts \<beta>) VWF = \<beta>"
	by (subst ordertype_eq_iff) (use assms in auto)
	qed

	lemma ordertype_infinite_\<omega>:
	assumes "A \<subseteq> elts \<omega>" "infinite A"
	shows "ordertype A VWF = \<omega>"
	proof (rule antisym)
	show "ordertype A VWF \<le> \<omega>"
	by (simp add: assms ordertype_le_Ord)
	show "\<omega> \<le> ordertype A VWF"
	using assms down ordertype_infinite_ge_\<omega> by auto
	qed

	text \<open>For infinite sets of natural numbers\<close>
	lemma ordertype_nat_\<omega>:
	assumes "infinite N" shows "ordertype N less_than = \<omega>"
	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 = \<omega>"
	by (force simp: assms finite_image_iff inj_on_def intro: ordertype_infinite_\<omega>)
	moreover have "ordertype (ord_of_nat ` N) VWF = ordertype N less_than"
	by (auto intro: ordertype_inc_eq \<open>small N\<close>)
	ultimately show ?thesis
	by simp
	qed

	proposition ordertype_eq_ordertype:
	assumes r: "wf r" "total_on A r" "trans r" and "small A"
	assumes s: "wf s" "total_on B s" "trans s" and "small B"
	shows "ordertype A r = ordertype B s \<longleftrightarrow>
	(\<exists>f. bij_betw f A B \<and> (\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r))"
	(is "?lhs = ?rhs")
	proof
	assume L: ?lhs
	define \<gamma> where "\<gamma> = ordertype A r"
	have A: "bij_betw (ordermap A r) A (ordermap A r ` A)"
	by (meson ordermap_bij assms(4) bij_betw_def r)
	have B: "bij_betw (ordermap B s) B (ordermap B s ` B)"
	by (meson ordermap_bij assms(8) bij_betw_def s)
	- define f where "f \<equiv> inv_into B (ordermap B s) o ordermap A r"
	+ define f where "f \<equiv> inv_into B (ordermap B s) \<circ> ordermap A r"
	show ?rhs
	proof (intro exI conjI)
	have bijA: "bij_betw (ordermap A r) A (elts \<gamma>)"
	unfolding \<gamma>_def using ordermap_bij \<open>small A\<close> r by blast
	moreover have bijB: "bij_betw (ordermap B s) B (elts \<gamma>)"
	by (simp add: L \<gamma>_def ordermap_bij \<open>small B\<close> s)
	ultimately show bij: "bij_betw f A B"
	unfolding f_def using bij_betw_comp_iff bij_betw_inv_into by blast
	have invB: "\<And>\<alpha>. \<alpha> \<in> elts \<gamma> \<Longrightarrow> ordermap B s (inv_into B (ordermap B s) \<alpha>) = \<alpha>"
	by (meson bijB bij_betw_inv_into_right)
	have ordermap_A_\<gamma>: "\<And>a. a \<in> A \<Longrightarrow> ordermap A r a \<in> elts \<gamma>"
	using bijA bij_betwE by auto
	have f_in_B: "\<And>a. a \<in> A \<Longrightarrow> f a \<in> B"
	using bij bij_betwE by fastforce
	show "\<forall>x\<in>A. \<forall>y\<in>A. (f x, f y) \<in> s \<longleftrightarrow> (x, y) \<in> r"
	proof (intro iffI ballI)
	fix x y
	assume "x \<in> A" "y \<in> A" and ins: "(f x, f y) \<in> s"
	then have "ordermap A r x < ordermap A r y"
	unfolding o_def
	by (metis (mono_tags, lifting) f_def \<open>small B\<close> comp_apply f_in_B invB ordermap_A_\<gamma> ordermap_mono_less s(1) s(3))
	then show "(x, y) \<in> r"
	by (metis \<open>x \<in> A\<close> \<open>y \<in> A\<close> \<open>small A\<close> order.asym ordermap_mono_less r total_on_def)
	next
	fix x y
	assume "x \<in> A" "y \<in> A" and "(x, y) \<in> r"
	then have "ordermap A r x < ordermap A r y"
	by (simp add: \<open>small A\<close> ordermap_mono_less r)
	then have "(f y, f x) \<notin> s"
	by (metis (mono_tags, lifting) \<open>x \<in> A\<close> \<open>y \<in> A\<close> \<open>small B\<close> comp_apply f_def f_in_B invB order.asym ordermap_A_\<gamma> ordermap_mono_less s(1) s(3))
	moreover have "f y \<noteq> f x"
	by (metis \<open>(x, y) \<in> r\<close> \<open>x \<in> A\<close> \<open>y \<in> A\<close> bij bij_betw_inv_into_left r(1) wf_not_sym)
	ultimately show "(f x, f y) \<in> s"
	by (meson \<open>x \<in> A\<close> \<open>y \<in> A\<close> f_in_B s(2) total_on_def)
	qed
	qed
	next
	assume ?rhs
	then show ?lhs
	using assms ordertype_eqI by blast
	qed

	corollary 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 \<longleftrightarrow> (\<exists>f. iso r s f)"
	(is "?lhs = ?rhs")
	proof
	assume L: ?lhs
	then obtain f where "bij_betw f A B" "\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> 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 \<open>small A\<close> iso_imp_ordertype_eq_ordertype r by blast
	qed

	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 "\<exists>y\<in>A. (x,y) \<in> r" if "x \<in> A" for x
	proof -
	let ?oy = "succ (ordermap A r x)"
	have \<section>: "?oy \<in> elts (ordertype A r)"
	by (simp add: Lim \<open>small A\<close> ordermap_in_ordertype succ_in_Limit_iff that)
	then have A: "inv_into A (ordermap A r) ?oy \<in> A"
	by (simp add: inv_into_ordermap)
	moreover have "(x, inv_into A (ordermap A r) ?oy) \<in> r"
	proof -
	have "ordermap A r x \<in> elts (ordermap A r (inv_into A (ordermap A r) ?oy))"
	by (metis "\<section>" elts_succ f_inv_into_f insert_iff ordermap_surj subsetD)
	then show ?thesis
	by (metis \<open>small A\<close> A converse_ordermap_mono r that)
	qed
	ultimately show ?thesis ..
	qed
	then have "A \<subseteq> 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 \<longleftrightarrow> (\<exists>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" "\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> 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 \<open>small A\<close> ordertype_Field_Restr r by blast
	moreover
	have "ordertype (Field (Restr s B)) (Restr s B) = ordertype B s"
	using FB \<open>small B\<close> ordertype_Field_Restr s by blast
	ultimately show ?lhs
	using iso_imp_ordertype_eq_ordertype FA FB \<open>small A\<close> r
	by (fastforce intro: total_on_imp_Total_Restr trans_Restr wf_Int1)
	qed

	lemma ordermap_insert:
	assumes "Ord \<alpha>" and y: "Ord y" "y \<le> \<alpha>" and U: "U \<subseteq> elts \<alpha>"
	shows "ordermap (insert \<alpha> U) VWF y = ordermap U VWF y"
	using y
	proof (induction rule: Ord_induct)
	case (step y)
	then have 1: "{u \<in> U. (u, y) \<in> VWF} = elts y \<inter> U"
	apply (simp add: set_eq_iff)
	by (meson Ord_in_Ord Ord_mem_iff_lt VWF_iff_Ord_less assms subsetD)
	have 2: "{u \<in> insert \<alpha> U. (u, y) \<in> VWF} = elts y \<inter> U"
	apply (simp add: set_eq_iff)
	by (meson Ord_in_Ord Ord_mem_iff_lt VWF_iff_Ord_less assms leD step.hyps step.prems subsetD)
	show ?case
	using step
	apply (simp only: ordermap [OF wf_VWF, of _ y] 1 2)
	by (meson Int_lower1 Ord_is_Transset Sup.SUP_cong Transset_def assms(1) in_mono vsubsetD)
	qed

	lemma ordertype_insert:
	assumes "Ord \<alpha>" and U: "U \<subseteq> elts \<alpha>"
	shows "ordertype (insert \<alpha> U) VWF = succ (ordertype U VWF)"
	proof -
	have \<dagger>: "{y \<in> insert \<alpha> U. (y, \<alpha>) \<in> VWF} = U" "{y \<in> U. (y, \<alpha>) \<in> VWF} = U"
	using Ord_in_Ord OrdmemD assms by auto
	have eq: "\<And>x. x \<in> U \<Longrightarrow> ordermap (insert \<alpha> U) VWF x = ordermap U VWF x"
	by (meson Ord_in_Ord Ord_is_Transset Transset_def U assms(1) in_mono ordermap_insert)
	have "ordertype (insert \<alpha> U) VWF =
	ZFC_in_HOL.set (insert (ordermap U VWF \<alpha>) (ordermap U VWF ` U))"
	by (simp add: ordertype_def ordermap_insert assms eq)
	also have "\<dots> = succ (ZFC_in_HOL.set (ordermap U VWF ` U))"
	using "\<dagger>" U by (simp add: ordermap [OF wf_VWF, of _ \<alpha>] down succ_def vinsert_def)
	also have "\<dots> = succ (ordertype U VWF)"
	by (simp add: ordertype_def)
	finally show ?thesis .
	qed

	lemma finite_ordertype_le_card:
	assumes "finite A" "wf r" "trans r"
	shows "ordertype A r \<le> ord_of_nat (card A)"
	proof -
	have "Ord (ordertype A r)"
	by (simp add: wf_Ord_ordertype assms)
	moreover have "ordermap A r ` A = elts (ordertype A r)"
	by (simp add: ordertype_def finite_imp_small \<open>finite A\<close>)
	moreover have "card (ordermap A r ` A) \<le> card A"
	using \<open>finite A\<close> card_image_le by blast
	ultimately show ?thesis
	by (metis Ord_linear_le Ord_ord_of_nat \<open>finite A\<close> card_ord_of_nat card_seteq finite_imageI less_eq_V_def)
	qed

	lemma ordertype_VWF_\<omega>:
	assumes "finite A"
	shows "ordertype A VWF \<in> elts \<omega>"
	proof -
	have "finite (ordermap A VWF ` A)"
	using assms by blast
	then have "ordertype A VWF < \<omega>"
	by (meson Ord_\<omega> OrdmemD trans_VWF wf_VWF assms finite_ordertype_le_card le_less_trans ord_of_nat_\<omega>)
	then show ?thesis
	by (simp add: Ord_mem_iff_lt)
	qed

	lemma ordertype_VWF_finite_nat:
	assumes "finite A"
	shows "ordertype A VWF = ord_of_nat (card A)"
	by (metis finite_imp_small ordermap_bij total_on_VWF wf_VWF \<omega>_def assms bij_betw_same_card card_ord_of_nat elts_of_set f_inv_into_f inf ordertype_VWF_\<omega>)

	lemma finite_ordertype_eq_card:
	assumes "small A" "wf r" "trans r" "total_on A r"
	shows "ordertype A r = ord_of_nat m \<longleftrightarrow> finite A \<and> card A = m"
	using ordermap_bij [OF \<open>wf r\<close>]
	proof -
	have *: "bij_betw (ordermap A r) A (elts (ordertype A r))"
	by (simp add: assms ordermap_bij)
	moreover have "card (ordermap A r ` A) = card A"
	by (meson bij_betw_def * card_image)
	ultimately show ?thesis
	using assms bij_betw_finite bij_betw_imp_surj_on finite_Ord_omega ordertype_VWF_finite_nat wf_Ord_ordertype by fastforce
	qed


	lemma ex_bij_betw_strict_mono_card:
	assumes "finite M" "M \<subseteq> ON"
	obtains h where "bij_betw h {..<card M} M" and "strict_mono_on h {..<card M}"
	proof -
	have bij: "bij_betw (ordermap M VWF) M (elts (card M))"
	using Finite_V \<open>finite M\<close> ordermap_bij ordertype_VWF_finite_nat by fastforce
	let ?h = "(inv_into M (ordermap M VWF)) \<circ> ord_of_nat"
	show thesis
	proof
	show bijh: "bij_betw ?h {..<card M} M"
	proof (rule bij_betw_trans)
	show "bij_betw ord_of_nat {..<card M} (elts (card M))"
	by (simp add: bij_betw_def elts_ord_of_nat inj_on_def)
	show "bij_betw (inv_into M (ordermap M VWF)) (elts (card M)) M"
	using Finite_V assms bij_betw_inv_into ordermap_bij ordertype_VWF_finite_nat by fastforce
	qed
	show "strict_mono_on ?h {..<card M}"
	proof -
	have "?h m < ?h n"
	if "m < n" "n < card M" for m n
	proof (rule ccontr)
	obtain mn: "m \<in> elts (ordertype M VWF)" "n \<in> elts (ordertype M VWF)"
	using \<open>m < n\<close> \<open>n < card M\<close> \<open>finite M\<close> ordertype_VWF_finite_nat by auto
	have ord: "Ord (?h m)" "Ord (?h n)"
	using bijh assms(2) bij_betwE that by fastforce+
	moreover
	assume "\<not> ?h m < ?h n"
	ultimately consider "?h m = ?h n" \| "?h m > ?h n"
	using Ord_linear_lt by blast
	then show False
	proof cases
	case 1
	then have "m = n"
	by (metis inv_ordermap_mono_eq mn comp_apply ord_of_nat_inject)
	with \<open>m < n\<close> show False by blast
	next
	case 2
	then have "ord_of_nat n \<le> ord_of_nat m"
	by (metis Finite_V mn assms comp_def inv_ordermap_VWF_mono_le less_imp_le)
	then show ?thesis
	using leD \<open>m < n\<close> by blast
	qed
	qed
	with assms show ?thesis
	by (auto simp: strict_mono_on_def)
	qed
	qed
	qed

	lemma ordertype_finite_less_than [simp]:
	assumes "finite A" shows "ordertype A less_than = card A"
	proof -
	let ?M = "ord_of_nat ` A"
	obtain M: "finite ?M" "?M \<subseteq> ON"
	using Ord_ord_of_nat assms by blast
	have "ordertype A less_than = ordertype ?M VWF"
	by (rule ordertype_inc_eq [symmetric]) (use assms finite_imp_small total_on_def in \<open>force+\<close>)
	also have "\<dots> = card A"
	proof (subst ordertype_eq_iff)
	let ?M = "ord_of_nat ` A"
	obtain h where bijh: "bij_betw h {..<card A} ?M" and smh: "strict_mono_on h {..<card A}"
	by (metis M card_image ex_bij_betw_strict_mono_card inj_on_def ord_of_nat_inject)
	define f where "f \<equiv> ord_of_nat \<circ> inv_into {..<card A} h"
	show "\<exists>f. bij_betw f ?M (elts (card A)) \<and> (\<forall>x\<in>?M. \<forall>y\<in>?M. f x < f y \<longleftrightarrow> ((x, y) \<in> VWF))"
	proof (intro exI conjI ballI)
	have "bij_betw (ord_of_nat \<circ> inv_into {..<card A} h) (ord_of_nat ` A) (ord_of_nat ` {..<card A})"
	by (meson UNIV_I bijh bij_betw_def bij_betw_inv_into bij_betw_subset bij_betw_trans inj_ord_of_nat subsetI)
	then show "bij_betw f ?M (elts (card A))"
	by (metis elts_ord_of_nat f_def)
	next
	fix x y
	assume xy: "x \<in> ?M" "y \<in> ?M"
	then obtain m n where "x = ord_of_nat m" "y = ord_of_nat n"
	by auto
	have "(f x < f y) \<longleftrightarrow> ((h \<circ> inv_into {..<card A} h) x < (h \<circ> inv_into {..<card A} h) y)"
	unfolding f_def using smh bij_betw_imp_surj_on [OF bijh]
	apply simp
	by (metis (mono_tags, lifting) inv_into_into not_less_iff_gr_or_eq order.asym strict_mono_onD xy)
	also have "\<dots> = (x < y)"
	using bijh
	by (simp add: bij_betw_inv_into_right xy)
	also have "\<dots> \<longleftrightarrow> ((x, y) \<in> VWF)"
	using M(2) ON_imp_Ord xy by auto
	finally show "(f x < f y) \<longleftrightarrow> ((x, y) \<in> VWF)" .
	qed
	qed auto
	finally show ?thesis .
	qed


	subsection\<open>Cardinality of a set\<close>

	definition vcard :: "V\<Rightarrow>V"
	where "vcard a \<equiv> (LEAST i. Ord i \<and> elts i \<approx> elts a)"

	definition Card:: "V\<Rightarrow>bool"
	where "Card i \<equiv> i = vcard i"

	abbreviation CARD where "CARD \<equiv> Collect Card"

	lemma cardinal_cong: "elts x \<approx> elts y \<Longrightarrow> vcard x = vcard y"
	unfolding vcard_def by (meson eqpoll_sym eqpoll_trans)

	+lemma vcard_set_image: "inj_on f (elts x) \<Longrightarrow> vcard (set (f ` elts x)) = vcard x"
	+ by (simp add: cardinal_cong)
	+
	lemma Card_cardinal_eq: "Card \<kappa> \<Longrightarrow> vcard \<kappa> = \<kappa>"
	by (simp add: Card_def)

	lemma Card_is_Ord:
	assumes "Card \<kappa>" shows "Ord \<kappa>"
	proof -
	obtain \<alpha> where "Ord \<alpha>" "elts \<alpha> \<approx> elts \<kappa>"
	using Ord_ordertype ordertype_eqpoll by blast
	then have "Ord (LEAST i. Ord i \<and> elts i \<approx> elts \<kappa>)"
	by (metis Ord_Least)
	then show ?thesis
	using Card_def vcard_def assms by auto
	qed

	lemma cardinal_eqpoll: "elts (vcard a) \<approx> elts a"
	unfolding vcard_def
	using ordertype_eqpoll [of "elts a"] Ord_LeastI by (meson Ord_ordertype small_elts)

	lemma inj_into_vcard:
	obtains f where "f \<in> elts A \<rightarrow> elts (vcard A)" "inj_on f (elts A)"
	using cardinal_eqpoll [of A] inj_on_the_inv_into the_inv_into_onto
	by (fastforce simp: Pi_iff bij_betw_def eqpoll_def)

	lemma cardinal_idem [simp]: "vcard (vcard a) = vcard a"
	using cardinal_cong cardinal_eqpoll by blast

	+lemma subset_smaller_vcard:
	+ assumes "\<kappa> \<le> vcard x" "Card \<kappa>"
	+ obtains y where "y \<le> x" "vcard y = \<kappa>"
	+proof -
	+ obtain \<phi> where \<phi>: "bij_betw \<phi> (elts (vcard x)) (elts x)"
	+ using cardinal_eqpoll eqpoll_def by blast
	+ show thesis
	+ proof
	+ let ?y = "ZFC_in_HOL.set (\<phi> ` elts \<kappa>)"
	+ show "?y \<le> x"
	+ by (meson \<phi> assms bij_betwE set_image_le_iff small_elts vsubsetD)
	+ show "vcard ?y = \<kappa>"
	+ by (metis vcard_set_image Card_def assms bij_betw_def bij_betw_subset \<phi> less_eq_V_def)
	+ qed
	+qed
	+
	text\<open>every natural number is a (finite) cardinal\<close>
	lemma nat_into_Card:
	assumes "\<alpha> \<in> elts \<omega>" shows "Card(\<alpha>)"
	proof (unfold Card_def vcard_def, rule sym)
	obtain n where n: "\<alpha> = ord_of_nat n"
	by (metis \<omega>_def assms elts_of_set imageE inf)
	have "Ord(\<alpha>)" using assms by auto
	moreover
	{ fix \<beta>
	assume "\<beta> < \<alpha>" "Ord \<beta>" "elts \<beta> \<approx> elts \<alpha>"
	with n have "elts \<beta> \<approx> {..<n}"
	by (simp add: ord_of_nat_eq_initial [of n] eqpoll_trans inj_on_def inj_on_image_eqpoll_self)
	hence False using assms n \<open>Ord \<beta>\<close> \<open>\<beta> < \<alpha>\<close> \<open>Ord(\<alpha>)\<close>
	by (metis \<open>elts \<beta> \<approx> elts \<alpha>\<close> card_seteq eqpoll_finite_iff eqpoll_iff_card finite_lessThan less_eq_V_def less_le_not_le order_refl)
	}
	ultimately
	show "(LEAST i. Ord i \<and> elts i \<approx> elts \<alpha>) = \<alpha>"
	by (metis (no_types, lifting) Least_equality Ord_linear_le eqpoll_refl less_le_not_le)
	qed

	lemma Card_ord_of_nat [simp]: "Card (ord_of_nat n)"
	by (simp add: \<omega>_def nat_into_Card)

	lemma Card_0 [iff]: "Card 0"
	by (simp add: nat_into_Card)

	lemma CardI: "\<lbrakk>Ord i; \<And>j. \<lbrakk>j < i; Ord j\<rbrakk> \<Longrightarrow> \<not> elts j \<approx> elts i\<rbrakk> \<Longrightarrow> Card i"
	unfolding Card_def vcard_def
	by (metis Ord_Least Ord_linear_lt cardinal_eqpoll eqpoll_refl not_less_Ord_Least vcard_def)

	lemma vcard_0 [simp]: "vcard 0 = 0"
	using Card_0 Card_def by auto

	lemma Ord_cardinal [simp,intro!]: "Ord(vcard a)"
	unfolding vcard_def by (metis Card_def Card_is_Ord cardinal_cong cardinal_eqpoll vcard_def)

	text\<open>The cardinals are the initial ordinals.\<close>
	lemma Card_iff_initial: "Card \<kappa> \<longleftrightarrow> Ord \<kappa> \<and> (\<forall>\<alpha>. Ord \<alpha> \<and> \<alpha> < \<kappa> \<longrightarrow> ~ elts \<alpha> \<approx> elts \<kappa>)"
	proof -
	{ fix j
	assume \<kappa>: "Card \<kappa>" "elts j \<approx> elts \<kappa>" "Ord j"
	assume "j < \<kappa>"
	also have "\<dots> = (LEAST i. Ord i \<and> elts i \<approx> elts \<kappa>)" using \<kappa>
	by (simp add: Card_def vcard_def)
	finally have "j < (LEAST i. Ord i \<and> elts i \<approx> elts \<kappa>)" .
	hence "False" using \<kappa>
	using not_less_Ord_Least by fastforce
	}
	then show ?thesis
	by (blast intro: CardI Card_is_Ord)
	qed

	lemma Card_\<omega> [iff]: "Card \<omega>"
	proof -
	have "\<And>\<alpha> f. \<lbrakk>\<alpha> \<in> elts \<omega>; bij_betw f (elts \<alpha>) (elts \<omega>)\<rbrakk> \<Longrightarrow> False"
	using bij_betw_finite finite_Ord_omega infinite_\<omega> by blast
	then show ?thesis
	by (meson CardI Ord_\<omega> Ord_mem_iff_lt eqpoll_def)
	qed

	lemma lt_Card_imp_lesspoll: "\<lbrakk>i < a; Card a; Ord i\<rbrakk> \<Longrightarrow> elts i \<prec> elts a"
	by (meson Card_iff_initial less_eq_V_def less_imp_le lesspoll_def subset_imp_lepoll)

	lemma lepoll_imp_Card_le:
	assumes "elts a \<lesssim> elts b" shows "vcard a \<le> vcard b"
	using Ord_cardinal [of a] Ord_cardinal [of b]
	proof (cases rule: Ord_linear_le)
	case le thus ?thesis .
	next
	case ge
	have "elts b \<approx> elts (vcard b)"
	by (simp add: cardinal_eqpoll eqpoll_sym)
	also have "\<dots> \<lesssim> elts (vcard a)"
	by (meson ge less_eq_V_def subset_imp_lepoll)
	also have "\<dots> \<approx> elts a"
	by (simp add: cardinal_eqpoll)
	finally have "elts b \<lesssim> elts a" .
	hence "elts a \<approx> elts b"
	using assms lepoll_antisym by blast
	hence "vcard a = vcard b"
	by (rule cardinal_cong)
	thus ?thesis by simp
	qed

	lemma lepoll_cardinal_le: "\<lbrakk>elts A \<lesssim> elts i; Ord i\<rbrakk> \<Longrightarrow> vcard A \<le> i"
	by (metis Ord_Least Ord_linear2 dual_order.trans eqpoll_refl lepoll_imp_Card_le not_less_Ord_Least vcard_def)

	lemma cardinal_le_lepoll: "vcard A \<le> \<alpha> \<Longrightarrow> elts A \<lesssim> elts \<alpha>"
	by (meson cardinal_eqpoll eqpoll_sym lepoll_trans1 less_eq_V_def subset_imp_lepoll)

	lemma lesspoll_imp_Card_less:
	assumes "elts a \<prec> elts b" shows "vcard a < vcard b"
	by (metis assms cardinal_eqpoll eqpoll_sym eqpoll_trans le_neq_trans lepoll_imp_Card_le lesspoll_def)


	lemma Card_Union [simp,intro]:
	assumes A: "\<And>x. x \<in> A \<Longrightarrow> Card(x)" shows "Card(\<Squnion>A)"
	proof (rule CardI)
	show "Ord(\<Squnion>A)" using A
	by (simp add: Card_is_Ord Ord_Sup)
	next
	fix j
	assume j: "j < \<Squnion>A" "Ord j"
	hence "\<exists>c\<in>A. j < c \<and> Card(c)" using A
	by (meson Card_is_Ord Ord_linear2 ZFC_in_HOL.Sup_least leD)
	then obtain c where c: "c\<in>A" "j < c" "Card(c)"
	by blast
	hence jls: "elts j \<prec> elts c"
	using j(2) lt_Card_imp_lesspoll by blast
	{ assume eqp: "elts j \<approx> elts (\<Squnion>A)"
	have "elts c \<lesssim> elts (\<Squnion>A)" using c
	using Sup_V_def ZFC_in_HOL.Sup_upper j(1) less_eq_V_def subset_imp_lepoll by fastforce
	also have "... \<approx> elts j" by (rule eqpoll_sym [OF eqp])
	also have "... \<prec> elts c" by (rule jls)
	finally have "elts c \<prec> elts c" .
	hence False
	by auto
	} thus "\<not> elts j \<approx> elts (\<Squnion>A)" by blast
	qed

	lemma Card_UN: "(\<And>x. x \<in> A \<Longrightarrow> Card(K x)) ==> Card(Sup (K ` A))"
	by blast

	subsection\<open>Transfinite recursion for definitions based on the three cases of ordinals\<close>

	definition
	transrec3 :: "[V, [V,V]\<Rightarrow>V, [V,V\<Rightarrow>V]\<Rightarrow>V, V] \<Rightarrow> V" where
	"transrec3 a b c \<equiv>
	transrec (\<lambda>r x.
	if x=0 then a
	else if Limit x then c x (\<lambda>y \<in> elts x. r y)
	else b(pred x) (r (pred x)))"

	lemma transrec3_0 [simp]: "transrec3 a b c 0 = a"
	by (simp add: transrec transrec3_def)

	lemma transrec3_succ [simp]:
	"transrec3 a b c (succ i) = b i (transrec3 a b c i)"
	by (simp add: transrec transrec3_def)

	lemma transrec3_Limit [simp]:
	"Limit i \<Longrightarrow> transrec3 a b c i = c i (\<lambda>j \<in> elts i. transrec3 a b c j)"
	unfolding transrec3_def
	by (subst transrec) auto


	subsection \<open>Cardinal Addition\<close>

	definition cadd :: "[V,V]\<Rightarrow>V" (infixl \<open>\<oplus>\<close> 65)
	where "\<kappa> \<oplus> \<mu> \<equiv> vcard (\<kappa> \<Uplus> \<mu>)"

	subsubsection\<open>Cardinal addition is commutative\<close>

	lemma vsum_commute_eqpoll: "elts (a\<Uplus>b) \<approx> elts (b\<Uplus>a)"
	proof -
	have "bij_betw (\<lambda>z \<in> elts (a\<Uplus>b). sum_case Inr Inl z) (elts (a\<Uplus>b)) (elts (b\<Uplus>a))"
	unfolding bij_betw_def
	proof (intro conjI inj_onI)
	show "restrict (sum_case Inr Inl) (elts (a \<Uplus> b)) ` elts (a \<Uplus> b) = elts (b \<Uplus> a)"
	apply auto
	apply (metis (no_types) imageI sum_case_Inr sum_iff)
	by (metis Inl_in_sum_iff imageI sum_case_Inl)
	qed auto
	then show ?thesis
	using eqpoll_def by blast
	qed

	lemma cadd_commute: "i \<oplus> j = j \<oplus> i"
	by (simp add: cadd_def cardinal_cong vsum_commute_eqpoll)

	subsubsection\<open>Cardinal addition is associative\<close>

	lemma sum_assoc_bij:
	"bij_betw (\<lambda>z \<in> elts ((a\<Uplus>b)\<Uplus>c). sum_case(sum_case Inl (\<lambda>y. Inr(Inl y))) (\<lambda>y. Inr(Inr y)) z)
	(elts ((a\<Uplus>b)\<Uplus>c)) (elts (a\<Uplus>(b\<Uplus>c)))"
	by (rule_tac f' = "sum_case (\<lambda>x. Inl (Inl x)) (sum_case (\<lambda>x. Inl (Inr x)) Inr)"
	in bij_betw_byWitness) auto

	lemma sum_assoc_eqpoll: "elts ((a\<Uplus>b)\<Uplus>c) \<approx> elts (a\<Uplus>(b\<Uplus>c))"
	unfolding eqpoll_def by (metis sum_assoc_bij)

	lemma elts_vcard_vsum_eqpoll: "elts (vcard (i \<Uplus> j)) \<approx> Inl ` elts i \<union> Inr ` elts j"
	proof -
	have "elts (i \<Uplus> j) \<approx> Inl ` elts i \<union> Inr ` elts j"
	by (simp add: elts_vsum)
	then show ?thesis
	using cardinal_eqpoll eqpoll_trans by blast
	qed

	lemma cadd_assoc: "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
	proof (unfold cadd_def, rule cardinal_cong)
	have "elts (vcard(i \<Uplus> j) \<Uplus> k) \<approx> elts ((i \<Uplus> j) \<Uplus> k)"
	by (auto simp: disjnt_def elts_vsum elts_vcard_vsum_eqpoll intro: Un_eqpoll_cong)
	also have "\<dots> \<approx> elts (i \<Uplus> (j \<Uplus> k))"
	by (rule sum_assoc_eqpoll)
	also have "\<dots> \<approx> elts (i \<Uplus> vcard(j \<Uplus> k))"
	by (auto simp: disjnt_def elts_vsum elts_vcard_vsum_eqpoll [THEN eqpoll_sym] intro: Un_eqpoll_cong)
	finally show "elts (vcard (i \<Uplus> j) \<Uplus> k) \<approx> elts (i \<Uplus> vcard (j \<Uplus> k))" .
	qed

	+lemma cadd_left_commute: "j \<oplus> (i \<oplus> k) = i \<oplus> (j \<oplus> k)"
	+ using cadd_assoc cadd_commute by force
	+
	+lemmas cadd_ac = cadd_assoc cadd_commute cadd_left_commute

	text\<open>0 is the identity for addition\<close>
	lemma vsum_0_eqpoll: "elts (0\<Uplus>a) \<approx> elts a"
	by (simp add: elts_vsum)

	lemma cadd_0 [simp]: "Card \<kappa> \<Longrightarrow> 0 \<oplus> \<kappa> = \<kappa>"
	by (metis Card_def cadd_def cardinal_cong vsum_0_eqpoll)

	lemma cadd_0_right [simp]: "Card \<kappa> \<Longrightarrow> \<kappa> \<oplus> 0 = \<kappa>"
	by (simp add: cadd_commute)

	lemma vsum_lepoll_self: "elts a \<lesssim> elts (a\<Uplus>b)"
	unfolding elts_vsum by (meson Inl_iff Un_upper1 inj_onI lepoll_def)

	lemma cadd_le_self:
	assumes \<kappa>: "Card \<kappa>" shows "\<kappa> \<le> \<kappa> \<oplus> a"
	proof (unfold cadd_def)
	have "\<kappa> \<le> vcard \<kappa>"
	using Card_def \<kappa> by auto
	also have "\<dots> \<le> vcard (\<kappa> \<Uplus> a)"
	by (simp add: lepoll_imp_Card_le vsum_lepoll_self)
	finally show "\<kappa> \<le> vcard (\<kappa> \<Uplus> a)" .
	qed

	text\<open>Monotonicity of addition\<close>
	lemma cadd_le_mono: "\<lbrakk>\<kappa>' \<le> \<kappa>; \<mu>' \<le> \<mu>\<rbrakk> \<Longrightarrow> \<kappa>' \<oplus> \<mu>' \<le> \<kappa> \<oplus> \<mu>"
	unfolding cadd_def
	by (metis (no_types) lepoll_imp_Card_le less_eq_V_def subset_imp_lepoll sum_subset_iff)

	subsection\<open>Cardinal multiplication\<close>

	definition cmult :: "[V,V]\<Rightarrow>V" (infixl \<open>\<otimes>\<close> 70)
	where "\<kappa> \<otimes> \<mu> \<equiv> vcard (VSigma \<kappa> (\<lambda>z. \<mu>))"

	subsubsection\<open>Cardinal multiplication is commutative\<close>

	lemma prod_bij: "\<lbrakk>bij_betw f A C; bij_betw g B D\<rbrakk>
	\<Longrightarrow> bij_betw (\<lambda>(x, y). (f x, g y)) (A \<times> B) (C \<times> D)"
	apply (rule bij_betw_byWitness [where f' = "\<lambda>(x,y). (inv_into A f x, inv_into B g y)"])
	apply (auto simp: bij_betw_inv_into_left bij_betw_inv_into_right bij_betwE)
	using bij_betwE bij_betw_inv_into apply blast+
	done

	lemma cmult_commute: "i \<otimes> j = j \<otimes> i"
	proof -
	have "(\<lambda>(x, y). \<langle>x, y\<rangle>) ` (elts i \<times> elts j) \<approx> (\<lambda>(x, y). \<langle>x, y\<rangle>) ` (elts j \<times> elts i)"
	- by (simp add: inj_on_vpair times_commute_eqpoll)
	+ by (simp add: times_commute_eqpoll)
	then show ?thesis
	unfolding cmult_def
	using cardinal_cong elts_VSigma by auto
	qed

	subsubsection\<open>Cardinal multiplication is associative\<close>

	lemma elts_vcard_VSigma_eqpoll: "elts (vcard (vtimes i j)) \<approx> elts i \<times> elts j"
	proof -
	have "elts (vtimes i j) \<approx> elts i \<times> elts j"
	by (simp add: elts_VSigma)
	then show ?thesis
	using cardinal_eqpoll eqpoll_trans by blast
	qed

	+lemma elts_cmult: "elts (\<kappa>' \<otimes> \<kappa>) \<approx> elts \<kappa>' \<times> elts \<kappa>"
	+ by (simp add: cmult_def elts_vcard_VSigma_eqpoll)
	+
	lemma cmult_assoc: "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
	unfolding cmult_def
	proof (rule cardinal_cong)
	have "elts (vcard (vtimes i j)) \<times> elts k \<approx> (elts i \<times> elts j) \<times> elts k"
	by (blast intro: times_eqpoll_cong elts_vcard_VSigma_eqpoll cardinal_eqpoll)
	also have "\<dots> \<approx> elts i \<times> (elts j \<times> elts k)"
	by (rule times_assoc_eqpoll)
	also have "\<dots> \<approx> elts i \<times> elts (vcard (vtimes j k))"
	by (blast intro: times_eqpoll_cong elts_vcard_VSigma_eqpoll cardinal_eqpoll eqpoll_sym)
	finally show "elts (VSigma (vcard (vtimes i j)) (\<lambda>z. k)) \<approx> elts (VSigma i (\<lambda>z. vcard (vtimes j k)))"
	by (simp add: elts_VSigma)
	qed

	subsubsection\<open>Cardinal multiplication distributes over addition\<close>

	lemma cadd_cmult_distrib: "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
	unfolding cadd_def cmult_def
	proof (rule cardinal_cong)
	have "elts (vtimes (vcard (i \<Uplus> j)) k) \<approx> elts (vcard (vsum i j)) \<times> elts k"
	using cardinal_eqpoll elts_vcard_VSigma_eqpoll eqpoll_sym eqpoll_trans by blast
	also have "\<dots> \<approx> (Inl ` elts i \<union> Inr ` elts j) \<times> elts k"
	using elts_vcard_vsum_eqpoll times_eqpoll_cong by blast
	also have "\<dots> \<approx> (Inl ` elts i) \<times> elts k \<union> (Inr ` elts j) \<times> elts k"
	by (simp add: Sigma_Un_distrib1)
	also have "\<dots> \<approx> elts (vtimes i k \<Uplus> vtimes j k)"
	unfolding Plus_def
	by (auto simp: elts_vsum elts_VSigma disjnt_iff intro!: Un_eqpoll_cong times_eqpoll_cong)
	also have "\<dots> \<approx> elts (vcard (vtimes i k \<Uplus> vtimes j k))"
	by (simp add: cardinal_eqpoll eqpoll_sym)
	also have "\<dots> \<approx> elts (vcard (vtimes i k) \<Uplus> vcard (vtimes j k))"
	by (metis cadd_assoc cadd_def cardinal_cong cardinal_eqpoll vsum_0_eqpoll vsum_commute_eqpoll)
	finally show "elts (VSigma (vcard (i \<Uplus> j)) (\<lambda>z. k))
	\<approx> elts (vcard (vtimes i k) \<Uplus> vcard (vtimes j k))" .
	qed

	text\<open>Multiplication by 0 yields 0\<close>
	lemma cmult_0 [simp]: "0 \<otimes> i = 0"
	using Card_0 Card_def cmult_def by auto

	text\<open>1 is the identity for multiplication\<close>
	lemma cmult_1 [simp]: assumes "Card \<kappa>" shows "1 \<otimes> \<kappa> = \<kappa>"
	proof -
	have "elts (vtimes (set {0}) \<kappa>) \<approx> elts \<kappa>"
	by (auto simp: elts_VSigma intro!: times_singleton_eqpoll)
	then show ?thesis
	by (metis Card_def assms cardinal_cong cmult_def elts_1 set_of_elts)
	qed

	subsection\<open>Some inequalities for multiplication\<close>

	lemma cmult_square_le: assumes "Card \<kappa>" shows "\<kappa> \<le> \<kappa> \<otimes> \<kappa>"
	proof -
	have "elts \<kappa> \<lesssim> elts (\<kappa> \<otimes> \<kappa>)"
	using times_square_lepoll [of "elts \<kappa>"] cmult_def elts_vcard_VSigma_eqpoll eqpoll_sym lepoll_trans2
	by fastforce
	then show ?thesis
	using Card_def assms cmult_def lepoll_cardinal_le by fastforce
	qed

	text\<open>Multiplication by a non-empty set\<close>
	lemma cmult_le_self: assumes "Card \<kappa>" "\<alpha> \<noteq> 0" shows "\<kappa> \<le> \<kappa> \<otimes> \<alpha>"
	proof -
	have "\<kappa> = vcard \<kappa>"
	using Card_def \<open>Card \<kappa>\<close> by blast
	also have "\<dots> \<le> vcard (vtimes \<kappa> \<alpha>)"
	apply (rule lepoll_imp_Card_le)
	apply (simp add: elts_VSigma)
	by (metis ZFC_in_HOL.ext \<open>\<alpha> \<noteq> 0\<close> elts_0 lepoll_times1)
	also have "\<dots> = \<kappa> \<otimes> \<alpha>"
	by (simp add: cmult_def)
	finally show ?thesis .
	qed


	text\<open>Monotonicity of multiplication\<close>
	lemma cmult_le_mono: "\<lbrakk>\<kappa>' \<le> \<kappa>; \<mu>' \<le> \<mu>\<rbrakk> \<Longrightarrow> \<kappa>' \<otimes> \<mu>' \<le> \<kappa> \<otimes> \<mu>"
	unfolding cmult_def
	by (auto simp: elts_VSigma intro!: lepoll_imp_Card_le times_lepoll_mono subset_imp_lepoll)

	+lemma vcard_Sup_le_cmult:
	+ assumes "small U" and \<kappa>: "\<And>x. x \<in> U \<Longrightarrow> vcard x \<le> \<kappa>"
	+ shows "vcard (\<Squnion>U) \<le> vcard (set U) \<otimes> \<kappa>"
	+proof -
	+ have "\<exists>f. f \<in> elts x \<rightarrow> elts \<kappa> \<and> inj_on f (elts x)" if "x \<in> U" for x
	+ using \<kappa> [OF that] by (metis cardinal_le_lepoll image_subset_iff_funcset lepoll_def)
	+ then obtain \<phi> where \<phi>: "\<And>x. x \<in> U \<Longrightarrow> (\<phi> x) \<in> elts x \<rightarrow> elts \<kappa> \<and> inj_on (\<phi> x) (elts x)"
	+ by metis
	+ define u where "u \<equiv> \<lambda>y. @x. x \<in> U \<and> y \<in> elts x"
	+ have u: "u y \<in> U \<and> y \<in> elts (u y)" if "y \<in> \<Union>(elts ` U)" for y
	+ unfolding u_def by (metis (mono_tags, lifting)that someI2_ex UN_iff)
	+ define \<psi> where "\<psi> \<equiv> \<lambda>y. (u y, \<phi> (u y) y)"
	+ have U: "elts (vcard (set U)) \<approx> U"
	+ by (metis \<open>small U\<close> cardinal_eqpoll elts_of_set)
	+ have "elts (\<Squnion>U) = \<Union>(elts ` U)"
	+ using \<open>small U\<close> by blast
	+ also have "\<dots> \<lesssim> U \<times> elts \<kappa>"
	+ unfolding lepoll_def
	+ proof (intro exI conjI)
	+ show "inj_on \<psi> (\<Union> (elts ` U))"
	+ using \<phi> u by (smt (verit) \<psi>_def inj_on_def prod.inject)
	+ show "\<psi> ` \<Union> (elts ` U) \<subseteq> U \<times> elts \<kappa>"
	+ using \<phi> u by (auto simp: \<psi>_def)
	+ qed
	+ also have "\<dots> \<approx> elts (vcard (set U) \<otimes> \<kappa>)"
	+ using U elts_cmult eqpoll_sym eqpoll_trans times_eqpoll_cong by blast
	+ finally have "elts (\<Squnion> U) \<lesssim> elts (vcard (set U) \<otimes> \<kappa>)" .
	+ then show ?thesis
	+ by (simp add: cmult_def lepoll_cardinal_le)
	+qed

	subsection\<open>The finite cardinals\<close>

	lemma succ_lepoll_succD: "elts (succ(m)) \<lesssim> elts (succ(n)) \<Longrightarrow> elts m \<lesssim> elts n"
	by (simp add: insert_lepoll_insertD)


	text\<open>Congruence law for @{text succ} under equipollence\<close>
	lemma succ_eqpoll_cong: "elts a \<approx> elts b \<Longrightarrow> elts (succ(a)) \<approx> elts (succ(b))"
	by (simp add: succ_def insert_eqpoll_cong)

	lemma sum_succ_eqpoll: "elts (succ a \<Uplus> b) \<approx> elts (succ(a\<Uplus>b))"
	unfolding eqpoll_def
	proof (rule exI)
	let ?f = "\<lambda>z. if z=Inl a then a\<Uplus>b else z"
	let ?g = "\<lambda>z. if z=a\<Uplus>b then Inl a else z"
	show "bij_betw ?f (elts (succ a \<Uplus> b)) (elts (succ (a \<Uplus> b)))"
	apply (rule bij_betw_byWitness [where f' = ?g], auto)
	apply (metis Inl_in_sum_iff mem_not_refl)
	by (metis Inr_in_sum_iff mem_not_refl)
	qed

	lemma cadd_succ: "succ m \<oplus> n = vcard (succ(m \<oplus> n))"
	proof (unfold cadd_def)
	have [intro]: "elts (m \<Uplus> n) \<approx> elts (vcard (m \<Uplus> n))"
	using cardinal_eqpoll eqpoll_sym by blast
	have "vcard (succ m \<Uplus> n) = vcard (succ(m \<Uplus> n))"
	by (rule sum_succ_eqpoll [THEN cardinal_cong])
	also have "\<dots> = vcard (succ(vcard (m \<Uplus> n)))"
	by (blast intro: succ_eqpoll_cong cardinal_cong)
	finally show "vcard (succ m \<Uplus> n) = vcard (succ(vcard (m \<Uplus> n)))" .
	qed

	lemma nat_cadd_eq_add: "ord_of_nat m \<oplus> ord_of_nat n = ord_of_nat (m + n)"
	proof (induct m)
	case (Suc m) thus ?case
	by (metis Card_def Card_ord_of_nat add_Suc cadd_succ ord_of_nat.simps(2))
	qed auto

	lemma vcard_disjoint_sup:
	assumes "x \<sqinter> y = 0" shows "vcard (x \<squnion> y) = vcard x \<oplus> vcard y"
	proof -
	have "elts (x \<squnion> y) \<approx> elts (x \<Uplus> y)"
	unfolding eqpoll_def
	proof (rule exI)
	let ?f = "\<lambda>z. if z \<in> elts x then Inl z else Inr z"
	let ?g = "sum_case id id"
	show "bij_betw ?f (elts (x \<squnion> y)) (elts (x \<Uplus> y))"
	by (rule bij_betw_byWitness [where f' = ?g]) (use assms V_disjoint_iff in auto)
	qed
	then show ?thesis
	by (metis cadd_commute cadd_def cardinal_cong cardinal_idem vsum_0_eqpoll cadd_assoc)
	qed

	+lemma vcard_sup: "vcard (x \<squnion> y) \<le> vcard x \<oplus> vcard y"
	+proof -
	+ have "elts (x \<squnion> y) \<lesssim> elts (x \<Uplus> y)"
	+ unfolding lepoll_def
	+ proof (intro exI conjI)
	+ let ?f = "\<lambda>z. if z \<in> elts x then Inl z else Inr z"
	+ show "inj_on ?f (elts (x \<squnion> y))"
	+ by (simp add: inj_on_def)
	+ show "?f ` elts (x \<squnion> y) \<subseteq> elts (x \<Uplus> y)"
	+ by force
	+ qed
	+ then show ?thesis
	+ using cadd_ac
	+ by (metis cadd_def cardinal_cong cardinal_idem lepoll_imp_Card_le vsum_0_eqpoll)
	+qed

	subsection\<open>Infinite cardinals\<close>

	definition InfCard :: "V\<Rightarrow>bool"
	where "InfCard \<kappa> \<equiv> Card \<kappa> \<and> \<omega> \<le> \<kappa>"

	lemma InfCard_iff: "InfCard \<kappa> \<longleftrightarrow> Card \<kappa> \<and> infinite (elts \<kappa>)"
	proof (cases "\<omega> \<le> \<kappa>")
	case True
	then show ?thesis
	using inj_ord_of_nat lepoll_def less_eq_V_def
	by (auto simp: InfCard_def \<omega>_def infinite_le_lepoll)
	next
	case False
	then show ?thesis
	using Card_iff_initial InfCard_def infinite_Ord_omega by blast
	qed

	lemma InfCard_ge_ord_of_nat:
	assumes "InfCard \<kappa>" shows "ord_of_nat n \<le> \<kappa>"
	using InfCard_def assms ord_of_nat_le_omega by blast

	lemma InfCard_not_0[iff]: "\<not> InfCard 0"
	by (simp add: InfCard_iff)

	definition csucc :: "V\<Rightarrow>V"
	where "csucc \<kappa> \<equiv> LEAST \<kappa>'. Ord \<kappa>' \<and> (Card \<kappa>' \<and> \<kappa> < \<kappa>')"


	lemma less_vcard_VPow: "vcard A < vcard (VPow A)"
	proof (rule lesspoll_imp_Card_less)
	show "elts A \<prec> elts (VPow A)"
	by (simp add: elts_VPow down inj_on_def lesspoll_Pow_self)
	qed

	lemma greater_Card:
	assumes "Card \<kappa>" shows "\<kappa> < vcard (VPow \<kappa>)"
	proof -
	have "\<kappa> = vcard \<kappa>"
	using Card_def assms by blast
	also have "\<dots> < vcard (VPow \<kappa>)"
	proof (rule lesspoll_imp_Card_less)
	show "elts \<kappa> \<prec> elts (VPow \<kappa>)"
	by (simp add: elts_VPow down inj_on_def lesspoll_Pow_self)
	qed
	finally show ?thesis .
	qed

	lemma
	assumes "Card \<kappa>"
	shows Card_csucc [simp]: "Card (csucc \<kappa>)" and less_csucc [simp]: "\<kappa> < csucc \<kappa>"
	proof -
	have "Card (csucc \<kappa>) \<and> \<kappa> < csucc \<kappa>"
	unfolding csucc_def
	proof (rule Ord_LeastI2)
	show "Card (vcard (VPow \<kappa>)) \<and> \<kappa> < (vcard (VPow \<kappa>))"
	using Card_def assms greater_Card by auto
	qed auto
	then show "Card (csucc \<kappa>)" "\<kappa> < csucc \<kappa>"
	by auto
	qed

	lemma le_csucc:
	assumes "Card \<kappa>" shows "\<kappa> \<le> csucc \<kappa>"
	by (simp add: assms less_csucc less_imp_le)


	lemma csucc_le: "\<lbrakk>Card \<mu>; \<kappa> \<in> elts \<mu>\<rbrakk> \<Longrightarrow> csucc \<kappa> \<le> \<mu>"
	unfolding csucc_def
	by (simp add: Card_is_Ord Ord_Least_le OrdmemD)

	lemma finite_csucc: "a \<in> elts \<omega> \<Longrightarrow> csucc a = succ a"
	unfolding csucc_def
	proof (rule Least_equality)
	show "Ord (ZFC_in_HOL.succ a) \<and> Card (ZFC_in_HOL.succ a) \<and> a < ZFC_in_HOL.succ a"
	if "a \<in> elts \<omega>"
	using that by (auto simp: less_V_def less_eq_V_def nat_into_Card)
	show "ZFC_in_HOL.succ a \<le> y"
	if "a \<in> elts \<omega>"
	and "Ord y \<and> Card y \<and> a < y"
	for y :: V
	using that
	using Ord_mem_iff_lt dual_order.strict_implies_order by fastforce
	qed

	lemma Finite_imp_cardinal_cons [simp]:
	assumes FA: "finite A" and a: "a \<notin> A"
	shows "vcard (set (insert a A)) = csucc(vcard (set A))"
	proof -
	show ?thesis
	unfolding csucc_def
	proof (rule Least_equality [THEN sym])
	have "small A"
	by (simp add: FA Finite_V)
	then have "\<not> elts (set A) \<approx> elts (set (insert a A))"
	using FA a eqpoll_imp_lepoll eqpoll_sym finite_insert_lepoll by fastforce
	then show "Ord (vcard (set (insert a A))) \<and> Card (vcard (set (insert a A))) \<and> vcard (set A) < vcard (set (insert a A))"
	by (simp add: Card_def lesspoll_imp_Card_less lesspoll_def subset_imp_lepoll subset_insertI)
	show "vcard (set (insert a A)) \<le> i"
	if "Ord i \<and> Card i \<and> vcard (set A) < i" for i
	proof -
	have "elts (vcard (set A)) \<approx> A"
	by (metis FA finite_imp_small cardinal_eqpoll elts_of_set)
	then have less: "A \<prec> elts i"
	using eq_lesspoll_trans eqpoll_sym lt_Card_imp_lesspoll that by blast
	show ?thesis
	using that less by (auto simp: less_imp_insert_lepoll lepoll_cardinal_le)
	qed
	qed
	qed

	lemma vcard_finite_set: "finite A \<Longrightarrow> vcard (set A) = ord_of_nat (card A)"
	by (induction A rule: finite_induct) (auto simp: set_empty \<omega>_def finite_csucc)

	lemma lt_csucc_iff:
	assumes "Ord \<alpha>" "Card \<kappa>"
	shows "\<alpha> < csucc \<kappa> \<longleftrightarrow> vcard \<alpha> \<le> \<kappa>"
	proof
	show "vcard \<alpha> \<le> \<kappa>" if "\<alpha> < csucc \<kappa>"
	proof -
	have "vcard \<alpha> \<le> csucc \<kappa>"
	by (meson \<open>Ord \<alpha>\<close> dual_order.trans lepoll_cardinal_le lepoll_refl less_le_not_le that)
	then show ?thesis
	by (metis (no_types) Card_def Card_iff_initial Ord_linear2 Ord_mem_iff_lt assms cardinal_eqpoll cardinal_idem csucc_le eq_iff eqpoll_sym that)
	qed
	show "\<alpha> < csucc \<kappa>" if "vcard \<alpha> \<le> \<kappa>"
	proof -
	have "\<not> csucc \<kappa> \<le> \<alpha>"
	using that
	by (metis Card_csucc Card_def assms(2) le_less_trans lepoll_imp_Card_le less_csucc less_eq_V_def less_le_not_le subset_imp_lepoll)
	then show ?thesis
	by (meson Card_csucc Card_is_Ord Ord_linear2 assms)
	qed
	qed

	lemma Card_lt_csucc_iff: "\<lbrakk>Card \<kappa>'; Card \<kappa>\<rbrakk> \<Longrightarrow> (\<kappa>' < csucc \<kappa>) = (\<kappa>' \<le> \<kappa>)"
	by (simp add: lt_csucc_iff Card_cardinal_eq Card_is_Ord)

	+lemma csucc_lt_csucc_iff: "\<lbrakk>Card \<kappa>'; Card \<kappa>\<rbrakk> \<Longrightarrow> (csucc \<kappa>' < csucc \<kappa>) = (\<kappa>' < \<kappa>)"
	+ by (metis Card_csucc Card_is_Ord Card_lt_csucc_iff Ord_not_less)
	+
	+lemma csucc_le_csucc_iff: "\<lbrakk>Card \<kappa>'; Card \<kappa>\<rbrakk> \<Longrightarrow> (csucc \<kappa>' \<le> csucc \<kappa>) = (\<kappa>' \<le> \<kappa>)"
	+ by (metis Card_csucc Card_is_Ord Card_lt_csucc_iff Ord_not_less)
	+
	+lemma csucc_0 [simp]: "csucc 0 = 1"
	+ by (simp add: finite_csucc one_V_def)
	+
	+lemma Card_Un [simp,intro]:
	+ assumes "Card x" "Card y" shows "Card(x \<squnion> y)"
	+ by (metis Card_is_Ord Ord_linear_le assms sup.absorb2 sup.orderE)
	+
	lemma InfCard_csucc: "InfCard \<kappa> \<Longrightarrow> InfCard (csucc \<kappa>)"
	using InfCard_def le_csucc by auto

	-
	text\<open>Kunen's Lemma 10.11\<close>
	lemma InfCard_is_Limit:
	assumes "InfCard \<kappa>" shows "Limit \<kappa>"
	proof (rule non_succ_LimitI)
	show "\<kappa> \<noteq> 0"
	using InfCard_def assms mem_not_refl by blast
	show "Ord \<kappa>"
	using Card_is_Ord InfCard_def assms by blast
	show "ZFC_in_HOL.succ y \<noteq> \<kappa>" for y
	proof
	assume "succ y = \<kappa>"
	then have "Card (succ y)"
	using InfCard_def assms by auto
	moreover have "\<omega> \<le> y"
	by (metis InfCard_iff Ord_in_Ord \<open>Ord \<kappa>\<close> \<open>ZFC_in_HOL.succ y = \<kappa>\<close> assms elts_succ finite_insert infinite_Ord_omega insertI1)
	moreover have "elts y \<approx> elts (succ y)"
	using InfCard_iff \<open>ZFC_in_HOL.succ y = \<kappa>\<close> assms eqpoll_sym infinite_insert_eqpoll by fastforce
	ultimately show False
	by (metis Card_iff_initial Ord_in_Ord OrdmemD elts_succ insertI1)
	qed
	qed


	subsection\<open>Toward's Kunen's Corollary 10.13 (1)\<close>

	text\<open>Kunen's Theorem 10.12\<close>
	lemma InfCard_csquare_eq:
	assumes "InfCard(\<kappa>)" shows "\<kappa> \<otimes> \<kappa> = \<kappa>"
	using infinite_times_eqpoll_self [of "elts \<kappa>"] assms
	unfolding InfCard_iff Card_def
	by (metis cardinal_cong cardinal_eqpoll cmult_def elts_vcard_VSigma_eqpoll eqpoll_trans)

	lemma InfCard_le_cmult_eq:
	assumes "InfCard \<kappa>" "\<mu> \<le> \<kappa>" "\<mu> \<noteq> 0"
	shows "\<kappa> \<otimes> \<mu> = \<kappa>"
	proof (rule order_antisym)
	have "\<kappa> \<otimes> \<mu> \<le> \<kappa> \<otimes> \<kappa>"
	by (simp add: assms(2) cmult_le_mono)
	also have "\<dots> \<le> \<kappa>"
	by (simp add: InfCard_csquare_eq assms(1))
	finally show "\<kappa> \<otimes> \<mu> \<le> \<kappa>" .
	show "\<kappa> \<le> \<kappa> \<otimes> \<mu>"
	using InfCard_def assms(1) assms(3) cmult_le_self by auto
	qed

	text\<open>Kunen's Corollary 10.13 (1), for cardinal multiplication\<close>
	lemma InfCard_cmult_eq: "\<lbrakk>InfCard \<kappa>; InfCard \<mu>\<rbrakk> \<Longrightarrow> \<kappa> \<otimes> \<mu> = \<kappa> \<squnion> \<mu>"
	by (metis Card_is_Ord InfCard_def InfCard_le_cmult_eq Ord_linear_le cmult_commute inf_sup_aci(5) mem_not_refl sup.orderE sup_V_0_right zero_in_omega)

	lemma cmult_succ:
	"succ(m) \<otimes> n = n \<oplus> (m \<otimes> n)"
	unfolding cmult_def cadd_def
	proof (rule cardinal_cong)
	have "elts (vtimes (ZFC_in_HOL.succ m) n) \<approx> elts n <+> elts m \<times> elts n"
	by (simp add: elts_VSigma prod_insert_eqpoll)
	also have "\<dots> \<approx> elts (n \<Uplus> vcard (vtimes m n))"
	unfolding elts_VSigma elts_vsum Plus_def
	proof (rule Un_eqpoll_cong)
	show "(Sum_Type.Inr ` (elts m \<times> elts n)::(V + V \<times> V) set) \<approx> Inr ` elts (vcard (vtimes m n))"
	by (simp add: elts_vcard_VSigma_eqpoll eqpoll_sym)
	qed (auto simp: disjnt_def)
	finally show "elts (vtimes (ZFC_in_HOL.succ m) n) \<approx> elts (n \<Uplus> vcard (vtimes m n))" .
	qed

	lemma cmult_2:
	assumes "Card n" shows "ord_of_nat 2 \<otimes> n = n \<oplus> n"
	proof -
	have "ord_of_nat 2 = succ (succ 0)"
	by force
	then show ?thesis
	by (simp add: cmult_succ assms)
	qed

	lemma InfCard_cdouble_eq:
	assumes "InfCard \<kappa>" shows "\<kappa> \<oplus> \<kappa> = \<kappa>"
	proof -
	have "\<kappa> \<oplus> \<kappa> = \<kappa> \<otimes> ord_of_nat 2"
	using InfCard_def assms cmult_2 cmult_commute by auto
	also have "\<dots> = \<kappa>"
	by (simp add: InfCard_le_cmult_eq InfCard_ge_ord_of_nat assms)
	finally show ?thesis .
	qed

	text\<open>Corollary 10.13 (1), for cardinal addition\<close>
	lemma InfCard_le_cadd_eq: "\<lbrakk>InfCard \<kappa>; \<mu> \<le> \<kappa>\<rbrakk> \<Longrightarrow> \<kappa> \<oplus> \<mu> = \<kappa>"
	by (metis InfCard_cdouble_eq InfCard_def antisym cadd_le_mono cadd_le_self)

	lemma InfCard_cadd_eq: "\<lbrakk>InfCard \<kappa>; InfCard \<mu>\<rbrakk> \<Longrightarrow> \<kappa> \<oplus> \<mu> = \<kappa> \<squnion> \<mu>"
	by (metis Card_iff_initial InfCard_def InfCard_le_cadd_eq Ord_linear_le cadd_commute sup.absorb2 sup.orderE)

	+lemma csucc_le_Card_iff: "\<lbrakk>Card \<kappa>'; Card \<kappa>\<rbrakk> \<Longrightarrow> csucc \<kappa>' \<le> \<kappa> \<longleftrightarrow> \<kappa>' < \<kappa>"
	+ by (metis Card_csucc Card_is_Ord Card_lt_csucc_iff Ord_not_le)
	+
	+lemma cadd_InfCard_le:
	+ assumes "\<alpha> \<le> \<kappa>" "\<beta> \<le> \<kappa>" "InfCard \<kappa>"
	+ shows "\<alpha> \<oplus> \<beta> \<le> \<kappa>"
	+ using assms by (metis InfCard_cdouble_eq cadd_le_mono)
	+
	+lemma cmult_InfCard_le:
	+ assumes "\<alpha> \<le> \<kappa>" "\<beta> \<le> \<kappa>" "InfCard \<kappa>"
	+ shows "\<alpha> \<otimes> \<beta> \<le> \<kappa>"
	+ using assms
	+ by (metis InfCard_csquare_eq cmult_le_mono)

	subsection \<open>The Aleph-seqence\<close>

	text \<open>This is the well-known transfinite enumeration of the cardinal numbers.\<close>

	-definition Aleph :: "V \<Rightarrow> V" (\<open>\<aleph>_\<close> [90] 90)
	- where "Aleph \<equiv> transrec3 \<omega> (\<lambda>x r. csucc(r)) (\<lambda>i r . \<Squnion> (r ` elts i))"
	-
	-lemma Card_Aleph [simp, intro]:
	- "Ord \<alpha> \<Longrightarrow> Card(Aleph \<alpha>)"
	-by (induction \<alpha> rule: Ord_induct3) (auto simp: Aleph_def)
	+definition Aleph :: "V \<Rightarrow> V" (\<open>\<aleph>_\<close> [90] 90)
	+ where "Aleph \<equiv> transrec (\<lambda>f x. \<omega> \<squnion> \<Squnion>((\<lambda>y. csucc(f y)) ` elts x))"
	+
	+lemma Aleph: "Aleph \<alpha> = \<omega> \<squnion> (\<Squnion>y\<in>elts \<alpha>. csucc (Aleph y))"
	+ by (simp add: Aleph_def transrec[of _ \<alpha>])
	+
	+lemma InfCard_Aleph [simp, intro]: "InfCard(Aleph x)"
	+proof (induction x rule: eps_induct)
	+ case (step x)
	+ then show ?case
	+ by (simp add: Aleph [of x] InfCard_def Card_UN step)
	+qed
	+
	+lemma Card_Aleph [simp, intro]: "Card(Aleph x)"
	+ using InfCard_def by auto

	lemma Aleph_0 [simp]: "\<aleph>0 = \<omega>"
	- by (simp add: Aleph_def)
	-
	-lemma Aleph_succ [simp]: "\<aleph>(succ x) = csucc (\<aleph> x)"
	- by (simp add: Aleph_def)
	-
	-lemma Aleph_Limit: "Limit \<gamma> \<Longrightarrow> \<aleph> \<gamma> = \<Squnion> (Aleph ` elts \<gamma>)"
	- by (simp add: Aleph_def)
	-
	-lemma mem_Aleph_succ: "Ord \<alpha> \<Longrightarrow> \<aleph>(\<alpha>) \<in> elts (\<aleph>(succ \<alpha>))"
	- by (simp add: Card_is_Ord Ord_mem_iff_lt)
	+ by (simp add: Aleph [of 0])
	+
	+lemma mem_Aleph_succ: "\<aleph>\<alpha> \<in> elts (Aleph (succ \<alpha>))"
	+ apply (simp add: Aleph [of "succ \<alpha>"])
	+ by (meson InfCard_Aleph Card_csucc Card_is_Ord InfCard_def Ord_mem_iff_lt less_csucc)
	+
	+lemma Aleph_lt_succD [simp]: "\<aleph>\<alpha> < Aleph (succ \<alpha>)"
	+ by (simp add: InfCard_is_Limit Limit_is_Ord OrdmemD mem_Aleph_succ)
	+
	+lemma Aleph_succ [simp]: "Aleph (succ x) = csucc (Aleph x)"
	+proof (rule antisym)
	+ show "Aleph (ZFC_in_HOL.succ x) \<le> csucc (Aleph x)"
	+ apply (simp add: Aleph [of "succ x"])
	+ by (metis Aleph InfCard_Aleph InfCard_def Sup_V_insert le_csucc le_sup_iff order_refl
	+ replacement small_elts)
	+ show "csucc (Aleph x) \<le> Aleph (ZFC_in_HOL.succ x)"
	+ by (force simp add: Aleph [of "succ x"])
	+qed
	+
	+lemma csucc_Aleph_le_Aleph: "\<alpha> \<in> elts \<beta> \<Longrightarrow> csucc (\<aleph>\<alpha>) \<le> \<aleph>\<beta>"
	+ by (metis Aleph ZFC_in_HOL.SUP_le_iff replacement small_elts sup_ge2)
	+
	+lemma Aleph_in_Aleph: "\<alpha> \<in> elts \<beta> \<Longrightarrow> \<aleph>\<alpha> \<in> elts (\<aleph>\<beta>)"
	+ using csucc_Aleph_le_Aleph mem_Aleph_succ by auto
	+
	+lemma Aleph_Limit:
	+ assumes "Limit \<gamma>"
	+ shows "Aleph \<gamma> = \<Squnion> (Aleph ` elts \<gamma>)"
	+proof -
	+ have [simp]: "\<gamma> \<noteq> 0"
	+ using assms by auto
	+ show ?thesis
	+ proof (rule antisym)
	+ show "Aleph \<gamma> \<le> \<Squnion> (Aleph ` elts \<gamma>)"
	+ apply (simp add: Aleph [of \<gamma>])
	+ by (metis (mono_tags, lifting) Aleph_0 Aleph_succ Limit_def ZFC_in_HOL.SUP_le_iff
	+ ZFC_in_HOL.Sup_upper assms imageI replacement small_elts)
	+ show "\<Squnion> (Aleph ` elts \<gamma>) \<le> Aleph \<gamma>"
	+ apply (simp add: cSup_le_iff)
	+ by (meson InfCard_Aleph InfCard_def csucc_Aleph_le_Aleph le_csucc order_trans)
	+ qed
	+qed

	lemma Aleph_increasing:
	- assumes ab: "\<alpha> < \<beta>" "Ord \<alpha>" "Ord \<beta>" shows "Aleph(\<alpha>) < Aleph(\<beta>)"
	-proof -
	- { fix x
	- have "\<lbrakk>Ord x; x \<in> elts \<beta>\<rbrakk> \<Longrightarrow> Aleph(x) \<in> elts (Aleph \<beta>)"
	- using \<open>Ord \<beta>\<close>
	- proof (induct \<beta> arbitrary: x rule: Ord_induct3)
	- case 0 thus ?case by simp
	- next
	- case (succ \<beta>)
	- then consider "x = \<beta>" \|"x \<in> elts \<beta>"
	- using OrdmemD by auto
	- then show ?case
	- proof cases
	- case 1
	- then show ?thesis
	- by (simp add: Card_is_Ord Ord_mem_iff_lt succ.hyps(1))
	- next
	- case 2
	- with succ show ?thesis
	- by (metis Aleph_succ Card_Aleph le_csucc vsubsetD)
	- qed
	- next
	- case (Limit \<gamma>)
	- hence sc: "succ x \<in> elts \<gamma>"
	- by (simp add: Limit_def Ord_mem_iff_lt)
	- hence "\<aleph> x \<in> elts (\<Squnion> (Aleph ` elts \<gamma>))"
	- using Limit
	- by blast
	- thus ?case using Limit
	- by (simp add: Aleph_Limit)
	- qed
	- } thus ?thesis using ab
	- by (simp add: Card_is_Ord Ord_mem_iff_lt)
	-qed
	+ assumes ab: "\<alpha> < \<beta>" "Ord \<alpha>" "Ord \<beta>" shows "\<aleph>\<alpha> < \<aleph>\<beta>"
	+ by (meson Aleph_in_Aleph InfCard_Aleph Card_iff_initial InfCard_def Ord_mem_iff_lt assms)

	lemma countable_iff_le_Aleph0: "countable (elts A) \<longleftrightarrow> vcard A \<le> \<aleph>0"
	proof
	show "vcard A \<le> \<aleph>0"
	if "countable (elts A)"
	proof (cases "finite (elts A)")
	case True
	then show ?thesis
	using vcard_finite_set by fastforce
	next
	case False
	then have "elts \<omega> \<approx> elts A"
	using countableE_infinite [OF that]
	- by (simp add: eqpoll_def \<omega>_def) (meson bij_betw_def bij_betw_inv bij_betw_trans inj_ord_of_nat)
	+ by (simp add: eqpoll_def \<omega>_def)
	+ (meson bij_betw_def bij_betw_inv bij_betw_trans inj_ord_of_nat)
	then show ?thesis
	using Card_\<omega> Card_def cardinal_cong vcard_def by auto
	qed
	show "countable (elts A)"
	- if "vcard A \<le> \<aleph>0"
	+ if "vcard A \<le> Aleph 0"
	proof -
	have "elts A \<lesssim> elts \<omega>"
	using cardinal_le_lepoll [OF that] by simp
	then show ?thesis
	by (simp add: countable_iff_lepoll \<omega>_def inj_ord_of_nat)
	qed
	qed

	+lemma Aleph_csquare_eq [simp]: "\<aleph>\<alpha> \<otimes> \<aleph>\<alpha> = \<aleph>\<alpha>"
	+ using InfCard_csquare_eq by auto
	+
	+lemma vcard_Aleph [simp]: "vcard (\<aleph>\<alpha>) = \<aleph>\<alpha>"
	+ using Card_def InfCard_Aleph InfCard_def by auto
	+
	+lemma omega_le_Aleph [simp]: "\<omega> \<le> \<aleph>\<alpha>"
	+ using InfCard_def by auto
	+
	+lemma finite_iff_less_Aleph0: "finite (elts x) \<longleftrightarrow> vcard x < \<omega>"
	+proof
	+ show "finite (elts x) \<Longrightarrow> vcard x < \<omega>"
	+ by (metis Card_\<omega> Card_def finite_lesspoll_infinite infinite_\<omega> lesspoll_imp_Card_less)
	+ show "vcard x < \<omega> \<Longrightarrow> finite (elts x)"
	+ by (meson Ord_cardinal cardinal_eqpoll eqpoll_finite_iff infinite_Ord_omega less_le_not_le)
	+qed
	+
	+lemma countable_iff_vcard_less1: "countable (elts x) \<longleftrightarrow> vcard x < \<aleph>1"
	+ by (simp add: countable_iff_le_Aleph0 lt_csucc_iff one_V_def)
	+
	+lemma countable_infinite_vcard: "countable (elts x) \<and> infinite (elts x) \<longleftrightarrow> vcard x = \<aleph>0"
	+ by (metis Aleph_0 countable_iff_le_Aleph0 dual_order.refl finite_iff_less_Aleph0 less_V_def)
	+
	subsection \<open>The ordinal @{term "\<omega>1"}\<close>

	abbreviation "\<omega>1 \<equiv> Aleph 1"

	lemma Ord_\<omega>1 [simp]: "Ord \<omega>1"
	- by (simp add: Card_is_Ord)
	+ by (metis Ord_cardinal vcard_Aleph)

	lemma omega_\<omega>1 [iff]: "\<omega> \<in> elts \<omega>1"
	- using mem_Aleph_succ one_V_def by fastforce
	+ by (metis Aleph_0 mem_Aleph_succ one_V_def)

	lemma ord_of_nat_\<omega>1 [iff]: "ord_of_nat n \<in> elts \<omega>1"
	using Ord_\<omega>1 Ord_trans by blast

	lemma countable_iff_less_\<omega>1:
	assumes "Ord \<alpha>"
	shows "countable (elts \<alpha>) \<longleftrightarrow> \<alpha> < \<omega>1"
	by (simp add: assms countable_iff_le_Aleph0 lt_csucc_iff one_V_def)

	lemma less_\<omega>1_imp_countable:
	assumes "\<alpha> \<in> elts \<omega>1"
	shows "countable (elts \<alpha>)"
	using Ord_\<omega>1 Ord_in_Ord OrdmemD assms countable_iff_less_\<omega>1 by blast

	lemma \<omega>1_gt0 [simp]: "\<omega>1 > 0"
	using Ord_\<omega>1 Ord_trans OrdmemD by blast

	lemma \<omega>1_gt1 [simp]: "\<omega>1 > 1"
	using Ord_\<omega>1 OrdmemD \<omega>_gt1 less_trans by blast

	lemma Limit_\<omega>1 [simp]: "Limit \<omega>1"
	by (simp add: InfCard_def InfCard_is_Limit le_csucc one_V_def)

	end
	diff --git a/thys/ZFC_in_HOL/ZFC_Typeclasses.thy b/thys/ZFC_in_HOL/ZFC_Typeclasses.thy
	--- a/thys/ZFC_in_HOL/ZFC_Typeclasses.thy
	+++ b/thys/ZFC_in_HOL/ZFC_Typeclasses.thy
	@@ -1,329 +1,308 @@
	section \<open>Type Classes for ZFC\<close>

	theory ZFC_Typeclasses
	imports ZFC_Cardinals Complex_Main

	begin

	-
	-
	subsection\<open>The class of embeddable types\<close>

	class embeddable =
	assumes ex_inj: "\<exists>V_of :: 'a \<Rightarrow> V. inj V_of"

	context countable
	begin

	subclass embeddable
	proof -
	have "inj (ord_of_nat \<circ> to_nat)" if "inj to_nat"
	for to_nat :: "'a \<Rightarrow> nat"
	using that by (simp add: inj_compose inj_ord_of_nat)
	then show "class.embeddable TYPE('a)"
	by intro_classes (meson local.ex_inj)
	qed

	end

	instance unit :: embeddable ..
	instance bool :: embeddable ..
	instance nat :: embeddable ..
	instance int :: embeddable ..
	instance rat :: embeddable ..
	instance char :: embeddable ..
	instance String.literal :: embeddable ..
	instance typerep :: embeddable ..


	lemma embeddable_classI:
	fixes f :: "'a \<Rightarrow> V"
	assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
	shows "OFCLASS('a, embeddable_class)"
	proof (intro_classes, rule exI)
	show "inj f"
	by (rule injI [OF assms]) assumption
	qed

	instance V :: embeddable
	- by (rule embeddable_classI [where f=id]) auto
	+ by (intro_classes) (meson inj_on_id)

	instance prod :: (embeddable,embeddable) embeddable
	proof -
	have "inj (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>)" if "inj V_of1" "inj V_of2"
	for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V"
	using that by (auto simp: inj_on_def)
	then show "OFCLASS('a \<times> 'b, embeddable_class)"
	by intro_classes (meson embeddable_class.ex_inj)
	qed

	instance sum :: (embeddable,embeddable) embeddable
	proof -
	have "inj (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2))" if "inj V_of1" "inj V_of2"
	for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V"
	using that by (auto simp: inj_on_def split: sum.split_asm)
	then show "OFCLASS('a + 'b, embeddable_class)"
	by intro_classes (meson embeddable_class.ex_inj)
	qed

	instance option :: (embeddable) embeddable
	proof -
	have "inj (case_option 0 (\<lambda>x. ZFC_in_HOL.set{V_of x}))" if "inj V_of"
	for V_of :: "'a \<Rightarrow> V"
	using that by (auto simp: inj_on_def split: option.split_asm)
	then show "OFCLASS('a option, embeddable_class)"
	by intro_classes (meson embeddable_class.ex_inj)
	qed

	primrec V_of_list where
	"V_of_list V_of Nil = 0"
	\| "V_of_list V_of (x#xs) = \<langle>V_of x, V_of_list V_of xs\<rangle>"

	lemma inj_V_of_list:
	assumes "inj V_of"
	shows "inj (V_of_list V_of)"
	proof -
	note inj_eq [OF assms, simp]
	have "x = y" if "V_of_list V_of x = V_of_list V_of y" for x y
	using that
	proof (induction x arbitrary: y)
	case Nil
	then show ?case
	by (cases y) auto
	next
	case (Cons a x)
	then show ?case
	by (cases y) auto
	qed
	then show ?thesis
	by (auto simp: inj_on_def)
	qed

	instance list :: (embeddable) embeddable
	proof -
	have "inj (rec_list 0 (\<lambda>x xs r. \<langle>V_of x, r\<rangle>))" (is "inj ?f")
	if V_of: "inj V_of" for V_of :: "'a \<Rightarrow> V"
	proof -
	note inj_eq [OF V_of, simp]
	have "x = y" if "?f x = ?f y" for x y
	using that
	proof (induction x arbitrary: y)
	case Nil
	then show ?case
	by (cases y) auto
	next
	case (Cons a x)
	then show ?case
	by (cases y) auto
	qed
	then show ?thesis
	by (auto simp: inj_on_def)
	qed
	then show "OFCLASS('a list, embeddable_class)"
	by intro_classes (meson embeddable_class.ex_inj)
	qed


	subsection\<open>The class of small types\<close>

	class small =
	assumes small: "small (UNIV::'a set)"
	begin

	subclass embeddable
	by intro_classes (meson local.small small_def)

	lemma TC_small [iff]:
	fixes A :: "'a set"
	shows "small A"
	using small smaller_than_small by blast

	end

	context countable
	begin

	subclass small
	proof -
	have *: "inj (ord_of_nat \<circ> to_nat)" if "inj to_nat"
	for to_nat :: "'a \<Rightarrow> nat"
	using that by (simp add: inj_compose inj_ord_of_nat)
	then show "class.small TYPE('a)"
	by intro_classes (metis small_image_nat local.ex_inj the_inv_into_onto)
	qed

	end

	lemma lepoll_UNIV_imp_small: "X \<lesssim> (UNIV::'a::small set) \<Longrightarrow> small X"
	by (meson lepoll_iff replacement small smaller_than_small)

	lemma lepoll_imp_small:
	fixes A :: "'a::small set"
	assumes "X \<lesssim> A"
	shows "small X"
	by (metis lepoll_UNIV_imp_small UNIV_I assms lepoll_def subsetI)

	instance unit :: small ..
	instance bool :: small ..
	instance nat :: small ..
	instance int :: small ..
	instance rat :: small ..
	instance char :: small ..
	instance String.literal :: small ..
	instance typerep :: small ..

	instance prod :: (small,small) small
	proof -
	have "inj (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>)"
	"range (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>) \<le> elts (VSigma A (\<lambda>x. B))"
	if "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" "range V_of2 \<le> elts B"
	for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
	using that by (auto simp: inj_on_def)
	with small [where 'a='a] small [where 'a='b]
	show "OFCLASS('a \<times> 'b, small_class)"
	- apply intro_classes
	- unfolding small_def
	- apply clarify
	- by (metis down_raw dual_order.refl)
	+ by intro_classes (smt (verit) down_raw f_inv_into_f set_eq_subset small_def)
	qed

	instance sum :: (small,small) small
	proof -
	have "inj (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2))"
	"range (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2)) \<le> elts (A \<Uplus> B)"
	if "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" "range V_of2 \<le> elts B"
	for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
	using that by (force simp: inj_on_def split: sum.split)+
	with small [where 'a='a] small [where 'a='b]
	show "OFCLASS('a + 'b, small_class)"
	- apply intro_classes
	- unfolding small_def
	- apply clarify
	- by (metis down_raw dual_order.refl)
	+ by intro_classes (metis down_raw replacement set_eq_subset small_def small_iff)
	qed

	instance option :: (small) small
	proof -
	have "inj (\<lambda>x. case x of None \<Rightarrow> 0 \| Some x \<Rightarrow> ZFC_in_HOL.set {V_of x})"
	"range (\<lambda>x. case x of None \<Rightarrow> 0 \| Some x \<Rightarrow> ZFC_in_HOL.set {V_of x}) \<le> insert 0 (elts (VPow A))"
	if "inj V_of" "range V_of \<le> elts A"
	for V_of :: "'a \<Rightarrow> V" and A
	using that by (auto simp: inj_on_def split: option.split_asm)
	with small [where 'a='a]
	show "OFCLASS('a option, small_class)"
	- apply intro_classes
	- unfolding small_def
	- apply clarify
	- by (metis down_raw elts_vinsert subset_insertI)
	+ by intro_classes (smt (verit) down order.refl ex_inj small_iff small_image_iff small_insert)
	qed

	instance list :: (small) small
	proof -
	have "small (range (V_of_list V_of))"
	if "inj V_of" "range V_of \<le> elts A"
	for V_of :: "'a \<Rightarrow> V" and A
	proof -
	have "range (V_of_list V_of) \<approx> (UNIV :: 'a list set)"
	using that by (simp add: inj_V_of_list)
	also have "\<dots> \<approx> lists (UNIV :: 'a set)"
	by simp
	also have "\<dots> \<lesssim> (UNIV :: 'a set) \<times> (UNIV :: nat set)"
	proof (cases "finite (range (V_of::'a \<Rightarrow> V))")
	case True
	then have "lists (UNIV :: 'a set) \<lesssim> (UNIV :: nat set)"
	using countable_iff_lepoll countable_image_inj_on that(1) uncountable_infinite by blast
	then show ?thesis
	by (blast intro: lepoll_trans [OF _ lepoll_times2])
	next
	case False
	then have "lists (UNIV :: 'a set) \<lesssim> (UNIV :: 'a set)"
	using \<open>infinite (range V_of)\<close> eqpoll_imp_lepoll infinite_eqpoll_lists by blast
	then show ?thesis
	using lepoll_times1 lepoll_trans by fastforce
	qed
	finally show ?thesis
	by (simp add: lepoll_imp_small)
	qed
	with small [where 'a='a]
	show "OFCLASS('a list, small_class)"
	- apply intro_classes
	- unfolding small_def
	- apply clarify
	- by (metis inj_V_of_list order_refl small_def small_iff_range)
	+ by intro_classes (metis inj_V_of_list order.refl small_def small_iff small_iff_range)
	qed

	instance "fun" :: (small,embeddable) embeddable
	proof -
	have "inj (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x))))"
	if *: "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A"
	for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A
	proof -
	have "f u = f' u"
	if "VLambda A (\<lambda>u. V_of2 (f (inv V_of1 u))) = VLambda A (\<lambda>x. V_of2 (f' (inv V_of1 x)))"
	for f f' :: "'a \<Rightarrow> 'b" and u
	by (metis inv_f_f rangeI subsetD VLambda_eq_D2 [OF that, of "V_of1 u"] *)
	then show ?thesis
	by (auto simp: inj_on_def)
	qed
	then show "OFCLASS('a \<Rightarrow> 'b, embeddable_class)"
	by intro_classes (metis embeddable_class.ex_inj small order_refl replacement small_iff)
	qed

	instance "fun" :: (small,small) small
	proof -
	have "inj (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x))))" (is "inj ?\<phi>")
	"range (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x)))) \<le> elts (VPi A (\<lambda>x. B))"
	if *: "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" and "range V_of2 \<le> elts B"
	for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
	proof -
	have "f u = f' u"
	if "VLambda A (\<lambda>u. V_of2 (f (inv V_of1 u))) = VLambda A (\<lambda>x. V_of2 (f' (inv V_of1 x)))"
	for f f' :: "'a \<Rightarrow> 'b" and u
	by (metis inv_f_f rangeI subsetD VLambda_eq_D2 [OF that, of "V_of1 u"] *)
	then show "inj ?\<phi>"
	by (auto simp: inj_on_def)
	show "range ?\<phi> \<le> elts (VPi A (\<lambda>x. B))"
	using that by (simp add: VPi_I subset_eq)
	qed
	with small [where 'a='a] small [where 'a='b]
	show "OFCLASS('a \<Rightarrow> 'b, small_class)"
	- apply intro_classes
	- unfolding small_def
	- apply clarify
	- by (metis down_raw dual_order.refl)
	+ by intro_classes (smt (verit, best) down_raw order_refl imageE small_def)
	qed

	instance set :: (small) small
	proof -
	have 1: "inj (\<lambda>x. ZFC_in_HOL.set (V_of ` x))"
	if "inj V_of" for V_of :: "'a \<Rightarrow> V"
	by (simp add: inj_on_def inj_image_eq_iff [OF that])
	have 2: "range (\<lambda>x. ZFC_in_HOL.set (V_of ` x)) \<le> elts (VPow A)"
	if "range V_of \<le> elts A" for V_of :: "'a \<Rightarrow> V" and A
	using that by (auto simp: inj_on_def image_subset_iff)
	from small [where 'a='a]
	show "OFCLASS('a set, small_class)"
	- apply intro_classes
	- unfolding small_def
	- apply clarify
	- by (metis 1 2 down_raw subsetI)
	+ by intro_classes (metis 1 2 down_raw imageE small_def order_refl)
	qed

	instance real :: small
	proof -
	have "small (range (Rep_real))"
	by simp
	then show "OFCLASS(real, small_class)"
	by intro_classes (metis Rep_real_inverse image_inv_f_f inj_on_def replacement)
	qed

	instance complex :: small
	proof -
	have "\<And>c. c \<in> range (\<lambda>(x,y). Complex x y)"
	by (metis case_prod_conv complex.exhaust_sel rangeI)
	then show "OFCLASS(complex, small_class)"
	by intro_classes (meson TC_small replacement smaller_than_small subset_eq)
	qed

	-
	end
	diff --git a/thys/ZFC_in_HOL/ZFC_in_HOL.thy b/thys/ZFC_in_HOL/ZFC_in_HOL.thy
	--- a/thys/ZFC_in_HOL/ZFC_in_HOL.thy
	+++ b/thys/ZFC_in_HOL/ZFC_in_HOL.thy
	@@ -1,1290 +1,1299 @@
	section \<open>The ZF Axioms, Ordinals and Transfinite Recursion\<close>

	theory ZFC_in_HOL
	imports ZFC_Library

	begin

	subsection\<open>Syntax and axioms\<close>

	hide_const (open) list.set Sum subset

	unbundle lattice_syntax

	typedecl V

	text\<open>Presentation refined by Dmitriy Traytel\<close>
	axiomatization elts :: "V \<Rightarrow> V set"
	where ext [intro?]: "elts x = elts y \<Longrightarrow> x=y"
	and down_raw: "Y \<subseteq> elts x \<Longrightarrow> Y \<in> range elts"
	and Union_raw: "X \<in> range elts \<Longrightarrow> Union (elts ` X) \<in> range elts"
	and Pow_raw: "X \<in> range elts \<Longrightarrow> inv elts ` Pow X \<in> range elts"
	and replacement_raw: "X \<in> range elts \<Longrightarrow> f ` X \<in> range elts"
	and inf_raw: "range (g :: nat \<Rightarrow> V) \<in> range elts"
	and foundation: "wf {(x,y). x \<in> elts y}"

	lemma mem_not_refl [simp]: "i \<notin> elts i"
	using wf_not_refl [OF foundation] by force

	lemma mem_not_sym: "\<not> (x \<in> elts y \<and> y \<in> elts x)"
	using wf_not_sym [OF foundation] by force

	text \<open>A set is small if it can be injected into the extension of a V-set.\<close>
	definition small :: "'a set \<Rightarrow> bool"
	where "small X \<equiv> \<exists>V_of :: 'a \<Rightarrow> V. inj_on V_of X \<and> V_of ` X \<in> range elts"

	lemma small_empty [iff]: "small {}"
	by (simp add: small_def down_raw)

	lemma small_iff_range: "small X \<longleftrightarrow> X \<in> range elts"
	apply (simp add: small_def)
	by (metis inj_on_id2 replacement_raw the_inv_into_onto)

	+lemma small_eqpoll: "small A \<longleftrightarrow> (\<exists>x. elts x \<approx> A)"
	+ unfolding small_def by (metis UNIV_I bij_betw_def eqpoll_def eqpoll_sym imageE image_eqI)
	+
	text\<open>Small classes can be mapped to sets.\<close>
	definition set :: "V set \<Rightarrow> V"
	where "set X \<equiv> (if small X then inv elts X else inv elts {})"

	lemma set_of_elts [simp]: "set (elts x) = x"
	by (force simp add: ext set_def f_inv_into_f small_def)

	lemma elts_of_set [simp]: "elts (set X) = (if small X then X else {})"
	by (simp add: ZFC_in_HOL.set_def down_raw f_inv_into_f small_iff_range)

	lemma down: "Y \<subseteq> elts x \<Longrightarrow> small Y"
	by (simp add: down_raw small_iff_range)

	lemma Union [intro]: "small X \<Longrightarrow> small (Union (elts ` X))"
	by (simp add: Union_raw small_iff_range)

	lemma Pow: "small X \<Longrightarrow> small (set ` Pow X)"
	unfolding small_iff_range using Pow_raw set_def down by force

	declare replacement_raw [intro,simp]

	lemma replacement [intro,simp]:
	assumes "small X"
	shows "small (f ` X)"
	proof -
	let ?A = "inv_into X f ` (f ` X)"
	have AX: "?A \<subseteq> X"
	by (simp add: image_subsetI inv_into_into)
	have inj: "inj_on f ?A"
	by (simp add: f_inv_into_f inj_on_def)
	have injo: "inj_on (inv_into X f) (f ` X)"
	using inj_on_inv_into by blast
	have "\<exists>V_of. inj_on V_of (f ` X) \<and> V_of ` f ` X \<in> range elts"
	if "inj_on V_of X" and "V_of ` X = elts x"
	for V_of :: "'a \<Rightarrow> V" and x
	proof (intro exI conjI)
	show "inj_on (V_of \<circ> inv_into X f) (f ` X)"
	by (meson \<open>inv_into X f ` f ` X \<subseteq> X\<close> comp_inj_on inj_on_subset injo that)
	have "(\<lambda>x. V_of (inv_into X f (f x))) ` X = elts (set (V_of ` ?A))"
	by (metis AX down elts_of_set image_image image_mono that(2))
	then show "(V_of \<circ> inv_into X f) ` f ` X \<in> range elts"
	by (metis image_comp image_image rangeI)
	qed
	then show ?thesis
	using assms by (auto simp: small_def)
	qed

	lemma small_image_iff [simp]: "inj_on f A \<Longrightarrow> small (f ` A) \<longleftrightarrow> small A"
	by (metis replacement the_inv_into_onto)

	text \<open>A little bootstrapping is needed to characterise @{term small} for sets of arbitrary type.\<close>

	lemma inf: "small (range (g :: nat \<Rightarrow> V))"
	by (simp add: inf_raw small_iff_range)

	lemma small_image_nat_V [simp]: "small (g ` N)" for g :: "nat \<Rightarrow> V"
	by (metis (mono_tags, opaque_lifting) down elts_of_set image_iff inf rangeI subsetI)

	lemma Finite_V:
	fixes X :: "V set"
	assumes "finite X" shows "small X"
	using ex_bij_betw_nat_finite [OF assms] unfolding bij_betw_def by (metis small_image_nat_V)

	lemma small_insert_V:
	fixes X :: "V set"
	assumes "small X"
	shows "small (insert a X)"
	proof (cases "finite X")
	case True
	then show ?thesis
	by (simp add: Finite_V)
	next
	case False
	show ?thesis
	using infinite_imp_bij_betw2 [OF False]
	by (metis replacement Un_insert_right assms bij_betw_imp_surj_on sup_bot.right_neutral)
	qed

	lemma small_UN_V [simp,intro]:
	fixes B :: "'a \<Rightarrow> V set"
	assumes X: "small X" and B: "\<And>x. x \<in> X \<Longrightarrow> small (B x)"
	shows "small (\<Union>x\<in>X. B x)"
	proof -
	have "(\<Union> (elts ` (\<lambda>x. ZFC_in_HOL.set (B x)) ` X)) = (\<Union> (B ` X))"
	using B by force
	then show ?thesis
	using Union [OF replacement [OF X, of "\<lambda>x. ZFC_in_HOL.set (B x)"]] by simp
	qed

	definition vinsert where "vinsert x y \<equiv> set (insert x (elts y))"

	lemma elts_vinsert [simp]: "elts (vinsert x y) = insert x (elts y)"
	using down small_insert_V vinsert_def by auto

	definition succ where "succ x \<equiv> vinsert x x"

	lemma elts_succ [simp]: "elts (succ x) = insert x (elts x)"
	by (simp add: succ_def)

	lemma finite_imp_small:
	assumes "finite X" shows "small X"
	using assms
	proof induction
	case empty
	then show ?case
	by simp
	next
	case (insert a X)
	then obtain V_of u where u: "inj_on V_of X" "V_of ` X = elts u"
	by (meson small_def image_iff)
	show ?case
	unfolding small_def
	proof (intro exI conjI)
	show "inj_on (V_of(a:=u)) (insert a X)"
	using u
	apply (clarsimp simp add: inj_on_def)
	by (metis image_eqI mem_not_refl)
	have "(V_of(a:=u)) ` insert a X = elts (vinsert u u)"
	using insert.hyps(2) u(2) by auto
	then show "(V_of(a:=u)) ` insert a X \<in> range elts"
	by (blast intro: elim: )
	qed
	qed

	lemma small_insert:
	assumes "small X"
	shows "small (insert a X)"
	proof (cases "finite X")
	case True
	then show ?thesis
	by (simp add: finite_imp_small)
	next
	case False
	show ?thesis
	using infinite_imp_bij_betw2 [OF False]
	by (metis replacement Un_insert_right assms bij_betw_imp_surj_on sup_bot.right_neutral)
	qed

	lemma smaller_than_small:
	assumes "small A" "B \<subseteq> A" shows "small B"
	using assms
	by (metis down elts_of_set image_mono small_def small_iff_range subset_inj_on)

	lemma small_insert_iff [iff]: "small (insert a X) \<longleftrightarrow> small X"
	by (meson small_insert smaller_than_small subset_insertI)

	lemma small_iff: "small X \<longleftrightarrow> (\<exists>x. X = elts x)"
	by (metis down elts_of_set subset_refl)

	lemma small_elts [iff]: "small (elts x)"
	by (auto simp: small_iff)

	lemma small_diff [iff]: "small (elts a - X)"
	by (meson Diff_subset down)

	lemma small_set [simp]: "small (list.set xs)"
	by (simp add: ZFC_in_HOL.finite_imp_small)

	lemma small_upair: "small {x,y}"
	by simp

	lemma small_Un_elts: "small (elts x \<union> elts y)"
	using Union [OF small_upair] by auto

	lemma small_eqcong: "\<lbrakk>small X; X \<approx> Y\<rbrakk> \<Longrightarrow> small Y"
	by (metis bij_betw_imp_surj_on eqpoll_def replacement)

	+lemma lepoll_small: "\<lbrakk>small Y; X \<lesssim> Y\<rbrakk> \<Longrightarrow> small X"
	+ by (meson lepoll_iff replacement smaller_than_small)
	+
	lemma big_UNIV [simp]: "\<not> small (UNIV::V set)" (is "\<not> small ?U")
	proof
	assume "small ?U"
	then have "small A" for A :: "V set"
	by (metis (full_types) UNIV_I down small_iff subsetI)
	then have "range elts = UNIV"
	by (meson small_iff surj_def)
	then show False
	by (metis Cantors_paradox Pow_UNIV)
	qed

	lemma inj_on_set: "inj_on set (Collect small)"
	by (metis elts_of_set inj_onI mem_Collect_eq)

	lemma set_injective [simp]: "\<lbrakk>small X; small Y\<rbrakk> \<Longrightarrow> set X = set Y \<longleftrightarrow> X=Y"
	by (metis elts_of_set)


	subsection\<open>Type classes and other basic setup\<close>

	instantiation V :: zero
	begin
	definition zero_V where "0 \<equiv> set {}"
	instance ..
	end

	lemma elts_0 [simp]: "elts 0 = {}"
	by (simp add: zero_V_def)

	lemma set_empty [simp]: "set {} = 0"
	by (simp add: zero_V_def)

	instantiation V :: one
	begin
	definition one_V where "1 \<equiv> succ 0"
	instance ..
	end

	lemma elts_1 [simp]: "elts 1 = {0}"
	by (simp add: one_V_def)

	lemma insert_neq_0 [simp]: "set (insert a X) = 0 \<longleftrightarrow> \<not> small X"
	unfolding zero_V_def
	by (metis elts_of_set empty_not_insert set_of_elts small_insert_iff)

	lemma elts_eq_empty_iff [simp]: "elts x = {} \<longleftrightarrow> x=0"
	by (auto simp: ZFC_in_HOL.ext)

	instantiation V :: distrib_lattice
	begin

	definition inf_V where "inf_V x y \<equiv> set (elts x \<inter> elts y)"

	definition sup_V where "sup_V x y \<equiv> set (elts x \<union> elts y)"

	definition less_eq_V where "less_eq_V x y \<equiv> elts x \<subseteq> elts y"

	definition less_V where "less_V x y \<equiv> less_eq x y \<and> x \<noteq> (y::V)"

	instance
	proof
	show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" for x :: V and y :: V
	using ext less_V_def less_eq_V_def by auto
	show "x \<le> x" for x :: V
	by (simp add: less_eq_V_def)
	show "x \<le> z" if "x \<le> y" "y \<le> z" for x y z :: V
	using that by (auto simp: less_eq_V_def)
	show "x = y" if "x \<le> y" "y \<le> x" for x y :: V
	using that by (simp add: ext less_eq_V_def)
	show "inf x y \<le> x" for x y :: V
	by (metis down elts_of_set inf_V_def inf_sup_ord(1) less_eq_V_def)
	show "inf x y \<le> y" for x y :: V
	by (metis Int_lower2 down elts_of_set inf_V_def less_eq_V_def)
	show "x \<le> inf y z" if "x \<le> y" "x \<le> z" for x y z :: V
	proof -
	have "small (elts y \<inter> elts z)"
	by (meson down inf.cobounded1)
	then show ?thesis
	using elts_of_set inf_V_def less_eq_V_def that by auto
	qed
	show "x \<le> x \<squnion> y" "y \<le> x \<squnion> y" for x y :: V
	by (simp_all add: less_eq_V_def small_Un_elts sup_V_def)
	show "sup y z \<le> x" if "y \<le> x" "z \<le> x" for x y z :: V
	using less_eq_V_def sup_V_def that by auto
	show "sup x (inf y z) = inf (x \<squnion> y) (sup x z)" for x y z :: V
	proof -
	have "small (elts y \<inter> elts z)"
	by (meson down inf.cobounded2)
	then show ?thesis
	by (simp add: Un_Int_distrib inf_V_def small_Un_elts sup_V_def)
	qed
	qed
	end

	lemma V_equalityI [intro]: "(\<And>x. x \<in> elts a \<longleftrightarrow> x \<in> elts b) \<Longrightarrow> a = b"
	by (meson dual_order.antisym less_eq_V_def subsetI)

	lemma vsubsetI [intro!]: "(\<And>x. x \<in> elts a \<Longrightarrow> x \<in> elts b) \<Longrightarrow> a \<le> b"
	by (simp add: less_eq_V_def subsetI)

	lemma vsubsetD [elim, intro?]: "a \<le> b \<Longrightarrow> c \<in> elts a \<Longrightarrow> c \<in> elts b"
	using less_eq_V_def by auto

	lemma rev_vsubsetD: "c \<in> elts a \<Longrightarrow> a \<le> b \<Longrightarrow> c \<in> elts b"
	\<comment> \<open>The same, with reversed premises for use with @{method erule} -- cf. @{thm rev_mp}.\<close>
	by (rule vsubsetD)

	lemma vsubsetCE [elim,no_atp]: "a \<le> b \<Longrightarrow> (c \<notin> elts a \<Longrightarrow> P) \<Longrightarrow> (c \<in> elts b \<Longrightarrow> P) \<Longrightarrow> P"
	\<comment> \<open>Classical elimination rule.\<close>
	using vsubsetD by blast

	lemma set_image_le_iff: "small A \<Longrightarrow> set (f ` A) \<le> B \<longleftrightarrow> (\<forall>x\<in>A. f x \<in> elts B)"
	by auto

	lemma eq0_iff: "x = 0 \<longleftrightarrow> (\<forall>y. y \<notin> elts x)"
	by auto

	lemma less_eq_V_0_iff [simp]: "x \<le> 0 \<longleftrightarrow> x = 0" for x::V
	by auto

	lemma subset_iff_less_eq_V:
	assumes "small B" shows "A \<subseteq> B \<longleftrightarrow> set A \<le> set B \<and> small A"
	using assms down small_iff by auto

	lemma small_Collect [simp]: "small A \<Longrightarrow> small {x \<in> A. P x}"
	by (simp add: smaller_than_small)

	lemma small_Union_iff: "small (\<Union>(elts ` X)) \<longleftrightarrow> small X"
	proof
	show "small X"
	if "small (\<Union> (elts ` X))"
	proof -
	have "X \<subseteq> set ` Pow (\<Union> (elts ` X))"
	by fastforce
	then show ?thesis
	using Pow subset_iff_less_eq_V that by auto
	qed
	qed auto

	lemma not_less_0 [iff]:
	fixes x::V shows "\<not> x < 0"
	by (simp add: less_eq_V_def less_le_not_le)

	lemma le_0 [iff]:
	fixes x::V shows "0 \<le> x"
	by auto

	lemma min_0L [simp]: "min 0 n = 0" for n :: V
	by (simp add: min_absorb1)

	lemma min_0R [simp]: "min n 0 = 0" for n :: V
	by (simp add: min_absorb2)

	lemma neq0_conv: "\<And>n::V. n \<noteq> 0 \<longleftrightarrow> 0 < n"
	by (simp add: less_V_def)


	definition VPow :: "V \<Rightarrow> V"
	where "VPow x \<equiv> set (set ` Pow (elts x))"

	lemma VPow_iff [iff]: "y \<in> elts (VPow x) \<longleftrightarrow> y \<le> x"
	using down Pow
	apply (auto simp: VPow_def less_eq_V_def)
	using less_eq_V_def apply fastforce
	done

	lemma VPow_le_VPow_iff [simp]: "VPow a \<le> VPow b \<longleftrightarrow> a \<le> b"
	by auto

	lemma elts_VPow: "elts (VPow x) = set ` Pow (elts x)"
	by (auto simp: VPow_def Pow)

	lemma small_sup_iff [simp]: "small (X \<union> Y) \<longleftrightarrow> small X \<and> small Y" for X::"V set"
	by (metis down elts_of_set small_Un_elts sup_ge1 sup_ge2)

	lemma elts_sup_iff [simp]: "elts (x \<squnion> y) = elts x \<union> elts y"
	by (simp add: sup_V_def)

	lemma trad_foundation:
	assumes z: "z \<noteq> 0" shows "\<exists>w. w \<in> elts z \<and> w \<sqinter> z = 0"
	using foundation assms
	by (simp add: wf_eq_minimal) (metis Int_emptyI equals0I inf_V_def set_of_elts zero_V_def)


	instantiation "V" :: Sup
	begin
	definition Sup_V where "Sup_V X \<equiv> if small X then set (Union (elts ` X)) else 0"
	instance ..
	end

	instantiation "V" :: Inf
	begin
	definition Inf_V where "Inf_V X \<equiv> if X = {} then 0 else set (Inter (elts ` X))"
	instance ..
	end

	lemma V_disjoint_iff: "x \<sqinter> y = 0 \<longleftrightarrow> elts x \<inter> elts y = {}"
	by (metis down elts_of_set inf_V_def inf_le1 zero_V_def)

	text\<open>I've no idea why @{term bdd_above} is treated differently from @{term bdd_below}, but anyway\<close>
	lemma bdd_above_iff_small [simp]: "bdd_above X = small X" for X::"V set"
	proof
	show "small X" if "bdd_above X"
	proof -
	obtain a where "\<forall>x\<in>X. x \<le> a"
	using that \<open>bdd_above X\<close> bdd_above_def by blast
	then show "small X"
	by (meson VPow_iff \<open>\<forall>x\<in>X. x \<le> a\<close> down subsetI)
	qed
	show "bdd_above X"
	if "small X"
	proof -
	have "\<forall>x\<in>X. x \<le> \<Squnion> X"
	by (simp add: SUP_upper Sup_V_def Union less_eq_V_def that)
	then show ?thesis
	by (meson bdd_above_def)
	qed
	qed


	instantiation "V" :: conditionally_complete_lattice
	begin

	definition bdd_below_V where "bdd_below_V X \<equiv> X \<noteq> {}"

	instance
	proof
	show "\<Sqinter> X \<le> x" if "x \<in> X" "bdd_below X"
	for x :: V and X :: "V set"
	using that by (auto simp: bdd_below_V_def Inf_V_def split: if_split_asm)
	show "z \<le> \<Sqinter> X"
	if "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
	for X :: "V set" and z :: V
	using that
	apply (clarsimp simp add: bdd_below_V_def Inf_V_def less_eq_V_def split: if_split_asm)
	by (meson INT_subset_iff down eq_refl equals0I)
	show "x \<le> \<Squnion> X" if "x \<in> X" and "bdd_above X" for x :: V and X :: "V set"
	using that Sup_V_def by auto
	show "\<Squnion> X \<le> (z::V)" if "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> x \<le> z" for X :: "V set" and z :: V
	using that by (simp add: SUP_least Sup_V_def less_eq_V_def)
	qed
	end

	lemma Sup_upper: "\<lbrakk>x \<in> A; small A\<rbrakk> \<Longrightarrow> x \<le> \<Squnion>A" for A::"V set"
	by (auto simp: Sup_V_def SUP_upper Union less_eq_V_def)

	lemma Sup_least:
	fixes z::V shows "(\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> \<Squnion>A \<le> z"
	by (auto simp: Sup_V_def SUP_least less_eq_V_def)

	lemma Sup_empty [simp]: "\<Squnion>{} = (0::V)"
	using Sup_V_def by auto

	lemma elts_Sup [simp]: "small X \<Longrightarrow> elts (\<Squnion> X) = \<Union>(elts ` X)"
	by (auto simp: Sup_V_def)

	lemma sup_V_0_left [simp]: "0 \<squnion> a = a" and sup_V_0_right [simp]: "a \<squnion> 0 = a" for a::V
	by auto

	lemma Sup_V_insert:
	fixes x::V assumes "small A" shows "\<Squnion>(insert x A) = x \<squnion> \<Squnion>A"
	by (simp add: assms cSup_insert_If)

	lemma Sup_Un_distrib: "\<lbrakk>small A; small B\<rbrakk> \<Longrightarrow> \<Squnion>(A \<union> B) = \<Squnion>A \<squnion> \<Squnion>B" for A::"V set"
	by auto

	lemma SUP_sup_distrib:
	fixes f :: "V \<Rightarrow> V"
	shows "small A \<Longrightarrow> (\<Squnion>x\<in>A. f x \<squnion> g x) = \<Squnion> (f ` A) \<squnion> \<Squnion> (g ` A)"
	by (force simp:)

	lemma SUP_const [simp]: "(\<Squnion>y \<in> A. a) = (if A = {} then (0::V) else a)"
	by simp

	lemma cSUP_subset_mono:
	fixes f :: "'a \<Rightarrow> V set" and g :: "'a \<Rightarrow> V set"
	shows "\<lbrakk>A \<subseteq> B; \<And>x. x \<in> A \<Longrightarrow> f x \<le> g x\<rbrakk> \<Longrightarrow> \<Squnion> (f ` A) \<le> \<Squnion> (g ` B)"
	by (simp add: SUP_subset_mono)

	lemma mem_Sup_iff [iff]: "x \<in> elts (\<Squnion>X) \<longleftrightarrow> x \<in> \<Union> (elts ` X) \<and> small X"
	using Sup_V_def by auto

	lemma cSUP_UNION:
	fixes B :: "V \<Rightarrow> V set" and f :: "V \<Rightarrow> V"
	assumes ne: "small A" and bdd_UN: "small (\<Union>x\<in>A. f ` B x)"
	shows "\<Squnion>(f ` (\<Union>x\<in>A. B x)) = \<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
	proof -
	have bdd: "\<And>x. x \<in> A \<Longrightarrow> small (f ` B x)"
	using bdd_UN subset_iff_less_eq_V
	by (meson SUP_upper smaller_than_small)
	then have bdd2: "small ((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
	using ne(1) by blast
	have "\<Squnion>(f ` (\<Union>x\<in>A. B x)) \<le> \<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
	using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper2 simp: bdd2 bdd)
	moreover have "\<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A) \<le> \<Squnion>(f ` (\<Union>x\<in>A. B x))"
	using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper simp: image_UN bdd_UN)
	ultimately show ?thesis
	by (rule order_antisym)
	qed

	lemma Sup_subset_mono: "small B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B" for A::"V set"
	by auto

	lemma Sup_le_iff: "small A \<Longrightarrow> Sup A \<le> a \<longleftrightarrow> (\<forall>x\<in>A. x \<le> a)" for A::"V set"
	by auto

	lemma SUP_le_iff: "small (f ` A) \<Longrightarrow> \<Squnion>(f ` A) \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)" for f :: "V \<Rightarrow> V"
	by blast

	lemma Sup_eq_0_iff [simp]: "\<Squnion>A = 0 \<longleftrightarrow> A \<subseteq> {0} \<or> \<not> small A" for A :: "V set"
	using Sup_upper by fastforce

	lemma Sup_Union_commute:
	fixes f :: "V \<Rightarrow> V set"
	assumes "small A" "\<And>x. x\<in>A \<Longrightarrow> small (f x)"
	shows "\<Squnion> (\<Union>x\<in>A. f x) = (\<Squnion>x\<in>A. \<Squnion> (f x))"
	using assms
	by (force simp: subset_iff_less_eq_V intro!: antisym)

	lemma Sup_eq_Sup:
	fixes B :: "V set"
	assumes "B \<subseteq> A" "small A" and *: "\<And>x. x \<in> A \<Longrightarrow> \<exists>y \<in> B. x \<le> y"
	shows "Sup A = Sup B"
	proof -
	have "small B"
	using assms subset_iff_less_eq_V by auto
	moreover have "\<exists>y\<in>B. u \<in> elts y"
	if "x \<in> A" "u \<in> elts x" for u x
	using that "*" by blast
	moreover have "\<exists>x\<in>A. v \<in> elts x"
	if "y \<in> B" "v \<in> elts y" for v y
	using that \<open>B \<subseteq> A\<close> by blast
	ultimately show ?thesis
	using assms by auto
	qed

	subsection\<open>Successor function\<close>

	lemma vinsert_not_empty [simp]: "vinsert a A \<noteq> 0"
	and empty_not_vinsert [simp]: "0 \<noteq> vinsert a A"
	by (auto simp: vinsert_def)

	lemma succ_not_0 [simp]: "succ n \<noteq> 0" and zero_not_succ [simp]: "0 \<noteq> succ n"
	by (auto simp: succ_def)

	instantiation V :: zero_neq_one
	begin
	instance
	by intro_classes (metis elts_0 elts_succ empty_iff insert_iff one_V_def set_of_elts)
	end

	instantiation V :: zero_less_one
	begin
	instance
	by intro_classes (simp add: less_V_def)
	end

	lemma succ_ne_self [simp]: "i \<noteq> succ i"
	by (metis elts_succ insertI1 mem_not_refl)

	lemma succ_notin_self: "succ i \<notin> elts i"
	using elts_succ mem_not_refl by blast

	lemma le_succE: "succ i \<le> succ j \<Longrightarrow> i \<le> j"
	using less_eq_V_def mem_not_sym by auto

	lemma succ_inject_iff [iff]: "succ i = succ j \<longleftrightarrow> i = j"
	by (simp add: dual_order.antisym le_succE)

	lemma inj_succ: "inj succ"
	by (simp add: inj_def)

	lemma succ_neq_zero: "succ x \<noteq> 0"
	by (metis elts_0 elts_succ insert_not_empty)

	definition pred where "pred i \<equiv> THE j. i = succ j"

	lemma pred_succ [simp]: "pred (succ i) = i"
	by (simp add: pred_def)


	subsection \<open>Ordinals\<close>

	definition Transset where "Transset x \<equiv> \<forall>y \<in> elts x. y \<le> x"

	definition Ord where "Ord x \<equiv> Transset x \<and> (\<forall>y \<in> elts x. Transset y)"

	abbreviation ON where "ON \<equiv> Collect Ord"

	subsubsection \<open>Transitive sets\<close>

	lemma Transset_0 [iff]: "Transset 0"
	by (auto simp: Transset_def)

	lemma Transset_succ [intro]:
	assumes "Transset x" shows "Transset (succ x)"
	using assms
	by (auto simp: Transset_def succ_def less_eq_V_def)

	lemma Transset_Sup:
	assumes "\<And>x. x \<in> X \<Longrightarrow> Transset x" shows "Transset (\<Squnion>X)"
	proof (cases "small X")
	case True
	with assms show ?thesis
	by (simp add: Transset_def) (meson Sup_upper assms dual_order.trans)
	qed (simp add: Sup_V_def)

	lemma Transset_sup:
	assumes "Transset x" "Transset y" shows "Transset (x \<squnion> y)"
	using Transset_def assms by fastforce

	lemma Transset_inf: "\<lbrakk>Transset i; Transset j\<rbrakk> \<Longrightarrow> Transset (i \<sqinter> j)"
	by (simp add: Transset_def rev_vsubsetD)

	lemma Transset_VPow: "Transset(i) \<Longrightarrow> Transset(VPow(i))"
	by (auto simp: Transset_def)

	lemma Transset_Inf: "(\<And>i. i \<in> A \<Longrightarrow> Transset i) \<Longrightarrow> Transset (\<Sqinter> A)"
	by (force simp: Transset_def Inf_V_def)

	lemma Transset_SUP: "(\<And>x. x \<in> A \<Longrightarrow> Transset (B x)) \<Longrightarrow> Transset (\<Squnion> (B ` A))"
	by (metis Transset_Sup imageE)

	lemma Transset_INT: "(\<And>x. x \<in> A \<Longrightarrow> Transset (B x)) \<Longrightarrow> Transset (\<Sqinter> (B ` A))"
	by (metis Transset_Inf imageE)


	subsubsection \<open>Zero, successor, sups\<close>

	lemma Ord_0 [iff]: "Ord 0"
	by (auto simp: Ord_def)

	lemma Ord_succ [intro]:
	assumes "Ord x" shows "Ord (succ x)"
	using assms by (auto simp: Ord_def)

	lemma Ord_Sup:
	assumes "\<And>x. x \<in> X \<Longrightarrow> Ord x" shows "Ord (\<Squnion>X)"
	proof (cases "small X")
	case True
	with assms show ?thesis
	by (auto simp: Ord_def Transset_Sup)
	qed (simp add: Sup_V_def)

	lemma Ord_Union:
	assumes "\<And>x. x \<in> X \<Longrightarrow> Ord x" "small X" shows "Ord (set (\<Union> (elts ` X)))"
	by (metis Ord_Sup Sup_V_def assms)

	lemma Ord_sup:
	assumes "Ord x" "Ord y" shows "Ord (x \<squnion> y)"
	using assms
	proof (clarsimp simp: Ord_def)
	show "Transset (x \<squnion> y) \<and> (\<forall>y\<in>elts x \<union> elts y. Transset y)"
	if "Transset x" "Transset y" "\<forall>y\<in>elts x. Transset y" "\<forall>y\<in>elts y. Transset y"
	using Ord_def Transset_sup assms by auto
	qed

	lemma big_ON [simp]: "\<not> small ON"
	proof
	assume "small ON"
	then have "set ON \<in> ON"
	by (metis Ord_Union Ord_succ Sup_upper elts_Sup elts_succ insertI1 mem_Collect_eq mem_not_refl set_of_elts vsubsetD)
	then show False
	by (metis \<open>small ON\<close> elts_of_set mem_not_refl)
	qed

	lemma Ord_1 [iff]: "Ord 1"
	using Ord_succ one_V_def succ_def vinsert_def by fastforce

	lemma OrdmemD: "Ord k \<Longrightarrow> j \<in> elts k \<Longrightarrow> j < k"
	using Ord_def Transset_def less_V_def by auto

	lemma Ord_trans: "\<lbrakk> i \<in> elts j; j \<in> elts k; Ord k \<rbrakk> \<Longrightarrow> i \<in> elts k"
	using Ord_def Transset_def by blast

	lemma mem_0_Ord:
	assumes k: "Ord k" and knz: "k \<noteq> 0" shows "0 \<in> elts k"
	by (metis Ord_def Transset_def inf.orderE k knz trad_foundation)

	lemma Ord_in_Ord: "\<lbrakk> Ord k; m \<in> elts k \<rbrakk> \<Longrightarrow> Ord m"
	using Ord_def Ord_trans by blast

	lemma OrdI: "\<lbrakk>Transset i; \<And>x. x \<in> elts i \<Longrightarrow> Transset x\<rbrakk> \<Longrightarrow> Ord i"
	by (simp add: Ord_def)

	lemma Ord_is_Transset: "Ord i \<Longrightarrow> Transset i"
	by (simp add: Ord_def)

	lemma Ord_contains_Transset: "\<lbrakk>Ord i; j \<in> elts i\<rbrakk> \<Longrightarrow> Transset j"
	using Ord_def by blast

	lemma ON_imp_Ord:
	assumes "H \<subseteq> ON" "x \<in> H"
	shows "Ord x"
	using assms by blast

	lemma elts_subset_ON: "Ord \<alpha> \<Longrightarrow> elts \<alpha> \<subseteq> ON"
	using Ord_in_Ord by blast

	lemma Transset_pred [simp]: "Transset x \<Longrightarrow> \<Squnion>(elts (succ x)) = x"
	by (fastforce simp: Transset_def)

	lemma Ord_pred [simp]: "Ord \<beta> \<Longrightarrow> \<Squnion> (insert \<beta> (elts \<beta>)) = \<beta>"
	using Ord_def Transset_pred by auto


	subsubsection \<open>Induction, Linearity, etc.\<close>

	lemma Ord_induct [consumes 1, case_names step]:
	assumes k: "Ord k"
	and step: "\<And>x.\<lbrakk> Ord x; \<And>y. y \<in> elts x \<Longrightarrow> P y \<rbrakk> \<Longrightarrow> P x"
	shows "P k"
	using foundation k
	proof (induction k rule: wf_induct_rule)
	case (less x)
	then show ?case
	using Ord_in_Ord local.step by auto
	qed

	text \<open>Comparability of ordinals\<close>
	lemma Ord_linear: "Ord k \<Longrightarrow> Ord l \<Longrightarrow> k \<in> elts l \<or> k=l \<or> l \<in> elts k"
	proof (induct k arbitrary: l rule: Ord_induct)
	case (step k)
	note step_k = step
	show ?case using \<open>Ord l\<close>
	proof (induct l rule: Ord_induct)
	case (step l)
	thus ?case using step_k
	by (metis Ord_trans V_equalityI)
	qed
	qed

	text \<open>The trichotomy law for ordinals\<close>
	lemma Ord_linear_lt:
	assumes "Ord k" "Ord l"
	obtains (lt) "k < l" \| (eq) "k=l" \| (gt) "l < k"
	using Ord_linear OrdmemD assms by blast

	lemma Ord_linear2:
	assumes "Ord k" "Ord l"
	obtains (lt) "k < l" \| (ge) "l \<le> k"
	by (metis Ord_linear_lt eq_refl assms order.strict_implies_order)

	lemma Ord_linear_le:
	assumes "Ord k" "Ord l"
	obtains (le) "k \<le> l" \| (ge) "l \<le> k"
	by (meson Ord_linear2 le_less assms)

	lemma union_less_iff [simp]: "\<lbrakk>Ord i; Ord j\<rbrakk> \<Longrightarrow> i \<squnion> j < k \<longleftrightarrow> i<k \<and> j<k"
	by (metis Ord_linear_le le_iff_sup sup.order_iff sup.strict_boundedE)

	lemma Ord_mem_iff_lt: "Ord k \<Longrightarrow> Ord l \<Longrightarrow> k \<in> elts l \<longleftrightarrow> k < l"
	by (metis Ord_linear OrdmemD less_le_not_le)

	lemma Ord_Collect_lt: "Ord \<alpha> \<Longrightarrow> {\<xi>. Ord \<xi> \<and> \<xi> < \<alpha>} = elts \<alpha>"
	by (auto simp flip: Ord_mem_iff_lt elim: Ord_in_Ord OrdmemD)

	lemma Ord_not_less: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> \<not> x < y \<longleftrightarrow> y \<le> x"
	by (metis (no_types) Ord_linear2 leD)

	lemma Ord_not_le: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> \<not> x \<le> y \<longleftrightarrow> y < x"
	by (metis (no_types) Ord_linear2 leD)

	lemma le_succ_iff: "Ord i \<Longrightarrow> Ord j \<Longrightarrow> succ i \<le> succ j \<longleftrightarrow> i \<le> j"
	by (metis Ord_linear_le Ord_succ le_succE order_antisym)

	lemma succ_le_iff: "Ord i \<Longrightarrow> Ord j \<Longrightarrow> succ i \<le> j \<longleftrightarrow> i < j"
	using Ord_mem_iff_lt dual_order.strict_implies_order less_eq_V_def by fastforce

	lemma succ_in_Sup_Ord:
	assumes eq: "succ \<beta> = \<Squnion>A" and "small A" "A \<subseteq> ON" "Ord \<beta>"
	shows "succ \<beta> \<in> A"
	proof -
	have "\<not> \<Squnion>A \<le> \<beta>"
	using eq \<open>Ord \<beta>\<close> succ_le_iff by fastforce
	then show ?thesis
	using assms by (metis Ord_linear2 Sup_least Sup_upper eq_iff mem_Collect_eq subsetD succ_le_iff)
	qed

	lemma in_succ_iff: "Ord i \<Longrightarrow> j \<in> elts (ZFC_in_HOL.succ i) \<longleftrightarrow> Ord j \<and> j \<le> i"
	by (metis Ord_in_Ord Ord_mem_iff_lt Ord_not_le Ord_succ succ_le_iff)

	lemma zero_in_succ [simp,intro]: "Ord i \<Longrightarrow> 0 \<in> elts (succ i)"
	using mem_0_Ord by auto

	+lemma less_succ_self: "x < succ x"
	+ by (simp add: less_eq_V_def order_neq_le_trans subset_insertI)
	+
	lemma Ord_finite_Sup: "\<lbrakk>finite A; A \<subseteq> ON; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<Squnion>A \<in> A"
	proof (induction A rule: finite_induct)
	case (insert x A)
	then have *: "small A" "A \<subseteq> ON" "Ord x"
	by (auto simp add: ZFC_in_HOL.finite_imp_small insert.hyps)
	show ?case
	proof (cases "A = {}")
	case False
	then have "\<Squnion>A \<in> A"
	using insert by blast
	then have "\<Squnion>A \<le> x" if "x \<squnion> \<Squnion>A \<notin> A"
	using * by (metis ON_imp_Ord Ord_linear_le sup.absorb2 that)
	then show ?thesis
	by (fastforce simp: \<open>small A\<close> Sup_V_insert)
	qed auto
	qed auto


	subsubsection \<open>The natural numbers\<close>

	primrec ord_of_nat :: "nat \<Rightarrow> V" where
	"ord_of_nat 0 = 0"
	\| "ord_of_nat (Suc n) = succ (ord_of_nat n)"

	lemma ord_of_nat_eq_initial: "ord_of_nat n = set (ord_of_nat ` {..<n})"
	by (induction n) (auto simp: lessThan_Suc succ_def)

	lemma mem_ord_of_nat_iff [simp]: "x \<in> elts (ord_of_nat n) \<longleftrightarrow> (\<exists>m<n. x = ord_of_nat m)"
	by (subst ord_of_nat_eq_initial) auto

	lemma elts_ord_of_nat: "elts (ord_of_nat k) = ord_of_nat ` {..<k}"
	by auto

	lemma Ord_equality: "Ord i \<Longrightarrow> i = \<Squnion> (succ ` elts i)"
	by (force intro: Ord_trans)

	lemma Ord_ord_of_nat [simp]: "Ord (ord_of_nat k)"
	by (induct k, auto)

	lemma ord_of_nat_equality: "ord_of_nat n = \<Squnion> ((succ \<circ> ord_of_nat) ` {..<n})"
	by (metis Ord_equality Ord_ord_of_nat elts_of_set image_comp small_image_nat_V ord_of_nat_eq_initial)

	definition \<omega> :: V where "\<omega> \<equiv> set (range ord_of_nat)"

	lemma elts_\<omega>: "elts \<omega> = {\<alpha>. \<exists>n. \<alpha> = ord_of_nat n}"
	by (auto simp: \<omega>_def image_iff)

	lemma nat_into_Ord [simp]: "n \<in> elts \<omega> \<Longrightarrow> Ord n"
	by (metis Ord_ord_of_nat \<omega>_def elts_of_set image_iff inf)

	lemma Sup_\<omega>: "\<Squnion>(elts \<omega>) = \<omega>"
	unfolding \<omega>_def by force

	lemma Ord_\<omega> [iff]: "Ord \<omega>"
	by (metis Ord_Sup Sup_\<omega> nat_into_Ord)

	lemma zero_in_omega [iff]: "0 \<in> elts \<omega>"
	by (metis \<omega>_def elts_of_set inf ord_of_nat.simps(1) rangeI)

	lemma succ_in_omega [simp]: "n \<in> elts \<omega> \<Longrightarrow> succ n \<in> elts \<omega>"
	by (metis \<omega>_def elts_of_set image_iff small_image_nat_V ord_of_nat.simps(2) rangeI)

	lemma ord_of_eq_0: "ord_of_nat j = 0 \<Longrightarrow> j = 0"
	by (induct j) (auto simp: succ_neq_zero)

	lemma ord_of_nat_le_omega: "ord_of_nat n \<le> \<omega>"
	by (metis Sup_\<omega> ZFC_in_HOL.Sup_upper \<omega>_def elts_of_set inf rangeI)

	lemma ord_of_eq_0_iff [simp]: "ord_of_nat n = 0 \<longleftrightarrow> n=0"
	by (auto simp: ord_of_eq_0)

	lemma ord_of_nat_inject [iff]: "ord_of_nat i = ord_of_nat j \<longleftrightarrow> i=j"
	proof (induct i arbitrary: j)
	case 0 show ?case
	using ord_of_eq_0 by auto
	next
	case (Suc i) then show ?case
	by auto (metis elts_0 elts_succ insert_not_empty not0_implies_Suc ord_of_nat.simps succ_inject_iff)
	qed

	corollary inj_ord_of_nat: "inj ord_of_nat"
	by (simp add: linorder_injI)

	corollary countable:
	assumes "countable X" shows "small X"
	proof -
	have "X \<subseteq> range (from_nat_into X)"
	by (simp add: assms subset_range_from_nat_into)
	then show ?thesis
	by (meson inf_raw inj_ord_of_nat replacement small_def smaller_than_small)
	qed

	corollary infinite_\<omega>: "infinite (elts \<omega>)"
	using range_inj_infinite [of ord_of_nat]
	by (simp add: \<omega>_def inj_ord_of_nat)

	corollary ord_of_nat_mono_iff [iff]: "ord_of_nat i \<le> ord_of_nat j \<longleftrightarrow> i \<le> j"
	by (metis Ord_def Ord_ord_of_nat Transset_def eq_iff mem_ord_of_nat_iff not_less ord_of_nat_inject)

	corollary ord_of_nat_strict_mono_iff [iff]: "ord_of_nat i < ord_of_nat j \<longleftrightarrow> i < j"
	by (simp add: less_le_not_le)

	lemma small_image_nat [simp]:
	fixes N :: "nat set" shows "small (g ` N)"
	by (simp add: countable)

	lemma finite_Ord_omega: "\<alpha> \<in> elts \<omega> \<Longrightarrow> finite (elts \<alpha>)"
	proof (clarsimp simp add: \<omega>_def)
	show "finite (elts (ord_of_nat n))" if "\<alpha> = ord_of_nat n" for n
	using that by (simp add: ord_of_nat_eq_initial [of n])
	qed

	lemma infinite_Ord_omega: "Ord \<alpha> \<Longrightarrow> infinite (elts \<alpha>) \<Longrightarrow> \<omega> \<le> \<alpha>"
	by (meson Ord_\<omega> Ord_linear2 Ord_mem_iff_lt finite_Ord_omega)

	lemma ord_of_minus_1: "n > 0 \<Longrightarrow> ord_of_nat n = succ (ord_of_nat (n - 1))"
	by (metis Suc_diff_1 ord_of_nat.simps(2))

	lemma card_ord_of_nat [simp]: "card (elts (ord_of_nat m)) = m"
	by (induction m) (auto simp: \<omega>_def finite_Ord_omega)

	lemma ord_of_nat_\<omega> [iff]:"ord_of_nat n \<in> elts \<omega>"
	by (simp add: \<omega>_def)

	lemma succ_\<omega>_iff [iff]: "succ n \<in> elts \<omega> \<longleftrightarrow> n \<in> elts \<omega>"
	by (metis Ord_\<omega> OrdmemD elts_vinsert insert_iff less_V_def succ_def succ_in_omega vsubsetD)

	lemma \<omega>_gt0 [simp]: "\<omega> > 0"
	by (simp add: OrdmemD)

	lemma \<omega>_gt1 [simp]: "\<omega> > 1"
	by (simp add: OrdmemD one_V_def)

	subsubsection\<open>Limit ordinals\<close>

	definition Limit :: "V\<Rightarrow>bool"
	where "Limit i \<equiv> Ord i \<and> 0 \<in> elts i \<and> (\<forall>y. y \<in> elts i \<longrightarrow> succ y \<in> elts i)"

	lemma zero_not_Limit [iff]: "\<not> Limit 0"
	by (simp add: Limit_def)

	lemma not_succ_Limit [simp]: "\<not> Limit(succ i)"
	by (metis Limit_def Ord_mem_iff_lt elts_succ insertI1 less_irrefl)

	lemma Limit_is_Ord: "Limit \<xi> \<Longrightarrow> Ord \<xi>"
	by (simp add: Limit_def)

	lemma succ_in_Limit_iff: "Limit \<xi> \<Longrightarrow> succ \<alpha> \<in> elts \<xi> \<longleftrightarrow> \<alpha> \<in> elts \<xi>"
	by (metis Limit_def OrdmemD elts_succ insertI1 less_V_def vsubsetD)

	lemma Limit_eq_Sup_self [simp]: "Limit i \<Longrightarrow> Sup (elts i) = i"
	apply (rule order_antisym)
	apply (simp add: Limit_def Ord_def Transset_def Sup_least)
	by (metis Limit_def Ord_equality Sup_V_def SUP_le_iff Sup_upper small_elts)

	lemma zero_less_Limit: "Limit \<beta> \<Longrightarrow> 0 < \<beta>"
	by (simp add: Limit_def OrdmemD)

	lemma non_Limit_ord_of_nat [iff]: "\<not> Limit (ord_of_nat m)"
	by (metis Limit_def mem_ord_of_nat_iff not_succ_Limit ord_of_eq_0_iff ord_of_minus_1)

	lemma Limit_omega [iff]: "Limit \<omega>"
	by (simp add: Limit_def)

	lemma omega_nonzero [simp]: "\<omega> \<noteq> 0"
	using Limit_omega by fastforce

	lemma Ord_cases_lemma:
	assumes "Ord k" shows "k = 0 \<or> (\<exists>j. k = succ j) \<or> Limit k"
	proof (cases "Limit k")
	case False
	have "succ j \<in> elts k" if "\<forall>j. k \<noteq> succ j" "j \<in> elts k" for j
	by (metis Ord_in_Ord Ord_linear Ord_succ assms elts_succ insertE mem_not_sym that)
	with assms show ?thesis
	by (auto simp: Limit_def mem_0_Ord)
	qed auto

	lemma Ord_cases [cases type: V, case_names 0 succ limit]:
	assumes "Ord k"
	obtains "k = 0" \| l where "Ord l" "succ l = k" \| "Limit k"
	by (metis assms Ord_cases_lemma Ord_in_Ord elts_succ insertI1)

	lemma non_succ_LimitI:
	assumes "i\<noteq>0" "Ord(i)" "\<And>y. succ(y) \<noteq> i"
	shows "Limit(i)"
	using Ord_cases_lemma assms by blast

	lemma Ord_induct3 [consumes 1, case_names 0 succ Limit, induct type: V]:
	assumes \<alpha>: "Ord \<alpha>"
	and P: "P 0" "\<And>\<alpha>. \<lbrakk>Ord \<alpha>; P \<alpha>\<rbrakk> \<Longrightarrow> P (succ \<alpha>)"
	"\<And>\<alpha>. \<lbrakk>Limit \<alpha>; \<And>\<xi>. \<xi> \<in> elts \<alpha> \<Longrightarrow> P \<xi>\<rbrakk> \<Longrightarrow> P (\<Squnion>\<xi> \<in> elts \<alpha>. \<xi>)"
	shows "P \<alpha>"
	using \<alpha>
	proof (induction \<alpha> rule: Ord_induct)
	case (step \<alpha>)
	then show ?case
	by (metis Limit_eq_Sup_self Ord_cases P elts_succ image_ident insertI1)
	qed


	subsubsection\<open>Properties of LEAST for ordinals\<close>

	lemma
	assumes "Ord k" "P k"
	shows Ord_LeastI: "P (LEAST i. Ord i \<and> P i)" and Ord_Least_le: "(LEAST i. Ord i \<and> P i) \<le> k"
	proof -
	have "P (LEAST i. Ord i \<and> P i) \<and> (LEAST i. Ord i \<and> P i) \<le> k"
	using assms
	proof (induct k rule: Ord_induct)
	case (step x) then have "P x" by simp
	show ?case proof (rule classical)
	assume assm: "\<not> (P (LEAST a. Ord a \<and> P a) \<and> (LEAST a. Ord a \<and> P a) \<le> x)"
	have "\<And>y. Ord y \<and> P y \<Longrightarrow> x \<le> y"
	proof (rule classical)
	fix y
	assume y: "Ord y \<and> P y" "\<not> x \<le> y"
	with step obtain "P (LEAST a. Ord a \<and> P a)" and le: "(LEAST a. Ord a \<and> P a) \<le> y"
	by (meson Ord_linear2 Ord_mem_iff_lt)
	with assm have "x < (LEAST a. Ord a \<and> P a)"
	by (meson Ord_linear_le y order.trans \<open>Ord x\<close>)
	then show "x \<le> y"
	using le by auto
	qed
	then have Least: "(LEAST a. Ord a \<and> P a) = x"
	by (simp add: Least_equality \<open>Ord x\<close> step.prems)
	with \<open>P x\<close> show ?thesis by simp
	qed
	qed
	then show "P (LEAST i. Ord i \<and> P i)" and "(LEAST i. Ord i \<and> P i) \<le> k" by auto
	qed

	lemma Ord_Least:
	assumes "Ord k" "P k"
	shows "Ord (LEAST i. Ord i \<and> P i)"
	proof -
	have "Ord (LEAST i. Ord i \<and> (Ord i \<and> P i))"
	using Ord_LeastI [where P = "\<lambda>i. Ord i \<and> P i"] assms by blast
	then show ?thesis
	by simp
	qed

	\<comment> \<open>The following 3 lemmas are due to Brian Huffman\<close>
	lemma Ord_LeastI_ex: "\<exists>i. Ord i \<and> P i \<Longrightarrow> P (LEAST i. Ord i \<and> P i)"
	using Ord_LeastI by blast

	lemma Ord_LeastI2:
	"\<lbrakk>Ord a; P a; \<And>x. \<lbrakk>Ord x; P x\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q (LEAST i. Ord i \<and> P i)"
	by (blast intro: Ord_LeastI Ord_Least)

	lemma Ord_LeastI2_ex:
	"\<exists>a. Ord a \<and> P a \<Longrightarrow> (\<And>x. \<lbrakk>Ord x; P x\<rbrakk> \<Longrightarrow> Q x) \<Longrightarrow> Q (LEAST i. Ord i \<and> P i)"
	by (blast intro: Ord_LeastI_ex Ord_Least)

	lemma Ord_LeastI2_wellorder:
	assumes "Ord a" "P a"
	and "\<And>a. \<lbrakk> P a; \<forall>b. Ord b \<and> P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
	shows "Q (LEAST i. Ord i \<and> P i)"
	proof (rule LeastI2_order)
	show "Ord (LEAST i. Ord i \<and> P i) \<and> P (LEAST i. Ord i \<and> P i)"
	using Ord_Least Ord_LeastI assms by auto
	next
	fix y assume "Ord y \<and> P y" thus "(LEAST i. Ord i \<and> P i) \<le> y"
	by (simp add: Ord_Least_le)
	next
	fix x assume "Ord x \<and> P x" "\<forall>y. Ord y \<and> P y \<longrightarrow> x \<le> y" thus "Q x"
	by (simp add: assms(3))
	qed

	lemma Ord_LeastI2_wellorder_ex:
	assumes "\<exists>x. Ord x \<and> P x"
	and "\<And>a. \<lbrakk> P a; \<forall>b. Ord b \<and> P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
	shows "Q (LEAST i. Ord i \<and> P i)"
	using assms by clarify (blast intro!: Ord_LeastI2_wellorder)

	lemma not_less_Ord_Least: "\<lbrakk>k < (LEAST x. Ord x \<and> P x); Ord k\<rbrakk> \<Longrightarrow> \<not> P k"
	using Ord_Least_le less_le_not_le by auto

	lemma exists_Ord_Least_iff: "(\<exists>\<alpha>. Ord \<alpha> \<and> P \<alpha>) \<longleftrightarrow> (\<exists>\<alpha>. Ord \<alpha> \<and> P \<alpha> \<and> (\<forall>\<beta> < \<alpha>. Ord \<beta> \<longrightarrow> \<not> P \<beta>))" (is "?lhs \<longleftrightarrow> ?rhs")
	proof
	assume ?rhs thus ?lhs by blast
	next
	assume H: ?lhs then obtain \<alpha> where \<alpha>: "Ord \<alpha>" "P \<alpha>" by blast
	let ?x = "LEAST \<alpha>. Ord \<alpha> \<and> P \<alpha>"
	have "Ord ?x"
	by (metis Ord_Least \<alpha>)
	moreover
	{ fix \<beta> assume m: "\<beta> < ?x" "Ord \<beta>"
	from not_less_Ord_Least[OF m] have "\<not> P \<beta>" . }
	ultimately show ?rhs
	using Ord_LeastI_ex[OF H] by blast
	qed

	lemma Ord_mono_imp_increasing:
	assumes fun_hD: "h \<in> D \<rightarrow> D"
	and mono_h: "strict_mono_on h D"
	and "D \<subseteq> ON" and \<nu>: "\<nu> \<in> D"
	shows "\<nu> \<le> h \<nu>"
	proof (rule ccontr)
	assume non: "\<not> \<nu> \<le> h \<nu>"
	define \<mu> where "\<mu> \<equiv> LEAST \<mu>. Ord \<mu> \<and> \<not> \<mu> \<le> h \<mu> \<and> \<mu> \<in> D"
	have "Ord \<nu>"
	using \<nu> \<open>D \<subseteq> ON\<close> by blast
	then have \<mu>: "\<not> \<mu> \<le> h \<mu> \<and> \<mu> \<in> D"
	unfolding \<mu>_def by (rule Ord_LeastI) (simp add: \<nu> non)
	have "Ord (h \<nu>)"
	using assms by auto
	then have "Ord (h (h \<nu>))"
	by (meson ON_imp_Ord \<nu> assms funcset_mem)
	have "Ord \<mu>"
	using \<mu> \<open>D \<subseteq> ON\<close> by blast
	then have "h \<mu> < \<mu>"
	by (metis ON_imp_Ord Ord_linear2 PiE \<mu> \<open>D \<subseteq> ON\<close> fun_hD)
	then have "\<not> h \<mu> \<le> h (h \<mu>)"
	using \<mu> fun_hD mono_h by (force simp: strict_mono_on_def)
	moreover have *: "h \<mu> \<in> D"
	using \<mu> fun_hD by auto
	moreover have "Ord (h \<mu>)"
	using \<open>D \<subseteq> ON\<close> * by blast
	ultimately have "\<mu> \<le> h \<mu>"
	by (simp add: \<mu>_def Ord_Least_le)
	then show False
	using \<mu> by blast
	qed

	lemma le_Sup_iff:
	assumes "A \<subseteq> ON" "Ord x" "small A" shows "x \<le> \<Squnion>A \<longleftrightarrow> (\<forall>y \<in> ON. y<x \<longrightarrow> (\<exists>a\<in>A. y < a))"
	proof (intro iffI ballI impI)
	show "\<exists>a\<in>A. y < a"
	if "x \<le> \<Squnion> A" "y \<in> ON" "y < x"
	for y
	proof -
	have "\<not> \<Squnion> A \<le> y" "Ord y"
	using that by auto
	then show ?thesis
	by (metis Ord_linear2 Sup_least \<open>A \<subseteq> ON\<close> mem_Collect_eq subset_eq)
	qed
	show "x \<le> \<Squnion> A"
	if "\<forall>y\<in>ON. y < x \<longrightarrow> (\<exists>a\<in>A. y < a)"
	using that assms
	by (metis Ord_Sup Ord_linear_le Sup_upper less_le_not_le mem_Collect_eq subsetD)
	qed

	lemma le_SUP_iff: "\<lbrakk>f ` A \<subseteq> ON; Ord x; small A\<rbrakk> \<Longrightarrow> x \<le> \<Squnion>(f ` A) \<longleftrightarrow> (\<forall>y \<in> ON. y<x \<longrightarrow> (\<exists>i\<in>A. y < f i))"
	by (simp add: le_Sup_iff)

	subsection\<open>Transfinite Recursion and the V-levels\<close>

	-definition transrec :: "[[V\<Rightarrow>V,V]\<Rightarrow>V, V] \<Rightarrow> V"
	+definition transrec :: "((V \<Rightarrow> 'a) \<Rightarrow> V \<Rightarrow> 'a) \<Rightarrow> V \<Rightarrow> 'a"
	where "transrec H a \<equiv> wfrec {(x,y). x \<in> elts y} H a"

	lemma transrec: "transrec H a = H (\<lambda>x \<in> elts a. transrec H x) a"
	proof -
	have "(cut (wfrec {(x, y). x \<in> elts y} H) {(x, y). x \<in> elts y} a)
	= (\<lambda>x\<in>elts a. wfrec {(x, y). x \<in> elts y} H x)"
	by (force simp: cut_def)
	then show ?thesis
	unfolding transrec_def
	by (simp add: foundation wfrec)
	qed

	text\<open>Avoids explosions in proofs; resolve it with a meta-level definition\<close>
	lemma def_transrec:
	"\<lbrakk>\<And>x. f x \<equiv> transrec H x\<rbrakk> \<Longrightarrow> f a = H(\<lambda>x \<in> elts a. f x) a"
	by (metis restrict_ext transrec)

	lemma eps_induct [case_names step]:
	assumes "\<And>x. (\<And>y. y \<in> elts x \<Longrightarrow> P y) \<Longrightarrow> P x"
	shows "P a"
	using wf_induct [OF foundation] assms by auto


	definition Vfrom :: "[V,V] \<Rightarrow> V"
	where "Vfrom a \<equiv> transrec (\<lambda>f x. a \<squnion> \<Squnion>((\<lambda>y. VPow(f y)) ` elts x))"

	abbreviation Vset :: "V \<Rightarrow> V" where "Vset \<equiv> Vfrom 0"

	lemma Vfrom: "Vfrom a i = a \<squnion> \<Squnion>((\<lambda>j. VPow(Vfrom a j)) ` elts i)"
	apply (subst Vfrom_def)
	apply (subst transrec)
	using Vfrom_def by auto

	lemma Vfrom_0 [simp]: "Vfrom a 0 = a"
	by (subst Vfrom) auto

	lemma Vset: "Vset i = \<Squnion>((\<lambda>j. VPow(Vset j)) ` elts i)"
	by (subst Vfrom) auto

	lemma Vfrom_mono1:
	assumes "a \<le> b" shows "Vfrom a i \<le> Vfrom b i"
	proof (induction i rule: eps_induct)
	case (step i)
	then have "a \<squnion> (\<Squnion>j\<in>elts i. VPow (Vfrom a j)) \<le> b \<squnion> (\<Squnion>j\<in>elts i. VPow (Vfrom b j))"
	by (intro sup_mono cSUP_subset_mono \<open>a \<le> b\<close>) auto
	then show ?case
	by (metis Vfrom)
	qed

	lemma Vfrom_mono2: "Vfrom a i \<le> Vfrom a (i \<squnion> j)"
	proof (induction arbitrary: j rule: eps_induct)
	case (step i)
	then have "a \<squnion> (\<Squnion>j\<in>elts i. VPow (Vfrom a j))
	\<le> a \<squnion> (\<Squnion>j\<in>elts (i \<squnion> j). VPow (Vfrom a j))"
	by (intro sup_mono cSUP_subset_mono order_refl) auto
	then show ?case
	by (metis Vfrom)
	qed

	lemma Vfrom_mono: "\<lbrakk>Ord i; a\<le>b; i\<le>j\<rbrakk> \<Longrightarrow> Vfrom a i \<le> Vfrom b j"
	by (metis (no_types) Vfrom_mono1 Vfrom_mono2 dual_order.trans sup.absorb_iff2)

	lemma Transset_Vfrom: "Transset(A) \<Longrightarrow> Transset(Vfrom A i)"
	proof (induction i rule: eps_induct)
	case (step i)
	then show ?case
	by (metis Transset_SUP Transset_VPow Transset_sup Vfrom)
	qed

	lemma Transset_Vset [simp]: "Transset(Vset i)"
	by (simp add: Transset_Vfrom)

	lemma Vfrom_sup: "Vfrom a (i \<squnion> j) = Vfrom a i \<squnion> Vfrom a j"
	proof (rule order_antisym)
	show "Vfrom a (i \<squnion> j) \<le> Vfrom a i \<squnion> Vfrom a j"
	by (simp add: Vfrom [of a "i \<squnion> j"] Vfrom [of a i] Vfrom [of a j] Sup_Un_distrib image_Un sup.assoc sup.left_commute)
	show "Vfrom a i \<squnion> Vfrom a j \<le> Vfrom a (i \<squnion> j)"
	by (metis Vfrom_mono2 le_supI sup_commute)
	qed

	lemma Vfrom_succ_Ord:
	assumes "Ord i" shows "Vfrom a (succ i) = a \<squnion> VPow(Vfrom a i)"
	proof (cases "i = 0")
	case True
	then show ?thesis
	by (simp add: Vfrom [of _ "succ 0"])
	next
	case False
	have *: "(\<Squnion>x\<in>elts i. VPow (Vfrom a x)) \<le> VPow (Vfrom a i)"
	proof (rule cSup_least)
	show "(\<lambda>x. VPow (Vfrom a x)) ` elts i \<noteq> {}"
	using False by auto
	show "x \<le> VPow (Vfrom a i)" if "x \<in> (\<lambda>x. VPow (Vfrom a x)) ` elts i" for x
	using that
	by clarsimp (meson Ord_in_Ord Ord_linear_le Vfrom_mono assms mem_not_refl order_refl vsubsetD)
	qed
	show ?thesis
	proof (rule Vfrom [THEN trans])
	show "a \<squnion> (\<Squnion>j\<in>elts (succ i). VPow (Vfrom a j)) = a \<squnion> VPow (Vfrom a i)"
	using assms
	by (intro sup_mono order_antisym) (auto simp: Sup_V_insert *)
	qed
	qed

	lemma Vset_succ: "Ord i \<Longrightarrow> Vset(succ(i)) = VPow(Vset(i))"
	by (simp add: Vfrom_succ_Ord)

	lemma Vfrom_Sup:
	assumes "X \<noteq> {}" "small X"
	shows "Vfrom a (Sup X) = (\<Squnion>y\<in>X. Vfrom a y)"
	proof (rule order_antisym)
	have "Vfrom a (\<Squnion> X) = a \<squnion> (\<Squnion>j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
	by (metis Vfrom)
	also have "\<dots> \<le> \<Squnion> (Vfrom a ` X)"
	proof -
	have "a \<le> \<Squnion> (Vfrom a ` X)"
	by (metis Vfrom all_not_in_conv assms bdd_above_iff_small cSUP_upper2 replacement sup_ge1)
	moreover have "(\<Squnion>j\<in>elts (\<Squnion> X). VPow (Vfrom a j)) \<le> \<Squnion> (Vfrom a ` X)"
	proof -
	have "VPow (Vfrom a x) \<le> \<Squnion> (Vfrom a ` X)"
	if "y \<in> X" "x \<in> elts y" for x y
	proof -
	have "VPow (Vfrom a x) \<le> Vfrom a y"
	by (metis Vfrom bdd_above_iff_small cSUP_upper2 le_supI2 order_refl replacement small_elts that(2))
	also have "\<dots> \<le> \<Squnion> (Vfrom a ` X)"
	using assms that by (force intro: cSUP_upper)
	finally show ?thesis .
	qed
	then show ?thesis
	by (simp add: SUP_le_iff \<open>small X\<close>)
	qed
	ultimately show ?thesis
	by auto
	qed
	finally show "Vfrom a (\<Squnion> X) \<le> \<Squnion> (Vfrom a ` X)" .
	have "\<And>x. x \<in> X \<Longrightarrow>
	a \<squnion> (\<Squnion>j\<in>elts x. VPow (Vfrom a j))
	\<le> a \<squnion> (\<Squnion>j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
	using cSUP_subset_mono \<open>small X\<close> by auto
	then show "\<Squnion> (Vfrom a ` X) \<le> Vfrom a (\<Squnion> X)"
	by (metis Vfrom assms(1) cSUP_least)
	qed

	lemma Limit_Vfrom_eq:
	"Limit(i) \<Longrightarrow> Vfrom a i = (\<Squnion>y \<in> elts i. Vfrom a y)"
	by (metis Limit_def Limit_eq_Sup_self Vfrom_Sup ex_in_conv small_elts)

	end
	diff --git a/web/entries/Abstract-Rewriting.html b/web/entries/Abstract-Rewriting.html
	--- a/web/entries/Abstract-Rewriting.html
	+++ b/web/entries/Abstract-Rewriting.html
	@@ -1,287 +1,287 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Abstract Rewriting - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>bstract

	<font class="first">R</font>ewriting

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Abstract Rewriting</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2010-06-14</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	We present an Isabelle formalization of abstract rewriting (see, e.g.,
	the book by Baader and Nipkow). First, we define standard relations like
	<i>joinability</i>, <i>meetability</i>, <i>conversion</i>, 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 <a
	href="http://cl-informatik.uibk.ac.at/software/ceta">CeTA</a> (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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2010-09-17]: Added theories defining several (ordered)
	semirings related to strong normalization and giving some standard
	instances. <br>
	[2013-10-16]: Generalized delta-orders from rationals to Archimedean fields.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Abstract-Rewriting-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {Abstract Rewriting},
	journal = {Archive of Formal Proofs},
	month = jun,
	year = 2010,
	note = {\url{https://isa-afp.org/entries/Abstract-Rewriting.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Regular-Sets.html">Regular-Sets</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Decreasing-Diagrams.html">Decreasing-Diagrams</a>, <a href="Decreasing-Diagrams-II.html">Decreasing-Diagrams-II</a>, <a href="First_Order_Terms.html">First_Order_Terms</a>, <a href="Matrix.html">Matrix</a>, <a href="Minsky_Machines.html">Minsky_Machines</a>, <a href="Myhill-Nerode.html">Myhill-Nerode</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="Polynomials.html">Polynomials</a>, <a href="Rewriting_Z.html">Rewriting_Z</a>, <a href="Well_Quasi_Orders.html">Well_Quasi_Orders</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Abstract-Rewriting/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Abstract-Rewriting/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Abstract-Rewriting/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Abstract-Rewriting-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Abstract-Rewriting-2021-02-23.tar.gz">
	afp-Abstract-Rewriting-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Abstract-Rewriting-2020-04-18.tar.gz">
	afp-Abstract-Rewriting-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Abstract-Rewriting-2019-06-11.tar.gz">
	afp-Abstract-Rewriting-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Abstract-Rewriting-2018-08-16.tar.gz">
	afp-Abstract-Rewriting-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Abstract-Rewriting-2017-10-10.tar.gz">
	afp-Abstract-Rewriting-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Abstract-Rewriting-2016-12-17.tar.gz">
	afp-Abstract-Rewriting-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Abstract-Rewriting-2016-02-22.tar.gz">
	afp-Abstract-Rewriting-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Abstract-Rewriting-2015-05-27.tar.gz">
	afp-Abstract-Rewriting-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Abstract-Rewriting-2014-08-28.tar.gz">
	afp-Abstract-Rewriting-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Abstract-Rewriting-2013-12-11.tar.gz">
	afp-Abstract-Rewriting-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Abstract-Rewriting-2013-11-17.tar.gz">
	afp-Abstract-Rewriting-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Abstract-Rewriting-2013-02-16.tar.gz">
	afp-Abstract-Rewriting-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Abstract-Rewriting-2012-05-24.tar.gz">
	afp-Abstract-Rewriting-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Abstract-Rewriting-2011-10-11.tar.gz">
	afp-Abstract-Rewriting-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-Abstract-Rewriting-2011-02-11.tar.gz">
	afp-Abstract-Rewriting-2011-02-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-2:
	<a href="../release/afp-Abstract-Rewriting-2010-06-30.tar.gz">
	afp-Abstract-Rewriting-2010-06-30.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-1:
	<a href="../release/afp-Abstract-Rewriting-2010-06-17.tar.gz">
	afp-Abstract-Rewriting-2010-06-17.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Abstract_Completeness.html b/web/entries/Abstract_Completeness.html
	--- a/web/entries/Abstract_Completeness.html
	+++ b/web/entries/Abstract_Completeness.html
	@@ -1,237 +1,237 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Abstract Completeness - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>bstract

	<font class="first">C</font>ompleteness

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Abstract Completeness</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Jasmin Christian Blanchette (j /dot/ c /dot/ blanchette /at/ vu /dot/ nl),
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a> and
	<a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2014-04-16</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">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].</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Abstract_Completeness-AFP,
	author = {Jasmin Christian Blanchette and Andrei Popescu and Dmitriy Traytel},
	title = {Abstract Completeness},
	journal = {Archive of Formal Proofs},
	month = apr,
	year = 2014,
	note = {\url{https://isa-afp.org/entries/Abstract_Completeness.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Collections.html">Collections</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="Abstract_Soundness.html">Abstract_Soundness</a>, <a href="Incredible_Proof_Machine.html">Incredible_Proof_Machine</a> </td></tr>
	+ <td class="data"><a href="Abstract_Soundness.html">Abstract_Soundness</a>, <a href="FOL_Seq_Calc2.html">FOL_Seq_Calc2</a>, <a href="Incredible_Proof_Machine.html">Incredible_Proof_Machine</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Abstract_Completeness/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Abstract_Completeness/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Abstract_Completeness/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Abstract_Completeness-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Abstract_Completeness-2021-02-23.tar.gz">
	afp-Abstract_Completeness-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Abstract_Completeness-2020-04-18.tar.gz">
	afp-Abstract_Completeness-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Abstract_Completeness-2019-06-11.tar.gz">
	afp-Abstract_Completeness-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Abstract_Completeness-2018-08-16.tar.gz">
	afp-Abstract_Completeness-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Abstract_Completeness-2017-10-10.tar.gz">
	afp-Abstract_Completeness-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Abstract_Completeness-2016-12-17.tar.gz">
	afp-Abstract_Completeness-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Abstract_Completeness-2016-02-22.tar.gz">
	afp-Abstract_Completeness-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Abstract_Completeness-2015-05-27.tar.gz">
	afp-Abstract_Completeness-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Abstract_Completeness-2014-08-28.tar.gz">
	afp-Abstract_Completeness-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Abstract_Completeness-2014-04-16.tar.gz">
	afp-Abstract_Completeness-2014-04-16.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Abstract_Soundness.html b/web/entries/Abstract_Soundness.html
	--- a/web/entries/Abstract_Soundness.html
	+++ b/web/entries/Abstract_Soundness.html
	@@ -1,222 +1,224 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Abstract Soundness - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>bstract

	<font class="first">S</font>oundness

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Abstract Soundness</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Jasmin Christian Blanchette (j /dot/ c /dot/ blanchette /at/ vu /dot/ nl),
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a> and
	<a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2017-02-10</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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 <em>Journal of Automated
	Reasoning</em>. The abstract proof can be instantiated for
	various formalisms, including first-order logic with inductive
	predicates.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Abstract_Soundness-AFP,
	author = {Jasmin Christian Blanchette and Andrei Popescu and Dmitriy Traytel},
	title = {Abstract Soundness},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2017,
	note = {\url{https://isa-afp.org/entries/Abstract_Soundness.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Abstract_Completeness.html">Abstract_Completeness</a> </td></tr>

	-
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="FOL_Seq_Calc2.html">FOL_Seq_Calc2</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Abstract_Soundness/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Abstract_Soundness/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Abstract_Soundness/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Abstract_Soundness-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Abstract_Soundness-2021-02-23.tar.gz">
	afp-Abstract_Soundness-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Abstract_Soundness-2020-04-18.tar.gz">
	afp-Abstract_Soundness-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Abstract_Soundness-2019-06-11.tar.gz">
	afp-Abstract_Soundness-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Abstract_Soundness-2018-08-16.tar.gz">
	afp-Abstract_Soundness-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Abstract_Soundness-2017-10-10.tar.gz">
	afp-Abstract_Soundness-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Abstract_Soundness-2017-02-13.tar.gz">
	afp-Abstract_Soundness-2017-02-13.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Actuarial_Mathematics.html b/web/entries/Actuarial_Mathematics.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Actuarial_Mathematics.html
	@@ -0,0 +1,192 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Actuarial Mathematics - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">A</font>ctuarial
	+
	+ <font class="first">M</font>athematics
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Actuarial Mathematics</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ Yosuke Ito (glacier345 /at/ gmail /dot/ com)
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-01-23</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+Actuarial Mathematics is a theory in applied mathematics, which is
	+mainly used for determining the prices of insurance products and
	+evaluating the liability of a company associating with insurance
	+contracts. It is related to calculus, probability theory and financial
	+theory, etc. In this entry, I formalize the very basic part of
	+Actuarial Mathematics in Isabelle/HOL. The first formalization is
	+about the theory of interest which deals with interest rates, present
	+value factors, an annuity certain, etc. I have already formalized the
	+basic part of Actuarial Mathematics in Coq
	+(https://github.com/Yosuke-Ito-345/Actuary). This entry is currently
	+the partial translation and a little generalization of the Coq
	+formalization. The further translation in Isabelle/HOL is now
	+proceeding.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Actuarial_Mathematics-AFP,
	+ author = {Yosuke Ito},
	+ title = {Actuarial Mathematics},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Actuarial_Mathematics.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Actuarial_Mathematics/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Actuarial_Mathematics/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Actuarial_Mathematics/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Actuarial_Mathematics-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Algebraic_Numbers.html b/web/entries/Algebraic_Numbers.html
	--- a/web/entries/Algebraic_Numbers.html
	+++ b/web/entries/Algebraic_Numbers.html
	@@ -1,246 +1,246 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Algebraic Numbers in Isabelle/HOL - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>lgebraic

	<font class="first">N</font>umbers

	in

	<font class="first">I</font>sabelle/HOL

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Algebraic Numbers in Isabelle/HOL</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>,
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at),
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp) and
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>
	</td>
	</tr>

	<tr>
	<td class="datahead">
	Contributor:
	</td>
	<td class="data">
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>


	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2015-12-22</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">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.
	</p><p>
	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.
	</p></td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2016-01-29]: Split off Polynomial Interpolation and Polynomial Factorization<br>
	[2017-04-16]: Use certified Berlekamp-Zassenhaus factorization, use subresultant algorithm for computing resultants, improved bisection algorithm</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Algebraic_Numbers-AFP,
	author = {René Thiemann and Akihisa Yamada and Sebastiaan Joosten},
	title = {Algebraic Numbers in Isabelle/HOL},
	journal = {Archive of Formal Proofs},
	month = dec,
	year = 2015,
	note = {\url{https://isa-afp.org/entries/Algebraic_Numbers.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Berlekamp_Zassenhaus.html">Berlekamp_Zassenhaus</a>, <a href="Sturm_Sequences.html">Sturm_Sequences</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="BenOr_Kozen_Reif.html">BenOr_Kozen_Reif</a>, <a href="Cubic_Quartic_Equations.html">Cubic_Quartic_Equations</a>, <a href="Factor_Algebraic_Polynomial.html">Factor_Algebraic_Polynomial</a>, <a href="Hermite_Lindemann.html">Hermite_Lindemann</a>, <a href="LLL_Basis_Reduction.html">LLL_Basis_Reduction</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Algebraic_Numbers/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Algebraic_Numbers/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Algebraic_Numbers/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Algebraic_Numbers-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Algebraic_Numbers-2021-02-23.tar.gz">
	afp-Algebraic_Numbers-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Algebraic_Numbers-2020-04-18.tar.gz">
	afp-Algebraic_Numbers-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Algebraic_Numbers-2019-06-11.tar.gz">
	afp-Algebraic_Numbers-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Algebraic_Numbers-2018-08-16.tar.gz">
	afp-Algebraic_Numbers-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Algebraic_Numbers-2017-10-10.tar.gz">
	afp-Algebraic_Numbers-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Algebraic_Numbers-2016-12-17.tar.gz">
	afp-Algebraic_Numbers-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Algebraic_Numbers-2016-02-22.tar.gz">
	afp-Algebraic_Numbers-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Algebraic_Numbers-2015-12-22.tar.gz">
	afp-Algebraic_Numbers-2015-12-22.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Berlekamp_Zassenhaus.html b/web/entries/Berlekamp_Zassenhaus.html
	--- a/web/entries/Berlekamp_Zassenhaus.html
	+++ b/web/entries/Berlekamp_Zassenhaus.html
	@@ -1,248 +1,248 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>The Factorization Algorithm of Berlekamp and Zassenhaus - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">T</font>he

	<font class="first">F</font>actorization

	<font class="first">A</font>lgorithm

	of

	<font class="first">B</font>erlekamp

	and

	<font class="first">Z</font>assenhaus

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">The Factorization Algorithm of Berlekamp and Zassenhaus</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-10-14</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>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.
	</p>
	<p>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.
	</p>
	<p>Through experiments we verify that our algorithm factors polynomials of degree
	100 within seconds.
	</p></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Berlekamp_Zassenhaus-AFP,
	author = {Jose Divasón and Sebastiaan Joosten and René Thiemann and Akihisa Yamada},
	title = {The Factorization Algorithm of Berlekamp and Zassenhaus},
	journal = {Archive of Formal Proofs},
	month = oct,
	year = 2016,
	note = {\url{https://isa-afp.org/entries/Berlekamp_Zassenhaus.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Efficient-Mergesort.html">Efficient-Mergesort</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="Polynomial_Interpolation.html">Polynomial_Interpolation</a>, <a href="Show.html">Show</a>, <a href="Subresultants.html">Subresultants</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Algebraic_Numbers.html">Algebraic_Numbers</a>, <a href="LLL_Basis_Reduction.html">LLL_Basis_Reduction</a>, <a href="Smith_Normal_Form.html">Smith_Normal_Form</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Berlekamp_Zassenhaus/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Berlekamp_Zassenhaus/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Berlekamp_Zassenhaus/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Berlekamp_Zassenhaus-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Berlekamp_Zassenhaus-2021-02-23.tar.gz">
	afp-Berlekamp_Zassenhaus-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Berlekamp_Zassenhaus-2020-04-18.tar.gz">
	afp-Berlekamp_Zassenhaus-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Berlekamp_Zassenhaus-2019-06-11.tar.gz">
	afp-Berlekamp_Zassenhaus-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Berlekamp_Zassenhaus-2018-09-07.tar.gz">
	afp-Berlekamp_Zassenhaus-2018-09-07.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Berlekamp_Zassenhaus-2018-08-16.tar.gz">
	afp-Berlekamp_Zassenhaus-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Berlekamp_Zassenhaus-2017-10-10.tar.gz">
	afp-Berlekamp_Zassenhaus-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Berlekamp_Zassenhaus-2016-12-17.tar.gz">
	afp-Berlekamp_Zassenhaus-2016-12-17.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Card_Equiv_Relations.html b/web/entries/Card_Equiv_Relations.html
	--- a/web/entries/Card_Equiv_Relations.html
	+++ b/web/entries/Card_Equiv_Relations.html
	@@ -1,234 +1,236 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Cardinality of Equivalence Relations - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">C</font>ardinality

	of

	<font class="first">E</font>quivalence

	<font class="first">R</font>elations

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Cardinality of Equivalence Relations</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	Lukas Bulwahn (lukas /dot/ bulwahn /at/ gmail /dot/ com)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-05-24</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Card_Equiv_Relations-AFP,
	author = {Lukas Bulwahn},
	title = {Cardinality of Equivalence Relations},
	journal = {Archive of Formal Proofs},
	month = may,
	year = 2016,
	note = {\url{https://isa-afp.org/entries/Card_Equiv_Relations.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Bell_Numbers_Spivey.html">Bell_Numbers_Spivey</a> </td></tr>

	-
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="Equivalence_Relation_Enumeration.html">Equivalence_Relation_Enumeration</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Card_Equiv_Relations/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Card_Equiv_Relations/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Card_Equiv_Relations/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Card_Equiv_Relations-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Card_Equiv_Relations-2021-02-23.tar.gz">
	afp-Card_Equiv_Relations-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Card_Equiv_Relations-2020-04-18.tar.gz">
	afp-Card_Equiv_Relations-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Card_Equiv_Relations-2019-06-11.tar.gz">
	afp-Card_Equiv_Relations-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Card_Equiv_Relations-2018-08-16.tar.gz">
	afp-Card_Equiv_Relations-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Card_Equiv_Relations-2017-10-10.tar.gz">
	afp-Card_Equiv_Relations-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Card_Equiv_Relations-2016-12-17.tar.gz">
	afp-Card_Equiv_Relations-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Card_Equiv_Relations-2016-05-24.tar.gz">
	afp-Card_Equiv_Relations-2016-05-24.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Certification_Monads.html b/web/entries/Certification_Monads.html
	--- a/web/entries/Certification_Monads.html
	+++ b/web/entries/Certification_Monads.html
	@@ -1,230 +1,230 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Certification Monads - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">C</font>ertification

	<font class="first">M</font>onads

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Certification Monads</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2014-10-03</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Certification_Monads-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {Certification Monads},
	journal = {Archive of Formal Proofs},
	month = oct,
	year = 2014,
	note = {\url{https://isa-afp.org/entries/Certification_Monads.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Partial_Function_MR.html">Partial_Function_MR</a>, <a href="Show.html">Show</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="AI_Planning_Languages_Semantics.html">AI_Planning_Languages_Semantics</a>, <a href="WOOT_Strong_Eventual_Consistency.html">WOOT_Strong_Eventual_Consistency</a>, <a href="XML.html">XML</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Certification_Monads/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Certification_Monads/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Certification_Monads/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Certification_Monads-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Certification_Monads-2021-02-23.tar.gz">
	afp-Certification_Monads-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Certification_Monads-2020-04-18.tar.gz">
	afp-Certification_Monads-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Certification_Monads-2019-06-11.tar.gz">
	afp-Certification_Monads-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Certification_Monads-2018-08-16.tar.gz">
	afp-Certification_Monads-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Certification_Monads-2017-10-10.tar.gz">
	afp-Certification_Monads-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Certification_Monads-2016-12-17.tar.gz">
	afp-Certification_Monads-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Certification_Monads-2016-02-22.tar.gz">
	afp-Certification_Monads-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Certification_Monads-2015-05-27.tar.gz">
	afp-Certification_Monads-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Certification_Monads-2014-10-08.tar.gz">
	afp-Certification_Monads-2014-10-08.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Collections.html b/web/entries/Collections.html
	--- a/web/entries/Collections.html
	+++ b/web/entries/Collections.html
	@@ -1,317 +1,317 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Collections Framework - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">C</font>ollections

	<font class="first">F</font>ramework

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Collections Framework</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	Peter Lammich
	</td>
	</tr>

	<tr>
	<td class="datahead">
	Contributors:
	</td>
	<td class="data">
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a> and
	Thomas Tuerk
	</td>
	</tr>


	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2009-11-25</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[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.<br>
	[2010-12-01]: New Interfaces: Priority Queues, Annotated Lists. Implemented by finger trees, (skew) binomial queues.<br>
	[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<br>
	[2012-04-25]: New iterator foundation by Tuerk. Various maintenance changes.<br>
	[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.<br>
	[2013-09]: Added Generic Collection Framework based on Autoref. The GenCF provides: Arbitrary nesting, full integration with Autoref.<br>
	[2014-06]: Maintenace changes to GenCF: Optimized inj_image on list_set. op_set_cart (Cartesian product). big-Union operation. atLeastLessThan - operation ({a..<b})<br></td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Collections-AFP,
	author = {Peter Lammich},
	title = {Collections Framework},
	journal = {Archive of Formal Proofs},
	month = nov,
	year = 2009,
	note = {\url{https://isa-afp.org/entries/Collections.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Binomial-Heaps.html">Binomial-Heaps</a>, <a href="Finger-Trees.html">Finger-Trees</a>, <a href="Native_Word.html">Native_Word</a>, <a href="Refine_Monadic.html">Refine_Monadic</a>, <a href="Trie.html">Trie</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="Abstract_Completeness.html">Abstract_Completeness</a>, <a href="Containers.html">Containers</a>, <a href="Deriving.html">Deriving</a>, <a href="Dijkstra_Shortest_Path.html">Dijkstra_Shortest_Path</a>, <a href="Formal_SSA.html">Formal_SSA</a>, <a href="Gale_Shapley.html">Gale_Shapley</a>, <a href="JinjaThreads.html">JinjaThreads</a>, <a href="Kruskal.html">Kruskal</a>, <a href="ROBDD.html">ROBDD</a>, <a href="Separation_Logic_Imperative_HOL.html">Separation_Logic_Imperative_HOL</a>, <a href="Transition_Systems_and_Automata.html">Transition_Systems_and_Automata</a>, <a href="Transitive-Closure.html">Transitive-Closure</a>, <a href="Tree-Automata.html">Tree-Automata</a> </td></tr>
	+ <td class="data"><a href="Abstract_Completeness.html">Abstract_Completeness</a>, <a href="Containers.html">Containers</a>, <a href="Deriving.html">Deriving</a>, <a href="Dijkstra_Shortest_Path.html">Dijkstra_Shortest_Path</a>, <a href="FOL_Seq_Calc2.html">FOL_Seq_Calc2</a>, <a href="Formal_SSA.html">Formal_SSA</a>, <a href="Gale_Shapley.html">Gale_Shapley</a>, <a href="JinjaThreads.html">JinjaThreads</a>, <a href="Kruskal.html">Kruskal</a>, <a href="ROBDD.html">ROBDD</a>, <a href="Separation_Logic_Imperative_HOL.html">Separation_Logic_Imperative_HOL</a>, <a href="Transition_Systems_and_Automata.html">Transition_Systems_and_Automata</a>, <a href="Transitive-Closure.html">Transitive-Closure</a>, <a href="Tree-Automata.html">Tree-Automata</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Collections/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Collections/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Collections/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Collections-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Collections-2021-02-23.tar.gz">
	afp-Collections-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Collections-2020-04-18.tar.gz">
	afp-Collections-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Collections-2019-06-11.tar.gz">
	afp-Collections-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Collections-2018-08-16.tar.gz">
	afp-Collections-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Collections-2017-10-10.tar.gz">
	afp-Collections-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Collections-2016-12-17.tar.gz">
	afp-Collections-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Collections-2016-02-22.tar.gz">
	afp-Collections-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Collections-2015-05-27.tar.gz">
	afp-Collections-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Collections-2014-08-28.tar.gz">
	afp-Collections-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Collections-2013-12-11.tar.gz">
	afp-Collections-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Collections-2013-11-17.tar.gz">
	afp-Collections-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Collections-2013-03-02.tar.gz">
	afp-Collections-2013-03-02.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Collections-2013-02-16.tar.gz">
	afp-Collections-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Collections-2012-05-24.tar.gz">
	afp-Collections-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Collections-2011-10-12.tar.gz">
	afp-Collections-2011-10-12.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Collections-2011-10-11.tar.gz">
	afp-Collections-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-Collections-2011-02-11.tar.gz">
	afp-Collections-2011-02-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-2:
	<a href="../release/afp-Collections-2010-06-30.tar.gz">
	afp-Collections-2010-06-30.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-1:
	<a href="../release/afp-Collections-2009-12-13.tar.gz">
	afp-Collections-2009-12-13.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-1:
	<a href="../release/afp-Collections-2009-12-12.tar.gz">
	afp-Collections-2009-12-12.tar.gz
	</a>
	</li>
	<li>Isabelle 2009:
	<a href="../release/afp-Collections-2009-11-29.tar.gz">
	afp-Collections-2009-11-29.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Containers.html b/web/entries/Containers.html
	--- a/web/entries/Containers.html
	+++ b/web/entries/Containers.html
	@@ -1,268 +1,268 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Light-weight Containers - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">L</font>ight-weight

	<font class="first">C</font>ontainers

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Light-weight Containers</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>

	<tr>
	<td class="datahead">
	Contributor:
	</td>
	<td class="data">
	René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>


	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2013-04-15</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.
	<p>
	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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2013-07-11]: add pretty printing for sets (revision 7f3f52c5f5fa)<br>
	[2013-09-20]:
	provide generators for canonical type class instantiations
	(revision 159f4401f4a8 by René Thiemann)<br>
	[2014-07-08]: add support for going from partial functions to mappings (revision 7a6fc957e8ed)<br>
	[2018-03-05]: add two application examples: depth-first search and 2SAT (revision e5e1a1da2411)</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Containers-AFP,
	author = {Andreas Lochbihler},
	title = {Light-weight Containers},
	journal = {Archive of Formal Proofs},
	month = apr,
	year = 2013,
	note = {\url{https://isa-afp.org/entries/Containers.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Automatic_Refinement.html">Automatic_Refinement</a>, <a href="Collections.html">Collections</a>, <a href="Deriving.html">Deriving</a>, <a href="Finger-Trees.html">Finger-Trees</a>, <a href="Regular-Sets.html">Regular-Sets</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="AI_Planning_Languages_Semantics.html">AI_Planning_Languages_Semantics</a>, <a href="MFOTL_Monitor.html">MFOTL_Monitor</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a> </td></tr>
	+ <td class="data"><a href="AI_Planning_Languages_Semantics.html">AI_Planning_Languages_Semantics</a>, <a href="Eval_FO.html">Eval_FO</a>, <a href="MFOTL_Monitor.html">MFOTL_Monitor</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="VYDRA_MDL.html">VYDRA_MDL</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Containers/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Containers/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Containers/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Containers-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Containers-2021-02-23.tar.gz">
	afp-Containers-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Containers-2020-04-18.tar.gz">
	afp-Containers-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Containers-2019-06-11.tar.gz">
	afp-Containers-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Containers-2018-08-16.tar.gz">
	afp-Containers-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Containers-2017-10-10.tar.gz">
	afp-Containers-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Containers-2016-12-17.tar.gz">
	afp-Containers-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Containers-2016-02-22.tar.gz">
	afp-Containers-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Containers-2015-05-27.tar.gz">
	afp-Containers-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Containers-2014-08-28.tar.gz">
	afp-Containers-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Containers-2013-12-11.tar.gz">
	afp-Containers-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Containers-2013-11-17.tar.gz">
	afp-Containers-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Containers-2013-04-23.tar.gz">
	afp-Containers-2013-04-23.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Cubic_Quartic_Equations.html b/web/entries/Cubic_Quartic_Equations.html
	--- a/web/entries/Cubic_Quartic_Equations.html
	+++ b/web/entries/Cubic_Quartic_Equations.html
	@@ -1,201 +1,201 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Solving Cubic and Quartic Equations - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">S</font>olving

	<font class="first">C</font>ubic

	and

	<font class="first">Q</font>uartic

	<font class="first">E</font>quations

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Solving Cubic and Quartic Equations</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2021-09-03</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>We formalize Cardano's formula to solve a cubic equation
	$$ax^3 + bx^2 + cx + d = 0,$$ as well as Ferrari's formula to
	solve a quartic equation. We further turn both formulas into
	executable algorithms based on the algebraic number implementation in
	the AFP. To this end we also slightly extended this library, namely by
	making the minimal polynomial of an algebraic number executable, and
	by defining and implementing $n$-th roots of complex
	numbers.</p></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Cubic_Quartic_Equations-AFP,
	author = {René Thiemann},
	title = {Solving Cubic and Quartic Equations},
	journal = {Archive of Formal Proofs},
	month = sep,
	year = 2021,
	note = {\url{https://isa-afp.org/entries/Cubic_Quartic_Equations.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Algebraic_Numbers.html">Algebraic_Numbers</a>, <a href="Complex_Geometry.html">Complex_Geometry</a>, <a href="Factor_Algebraic_Polynomial.html">Factor_Algebraic_Polynomial</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Cubic_Quartic_Equations/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Cubic_Quartic_Equations/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Cubic_Quartic_Equations/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Cubic_Quartic_Equations-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Cubic_Quartic_Equations-2021-09-03.tar.gz">
	afp-Cubic_Quartic_Equations-2021-09-03.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Datatype_Order_Generator.html b/web/entries/Datatype_Order_Generator.html
	--- a/web/entries/Datatype_Order_Generator.html
	+++ b/web/entries/Datatype_Order_Generator.html
	@@ -1,273 +1,273 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Generating linear orders for datatypes - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">G</font>enerating

	linear

	orders

	for

	datatypes

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Generating linear orders for datatypes</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2012-08-07</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.
	<p>
	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.
	<p>
	Our formalization was performed as part of the <a href="http://cl-informatik.uibk.ac.at/software/ceta">IsaFoR/CeTA</a> project.
	With our new tactic we could completely remove
	tedious proofs for linear orders of two datatypes.
	<p>
	This development is aimed at datatypes generated by the "old_datatype"
	command.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Datatype_Order_Generator-AFP,
	author = {René Thiemann},
	title = {Generating linear orders for datatypes},
	journal = {Archive of Formal Proofs},
	month = aug,
	year = 2012,
	note = {\url{https://isa-afp.org/entries/Datatype_Order_Generator.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Deriving.html">Deriving</a>, <a href="Native_Word.html">Native_Word</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Higher_Order_Terms.html">Higher_Order_Terms</a>, <a href="WOOT_Strong_Eventual_Consistency.html">WOOT_Strong_Eventual_Consistency</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Datatype_Order_Generator/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Datatype_Order_Generator/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Datatype_Order_Generator/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Datatype_Order_Generator-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Datatype_Order_Generator-2021-02-23.tar.gz">
	afp-Datatype_Order_Generator-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Datatype_Order_Generator-2020-04-18.tar.gz">
	afp-Datatype_Order_Generator-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Datatype_Order_Generator-2019-06-11.tar.gz">
	afp-Datatype_Order_Generator-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Datatype_Order_Generator-2018-08-16.tar.gz">
	afp-Datatype_Order_Generator-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Datatype_Order_Generator-2017-10-10.tar.gz">
	afp-Datatype_Order_Generator-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Datatype_Order_Generator-2016-12-17.tar.gz">
	afp-Datatype_Order_Generator-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Datatype_Order_Generator-2016-02-22.tar.gz">
	afp-Datatype_Order_Generator-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Datatype_Order_Generator-2015-05-27.tar.gz">
	afp-Datatype_Order_Generator-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Datatype_Order_Generator-2014-08-28.tar.gz">
	afp-Datatype_Order_Generator-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Datatype_Order_Generator-2013-12-11.tar.gz">
	afp-Datatype_Order_Generator-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Datatype_Order_Generator-2013-11-17.tar.gz">
	afp-Datatype_Order_Generator-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Datatype_Order_Generator-2013-03-02.tar.gz">
	afp-Datatype_Order_Generator-2013-03-02.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Datatype_Order_Generator-2013-02-16.tar.gz">
	afp-Datatype_Order_Generator-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Datatype_Order_Generator-2012-08-07.tar.gz">
	afp-Datatype_Order_Generator-2012-08-07.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Depth-First-Search.html b/web/entries/Depth-First-Search.html
	--- a/web/entries/Depth-First-Search.html
	+++ b/web/entries/Depth-First-Search.html
	@@ -1,293 +1,293 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Depth First Search - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">D</font>epth

	<font class="first">F</font>irst

	<font class="first">S</font>earch

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Depth First Search</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Toshiaki Nishihara and
	- Yasuhiko Minamide
	+ <a href="https://sv.c.titech.ac.jp/minamide/index.en.html">Yasuhiko Minamide</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2004-06-24</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Depth-First-Search-AFP,
	author = {Toshiaki Nishihara and Yasuhiko Minamide},
	title = {Depth First Search},
	journal = {Archive of Formal Proofs},
	month = jun,
	year = 2004,
	note = {\url{https://isa-afp.org/entries/Depth-First-Search.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>






	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Depth-First-Search/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Depth-First-Search/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Depth-First-Search/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Depth-First-Search-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Depth-First-Search-2021-02-23.tar.gz">
	afp-Depth-First-Search-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Depth-First-Search-2020-04-18.tar.gz">
	afp-Depth-First-Search-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Depth-First-Search-2019-06-11.tar.gz">
	afp-Depth-First-Search-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Depth-First-Search-2018-08-16.tar.gz">
	afp-Depth-First-Search-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Depth-First-Search-2017-10-10.tar.gz">
	afp-Depth-First-Search-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Depth-First-Search-2016-12-17.tar.gz">
	afp-Depth-First-Search-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Depth-First-Search-2016-02-22.tar.gz">
	afp-Depth-First-Search-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Depth-First-Search-2015-05-27.tar.gz">
	afp-Depth-First-Search-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Depth-First-Search-2014-08-28.tar.gz">
	afp-Depth-First-Search-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Depth-First-Search-2013-12-11.tar.gz">
	afp-Depth-First-Search-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Depth-First-Search-2013-11-17.tar.gz">
	afp-Depth-First-Search-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Depth-First-Search-2013-02-16.tar.gz">
	afp-Depth-First-Search-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Depth-First-Search-2012-05-24.tar.gz">
	afp-Depth-First-Search-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Depth-First-Search-2011-10-11.tar.gz">
	afp-Depth-First-Search-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-Depth-First-Search-2011-02-11.tar.gz">
	afp-Depth-First-Search-2011-02-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-2:
	<a href="../release/afp-Depth-First-Search-2010-06-30.tar.gz">
	afp-Depth-First-Search-2010-06-30.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-1:
	<a href="../release/afp-Depth-First-Search-2009-12-12.tar.gz">
	afp-Depth-First-Search-2009-12-12.tar.gz
	</a>
	</li>
	<li>Isabelle 2009:
	<a href="../release/afp-Depth-First-Search-2009-04-29.tar.gz">
	afp-Depth-First-Search-2009-04-29.tar.gz
	</a>
	</li>
	<li>Isabelle 2008:
	<a href="../release/afp-Depth-First-Search-2008-06-10.tar.gz">
	afp-Depth-First-Search-2008-06-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2007:
	<a href="../release/afp-Depth-First-Search-2007-11-27.tar.gz">
	afp-Depth-First-Search-2007-11-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2005:
	<a href="../release/afp-Depth-First-Search-2005-10-14.tar.gz">
	afp-Depth-First-Search-2005-10-14.tar.gz
	</a>
	</li>
	<li>Isabelle 2004:
	<a href="../release/afp-Depth-First-Search-2004-06-24.tar.gz">
	afp-Depth-First-Search-2004-06-24.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Deriving.html b/web/entries/Deriving.html
	--- a/web/entries/Deriving.html
	+++ b/web/entries/Deriving.html
	@@ -1,244 +1,244 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Deriving class instances for datatypes - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">D</font>eriving

	class

	instances

	for

	datatypes

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Deriving class instances for datatypes</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2015-03-11</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>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.</p>
	<p>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.</p>
	<p>Our formalization was performed as part of the <a href="http://cl-informatik.uibk.ac.at/software/ceta">IsaFoR/CeTA</a> 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.</p></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Deriving-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {Deriving class instances for datatypes},
	journal = {Archive of Formal Proofs},
	month = mar,
	year = 2015,
	note = {\url{https://isa-afp.org/entries/Deriving.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Collections.html">Collections</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Affine_Arithmetic.html">Affine_Arithmetic</a>, <a href="Containers.html">Containers</a>, <a href="Datatype_Order_Generator.html">Datatype_Order_Generator</a>, <a href="Formula_Derivatives.html">Formula_Derivatives</a>, <a href="Groebner_Bases.html">Groebner_Bases</a>, <a href="LTL_Master_Theorem.html">LTL_Master_Theorem</a>, <a href="MSO_Regex_Equivalence.html">MSO_Regex_Equivalence</a>, <a href="Real_Impl.html">Real_Impl</a>, <a href="Show.html">Show</a>, <a href="Van_Emde_Boas_Trees.html">Van_Emde_Boas_Trees</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Deriving/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Deriving/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Deriving/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Deriving-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Deriving-2021-02-23.tar.gz">
	afp-Deriving-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Deriving-2020-04-18.tar.gz">
	afp-Deriving-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Deriving-2019-06-11.tar.gz">
	afp-Deriving-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Deriving-2018-08-16.tar.gz">
	afp-Deriving-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Deriving-2017-10-10.tar.gz">
	afp-Deriving-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Deriving-2016-12-17.tar.gz">
	afp-Deriving-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Deriving-2016-02-22.tar.gz">
	afp-Deriving-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Deriving-2015-05-27.tar.gz">
	afp-Deriving-2015-05-27.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Equivalence_Relation_Enumeration.html b/web/entries/Equivalence_Relation_Enumeration.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Equivalence_Relation_Enumeration.html
	@@ -0,0 +1,198 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Enumeration of Equivalence Relations - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">E</font>numeration
	+
	+ of
	+
	+ <font class="first">E</font>quivalence
	+
	+ <font class="first">R</font>elations
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Enumeration of Equivalence Relations</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-04</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+<p>This entry contains a formalization of an algorithm
	+enumerating all equivalence relations on an initial segment of the
	+natural numbers. The approach follows the method described by Stanton
	+and White <a
	+href="https://doi.org/10.1007/978-1-4612-4968-9">[5,§
	+1.5]</a> using restricted growth functions.</p>
	+<p>The algorithm internally enumerates restricted growth
	+functions (as lists), whose equivalence kernels then form the
	+equivalence relations. This has the advantage that the representation
	+is compact and lookup of the relation reduces to a list lookup
	+operation.</p> <p>The algorithm can also be used within a
	+proof and an example application is included, where a sequence of
	+variables is split by the possible partitions they can form.</p></td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Equivalence_Relation_Enumeration-AFP,
	+ author = {Emin Karayel},
	+ title = {Enumeration of Equivalence Relations},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Equivalence_Relation_Enumeration.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="Card_Equiv_Relations.html">Card_Equiv_Relations</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Equivalence_Relation_Enumeration/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Equivalence_Relation_Enumeration/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Equivalence_Relation_Enumeration/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Equivalence_Relation_Enumeration-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Eval_FO.html b/web/entries/Eval_FO.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Eval_FO.html
	@@ -0,0 +1,220 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>First-Order Query Evaluation - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">F</font>irst-Order
	+
	+ <font class="first">Q</font>uery
	+
	+ <font class="first">E</font>valuation
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">First-Order Query Evaluation</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ Martin Raszyk (martin /dot/ raszyk /at/ inf /dot/ ethz /dot/ ch)
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-15</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+We formalize first-order query evaluation over an infinite domain with
	+equality. We first define the syntax and semantics of first-order
	+logic with equality. Next we define a locale
	+<i>eval&lowbar;fo</i> abstracting a representation of
	+a potentially infinite set of tuples satisfying a first-order query
	+over finite relations. Inside the locale, we define a function
	+<i>eval</i> checking if the set of tuples satisfying a
	+first-order query over a database (an interpretation of the
	+query's predicates) is finite (i.e., deciding <i>relative
	+safety</i>) and computing the set of satisfying tuples if it is
	+finite. Altogether the function <i>eval</i> solves
	+<i>capturability</i> (Avron and Hirshfeld, 1991) of
	+first-order logic with equality. We also use the function
	+<i>eval</i> to prove a code equation for the semantics of
	+first-order logic, i.e., the function checking if a first-order query
	+over a database is satisfied by a variable assignment.<br/> We provide an
	+interpretation of the locale <i>eval&lowbar;fo</i>
	+based on the approach by Ailamazyan et al. A core notion in the
	+interpretation is the active domain of a query and a database that
	+contains all domain elements that occur in the database or interpret
	+the query's constants. We prove the main theorem of Ailamazyan et
	+al. relating the satisfaction of a first-order query over an infinite
	+domain to the satisfaction of this query over a finite domain
	+consisting of the active domain and a few additional domain elements
	+(outside the active domain) whose number only depends on the query. In
	+our interpretation of the locale
	+<i>eval&lowbar;fo</i>, we use a potentially higher
	+number of the additional domain elements, but their number still only
	+depends on the query and thus has no effect on the data complexity
	+(Vardi, 1982) of query evaluation. Our interpretation yields an
	+<i>executable</i> function <i>eval</i>. The
	+time complexity of <i>eval</i> on a query is linear in the
	+total number of tuples in the intermediate relations for the
	+subqueries. Specifically, we build a database index to evaluate a
	+conjunction. We also optimize the case of a negated subquery in a
	+conjunction. Finally, we export code for the infinite domain of
	+natural numbers.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Eval_FO-AFP,
	+ author = {Martin Raszyk},
	+ title = {First-Order Query Evaluation},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Eval_FO.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="Containers.html">Containers</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Eval_FO/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Eval_FO/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Eval_FO/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Eval_FO-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/FOL-Fitting.html b/web/entries/FOL-Fitting.html
	--- a/web/entries/FOL-Fitting.html
	+++ b/web/entries/FOL-Fitting.html
	@@ -1,305 +1,305 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>First-Order Logic According to Fitting - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">F</font>irst-Order

	<font class="first">L</font>ogic

	<font class="first">A</font>ccording

	to

	<font class="first">F</font>itting

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">First-Order Logic According to Fitting</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="http://www.in.tum.de/~berghofe">Stefan Berghofer</a>
	</td>
	</tr>

	<tr>
	<td class="datahead">
	Contributor:
	</td>
	<td class="data">
	<a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	</td>
	</tr>


	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2007-08-02</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{FOL-Fitting-AFP,
	author = {Stefan Berghofer},
	title = {First-Order Logic According to Fitting},
	journal = {Archive of Formal Proofs},
	month = aug,
	year = 2007,
	note = {\url{https://isa-afp.org/entries/FOL-Fitting.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>



	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="FOL_Seq_Calc1.html">FOL_Seq_Calc1</a> </td></tr>
	+ <td class="data"><a href="FO_Theory_Rewriting.html">FO_Theory_Rewriting</a>, <a href="FOL_Seq_Calc1.html">FOL_Seq_Calc1</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/FOL-Fitting/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/FOL-Fitting/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/FOL-Fitting/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-FOL-Fitting-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-FOL-Fitting-2021-02-23.tar.gz">
	afp-FOL-Fitting-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-FOL-Fitting-2020-04-18.tar.gz">
	afp-FOL-Fitting-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-FOL-Fitting-2019-06-11.tar.gz">
	afp-FOL-Fitting-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-FOL-Fitting-2018-08-16.tar.gz">
	afp-FOL-Fitting-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-FOL-Fitting-2017-10-10.tar.gz">
	afp-FOL-Fitting-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-FOL-Fitting-2016-12-17.tar.gz">
	afp-FOL-Fitting-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-FOL-Fitting-2016-02-22.tar.gz">
	afp-FOL-Fitting-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-FOL-Fitting-2015-05-27.tar.gz">
	afp-FOL-Fitting-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-FOL-Fitting-2014-08-28.tar.gz">
	afp-FOL-Fitting-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-FOL-Fitting-2013-12-11.tar.gz">
	afp-FOL-Fitting-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-FOL-Fitting-2013-11-17.tar.gz">
	afp-FOL-Fitting-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-FOL-Fitting-2013-03-02.tar.gz">
	afp-FOL-Fitting-2013-03-02.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-FOL-Fitting-2013-02-16.tar.gz">
	afp-FOL-Fitting-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-FOL-Fitting-2012-05-24.tar.gz">
	afp-FOL-Fitting-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-FOL-Fitting-2011-10-11.tar.gz">
	afp-FOL-Fitting-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-FOL-Fitting-2011-02-11.tar.gz">
	afp-FOL-Fitting-2011-02-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-2:
	<a href="../release/afp-FOL-Fitting-2010-06-30.tar.gz">
	afp-FOL-Fitting-2010-06-30.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-1:
	<a href="../release/afp-FOL-Fitting-2009-12-12.tar.gz">
	afp-FOL-Fitting-2009-12-12.tar.gz
	</a>
	</li>
	<li>Isabelle 2009:
	<a href="../release/afp-FOL-Fitting-2009-04-29.tar.gz">
	afp-FOL-Fitting-2009-04-29.tar.gz
	</a>
	</li>
	<li>Isabelle 2008:
	<a href="../release/afp-FOL-Fitting-2008-06-10.tar.gz">
	afp-FOL-Fitting-2008-06-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2007:
	<a href="../release/afp-FOL-Fitting-2007-11-27.tar.gz">
	afp-FOL-Fitting-2007-11-27.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/FOL_Seq_Calc1.html b/web/entries/FOL_Seq_Calc1.html
	--- a/web/entries/FOL_Seq_Calc1.html
	+++ b/web/entries/FOL_Seq_Calc1.html
	@@ -1,222 +1,224 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>A Sequent Calculus for First-Order Logic - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>

	<font class="first">S</font>equent

	<font class="first">C</font>alculus

	for

	<font class="first">F</font>irst-Order

	<font class="first">L</font>ogic

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">A Sequent Calculus for First-Order Logic</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	</td>
	</tr>

	<tr>
	<td class="datahead">
	Contributors:
	</td>
	<td class="data">
	<a href="https://people.compute.dtu.dk/aleje/">Alexander Birch Jensen</a>,
	<a href="https://people.compute.dtu.dk/andschl/">Anders Schlichtkrull</a> and
	<a href="https://people.compute.dtu.dk/jovi/">Jørgen Villadsen</a>
	</td>
	</tr>


	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2019-07-18</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.
	Paper: <a href="http://ceur-ws.org/Vol-3002/paper7.pdf">http://ceur-ws.org/Vol-3002/paper7.pdf</a>.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{FOL_Seq_Calc1-AFP,
	author = {Asta Halkjær From},
	title = {A Sequent Calculus for First-Order Logic},
	journal = {Archive of Formal Proofs},
	month = jul,
	year = 2019,
	note = {\url{https://isa-afp.org/entries/FOL_Seq_Calc1.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="FOL-Fitting.html">FOL-Fitting</a> </td></tr>

	-
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="FOL_Seq_Calc2.html">FOL_Seq_Calc2</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/FOL_Seq_Calc1/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/FOL_Seq_Calc1/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/FOL_Seq_Calc1/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-FOL_Seq_Calc1-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-FOL_Seq_Calc1-2021-02-23.tar.gz">
	afp-FOL_Seq_Calc1-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-FOL_Seq_Calc1-2020-04-18.tar.gz">
	afp-FOL_Seq_Calc1-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-FOL_Seq_Calc1-2019-07-18.tar.gz">
	afp-FOL_Seq_Calc1-2019-07-18.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/FOL_Seq_Calc2.html b/web/entries/FOL_Seq_Calc2.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/FOL_Seq_Calc2.html
	@@ -0,0 +1,208 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>A Sequent Calculus Prover for First-Order Logic with Functions - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">A</font>
	+
	+ <font class="first">S</font>equent
	+
	+ <font class="first">C</font>alculus
	+
	+ <font class="first">P</font>rover
	+
	+ for
	+
	+ <font class="first">F</font>irst-Order
	+
	+ <font class="first">L</font>ogic
	+
	+ with
	+
	+ <font class="first">F</font>unctions
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">A Sequent Calculus Prover for First-Order Logic with Functions</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ <a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a> and
	+ <a href="http://people.compute.dtu.dk/fkjac/">Frederik Krogsdal Jacobsen</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-01-31</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+We formalize an automated theorem prover for first-order logic with
	+functions. The proof search procedure is based on sequent calculus and
	+we verify its soundness and completeness using the Abstract Soundness
	+and Abstract Completeness theories. Our analytic completeness proof
	+covers both open and closed formulas. Since our deterministic prover
	+considers only the subset of terms relevant to proving a given
	+sequent, we do so as well when building a countermodel from a failed
	+proof. We formally connect our prover with the proof system and
	+semantics of the existing SeCaV system. In particular, the
	+prover's output can be post-processed in Haskell to generate
	+human-readable SeCaV proofs which are also machine-verifiable proof
	+certificates.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{FOL_Seq_Calc2-AFP,
	+ author = {Asta Halkjær From and Frederik Krogsdal Jacobsen},
	+ title = {A Sequent Calculus Prover for First-Order Logic with Functions},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/FOL_Seq_Calc2.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="Abstract_Completeness.html">Abstract_Completeness</a>, <a href="Abstract_Soundness.html">Abstract_Soundness</a>, <a href="Collections.html">Collections</a>, <a href="FOL_Seq_Calc1.html">FOL_Seq_Calc1</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/FOL_Seq_Calc2/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/FOL_Seq_Calc2/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/FOL_Seq_Calc2/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-FOL_Seq_Calc2-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/FO_Theory_Rewriting.html b/web/entries/FO_Theory_Rewriting.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/FO_Theory_Rewriting.html
	@@ -0,0 +1,198 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>First-Order Theory of Rewriting - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">F</font>irst-Order
	+
	+ <font class="first">T</font>heory
	+
	+ of
	+
	+ <font class="first">R</font>ewriting
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">First-Order Theory of Rewriting</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ Alexander Lochmann (alexander /dot/ lochmann /at/ uibk /dot/ ac /dot/ at) and
	+ Bertram Felgenhauer
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-02</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+The first-order theory of rewriting (FORT) is a decidable theory for
	+linear variable-separated rewrite systems. The decision procedure is
	+based on tree automata technique and an inference system presented in
	+"Certifying Proofs in the First-Order Theory of Rewriting".
	+This AFP entry provides a formalization of the underlying decision
	+procedure. Moreover it allows to generate a function that can verify
	+each inference step via the code generation facility of Isabelle/HOL.
	+Additionally it contains the specification of a certificate language
	+(that allows to state proofs in FORT) and a formalized function that
	+allows to verify the validity of the proof. This gives software tool
	+authors, that implement the decision procedure, the possibility to
	+verify their output.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{FO_Theory_Rewriting-AFP,
	+ author = {Alexander Lochmann and Bertram Felgenhauer},
	+ title = {First-Order Theory of Rewriting},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/FO_Theory_Rewriting.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="FOL-Fitting.html">FOL-Fitting</a>, <a href="Regular_Tree_Relations.html">Regular_Tree_Relations</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/FO_Theory_Rewriting/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/FO_Theory_Rewriting/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/FO_Theory_Rewriting/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-FO_Theory_Rewriting-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Factor_Algebraic_Polynomial.html b/web/entries/Factor_Algebraic_Polynomial.html
	--- a/web/entries/Factor_Algebraic_Polynomial.html
	+++ b/web/entries/Factor_Algebraic_Polynomial.html
	@@ -1,208 +1,208 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Factorization of Polynomials with Algebraic Coefficients - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">F</font>actorization

	of

	<font class="first">P</font>olynomials

	with

	<font class="first">A</font>lgebraic

	<font class="first">C</font>oefficients

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Factorization of Polynomials with Algebraic Coefficients</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="https://pruvisto.org">Manuel Eberl</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2021-11-08</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	The AFP already contains a verified implementation of algebraic
	numbers. However, it is has a severe limitation in its factorization
	algorithm of real and complex polynomials: the factorization is only
	guaranteed to succeed if the coefficients of the polynomial are
	rational numbers. In this work, we verify an algorithm to factor all
	real and complex polynomials whose coefficients are algebraic. The
	existence of such an algorithm proves in a constructive way that the
	set of complex algebraic numbers is algebraically closed. Internally,
	the algorithm is based on resultants of multivariate polynomials and
	an approximation algorithm using interval arithmetic.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Factor_Algebraic_Polynomial-AFP,
	author = {Manuel Eberl and René Thiemann},
	title = {Factorization of Polynomials with Algebraic Coefficients},
	journal = {Archive of Formal Proofs},
	month = nov,
	year = 2021,
	note = {\url{https://isa-afp.org/entries/Factor_Algebraic_Polynomial.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Algebraic_Numbers.html">Algebraic_Numbers</a>, <a href="Hermite_Lindemann.html">Hermite_Lindemann</a>, <a href="Polynomials.html">Polynomials</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Cubic_Quartic_Equations.html">Cubic_Quartic_Equations</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Factor_Algebraic_Polynomial/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Factor_Algebraic_Polynomial/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Factor_Algebraic_Polynomial/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Factor_Algebraic_Polynomial-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Factor_Algebraic_Polynomial-2021-11-14.tar.gz">
	afp-Factor_Algebraic_Polynomial-2021-11-14.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Farkas.html b/web/entries/Farkas.html
	--- a/web/entries/Farkas.html
	+++ b/web/entries/Farkas.html
	@@ -1,222 +1,222 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Farkas' Lemma and Motzkin's Transposition Theorem - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">F</font>arkas'

	<font class="first">L</font>emma

	and

	<font class="first">M</font>otzkin's

	<font class="first">T</font>ransposition

	<font class="first">T</font>heorem

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Farkas' Lemma and Motzkin's Transposition Theorem</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Ralph Bottesch,
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Max W. Haslbeck</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2019-01-17</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Farkas-AFP,
	author = {Ralph Bottesch and Max W. Haslbeck and René Thiemann},
	title = {Farkas' Lemma and Motzkin's Transposition Theorem},
	journal = {Archive of Formal Proofs},
	month = jan,
	year = 2019,
	note = {\url{https://isa-afp.org/entries/Farkas.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a>, <a href="Simplex.html">Simplex</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Linear_Programming.html">Linear_Programming</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Farkas/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Farkas/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Farkas/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Farkas-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Farkas-2021-02-23.tar.gz">
	afp-Farkas-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Farkas-2020-04-18.tar.gz">
	afp-Farkas-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Farkas-2019-06-11.tar.gz">
	afp-Farkas-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Farkas-2019-01-21.tar.gz">
	afp-Farkas-2019-01-21.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/First_Order_Terms.html b/web/entries/First_Order_Terms.html
	--- a/web/entries/First_Order_Terms.html
	+++ b/web/entries/First_Order_Terms.html
	@@ -1,224 +1,224 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>First-Order Terms - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">F</font>irst-Order

	<font class="first">T</font>erms

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">First-Order Terms</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2018-02-06</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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 <i>Isabelle
	Formalization of Rewriting</i> <a
	href="http://cl-informatik.uibk.ac.at/isafor">IsaFoR</a>,
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{First_Order_Terms-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {First-Order Terms},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2018,
	note = {\url{https://isa-afp.org/entries/First_Order_Terms.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Abstract-Rewriting.html">Abstract-Rewriting</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Functional_Ordered_Resolution_Prover.html">Functional_Ordered_Resolution_Prover</a>, <a href="Knuth_Bendix_Order.html">Knuth_Bendix_Order</a>, <a href="Resolution_FOL.html">Resolution_FOL</a>, <a href="Saturation_Framework_Extensions.html">Saturation_Framework_Extensions</a>, <a href="Stateful_Protocol_Composition_and_Typing.html">Stateful_Protocol_Composition_and_Typing</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/First_Order_Terms/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/First_Order_Terms/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/First_Order_Terms/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-First_Order_Terms-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-First_Order_Terms-2021-02-23.tar.gz">
	afp-First_Order_Terms-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-First_Order_Terms-2020-04-18.tar.gz">
	afp-First_Order_Terms-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-First_Order_Terms-2019-06-11.tar.gz">
	afp-First_Order_Terms-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-First_Order_Terms-2018-08-16.tar.gz">
	afp-First_Order_Terms-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-First_Order_Terms-2018-02-07.tar.gz">
	afp-First_Order_Terms-2018-02-07.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-First_Order_Terms-2018-02-06.tar.gz">
	afp-First_Order_Terms-2018-02-06.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Fourier.html b/web/entries/Fourier.html
	--- a/web/entries/Fourier.html
	+++ b/web/entries/Fourier.html
	@@ -1,202 +1,202 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Fourier Series - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">F</font>ourier

	<font class="first">S</font>eries

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Fourier Series</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C Paulson</a>
	+ Lawrence C Paulson
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2019-09-06</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Fourier-AFP,
	author = {Lawrence C Paulson},
	title = {Fourier Series},
	journal = {Archive of Formal Proofs},
	month = sep,
	year = 2019,
	note = {\url{https://isa-afp.org/entries/Fourier.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Lp.html">Lp</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Fourier/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Fourier/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Fourier/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Fourier-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Fourier-2021-02-23.tar.gz">
	afp-Fourier-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Fourier-2020-04-18.tar.gz">
	afp-Fourier-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Fourier-2019-09-11.tar.gz">
	afp-Fourier-2019-09-11.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Interpolation_Polynomials_HOL_Algebra.html b/web/entries/Interpolation_Polynomials_HOL_Algebra.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Interpolation_Polynomials_HOL_Algebra.html
	@@ -0,0 +1,204 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Interpolation Polynomials (in HOL-Algebra) - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">I</font>nterpolation
	+
	+ <font class="first">P</font>olynomials
	+
	+ <font class="first">(</font>in
	+
	+ <font class="first">H</font>OL-Algebra)
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Interpolation Polynomials (in HOL-Algebra)</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-01-29</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+<p>A well known result from algebra is that, on any field, there
	+is exactly one polynomial of degree less than n interpolating n points
	+[<a
	+href="https://doi.org/10.1017/CBO9780511814549">1</a>,
	+§7].</p> <p>This entry contains a formalization of the
	+above result, as well as the following generalization in the case of
	+finite fields <i>F</i>: There are
	+<i>\|F\|<sup>m-n</sup></i> polynomials of degree
	+less than <i>m ≥ n</i> interpolating the same n points,
	+where <i>\|F\|</i> denotes the size of the domain of the
	+field. To establish the result the entry also includes a formalization
	+of Lagrange interpolation, which might be of independent
	+interest.</p> <p>The formalized results are defined on the
	+algebraic structures from HOL-Algebra, which are distinct from the
	+type-class based structures defined in HOL. Note that there is an
	+existing formalization for polynomial interpolation and, in
	+particular, Lagrange interpolation by Thiemann and Yamada [<a
	+href="https://www.isa-afp.org/entries/Polynomial_Interpolation.html">2</a>]
	+on the type-class based structures in HOL.</p></td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Interpolation_Polynomials_HOL_Algebra-AFP,
	+ author = {Emin Karayel},
	+ title = {Interpolation Polynomials (in HOL-Algebra)},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Interpolation_Polynomials_HOL_Algebra.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="Universal_Hash_Families.html">Universal_Hash_Families</a> </td></tr>
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Interpolation_Polynomials_HOL_Algebra/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Interpolation_Polynomials_HOL_Algebra/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Interpolation_Polynomials_HOL_Algebra/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Interpolation_Polynomials_HOL_Algebra-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Irrationals_From_THEBOOK.html b/web/entries/Irrationals_From_THEBOOK.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Irrationals_From_THEBOOK.html
	@@ -0,0 +1,197 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Irrational numbers from THE BOOK - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">I</font>rrational
	+
	+ numbers
	+
	+ from
	+
	+ <font class="first">T</font>HE
	+
	+ <font class="first">B</font>OOK
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Irrational numbers from THE BOOK</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ Lawrence C Paulson
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-01-08</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+An elementary proof is formalised: that <em>exp r</em> is irrational for
	+every nonzero rational number <em>r</em>. The mathematical development comes
	+from the well-known volume <em>Proofs from THE BOOK</em>,
	+by Aigner and Ziegler, who credit the idea to Hermite. The development
	+illustrates a number of basic Isabelle techniques: the manipulation of
	+summations, the calculation of quite complicated derivatives and the
	+estimation of integrals. We also see how to import another AFP entry (Stirling's formula).
	+As for the theorem itself, note that a much stronger and more general
	+result (the Hermite--Lindemann--Weierstraß transcendence theorem) is
	+already available in the AFP.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Irrationals_From_THEBOOK-AFP,
	+ author = {Lawrence C Paulson},
	+ title = {Irrational numbers from THE BOOK},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Irrationals_From_THEBOOK.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="Stirling_Formula.html">Stirling_Formula</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Irrationals_From_THEBOOK/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Irrationals_From_THEBOOK/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Irrationals_From_THEBOOK/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Irrationals_From_THEBOOK-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Jordan_Normal_Form.html b/web/entries/Jordan_Normal_Form.html
	--- a/web/entries/Jordan_Normal_Form.html
	+++ b/web/entries/Jordan_Normal_Form.html
	@@ -1,259 +1,259 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Matrices, Jordan Normal Forms, and Spectral Radius Theory - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">M</font>atrices,

	<font class="first">J</font>ordan

	<font class="first">N</font>ormal

	<font class="first">F</font>orms,

	and

	<font class="first">S</font>pectral

	<font class="first">R</font>adius

	<font class="first">T</font>heory

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Matrices, Jordan Normal Forms, and Spectral Radius Theory</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>

	<tr>
	<td class="datahead">
	Contributor:
	</td>
	<td class="data">
	Alexander Bentkamp (bentkamp /at/ gmail /dot/ com)
	</td>
	</tr>


	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2015-08-21</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>
	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.
	</p><p>
	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.
	</p><p>
	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.
	</p><p>
	All the results have been applied to improve CeTA, our certifier to validate termination and complexity proof certificates.
	</p></td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2016-01-07]: Added Schur-decomposition, Gram-Schmidt orthogonalization, uniqueness of Jordan normal forms<br/>
	[2018-04-17]: Integrated lemmas from deep-learning AFP-entry of Alexander Bentkamp</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Jordan_Normal_Form-AFP,
	author = {René Thiemann and Akihisa Yamada},
	title = {Matrices, Jordan Normal Forms, and Spectral Radius Theory},
	journal = {Archive of Formal Proofs},
	month = aug,
	year = 2015,
	note = {\url{https://isa-afp.org/entries/Jordan_Normal_Form.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Polynomial_Factorization.html">Polynomial_Factorization</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Complex_Bounded_Operators.html">Complex_Bounded_Operators</a>, <a href="Deep_Learning.html">Deep_Learning</a>, <a href="Farkas.html">Farkas</a>, <a href="Groebner_Bases.html">Groebner_Bases</a>, <a href="Isabelle_Marries_Dirac.html">Isabelle_Marries_Dirac</a>, <a href="Linear_Programming.html">Linear_Programming</a>, <a href="Modular_arithmetic_LLL_and_HNF_algorithms.html">Modular_arithmetic_LLL_and_HNF_algorithms</a>, <a href="Perron_Frobenius.html">Perron_Frobenius</a>, <a href="QHLProver.html">QHLProver</a>, <a href="Simplicial_complexes_and_boolean_functions.html">Simplicial_complexes_and_boolean_functions</a>, <a href="Stochastic_Matrices.html">Stochastic_Matrices</a>, <a href="Subresultants.html">Subresultants</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Jordan_Normal_Form/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Jordan_Normal_Form/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Jordan_Normal_Form/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Jordan_Normal_Form-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Jordan_Normal_Form-2021-02-23.tar.gz">
	afp-Jordan_Normal_Form-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Jordan_Normal_Form-2020-04-18.tar.gz">
	afp-Jordan_Normal_Form-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Jordan_Normal_Form-2019-06-11.tar.gz">
	afp-Jordan_Normal_Form-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Jordan_Normal_Form-2018-08-16.tar.gz">
	afp-Jordan_Normal_Form-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Jordan_Normal_Form-2017-10-10.tar.gz">
	afp-Jordan_Normal_Form-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Jordan_Normal_Form-2016-12-17.tar.gz">
	afp-Jordan_Normal_Form-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Jordan_Normal_Form-2016-02-22.tar.gz">
	afp-Jordan_Normal_Form-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Jordan_Normal_Form-2015-08-23.tar.gz">
	afp-Jordan_Normal_Form-2015-08-23.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Knuth_Bendix_Order.html b/web/entries/Knuth_Bendix_Order.html
	--- a/web/entries/Knuth_Bendix_Order.html
	+++ b/web/entries/Knuth_Bendix_Order.html
	@@ -1,211 +1,211 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>A Formalization of Knuth–Bendix Orders - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>

	<font class="first">F</font>ormalization

	of

	<font class="first">K</font>nuth–Bendix

	<font class="first">O</font>rders

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">A Formalization of Knuth–Bendix Orders</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2020-05-13</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Knuth_Bendix_Order-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {A Formalization of Knuth–Bendix Orders},
	journal = {Archive of Formal Proofs},
	month = may,
	year = 2020,
	note = {\url{https://isa-afp.org/entries/Knuth_Bendix_Order.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="First_Order_Terms.html">First_Order_Terms</a>, <a href="Matrix.html">Matrix</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Functional_Ordered_Resolution_Prover.html">Functional_Ordered_Resolution_Prover</a>, <a href="Regular_Tree_Relations.html">Regular_Tree_Relations</a>, <a href="Weighted_Path_Order.html">Weighted_Path_Order</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Knuth_Bendix_Order/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Knuth_Bendix_Order/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Knuth_Bendix_Order/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Knuth_Bendix_Order-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Knuth_Bendix_Order-2021-02-23.tar.gz">
	afp-Knuth_Bendix_Order-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Knuth_Bendix_Order-2020-05-16.tar.gz">
	afp-Knuth_Bendix_Order-2020-05-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Knuth_Bendix_Order-2020-05-15.tar.gz">
	afp-Knuth_Bendix_Order-2020-05-15.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/LLL_Basis_Reduction.html b/web/entries/LLL_Basis_Reduction.html
	--- a/web/entries/LLL_Basis_Reduction.html
	+++ b/web/entries/LLL_Basis_Reduction.html
	@@ -1,241 +1,241 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>A verified LLL algorithm - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>

	verified

	<font class="first">L</font>LL

	algorithm

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">A verified LLL algorithm</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Ralph Bottesch,
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2018-02-02</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2018-04-16]: Integrated formal complexity bounds (Haslbeck, Thiemann)
	[2018-05-25]: Integrated much faster LLL implementation based on integer arithmetic (Bottesch, Haslbeck, Thiemann)</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{LLL_Basis_Reduction-AFP,
	author = {Ralph Bottesch and Jose Divasón and Maximilian Haslbeck and Sebastiaan Joosten and René Thiemann and Akihisa Yamada},
	title = {A verified LLL algorithm},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2018,
	note = {\url{https://isa-afp.org/entries/LLL_Basis_Reduction.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Algebraic_Numbers.html">Algebraic_Numbers</a>, <a href="Berlekamp_Zassenhaus.html">Berlekamp_Zassenhaus</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Linear_Inequalities.html">Linear_Inequalities</a>, <a href="LLL_Factorization.html">LLL_Factorization</a>, <a href="Modular_arithmetic_LLL_and_HNF_algorithms.html">Modular_arithmetic_LLL_and_HNF_algorithms</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/LLL_Basis_Reduction/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/LLL_Basis_Reduction/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/LLL_Basis_Reduction/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-LLL_Basis_Reduction-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-LLL_Basis_Reduction-2021-02-23.tar.gz">
	afp-LLL_Basis_Reduction-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-LLL_Basis_Reduction-2020-04-20.tar.gz">
	afp-LLL_Basis_Reduction-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-LLL_Basis_Reduction-2019-06-11.tar.gz">
	afp-LLL_Basis_Reduction-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-LLL_Basis_Reduction-2018-09-07.tar.gz">
	afp-LLL_Basis_Reduction-2018-09-07.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-LLL_Basis_Reduction-2018-08-16.tar.gz">
	afp-LLL_Basis_Reduction-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-LLL_Basis_Reduction-2018-02-03.tar.gz">
	afp-LLL_Basis_Reduction-2018-02-03.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/LLL_Factorization.html b/web/entries/LLL_Factorization.html
	--- a/web/entries/LLL_Factorization.html
	+++ b/web/entries/LLL_Factorization.html
	@@ -1,239 +1,239 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>A verified factorization algorithm for integer polynomials with polynomial complexity - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>

	verified

	factorization

	algorithm

	for

	integer

	polynomials

	with

	polynomial

	complexity

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">A verified factorization algorithm for integer polynomials with polynomial complexity</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2018-02-06</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{LLL_Factorization-AFP,
	author = {Jose Divasón and Sebastiaan Joosten and René Thiemann and Akihisa Yamada},
	title = {A verified factorization algorithm for integer polynomials with polynomial complexity},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2018,
	note = {\url{https://isa-afp.org/entries/LLL_Factorization.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="LLL_Basis_Reduction.html">LLL_Basis_Reduction</a>, <a href="Perron_Frobenius.html">Perron_Frobenius</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/LLL_Factorization/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/LLL_Factorization/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/LLL_Factorization/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-LLL_Factorization-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-LLL_Factorization-2021-02-23.tar.gz">
	afp-LLL_Factorization-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-LLL_Factorization-2020-04-20.tar.gz">
	afp-LLL_Factorization-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-LLL_Factorization-2019-06-11.tar.gz">
	afp-LLL_Factorization-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-LLL_Factorization-2018-08-16.tar.gz">
	afp-LLL_Factorization-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-LLL_Factorization-2018-02-07.tar.gz">
	afp-LLL_Factorization-2018-02-07.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/LP_Duality.html b/web/entries/LP_Duality.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/LP_Duality.html
	@@ -0,0 +1,191 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Duality of Linear Programming - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">D</font>uality
	+
	+ of
	+
	+ <font class="first">L</font>inear
	+
	+ <font class="first">P</font>rogramming
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Duality of Linear Programming</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-03</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+We formalize the weak and strong duality theorems of linear
	+programming. For the strong duality theorem we provide three
	+sufficient preconditions: both the primal problem and the dual problem
	+are satisfiable, the primal problem is satisfiable and bounded, or the
	+dual problem is satisfiable and bounded. The proofs are based on an
	+existing formalization of Farkas' Lemma.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{LP_Duality-AFP,
	+ author = {René Thiemann},
	+ title = {Duality of Linear Programming},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/LP_Duality.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="Linear_Inequalities.html">Linear_Inequalities</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/LP_Duality/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/LP_Duality/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/LP_Duality/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-LP_Duality-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Lifting_Definition_Option.html b/web/entries/Lifting_Definition_Option.html
	--- a/web/entries/Lifting_Definition_Option.html
	+++ b/web/entries/Lifting_Definition_Option.html
	@@ -1,241 +1,241 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Lifting Definition Option - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">L</font>ifting

	<font class="first">D</font>efinition

	<font class="first">O</font>ption

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Lifting Definition Option</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2014-10-13</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	We implemented a command that can be used to easily generate
	elements of a restricted type <tt>{x :: 'a. P x}</tt>,
	provided the definition is of the form
	<tt>f ys = (if check ys then Some(generate ys :: 'a) else None)</tt> where
	<tt>ys</tt> is a list of variables <tt>y1 ... yn</tt> and
	<tt>check ys ==> P(generate ys)</tt> can be proved.
	<p>
	In principle, such a definition is also directly possible using the
	<tt>lift_definition</tt> 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 <tt>check ys</tt> will only be performed once. In the
	automation, one auxiliary type is created, and Isabelle's lifting- and
	transfer-package is invoked several times.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Lifting_Definition_Option-AFP,
	author = {René Thiemann},
	title = {Lifting Definition Option},
	journal = {Archive of Formal Proofs},
	month = oct,
	year = 2014,
	note = {\url{https://isa-afp.org/entries/Lifting_Definition_Option.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>






	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Lifting_Definition_Option/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Lifting_Definition_Option/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Lifting_Definition_Option/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Lifting_Definition_Option-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Lifting_Definition_Option-2021-02-23.tar.gz">
	afp-Lifting_Definition_Option-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Lifting_Definition_Option-2020-04-18.tar.gz">
	afp-Lifting_Definition_Option-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Lifting_Definition_Option-2019-06-11.tar.gz">
	afp-Lifting_Definition_Option-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Lifting_Definition_Option-2018-08-16.tar.gz">
	afp-Lifting_Definition_Option-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Lifting_Definition_Option-2017-10-10.tar.gz">
	afp-Lifting_Definition_Option-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Lifting_Definition_Option-2016-12-17.tar.gz">
	afp-Lifting_Definition_Option-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Lifting_Definition_Option-2016-02-22.tar.gz">
	afp-Lifting_Definition_Option-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Lifting_Definition_Option-2015-05-27.tar.gz">
	afp-Lifting_Definition_Option-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Lifting_Definition_Option-2014-10-15.tar.gz">
	afp-Lifting_Definition_Option-2014-10-15.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Linear_Inequalities.html b/web/entries/Linear_Inequalities.html
	--- a/web/entries/Linear_Inequalities.html
	+++ b/web/entries/Linear_Inequalities.html
	@@ -1,209 +1,209 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Linear Inequalities - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">L</font>inear

	<font class="first">I</font>nequalities

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Linear Inequalities</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Ralph Bottesch,
	Alban Reynaud and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2019-06-21</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Linear_Inequalities-AFP,
	author = {Ralph Bottesch and Alban Reynaud and René Thiemann},
	title = {Linear Inequalities},
	journal = {Archive of Formal Proofs},
	month = jun,
	year = 2019,
	note = {\url{https://isa-afp.org/entries/Linear_Inequalities.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="LLL_Basis_Reduction.html">LLL_Basis_Reduction</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="Linear_Programming.html">Linear_Programming</a> </td></tr>
	+ <td class="data"><a href="Linear_Programming.html">Linear_Programming</a>, <a href="LP_Duality.html">LP_Duality</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Linear_Inequalities/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Linear_Inequalities/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Linear_Inequalities/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Linear_Inequalities-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Linear_Inequalities-2021-02-23.tar.gz">
	afp-Linear_Inequalities-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Linear_Inequalities-2020-04-18.tar.gz">
	afp-Linear_Inequalities-2020-04-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Linear_Inequalities-2019-06-24.tar.gz">
	afp-Linear_Inequalities-2019-06-24.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Matrix.html b/web/entries/Matrix.html
	--- a/web/entries/Matrix.html
	+++ b/web/entries/Matrix.html
	@@ -1,298 +1,298 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Executable Matrix Operations on Matrices of Arbitrary Dimensions - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">E</font>xecutable

	<font class="first">M</font>atrix

	<font class="first">O</font>perations

	on

	<font class="first">M</font>atrices

	of

	<font class="first">A</font>rbitrary

	<font class="first">D</font>imensions

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Executable Matrix Operations on Matrices of Arbitrary Dimensions</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2010-06-17</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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 <a
	href="http://cl-informatik.uibk.ac.at/software/ceta">CeTA</a> system
	which contains several termination techniques. The provided theories have
	been essential to formalize matrix-interpretations and arctic
	interpretations.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2010-09-17]: Moved theory on arbitrary (ordered) semirings to Abstract Rewriting.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Matrix-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {Executable Matrix Operations on Matrices of Arbitrary Dimensions},
	journal = {Archive of Formal Proofs},
	month = jun,
	year = 2010,
	note = {\url{https://isa-afp.org/entries/Matrix.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Abstract-Rewriting.html">Abstract-Rewriting</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Knuth_Bendix_Order.html">Knuth_Bendix_Order</a>, <a href="Matrix_Tensor.html">Matrix_Tensor</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="Polynomials.html">Polynomials</a>, <a href="Transitive-Closure.html">Transitive-Closure</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Matrix/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Matrix/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Matrix/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Matrix-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Matrix-2021-02-23.tar.gz">
	afp-Matrix-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Matrix-2020-04-20.tar.gz">
	afp-Matrix-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Matrix-2019-06-11.tar.gz">
	afp-Matrix-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Matrix-2018-08-16.tar.gz">
	afp-Matrix-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Matrix-2017-10-10.tar.gz">
	afp-Matrix-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Matrix-2016-12-17.tar.gz">
	afp-Matrix-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Matrix-2016-02-22.tar.gz">
	afp-Matrix-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Matrix-2015-05-27.tar.gz">
	afp-Matrix-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Matrix-2014-08-28.tar.gz">
	afp-Matrix-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Matrix-2013-12-11.tar.gz">
	afp-Matrix-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Matrix-2013-11-17.tar.gz">
	afp-Matrix-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Matrix-2013-02-16.tar.gz">
	afp-Matrix-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Matrix-2012-05-24.tar.gz">
	afp-Matrix-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Matrix-2011-10-11.tar.gz">
	afp-Matrix-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-Matrix-2011-02-11.tar.gz">
	afp-Matrix-2011-02-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-2:
	<a href="../release/afp-Matrix-2010-07-01.tar.gz">
	afp-Matrix-2010-07-01.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-1:
	<a href="../release/afp-Matrix-2010-06-17.tar.gz">
	afp-Matrix-2010-06-17.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Median_Method.html b/web/entries/Median_Method.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Median_Method.html
	@@ -0,0 +1,198 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Median Method - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">M</font>edian
	+
	+ <font class="first">M</font>ethod
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Median Method</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-01-25</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+<p>The median method is an amplification result for randomized
	+approximation algorithms described in [<a
	+href="https://doi.org/10.1006/jcss.1997.1545">1</a>].
	+Given an algorithm whose result is in a desired interval with a
	+probability larger than <i>1/2</i>, it is possible to
	+improve the success probability, by running the algorithm multiple
	+times independently and using the median. In contrast to using the
	+mean, the amplification of the success probability grows exponentially
	+with the number of independent runs.</p> <p>This entry
	+contains a formalization of the underlying theorem: Given a sequence
	+of n independent random variables, which are in a desired interval
	+with a probability <i>1/2 + a</i>. Then their median will
	+be in the desired interval with a probability of <i>1 −
	+exp(−2a<sup>2</sup> n)</i>. In particular, the
	+success probability approaches <i>1</i> exponentially with
	+the number of variables.</p> <p>In addition to that, this
	+entry also contains a proof that order-statistics of Borel-measurable
	+random variables are themselves measurable and that generalized
	+intervals in linearly ordered Borel-spaces are measurable.</p></td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Median_Method-AFP,
	+ author = {Emin Karayel},
	+ title = {Median Method},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Median_Method.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Median_Method/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Median_Method/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Median_Method/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Median_Method-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Modular_arithmetic_LLL_and_HNF_algorithms.html b/web/entries/Modular_arithmetic_LLL_and_HNF_algorithms.html
	--- a/web/entries/Modular_arithmetic_LLL_and_HNF_algorithms.html
	+++ b/web/entries/Modular_arithmetic_LLL_and_HNF_algorithms.html
	@@ -1,225 +1,225 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Two algorithms based on modular arithmetic: lattice basis reduction and Hermite normal form computation - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">T</font>wo

	algorithms

	based

	on

	modular

	arithmetic:

	lattice

	basis

	reduction

	and

	<font class="first">H</font>ermite

	normal

	form

	computation

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Two algorithms based on modular arithmetic: lattice basis reduction and Hermite normal form computation</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Ralph Bottesch,
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2021-03-12</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	We verify two algorithms for which modular arithmetic plays an
	essential role: Storjohann's variant of the LLL lattice basis
	reduction algorithm and Kopparty's algorithm for computing the
	Hermite normal form of a matrix. To do this, we also formalize some
	facts about the modulo operation with symmetric range. Our
	implementations are based on the original papers, but are otherwise
	efficient. For basis reduction we formalize two versions: one that
	includes all of the optimizations/heuristics from Storjohann's
	paper, and one excluding a heuristic that we observed to often
	decrease efficiency. We also provide a fast, self-contained certifier
	for basis reduction, based on the efficient Hermite normal form
	algorithm.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Modular_arithmetic_LLL_and_HNF_algorithms-AFP,
	author = {Ralph Bottesch and Jose Divasón and René Thiemann},
	title = {Two algorithms based on modular arithmetic: lattice basis reduction and Hermite normal form computation},
	journal = {Archive of Formal Proofs},
	month = mar,
	year = 2021,
	note = {\url{https://isa-afp.org/entries/Modular_arithmetic_LLL_and_HNF_algorithms.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Hermite.html">Hermite</a>, <a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a>, <a href="LLL_Basis_Reduction.html">LLL_Basis_Reduction</a>, <a href="Show.html">Show</a>, <a href="Smith_Normal_Form.html">Smith_Normal_Form</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Modular_arithmetic_LLL_and_HNF_algorithms/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Modular_arithmetic_LLL_and_HNF_algorithms/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Modular_arithmetic_LLL_and_HNF_algorithms/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Modular_arithmetic_LLL_and_HNF_algorithms-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Modular_arithmetic_LLL_and_HNF_algorithms-2021-03-14.tar.gz">
	afp-Modular_arithmetic_LLL_and_HNF_algorithms-2021-03-14.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Partial_Function_MR.html b/web/entries/Partial_Function_MR.html
	--- a/web/entries/Partial_Function_MR.html
	+++ b/web/entries/Partial_Function_MR.html
	@@ -1,236 +1,236 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Mutually Recursive Partial Functions - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">M</font>utually

	<font class="first">R</font>ecursive

	<font class="first">P</font>artial

	<font class="first">F</font>unctions

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Mutually Recursive Partial Functions</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2014-02-18</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">We provide a wrapper around the partial-function command that supports mutual recursion.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Partial_Function_MR-AFP,
	author = {René Thiemann},
	title = {Mutually Recursive Partial Functions},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2014,
	note = {\url{https://isa-afp.org/entries/Partial_Function_MR.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>



	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Certification_Monads.html">Certification_Monads</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Partial_Function_MR/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Partial_Function_MR/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Partial_Function_MR/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Partial_Function_MR-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Partial_Function_MR-2021-02-23.tar.gz">
	afp-Partial_Function_MR-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Partial_Function_MR-2020-04-20.tar.gz">
	afp-Partial_Function_MR-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Partial_Function_MR-2019-06-11.tar.gz">
	afp-Partial_Function_MR-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Partial_Function_MR-2018-08-16.tar.gz">
	afp-Partial_Function_MR-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Partial_Function_MR-2017-10-10.tar.gz">
	afp-Partial_Function_MR-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Partial_Function_MR-2016-12-17.tar.gz">
	afp-Partial_Function_MR-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Partial_Function_MR-2016-02-22.tar.gz">
	afp-Partial_Function_MR-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Partial_Function_MR-2015-05-27.tar.gz">
	afp-Partial_Function_MR-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Partial_Function_MR-2014-08-28.tar.gz">
	afp-Partial_Function_MR-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Partial_Function_MR-2014-02-19.tar.gz">
	afp-Partial_Function_MR-2014-02-19.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Perron_Frobenius.html b/web/entries/Perron_Frobenius.html
	--- a/web/entries/Perron_Frobenius.html
	+++ b/web/entries/Perron_Frobenius.html
	@@ -1,262 +1,262 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Perron-Frobenius Theorem for Spectral Radius Analysis - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">P</font>erron-Frobenius

	<font class="first">T</font>heorem

	for

	<font class="first">S</font>pectral

	<font class="first">R</font>adius

	<font class="first">A</font>nalysis

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Perron-Frobenius Theorem for Spectral Radius Analysis</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="http://www21.in.tum.de/~kuncar/">Ondřej Kunčar</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-05-20</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>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 A<sup>n</sup> 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
	<em>complex</em> 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 <em>real</em> eigenvalues of A, i.e., applying Sturm's method can
	decide the polynomial growth of A<sup>n</sup>. </p><p> 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 A<sup>n</sup> is polynomially bounded in n. </p></td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2017-10-18]:
	added Perron-Frobenius theorem for irreducible matrices with generalization
	(revision bda1f1ce8a1c)<br/>
	[2018-05-17]:
	prove conjecture of CPP'18 paper: Jordan blocks of spectral radius have maximum size
	(revision ffdb3794e5d5)</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Perron_Frobenius-AFP,
	author = {Jose Divasón and Ondřej Kunčar and René Thiemann and Akihisa Yamada},
	title = {Perron-Frobenius Theorem for Spectral Radius Analysis},
	journal = {Archive of Formal Proofs},
	month = may,
	year = 2016,
	note = {\url{https://isa-afp.org/entries/Perron_Frobenius.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="Rank_Nullity_Theorem.html">Rank_Nullity_Theorem</a>, <a href="Sturm_Sequences.html">Sturm_Sequences</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="LLL_Factorization.html">LLL_Factorization</a>, <a href="Smith_Normal_Form.html">Smith_Normal_Form</a>, <a href="Stochastic_Matrices.html">Stochastic_Matrices</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Perron_Frobenius/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Perron_Frobenius/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Perron_Frobenius/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Perron_Frobenius-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Perron_Frobenius-2021-02-23.tar.gz">
	afp-Perron_Frobenius-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Perron_Frobenius-2020-04-20.tar.gz">
	afp-Perron_Frobenius-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Perron_Frobenius-2019-06-11.tar.gz">
	afp-Perron_Frobenius-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Perron_Frobenius-2018-08-16.tar.gz">
	afp-Perron_Frobenius-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Perron_Frobenius-2017-10-18.tar.gz">
	afp-Perron_Frobenius-2017-10-18.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Perron_Frobenius-2017-10-10.tar.gz">
	afp-Perron_Frobenius-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Perron_Frobenius-2016-12-17.tar.gz">
	afp-Perron_Frobenius-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Perron_Frobenius-2016-05-20.tar.gz">
	afp-Perron_Frobenius-2016-05-20.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ 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,234 +1,234 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Polynomial Factorization - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">P</font>olynomial

	<font class="first">F</font>actorization

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Polynomial Factorization</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-01-29</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.
	<p>
	As side products, we developed division algorithms for polynomials over integral domains,
	as well as primality-testing and prime-factorization algorithms for integers.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Polynomial_Factorization-AFP,
	author = {René Thiemann and Akihisa Yamada},
	title = {Polynomial Factorization},
	journal = {Archive of Formal Proofs},
	month = jan,
	year = 2016,
	note = {\url{https://isa-afp.org/entries/Polynomial_Factorization.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Abstract-Rewriting.html">Abstract-Rewriting</a>, <a href="Containers.html">Containers</a>, <a href="Gauss_Jordan.html">Gauss_Jordan</a>, <a href="Matrix.html">Matrix</a>, <a href="Partial_Function_MR.html">Partial_Function_MR</a>, <a href="Polynomial_Interpolation.html">Polynomial_Interpolation</a>, <a href="Show.html">Show</a>, <a href="Sqrt_Babylonian.html">Sqrt_Babylonian</a>, <a href="VectorSpace.html">VectorSpace</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Amicable_Numbers.html">Amicable_Numbers</a>, <a href="Berlekamp_Zassenhaus.html">Berlekamp_Zassenhaus</a>, <a href="Dirichlet_Series.html">Dirichlet_Series</a>, <a href="Functional_Ordered_Resolution_Prover.html">Functional_Ordered_Resolution_Prover</a>, <a href="Gaussian_Integers.html">Gaussian_Integers</a>, <a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a>, <a href="Knuth_Bendix_Order.html">Knuth_Bendix_Order</a>, <a href="Linear_Recurrences.html">Linear_Recurrences</a>, <a href="Perron_Frobenius.html">Perron_Frobenius</a>, <a href="Power_Sum_Polynomials.html">Power_Sum_Polynomials</a>, <a href="Subresultants.html">Subresultants</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Polynomial_Factorization/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Polynomial_Factorization/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Polynomial_Factorization/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Polynomial_Factorization-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Polynomial_Factorization-2021-02-23.tar.gz">
	afp-Polynomial_Factorization-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Polynomial_Factorization-2020-04-20.tar.gz">
	afp-Polynomial_Factorization-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Polynomial_Factorization-2019-06-11.tar.gz">
	afp-Polynomial_Factorization-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Polynomial_Factorization-2018-08-16.tar.gz">
	afp-Polynomial_Factorization-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Polynomial_Factorization-2017-10-10.tar.gz">
	afp-Polynomial_Factorization-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Polynomial_Factorization-2016-12-17.tar.gz">
	afp-Polynomial_Factorization-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Polynomial_Factorization-2016-02-22.tar.gz">
	afp-Polynomial_Factorization-2016-02-22.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Polynomial_Interpolation.html b/web/entries/Polynomial_Interpolation.html
	--- a/web/entries/Polynomial_Interpolation.html
	+++ b/web/entries/Polynomial_Interpolation.html
	@@ -1,234 +1,234 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Polynomial Interpolation - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">P</font>olynomial

	<font class="first">I</font>nterpolation

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Polynomial Interpolation</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-01-29</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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 <i>p</i> such that
	<i>p(0) = 0</i> and <i>p(2) = 1</i>. 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.
	<p>
	The development also contains improved code equations to speed up the
	division of integers in target languages.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Polynomial_Interpolation-AFP,
	author = {René Thiemann and Akihisa Yamada},
	title = {Polynomial Interpolation},
	journal = {Archive of Formal Proofs},
	month = jan,
	year = 2016,
	note = {\url{https://isa-afp.org/entries/Polynomial_Interpolation.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Sqrt_Babylonian.html">Sqrt_Babylonian</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Berlekamp_Zassenhaus.html">Berlekamp_Zassenhaus</a>, <a href="Count_Complex_Roots.html">Count_Complex_Roots</a>, <a href="Deep_Learning.html">Deep_Learning</a>, <a href="Formal_Puiseux_Series.html">Formal_Puiseux_Series</a>, <a href="Gauss_Sums.html">Gauss_Sums</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="Three_Circles.html">Three_Circles</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Polynomial_Interpolation/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Polynomial_Interpolation/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Polynomial_Interpolation/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Polynomial_Interpolation-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Polynomial_Interpolation-2021-02-23.tar.gz">
	afp-Polynomial_Interpolation-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Polynomial_Interpolation-2020-04-20.tar.gz">
	afp-Polynomial_Interpolation-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Polynomial_Interpolation-2019-06-11.tar.gz">
	afp-Polynomial_Interpolation-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Polynomial_Interpolation-2018-08-16.tar.gz">
	afp-Polynomial_Interpolation-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Polynomial_Interpolation-2017-10-10.tar.gz">
	afp-Polynomial_Interpolation-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Polynomial_Interpolation-2016-12-17.tar.gz">
	afp-Polynomial_Interpolation-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Polynomial_Interpolation-2016-02-22.tar.gz">
	afp-Polynomial_Interpolation-2016-02-22.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Polynomials.html b/web/entries/Polynomials.html
	--- a/web/entries/Polynomials.html
	+++ b/web/entries/Polynomials.html
	@@ -1,306 +1,306 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Executable Multivariate Polynomials - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">E</font>xecutable

	<font class="first">M</font>ultivariate

	<font class="first">P</font>olynomials

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Executable Multivariate Polynomials</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>,
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at),
	<a href="https://risc.jku.at/m/alexander-maletzky/">Alexander Maletzky</a>,
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>,
	<a href="http://isabelle.in.tum.de/~haftmann">Florian Haftmann</a>,
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a> and
	Alexander Bentkamp (bentkamp /at/ gmail /dot/ com)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2010-08-10</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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 <a
	href="http://cl-informatik.uibk.ac.at/software/ceta">IsaFoR/CeTA-system</a>
	which contains several termination techniques. The provided theories have
	been essential to formalize polynomial interpretations.
	<p>
	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].</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2010-09-17]: Moved theories on arbitrary (ordered) semirings to Abstract Rewriting.<br>
	[2016-10-28]: Added abstract representation of polynomials and authors Maletzky/Immler.<br>
	[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".<br>
	[2019-04-18]: Added material about polynomials whose power-products are represented themselves
	by polynomial mappings.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Polynomials-AFP,
	author = {Christian Sternagel and René Thiemann and Alexander Maletzky and Fabian Immler and Florian Haftmann and Andreas Lochbihler and Alexander Bentkamp},
	title = {Executable Multivariate Polynomials},
	journal = {Archive of Formal Proofs},
	month = aug,
	year = 2010,
	note = {\url{https://isa-afp.org/entries/Polynomials.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Abstract-Rewriting.html">Abstract-Rewriting</a>, <a href="Matrix.html">Matrix</a>, <a href="Show.html">Show</a>, <a href="Well_Quasi_Orders.html">Well_Quasi_Orders</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Deep_Learning.html">Deep_Learning</a>, <a href="Factor_Algebraic_Polynomial.html">Factor_Algebraic_Polynomial</a>, <a href="Groebner_Bases.html">Groebner_Bases</a>, <a href="Lambda_Free_KBOs.html">Lambda_Free_KBOs</a>, <a href="PAC_Checker.html">PAC_Checker</a>, <a href="Symmetric_Polynomials.html">Symmetric_Polynomials</a>, <a href="Virtual_Substitution.html">Virtual_Substitution</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Polynomials/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Polynomials/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Polynomials/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Polynomials-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Polynomials-2021-02-23.tar.gz">
	afp-Polynomials-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Polynomials-2020-04-20.tar.gz">
	afp-Polynomials-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Polynomials-2020-01-14.tar.gz">
	afp-Polynomials-2020-01-14.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Polynomials-2019-06-11.tar.gz">
	afp-Polynomials-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Polynomials-2018-08-16.tar.gz">
	afp-Polynomials-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Polynomials-2017-10-10.tar.gz">
	afp-Polynomials-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Polynomials-2016-12-17.tar.gz">
	afp-Polynomials-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Polynomials-2016-02-22.tar.gz">
	afp-Polynomials-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Polynomials-2015-05-27.tar.gz">
	afp-Polynomials-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Polynomials-2014-08-28.tar.gz">
	afp-Polynomials-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Polynomials-2013-12-11.tar.gz">
	afp-Polynomials-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Polynomials-2013-11-17.tar.gz">
	afp-Polynomials-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Polynomials-2013-02-16.tar.gz">
	afp-Polynomials-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Polynomials-2012-05-24.tar.gz">
	afp-Polynomials-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Polynomials-2011-10-11.tar.gz">
	afp-Polynomials-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-Polynomials-2011-02-11.tar.gz">
	afp-Polynomials-2011-02-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-2:
	<a href="../release/afp-Polynomials-2010-08-11.tar.gz">
	afp-Polynomials-2010-08-11.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Quasi_Borel_Spaces.html b/web/entries/Quasi_Borel_Spaces.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Quasi_Borel_Spaces.html
	@@ -0,0 +1,196 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Quasi-Borel Spaces - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">Q</font>uasi-Borel
	+
	+ <font class="first">S</font>paces
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Quasi-Borel Spaces</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ Michikazu Hirata,
	+ <a href="https://sv.c.titech.ac.jp/minamide/index.en.html">Yasuhiko Minamide</a> and
	+ <a href="https://sites.google.com/view/tetsuyasato/">Tetsuya Sato</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-03</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+The notion of quasi-Borel spaces was introduced by <a
	+href="https://dl.acm.org/doi/10.5555/3329995.3330072">
	+Heunen et al</a>. The theory provides a suitable
	+denotational model for higher-order probabilistic programming
	+languages with continuous distributions. This entry is a formalization
	+of the theory of quasi-Borel spaces, including construction of
	+quasi-Borel spaces (product, coproduct, function spaces), the
	+adjunction between the category of measurable spaces and the category
	+of quasi-Borel spaces, and the probability monad on quasi-Borel
	+spaces. This entry also contains the formalization of the Bayesian
	+regression presented in the work of Heunen et al. This work is a part
	+of the work by same authors, <i>Program Logic for Higher-Order
	+Probabilistic Programs in Isabelle/HOL</i>, which will be
	+published in the proceedings of the 16th International Symposium on
	+Functional and Logic Programming (FLOPS 2022).</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Quasi_Borel_Spaces-AFP,
	+ author = {Michikazu Hirata and Yasuhiko Minamide and Tetsuya Sato},
	+ title = {Quasi-Borel Spaces},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Quasi_Borel_Spaces.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Quasi_Borel_Spaces/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Quasi_Borel_Spaces/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Quasi_Borel_Spaces/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Quasi_Borel_Spaces-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Real_Impl.html b/web/entries/Real_Impl.html
	--- a/web/entries/Real_Impl.html
	+++ b/web/entries/Real_Impl.html
	@@ -1,257 +1,257 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Implementing field extensions of the form Q[sqrt(b)] - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">I</font>mplementing

	field

	extensions

	of

	the

	form

	<font class="first">Q</font>[sqrt(b)]

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Implementing field extensions of the form Q[sqrt(b)]</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2014-02-06</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.
	<p>
	Our results have been used to certify termination proofs which involve
	polynomial interpretations over the reals.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2014-07-11]: Moved NthRoot_Impl to Sqrt-Babylonian.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Real_Impl-AFP,
	author = {René Thiemann},
	title = {Implementing field extensions of the form Q[sqrt(b)]},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2014,
	note = {\url{https://isa-afp.org/entries/Real_Impl.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Deriving.html">Deriving</a>, <a href="Show.html">Show</a>, <a href="Sqrt_Babylonian.html">Sqrt_Babylonian</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Complex_Bounded_Operators.html">Complex_Bounded_Operators</a>, <a href="QR_Decomposition.html">QR_Decomposition</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Real_Impl/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Real_Impl/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Real_Impl/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Real_Impl-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Real_Impl-2021-02-23.tar.gz">
	afp-Real_Impl-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Real_Impl-2020-04-20.tar.gz">
	afp-Real_Impl-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Real_Impl-2019-06-11.tar.gz">
	afp-Real_Impl-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Real_Impl-2018-08-16.tar.gz">
	afp-Real_Impl-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Real_Impl-2017-10-10.tar.gz">
	afp-Real_Impl-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Real_Impl-2016-12-17.tar.gz">
	afp-Real_Impl-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Real_Impl-2016-02-22.tar.gz">
	afp-Real_Impl-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Real_Impl-2015-05-27.tar.gz">
	afp-Real_Impl-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Real_Impl-2014-08-28.tar.gz">
	afp-Real_Impl-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Real_Impl-2014-02-11.tar.gz">
	afp-Real_Impl-2014-02-11.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Regular_Tree_Relations.html b/web/entries/Regular_Tree_Relations.html
	--- a/web/entries/Regular_Tree_Relations.html
	+++ b/web/entries/Regular_Tree_Relations.html
	@@ -1,203 +1,205 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Regular Tree Relations - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">R</font>egular

	<font class="first">T</font>ree

	<font class="first">R</font>elations

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Regular Tree Relations</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Alexander Lochmann (alexander /dot/ lochmann /at/ uibk /dot/ ac /dot/ at),
	Bertram Felgenhauer,
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Thomas Sternagel
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2021-12-15</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	Tree automata have good closure properties and therefore a commonly
	used to prove/disprove properties. This formalization contains among
	other things the proofs of many closure properties of tree automata
	(anchored) ground tree transducers and regular relations. Additionally
	it includes the well known pumping lemma and a lifting of the Myhill
	Nerode theorem for regular languages to tree languages. We want to
	mention the existence of a <a
	href="https://www.isa-afp.org/entries/Tree-Automata.html">tree
	automata APF-entry</a> developed by Peter Lammich. His work is
	based on epsilon free top-down tree automata, while this entry builds
	on bottom-up tree auotamta with epsilon transitions. Moreover our
	formalization relies on the <a
	href="https://www.isa-afp.org/entries/Collections.html">Collections
	Framework</a>, also by Peter Lammich, to obtain efficient code.
	All proven constructions of the closure properties are exportable
	using the Isabelle/HOL code generation facilities.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Regular_Tree_Relations-AFP,
	author = {Alexander Lochmann and Bertram Felgenhauer and Christian Sternagel and René Thiemann and Thomas Sternagel},
	title = {Regular Tree Relations},
	journal = {Archive of Formal Proofs},
	month = dec,
	year = 2021,
	note = {\url{https://isa-afp.org/entries/Regular_Tree_Relations.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Knuth_Bendix_Order.html">Knuth_Bendix_Order</a> </td></tr>

	-
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="FO_Theory_Rewriting.html">FO_Theory_Rewriting</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Regular_Tree_Relations/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Regular_Tree_Relations/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Regular_Tree_Relations/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Regular_Tree_Relations-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	None
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Show.html b/web/entries/Show.html
	--- a/web/entries/Show.html
	+++ b/web/entries/Show.html
	@@ -1,252 +1,252 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Haskell's Show Class in Isabelle/HOL - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">H</font>askell's

	<font class="first">S</font>how

	<font class="first">C</font>lass

	in

	<font class="first">I</font>sabelle/HOL

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Haskell's Show Class in Isabelle/HOL</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2014-07-29</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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".</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2015-03-11]: Adapted development to new-style (BNF-based) datatypes.<br>
	[2015-04-10]: Moved development for old-style datatypes into subdirectory
	"Old_Datatype".<br></td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Show-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {Haskell's Show Class in Isabelle/HOL},
	journal = {Archive of Formal Proofs},
	month = jul,
	year = 2014,
	note = {\url{https://isa-afp.org/entries/Show.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Deriving.html">Deriving</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Affine_Arithmetic.html">Affine_Arithmetic</a>, <a href="AI_Planning_Languages_Semantics.html">AI_Planning_Languages_Semantics</a>, <a href="Berlekamp_Zassenhaus.html">Berlekamp_Zassenhaus</a>, <a href="CakeML.html">CakeML</a>, <a href="CakeML_Codegen.html">CakeML_Codegen</a>, <a href="Certification_Monads.html">Certification_Monads</a>, <a href="Dict_Construction.html">Dict_Construction</a>, <a href="MiniSail.html">MiniSail</a>, <a href="Modular_arithmetic_LLL_and_HNF_algorithms.html">Modular_arithmetic_LLL_and_HNF_algorithms</a>, <a href="Monad_Memo_DP.html">Monad_Memo_DP</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="Polynomials.html">Polynomials</a>, <a href="Real_Impl.html">Real_Impl</a>, <a href="XML.html">XML</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Show/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Show/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Show/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Show-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Show-2021-02-23.tar.gz">
	afp-Show-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Show-2020-04-20.tar.gz">
	afp-Show-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Show-2019-06-11.tar.gz">
	afp-Show-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Show-2018-08-16.tar.gz">
	afp-Show-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Show-2017-10-10.tar.gz">
	afp-Show-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Show-2016-12-17.tar.gz">
	afp-Show-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Show-2016-02-22.tar.gz">
	afp-Show-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Show-2015-05-27.tar.gz">
	afp-Show-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Show-2014-08-29.tar.gz">
	afp-Show-2014-08-29.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Show-2014-08-28.tar.gz">
	afp-Show-2014-08-28.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Simplex.html b/web/entries/Simplex.html
	--- a/web/entries/Simplex.html
	+++ b/web/entries/Simplex.html
	@@ -1,230 +1,230 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>An Incremental Simplex Algorithm with Unsatisfiable Core Generation - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>n

	<font class="first">I</font>ncremental

	<font class="first">S</font>implex

	<font class="first">A</font>lgorithm

	with

	<font class="first">U</font>nsatisfiable

	<font class="first">C</font>ore

	<font class="first">G</font>eneration

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">An Incremental Simplex Algorithm with Unsatisfiable Core Generation</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Filip Marić (filip /at/ matf /dot/ bg /dot/ ac /dot/ rs),
	Mirko Spasić (mirko /at/ matf /dot/ bg /dot/ ac /dot/ rs) and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2018-08-24</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Simplex-AFP,
	author = {Filip Marić and Mirko Spasić and René Thiemann},
	title = {An Incremental Simplex Algorithm with Unsatisfiable Core Generation},
	journal = {Archive of Formal Proofs},
	month = aug,
	year = 2018,
	note = {\url{https://isa-afp.org/entries/Simplex.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>



	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Farkas.html">Farkas</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Simplex/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Simplex/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Simplex/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Simplex-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Simplex-2021-02-23.tar.gz">
	afp-Simplex-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Simplex-2020-04-20.tar.gz">
	afp-Simplex-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Simplex-2020-01-14.tar.gz">
	afp-Simplex-2020-01-14.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Simplex-2019-06-11.tar.gz">
	afp-Simplex-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Simplex-2018-08-27.tar.gz">
	afp-Simplex-2018-08-27.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Sqrt_Babylonian.html b/web/entries/Sqrt_Babylonian.html
	--- a/web/entries/Sqrt_Babylonian.html
	+++ b/web/entries/Sqrt_Babylonian.html
	@@ -1,268 +1,268 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Computing N-th Roots using the Babylonian Method - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">C</font>omputing

	<font class="first">N</font>-th

	<font class="first">R</font>oots

	using

	the

	<font class="first">B</font>abylonian

	<font class="first">M</font>ethod

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Computing N-th Roots using the Babylonian Method</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2013-01-03</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Sqrt_Babylonian-AFP,
	author = {René Thiemann},
	title = {Computing N-th Roots using the Babylonian Method},
	journal = {Archive of Formal Proofs},
	month = jan,
	year = 2013,
	note = {\url{https://isa-afp.org/entries/Sqrt_Babylonian.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Cauchy.html">Cauchy</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Polynomial_Factorization.html">Polynomial_Factorization</a>, <a href="Polynomial_Interpolation.html">Polynomial_Interpolation</a>, <a href="QR_Decomposition.html">QR_Decomposition</a>, <a href="Real_Impl.html">Real_Impl</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Sqrt_Babylonian/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Sqrt_Babylonian/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Sqrt_Babylonian/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Sqrt_Babylonian-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Sqrt_Babylonian-2021-02-23.tar.gz">
	afp-Sqrt_Babylonian-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Sqrt_Babylonian-2020-04-20.tar.gz">
	afp-Sqrt_Babylonian-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Sqrt_Babylonian-2019-06-11.tar.gz">
	afp-Sqrt_Babylonian-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Sqrt_Babylonian-2018-08-16.tar.gz">
	afp-Sqrt_Babylonian-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Sqrt_Babylonian-2017-10-10.tar.gz">
	afp-Sqrt_Babylonian-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Sqrt_Babylonian-2016-12-17.tar.gz">
	afp-Sqrt_Babylonian-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Sqrt_Babylonian-2016-02-22.tar.gz">
	afp-Sqrt_Babylonian-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Sqrt_Babylonian-2015-05-27.tar.gz">
	afp-Sqrt_Babylonian-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Sqrt_Babylonian-2014-08-28.tar.gz">
	afp-Sqrt_Babylonian-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Sqrt_Babylonian-2013-12-11.tar.gz">
	afp-Sqrt_Babylonian-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Sqrt_Babylonian-2013-11-17.tar.gz">
	afp-Sqrt_Babylonian-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Sqrt_Babylonian-2013-02-16.tar.gz">
	afp-Sqrt_Babylonian-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Sqrt_Babylonian-2013-01-04.tar.gz">
	afp-Sqrt_Babylonian-2013-01-04.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Stirling_Formula.html b/web/entries/Stirling_Formula.html
	--- a/web/entries/Stirling_Formula.html
	+++ b/web/entries/Stirling_Formula.html
	@@ -1,222 +1,222 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Stirling's formula - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">S</font>tirling's

	formula

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Stirling's formula</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-09-01</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>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 <a
	href="http://www.maths.lancs.ac.uk/~jameson/stirlgamma.pdf">Graham Jameson</a>.</p>
	<p>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.</p></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Stirling_Formula-AFP,
	author = {Manuel Eberl},
	title = {Stirling's formula},
	journal = {Archive of Formal Proofs},
	month = sep,
	year = 2016,
	note = {\url{https://isa-afp.org/entries/Stirling_Formula.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Bernoulli.html">Bernoulli</a>, <a href="Landau_Symbols.html">Landau_Symbols</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="Comparison_Sort_Lower_Bound.html">Comparison_Sort_Lower_Bound</a>, <a href="Lambert_W.html">Lambert_W</a>, <a href="Prime_Number_Theorem.html">Prime_Number_Theorem</a> </td></tr>
	+ <td class="data"><a href="Comparison_Sort_Lower_Bound.html">Comparison_Sort_Lower_Bound</a>, <a href="Irrationals_From_THEBOOK.html">Irrationals_From_THEBOOK</a>, <a href="Lambert_W.html">Lambert_W</a>, <a href="Prime_Number_Theorem.html">Prime_Number_Theorem</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Stirling_Formula/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Stirling_Formula/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Stirling_Formula/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Stirling_Formula-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Stirling_Formula-2021-02-23.tar.gz">
	afp-Stirling_Formula-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Stirling_Formula-2020-04-20.tar.gz">
	afp-Stirling_Formula-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Stirling_Formula-2019-06-11.tar.gz">
	afp-Stirling_Formula-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Stirling_Formula-2018-08-16.tar.gz">
	afp-Stirling_Formula-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Stirling_Formula-2017-10-10.tar.gz">
	afp-Stirling_Formula-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Stirling_Formula-2016-12-17.tar.gz">
	afp-Stirling_Formula-2016-12-17.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Stochastic_Matrices.html b/web/entries/Stochastic_Matrices.html
	--- a/web/entries/Stochastic_Matrices.html
	+++ b/web/entries/Stochastic_Matrices.html
	@@ -1,223 +1,223 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Stochastic Matrices and the Perron-Frobenius Theorem - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">S</font>tochastic

	<font class="first">M</font>atrices

	and

	the

	<font class="first">P</font>erron-Frobenius

	<font class="first">T</font>heorem

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Stochastic Matrices and the Perron-Frobenius Theorem</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2017-11-22</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Stochastic_Matrices-AFP,
	author = {René Thiemann},
	title = {Stochastic Matrices and the Perron-Frobenius Theorem},
	journal = {Archive of Formal Proofs},
	month = nov,
	year = 2017,
	note = {\url{https://isa-afp.org/entries/Stochastic_Matrices.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a>, <a href="Markov_Models.html">Markov_Models</a>, <a href="Perron_Frobenius.html">Perron_Frobenius</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Stochastic_Matrices/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Stochastic_Matrices/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Stochastic_Matrices/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Stochastic_Matrices-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Stochastic_Matrices-2021-02-23.tar.gz">
	afp-Stochastic_Matrices-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Stochastic_Matrices-2020-04-20.tar.gz">
	afp-Stochastic_Matrices-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Stochastic_Matrices-2019-06-11.tar.gz">
	afp-Stochastic_Matrices-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Stochastic_Matrices-2018-08-16.tar.gz">
	afp-Stochastic_Matrices-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Stochastic_Matrices-2017-11-23.tar.gz">
	afp-Stochastic_Matrices-2017-11-23.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Subresultants.html b/web/entries/Subresultants.html
	--- a/web/entries/Subresultants.html
	+++ b/web/entries/Subresultants.html
	@@ -1,218 +1,218 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Subresultants - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">S</font>ubresultants

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Subresultants</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2017-04-06</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Subresultants-AFP,
	author = {Sebastiaan Joosten and René Thiemann and Akihisa Yamada},
	title = {Subresultants},
	journal = {Archive of Formal Proofs},
	month = apr,
	year = 2017,
	note = {\url{https://isa-afp.org/entries/Subresultants.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Berlekamp_Zassenhaus.html">Berlekamp_Zassenhaus</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Subresultants/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Subresultants/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Subresultants/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Subresultants-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Subresultants-2021-02-23.tar.gz">
	afp-Subresultants-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Subresultants-2020-04-20.tar.gz">
	afp-Subresultants-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Subresultants-2019-06-11.tar.gz">
	afp-Subresultants-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Subresultants-2018-08-16.tar.gz">
	afp-Subresultants-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Subresultants-2017-10-10.tar.gz">
	afp-Subresultants-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Subresultants-2017-04-07.tar.gz">
	afp-Subresultants-2017-04-07.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Sunflowers.html b/web/entries/Sunflowers.html
	--- a/web/entries/Sunflowers.html
	+++ b/web/entries/Sunflowers.html
	@@ -1,200 +1,200 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>The Sunflower Lemma of Erdős and Rado - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">T</font>he

	<font class="first">S</font>unflower

	<font class="first">L</font>emma

	of

	<font class="first">E</font>rdős

	and

	<font class="first">R</font>ado

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">The Sunflower Lemma of Erdős and Rado</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2021-02-25</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	We formally define sunflowers and provide a formalization of the
	sunflower lemma of Erd&odblac;s and Rado: whenever a set of
	size-<i>k</i>-sets has a larger cardinality than
	<i>(r - 1)<sup>k</sup> · k!</i>,
	then it contains a sunflower of cardinality <i>r</i>.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Sunflowers-AFP,
	author = {René Thiemann},
	title = {The Sunflower Lemma of Erdős and Rado},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2021,
	note = {\url{https://isa-afp.org/entries/Sunflowers.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>






	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Sunflowers/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Sunflowers/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Sunflowers/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Sunflowers-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Sunflowers-2021-03-01.tar.gz">
	afp-Sunflowers-2021-03-01.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Transitive-Closure-II.html b/web/entries/Transitive-Closure-II.html
	--- a/web/entries/Transitive-Closure-II.html
	+++ b/web/entries/Transitive-Closure-II.html
	@@ -1,273 +1,273 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Executable Transitive Closures - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">E</font>xecutable

	<font class="first">T</font>ransitive

	<font class="first">C</font>losures

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Executable Transitive Closures</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2012-02-29</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>
	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.
	</p><p>
	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.
	</p></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Transitive-Closure-II-AFP,
	author = {René Thiemann},
	title = {Executable Transitive Closures},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2012,
	note = {\url{https://isa-afp.org/entries/Transitive-Closure-II.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Regular-Sets.html">Regular-Sets</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Transitive-Closure-II/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Transitive-Closure-II/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Transitive-Closure-II/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Transitive-Closure-II-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Transitive-Closure-II-2021-02-23.tar.gz">
	afp-Transitive-Closure-II-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Transitive-Closure-II-2020-04-20.tar.gz">
	afp-Transitive-Closure-II-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Transitive-Closure-II-2019-06-11.tar.gz">
	afp-Transitive-Closure-II-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Transitive-Closure-II-2018-08-16.tar.gz">
	afp-Transitive-Closure-II-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Transitive-Closure-II-2017-10-10.tar.gz">
	afp-Transitive-Closure-II-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Transitive-Closure-II-2016-12-17.tar.gz">
	afp-Transitive-Closure-II-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Transitive-Closure-II-2016-02-22.tar.gz">
	afp-Transitive-Closure-II-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Transitive-Closure-II-2015-05-27.tar.gz">
	afp-Transitive-Closure-II-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Transitive-Closure-II-2014-08-28.tar.gz">
	afp-Transitive-Closure-II-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Transitive-Closure-II-2013-12-11.tar.gz">
	afp-Transitive-Closure-II-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Transitive-Closure-II-2013-11-17.tar.gz">
	afp-Transitive-Closure-II-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Transitive-Closure-II-2013-02-16.tar.gz">
	afp-Transitive-Closure-II-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Transitive-Closure-II-2012-05-24.tar.gz">
	afp-Transitive-Closure-II-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Transitive-Closure-II-2012-03-15.tar.gz">
	afp-Transitive-Closure-II-2012-03-15.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Transitive-Closure-II-2012-02-29.tar.gz">
	afp-Transitive-Closure-II-2012-02-29.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Transitive-Closure.html b/web/entries/Transitive-Closure.html
	--- a/web/entries/Transitive-Closure.html
	+++ b/web/entries/Transitive-Closure.html
	@@ -1,277 +1,277 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Executable Transitive Closures of Finite Relations - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">E</font>xecutable

	<font class="first">T</font>ransitive

	<font class="first">C</font>losures

	of

	<font class="first">F</font>inite

	<font class="first">R</font>elations

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Executable Transitive Closures of Finite Relations</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2011-03-14</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[2014-09-04] added example simprocs in Finite_Transitive_Closure_Simprocs</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Transitive-Closure-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {Executable Transitive Closures of Finite Relations},
	journal = {Archive of Formal Proofs},
	month = mar,
	year = 2011,
	note = {\url{https://isa-afp.org/entries/Transitive-Closure.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE.LGPL">GNU Lesser General Public License (LGPL)</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Collections.html">Collections</a>, <a href="Matrix.html">Matrix</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="KBPs.html">KBPs</a>, <a href="Network_Security_Policy_Verification.html">Network_Security_Policy_Verification</a>, <a href="Planarity_Certificates.html">Planarity_Certificates</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Transitive-Closure/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Transitive-Closure/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Transitive-Closure/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Transitive-Closure-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Transitive-Closure-2021-02-23.tar.gz">
	afp-Transitive-Closure-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-Transitive-Closure-2020-04-20.tar.gz">
	afp-Transitive-Closure-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-Transitive-Closure-2019-06-11.tar.gz">
	afp-Transitive-Closure-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-Transitive-Closure-2018-08-16.tar.gz">
	afp-Transitive-Closure-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Transitive-Closure-2017-10-10.tar.gz">
	afp-Transitive-Closure-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Transitive-Closure-2016-12-17.tar.gz">
	afp-Transitive-Closure-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Transitive-Closure-2016-02-22.tar.gz">
	afp-Transitive-Closure-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Transitive-Closure-2015-05-27.tar.gz">
	afp-Transitive-Closure-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Transitive-Closure-2014-08-28.tar.gz">
	afp-Transitive-Closure-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Transitive-Closure-2013-12-11.tar.gz">
	afp-Transitive-Closure-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Transitive-Closure-2013-11-17.tar.gz">
	afp-Transitive-Closure-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-Transitive-Closure-2013-02-16.tar.gz">
	afp-Transitive-Closure-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-Transitive-Closure-2012-05-24.tar.gz">
	afp-Transitive-Closure-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Transitive-Closure-2011-10-12.tar.gz">
	afp-Transitive-Closure-2011-10-12.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-Transitive-Closure-2011-10-11.tar.gz">
	afp-Transitive-Closure-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-Transitive-Closure-2011-03-14.tar.gz">
	afp-Transitive-Closure-2011-03-14.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Universal_Hash_Families.html b/web/entries/Universal_Hash_Families.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Universal_Hash_Families.html
	@@ -0,0 +1,197 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Universal Hash Families - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">U</font>niversal
	+
	+ <font class="first">H</font>ash
	+
	+ <font class="first">F</font>amilies
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Universal Hash Families</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-20</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+A <i>k</i>-universal hash family is a probability
	+space of functions, which have uniform distribution and form
	+<i>k</i>-wise independent random variables. They can often be used
	+in place of classic (or cryptographic) hash functions and allow the
	+rigorous analysis of the performance of randomized algorithms and
	+data structures that rely on hash functions. In 1981
	+<a href="https://doi.org/10.1016/0022-0000(81)90033-7">Wegman and Carter</a>
	+introduced a generic construction for such families with arbitrary
	+<i>k</i> using polynomials over a finite field. This entry
	+contains a formalization of them and establishes the property of
	+<i>k</i>-universality. To be useful the formalization also provides
	+an explicit construction of finite fields using the factor ring of
	+integers modulo a prime. Additionally, some generic results about
	+independent families are shown that might be of independent interest.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Universal_Hash_Families-AFP,
	+ author = {Emin Karayel},
	+ title = {Universal Hash Families},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Universal_Hash_Families.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="Interpolation_Polynomials_HOL_Algebra.html">Interpolation_Polynomials_HOL_Algebra</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Universal_Hash_Families/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Universal_Hash_Families/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Universal_Hash_Families/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Universal_Hash_Families-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/VYDRA_MDL.html b/web/entries/VYDRA_MDL.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/VYDRA_MDL.html
	@@ -0,0 +1,214 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Multi-Head Monitoring of Metric Dynamic Logic - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">M</font>ulti-Head
	+
	+ <font class="first">M</font>onitoring
	+
	+ of
	+
	+ <font class="first">M</font>etric
	+
	+ <font class="first">D</font>ynamic
	+
	+ <font class="first">L</font>ogic
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Multi-Head Monitoring of Metric Dynamic Logic</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ Martin Raszyk (martin /dot/ raszyk /at/ inf /dot/ ethz /dot/ ch)
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-13</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+Runtime monitoring (or runtime verification) is an approach to
	+checking compliance of a system's execution with a specification
	+(e.g., a temporal query). The system's execution is logged into a
	+trace---a sequence of time-points, each consisting of a time-stamp and
	+observed events. A monitor is an algorithm that produces verdicts on
	+the satisfaction of a temporal query on a trace. We formalize a
	+monitoring algorithm for metric dynamic logic, an extension of metric
	+temporal logic with regular expressions. The monitor computes whether
	+a given query is satisfied at every position in an input trace of
	+time-stamped events. We formalize the time-stamps as an abstract
	+algebraic structure satisfying certain assumptions. Instances of this
	+structure include natural numbers, real numbers, and lexicographic
	+combinations of them. Our monitor follows the multi-head paradigm: it
	+reads the input simultaneously at multiple positions and moves its
	+reading heads asynchronously. This mode of operation results in
	+unprecedented time and space complexity guarantees for metric dynamic
	+logic: The monitor's amortized time complexity to process a
	+time-point and the monitor's space complexity neither depends on
	+the event-rate, i.e., the number of events within a fixed time-unit,
	+nor on the numeric constants occurring in the quantitative temporal
	+constraints in the given query. The multi-head monitoring algorithm
	+for metric dynamic logic is reported in our paper "Multi-Head
	+Monitoring of Metric Dynamic Logic" published at ATVA 2020. We
	+have also formalized unpublished specialized algorithms for the
	+temporal operators of metric temporal logic.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{VYDRA_MDL-AFP,
	+ author = {Martin Raszyk},
	+ title = {Multi-Head Monitoring of Metric Dynamic Logic},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/VYDRA_MDL.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="Containers.html">Containers</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/VYDRA_MDL/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/VYDRA_MDL/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/VYDRA_MDL/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-VYDRA_MDL-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/Weighted_Path_Order.html b/web/entries/Weighted_Path_Order.html
	--- a/web/entries/Weighted_Path_Order.html
	+++ b/web/entries/Weighted_Path_Order.html
	@@ -1,218 +1,218 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>A Formalization of Weighted Path Orders and Recursive Path Orders - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">A</font>

	<font class="first">F</font>ormalization

	of

	<font class="first">W</font>eighted

	<font class="first">P</font>ath

	<font class="first">O</font>rders

	and

	<font class="first">R</font>ecursive

	<font class="first">P</font>ath

	<font class="first">O</font>rders

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">A Formalization of Weighted Path Orders and Recursive Path Orders</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a> and
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at) and
	Akihisa Yamada (akihisa /dot/ yamada /at/ aist /dot/ go /dot/ jp)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2021-09-16</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	We define the weighted path order (WPO) and formalize several
	properties such as strong normalization, the subterm property, and
	closure properties under substitutions and contexts. Our definition of
	WPO extends the original definition by also permitting multiset
	comparisons of arguments instead of just lexicographic extensions.
	Therefore, our WPO not only subsumes lexicographic path orders (LPO),
	but also recursive path orders (RPO). We formally prove these
	subsumptions and therefore all of the mentioned properties of WPO are
	automatically transferable to LPO and RPO as well. Such a
	transformation is not required for Knuth–Bendix orders
	(KBO), since they have already been formalized. Nevertheless, we still
	provide a proof that WPO subsumes KBO and thereby underline the
	generality of WPO.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Weighted_Path_Order-AFP,
	author = {Christian Sternagel and René Thiemann and Akihisa Yamada},
	title = {A Formalization of Weighted Path Orders and Recursive Path Orders},
	journal = {Archive of Formal Proofs},
	month = sep,
	year = 2021,
	note = {\url{https://isa-afp.org/entries/Weighted_Path_Order.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Knuth_Bendix_Order.html">Knuth_Bendix_Order</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Weighted_Path_Order/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Weighted_Path_Order/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Weighted_Path_Order/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Weighted_Path_Order-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-Weighted_Path_Order-2021-09-26.tar.gz">
	afp-Weighted_Path_Order-2021-09-26.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Wetzels_Problem.html b/web/entries/Wetzels_Problem.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Wetzels_Problem.html
	@@ -0,0 +1,200 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Wetzel's Problem and the Continuum Hypothesis - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">W</font>etzel's
	+
	+ <font class="first">P</font>roblem
	+
	+ and
	+
	+ the
	+
	+ <font class="first">C</font>ontinuum
	+
	+ <font class="first">H</font>ypothesis
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Wetzel's Problem and the Continuum Hypothesis</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ Lawrence C Paulson
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-02-18</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+Let $F$ be a set of analytic functions on the complex plane such that,
	+for each $z\in\mathbb{C}$, the set $\{f(z) \mid f\in F\}$ is
	+countable; must then $F$ itself be countable? The answer is yes if the
	+Continuum Hypothesis is false, i.e., if the cardinality of
	+$\mathbb{R}$ exceeds $\aleph_1$. But if CH is true then such an $F$,
	+of cardinality $\aleph_1$, can be constructed by transfinite
	+recursion. The formal proof illustrates reasoning about complex
	+analysis (analytic and homomorphic functions) and set theory
	+(transfinite cardinalities) in a single setting. The mathematical text
	+comes from <em>Proofs from THE BOOK</em> by Aigner and
	+Ziegler.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Wetzels_Problem-AFP,
	+ author = {Lawrence C Paulson},
	+ title = {Wetzel's Problem and the Continuum Hypothesis},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Wetzels_Problem.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+ <tr><td class="datahead">Depends on:</td>
	+ <td class="data"><a href="ZFC_in_HOL.html">ZFC_in_HOL</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Wetzels_Problem/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Wetzels_Problem/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Wetzels_Problem/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Wetzels_Problem-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ No newline at end of file
	diff --git a/web/entries/XML.html b/web/entries/XML.html
	--- a/web/entries/XML.html
	+++ b/web/entries/XML.html
	@@ -1,233 +1,233 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>XML - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">X</font>ML

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">XML</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a> and
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann (rene /dot/ thiemann /at/ uibk /dot/ ac /dot/ at)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2014-10-03</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{XML-AFP,
	author = {Christian Sternagel and René Thiemann},
	title = {XML},
	journal = {Archive of Formal Proofs},
	month = oct,
	year = 2014,
	note = {\url{https://isa-afp.org/entries/XML.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>


	<tr><td class="datahead">Depends on:</td>
	<td class="data"><a href="Certification_Monads.html">Certification_Monads</a>, <a href="Show.html">Show</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/XML/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/XML/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/XML/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-XML-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-XML-2021-02-23.tar.gz">
	afp-XML-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-XML-2020-04-20.tar.gz">
	afp-XML-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-XML-2019-06-11.tar.gz">
	afp-XML-2019-06-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2018:
	<a href="../release/afp-XML-2018-08-16.tar.gz">
	afp-XML-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-XML-2017-10-10.tar.gz">
	afp-XML-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-XML-2016-12-17.tar.gz">
	afp-XML-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-XML-2016-02-22.tar.gz">
	afp-XML-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-XML-2015-05-27.tar.gz">
	afp-XML-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-XML-2014-10-08.tar.gz">
	afp-XML-2014-10-08.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ No newline at end of file
	diff --git a/web/entries/Youngs_Inequality.html b/web/entries/Youngs_Inequality.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Youngs_Inequality.html
	@@ -0,0 +1,194 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Young's Inequality for Increasing Functions - Archive of Formal Proofs
	+</title>
	+<link rel="stylesheet" type="text/css" href="../front.css">
	+<link rel="icon" href="../images/favicon.ico" type="image/icon">
	+<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	+<!-- MathJax for LaTeX support in abstracts -->
	+<script>
	+MathJax = {
	+ tex: {
	+ inlineMath: [['$', '$'], ['\$', '\$']]
	+ },
	+ processEscapes: true,
	+ svg: {
	+ fontCache: 'global'
	+ }
	+};
	+</script>
	+<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	+</head>
	+
	+<body class="mathjax_ignore">
	+
	+<table width="100%">
	+<tbody>
	+<tr>
	+
	+<!-- Navigation -->
	+<td width="20%" align="center" valign="top">
	+ <p> </p>
	+ <a href="https://www.isa-afp.org/">
	+ <img src="../images/isabelle.png" width="100" height="88" border=0>
	+ </a>
	+ <p> </p>
	+ <p> </p>
	+ <table class="nav" width="80%">
	+ <tr>
	+ <td class="nav" width="100%"><a href="../index.html">Home</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../about.html">About</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../submitting.html">Submission</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../updating.html">Updating Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../using.html">Using Entries</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../search.html">Search</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../statistics.html">Statistics</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../topics.html">Index</a></td>
	+ </tr>
	+ <tr>
	+ <td class="nav"><a href="../download.html">Download</a></td>
	+ </tr>
	+ </table>
	+ <p> </p>
	+ <p> </p>
	+</td>
	+
	+
	+<!-- Content -->
	+<td width="80%" valign="top">
	+<div align="center">
	+ <p> </p>
	+ <h1> <font class="first">Y</font>oung's
	+
	+ <font class="first">I</font>nequality
	+
	+ for
	+
	+ <font class="first">I</font>ncreasing
	+
	+ <font class="first">F</font>unctions
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Young's Inequality for Increasing Functions</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ Lawrence C Paulson
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2022-01-31</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract mathjax_process">
	+Young's inequality states that $$ ab \leq \int_0^a f(x)dx +
	+\int_0^b f^{-1}(y) dy $$ where $a\geq 0$, $b\geq 0$ and $f$ is
	+strictly increasing and continuous. Its proof is formalised following
	+<a href="https://www.jstor.org/stable/2318018">the
	+development</a> by Cunningham and Grossman. Their idea is to
	+make the intuitive, geometric folklore proof rigorous by reasoning
	+about step functions. The lack of the Riemann integral makes the
	+development longer than one would like, but their argument is
	+reproduced faithfully.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Youngs_Inequality-AFP,
	+ author = {Lawrence C Paulson},
	+ title = {Young's Inequality for Increasing Functions},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2022,
	+ note = {\url{https://isa-afp.org/entries/Youngs_Inequality.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}</pre>
	+ </td>
	+</tr>
	+
	+ <tr><td class="datahead">License:</td>
	+ <td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>
	+
	+
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Youngs_Inequality/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Youngs_Inequality/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Youngs_Inequality/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Youngs_Inequality-current.tar.gz">Download this entry</a>
	+ </td>
	+ </tr>
	+
	+
	+ <tr><td class="links">Older releases:
	+ None
	+ </td></tr>
	+
	+ </tbody>
	+</table>
	+
	+</div>
	+</td>
	+
	+</tr>
	+</tbody>
	+</table>
	+
	+<script src="../jquery.min.js"></script>
	+<script src="../script.js"></script>
	+
	+</body>
	+</html>
	\ 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,233 +1,233 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Zermelo Fraenkel Set Theory in Higher-Order Logic - Archive of Formal Proofs
	</title>
	<link rel="stylesheet" type="text/css" href="../front.css">
	<link rel="icon" href="../images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="../rss.xml">
	<!-- MathJax for LaTeX support in abstracts -->
	<script>
	MathJax = {
	tex: {
	inlineMath: [['$', '$'], ['\$', '\$']]
	},
	processEscapes: true,
	svg: {
	fontCache: 'global'
	}
	};
	</script>
	<script id="MathJax-script" async src="../components/mathjax/es5/tex-mml-chtml.js"></script>
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="../images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="../index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="../download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1> <font class="first">Z</font>ermelo

	<font class="first">F</font>raenkel

	<font class="first">S</font>et

	<font class="first">T</font>heory

	in

	<font class="first">H</font>igher-Order

	<font class="first">L</font>ogic

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Zermelo Fraenkel Set Theory in Higher-Order Logic</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2019-10-24</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract mathjax_process">
	<p>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.</p>
	<p>There is a type <em>V</em> of sets and a function <em>elts :: V => V
	set</em> mapping a set to its elements. Classes simply have type <em>V
	set</em>, 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.</p>
	<p>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.</p>
	<p>The theory provides two type classes with the aim of facilitating
	developments that combine <em>V</em> with other Isabelle/HOL types:
	<em>embeddable</em>, the class of types that can be injected into <em>V</em>
	(including <em>V</em> itself as well as <em>V*V</em>, etc.), and
	<em>small</em>, the class of types that correspond to some ZF set.</p>
	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)</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@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{https://isa-afp.org/entries/ZFC_in_HOL.html},
	Formal proof development},
	ISSN = {2150-914x},
	}</pre>
	</td>
	</tr>

	<tr><td class="datahead">License:</td>
	<td class="data"><a href="http://isa-afp.org/LICENSE">BSD License</a></td></tr>



	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="CZH_Foundations.html">CZH_Foundations</a>, <a href="Ordinal_Partitions.html">Ordinal_Partitions</a> </td></tr>
	+ <td class="data"><a href="CZH_Foundations.html">CZH_Foundations</a>, <a href="Ordinal_Partitions.html">Ordinal_Partitions</a>, <a href="Wetzels_Problem.html">Wetzels_Problem</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/ZFC_in_HOL/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/ZFC_in_HOL/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/ZFC_in_HOL/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-ZFC_in_HOL-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2021:
	<a href="../release/afp-ZFC_in_HOL-2021-02-23.tar.gz">
	afp-ZFC_in_HOL-2021-02-23.tar.gz
	</a>
	</li>
	<li>Isabelle 2020:
	<a href="../release/afp-ZFC_in_HOL-2020-04-20.tar.gz">
	afp-ZFC_in_HOL-2020-04-20.tar.gz
	</a>
	</li>
	<li>Isabelle 2019:
	<a href="../release/afp-ZFC_in_HOL-2019-11-04.tar.gz">
	afp-ZFC_in_HOL-2019-11-04.tar.gz
	</a>
	</li>
	</ul>
	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="../jquery.min.js"></script>
	<script src="../script.js"></script>

	</body>
	</html>
	\ 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,5965 +1,6081 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Archive of Formal Proofs</title>
	<link rel="stylesheet" type="text/css" href="front.css">
	<link rel="icon" href="images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="rss.xml">
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1><font class="first">A</font>rchive of
	<font class="first">F</font>ormal
	<font class="first">P</font>roofs</h1>
	</h1>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td>
	The Archive of Formal Proofs is a collection of proof libraries, examples, and larger scientific developments,
	mechanically checked in the theorem prover <a href="http://isabelle.in.tum.de/">Isabelle</a>. It is organized in the way
	of a scientific journal, is indexed by <a href="http://dblp.uni-trier.de/db/journals/afp/">dblp</a> and has an ISSN:
	2150-914x. Submissions are refereed. The preferred citation style is available <a href="citing.html">[here]</a>. We encourage companion AFP submissions to conference and journal publications.
	<br><br>A <a href="http://devel.isa-afp.org">development version</a> of the archive is available as well. </td>
	</tr>
	</tbody>
	</table>

	<p> </p>

	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2022</td>
	</tr>
	<tr>
	<td class="entry">
	+ 2022-02-20: <a href="entries/Universal_Hash_Families.html">Universal Hash Families</a>
	+ <br>
	+ Author:
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-02-18: <a href="entries/Wetzels_Problem.html">Wetzel's Problem and the Continuum Hypothesis</a>
	+ <br>
	+ Author:
	+ Lawrence C Paulson
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-02-15: <a href="entries/Eval_FO.html">First-Order Query Evaluation</a>
	+ <br>
	+ Author:
	+ Martin Raszyk
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-02-13: <a href="entries/VYDRA_MDL.html">Multi-Head Monitoring of Metric Dynamic Logic</a>
	+ <br>
	+ Author:
	+ Martin Raszyk
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-02-04: <a href="entries/Equivalence_Relation_Enumeration.html">Enumeration of Equivalence Relations</a>
	+ <br>
	+ Author:
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-02-03: <a href="entries/Quasi_Borel_Spaces.html">Quasi-Borel Spaces</a>
	+ <br>
	+ Authors:
	+ Michikazu Hirata,
	+ <a href="https://sv.c.titech.ac.jp/minamide/index.en.html">Yasuhiko Minamide</a>
	+ and <a href="https://sites.google.com/view/tetsuyasato/">Tetsuya Sato</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-02-03: <a href="entries/LP_Duality.html">Duality of Linear Programming</a>
	+ <br>
	+ Author:
	+ René Thiemann
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-02-02: <a href="entries/FO_Theory_Rewriting.html">First-Order Theory of Rewriting</a>
	+ <br>
	+ Authors:
	+ Alexander Lochmann
	+ and Bertram Felgenhauer
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-01-31: <a href="entries/Youngs_Inequality.html">Young's Inequality for Increasing Functions</a>
	+ <br>
	+ Author:
	+ Lawrence C Paulson
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-01-31: <a href="entries/FOL_Seq_Calc2.html">A Sequent Calculus Prover for First-Order Logic with Functions</a>
	+ <br>
	+ Authors:
	+ <a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	+ and <a href="http://people.compute.dtu.dk/fkjac/">Frederik Krogsdal Jacobsen</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-01-29: <a href="entries/Interpolation_Polynomials_HOL_Algebra.html">Interpolation Polynomials (in HOL-Algebra)</a>
	+ <br>
	+ Author:
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-01-25: <a href="entries/Median_Method.html">Median Method</a>
	+ <br>
	+ Author:
	+ <a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-01-23: <a href="entries/Actuarial_Mathematics.html">Actuarial Mathematics</a>
	+ <br>
	+ Author:
	+ Yosuke Ito
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	+ 2022-01-08: <a href="entries/Irrationals_From_THEBOOK.html">Irrational numbers from THE BOOK</a>
	+ <br>
	+ Author:
	+ Lawrence C Paulson
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="entry">
	2022-01-04: <a href="entries/Knights_Tour.html">Knight's Tour Revisited Revisited</a>
	<br>
	Author:
	Lukas Koller
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2021</td>
	</tr>
	<tr>
	<td class="entry">
	2021-12-31: <a href="entries/Hyperdual.html">Hyperdual Numbers and Forward Differentiation</a>
	<br>
	Authors:
	Filip Smola
	and <a href="https://www.inf.ed.ac.uk/people/staff/Jacques_Fleuriot.html">Jacques Fleuriot</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-12-29: <a href="entries/Gale_Shapley.html">Gale-Shapley Algorithm</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-12-28: <a href="entries/Roth_Arithmetic_Progressions.html">Roth's Theorem on Arithmetic Progressions</a>
	<br>
	Authors:
	<a href="https://www.cst.cam.ac.uk/people/cle47">Chelsea Edmonds</a>,
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-12-16: <a href="entries/MDP-Rewards.html">Markov Decision Processes with Rewards</a>
	<br>
	Authors:
	Maximilian Schäffeler
	and <a href="http://home.in.tum.de/~mansour/">Mohammad Abdulaziz</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-12-16: <a href="entries/MDP-Algorithms.html">Verified Algorithms for Solving Markov Decision Processes</a>
	<br>
	Authors:
	Maximilian Schäffeler
	and <a href="http://home.in.tum.de/~mansour/">Mohammad Abdulaziz</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-12-15: <a href="entries/Regular_Tree_Relations.html">Regular Tree Relations</a>
	<br>
	Authors:
	Alexander Lochmann,
	Bertram Felgenhauer,
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Thomas Sternagel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-29: <a href="entries/Simplicial_complexes_and_boolean_functions.html">Simplicial Complexes and Boolean functions</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jearansa">Jesús Aransay</a>,
	Alejandro del Campo
	and <a href="http://liftm.de/">Julius Michaelis</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-23: <a href="entries/Van_Emde_Boas_Trees.html">van Emde Boas Trees</a>
	<br>
	Authors:
	Thomas Ammer
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-22: <a href="entries/Foundation_of_geometry.html">Foundation of geometry in planes, and some complements: Excluding the parallel axioms</a>
	<br>
	Author:
	Fumiya Iwama
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-19: <a href="entries/Hahn_Jordan_Decomposition.html">The Hahn and Jordan Decomposition Theorems</a>
	<br>
	Authors:
	Marie Cousin,
	Mnacho Echenim
	and Hervé Guiol
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-08: <a href="entries/SimplifiedOntologicalArgument.html">Exploring Simplified Variants of Gödel’s Ontological Argument in Isabelle/HOL</a>
	<br>
	Author:
	<a href="http://christoph-benzmueller.de">Christoph Benzmüller</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-08: <a href="entries/Real_Power.html">Real Exponents as the Limits of Sequences of Rational Exponents</a>
	<br>
	Author:
	<a href="https://www.inf.ed.ac.uk/people/staff/Jacques_Fleuriot.html">Jacques D. Fleuriot</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-08: <a href="entries/PAL.html">Automating Public Announcement Logic and the Wise Men Puzzle in Isabelle/HOL</a>
	<br>
	Authors:
	<a href="http://christoph-benzmueller.de">Christoph Benzmüller</a>
	and <a href="https://www.linkedin.com/in/sebastian-reiche-0b2093178">Sebastian Reiche</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-08: <a href="entries/Factor_Algebraic_Polynomial.html">Factorization of Polynomials with Algebraic Coefficients</a>
	<br>
	Authors:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-11-05: <a href="entries/Szemeredi_Regularity.html">Szemerédi's Regularity Lemma</a>
	<br>
	Authors:
	<a href="https://www.cst.cam.ac.uk/people/cle47">Chelsea Edmonds</a>,
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-10-28: <a href="entries/Registers.html">Quantum and Classical Registers</a>
	<br>
	Author:
	<a href="https://www.ut.ee/~unruh/">Dominique Unruh</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-10-19: <a href="entries/Belief_Revision.html">Belief Revision Theory</a>
	<br>
	Authors:
	Valentin Fouillard,
	Safouan Taha,
	Frédéric Boulanger
	and Nicolas Sabouret
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-10-13: <a href="entries/X86_Semantics.html">X86 instruction semantics and basic block symbolic execution</a>
	<br>
	Authors:
	Freek Verbeek,
	Abhijith Bharadwaj,
	Joshua Bockenek,
	Ian Roessle,
	Timmy Weerwag
	and Binoy Ravindran
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-10-12: <a href="entries/Correctness_Algebras.html">Algebras for Iteration, Infinite Executions and Correctness of Sequential Computations</a>
	<br>
	Author:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-10-02: <a href="entries/Virtual_Substitution.html">Verified Quadratic Virtual Substitution for Real Arithmetic</a>
	<br>
	Authors:
	Matias Scharager,
	Katherine Cordwell,
	Stefan Mitsch
	and André Platzer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-24: <a href="entries/FOL_Axiomatic.html">Soundness and Completeness of an Axiomatic System for First-Order Logic</a>
	<br>
	Author:
	<a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-18: <a href="entries/Complex_Bounded_Operators.html">Complex Bounded Operators</a>
	<br>
	Authors:
	<a href="https://josephcmac.github.io/">Jose Manuel Rodriguez Caballero</a>
	and <a href="https://www.ut.ee/~unruh/">Dominique Unruh</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-16: <a href="entries/Weighted_Path_Order.html">A Formalization of Weighted Path Orders and Recursive Path Orders</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-06: <a href="entries/Types_To_Sets_Extension.html">Extension of Types-To-Sets</a>
	<br>
	Author:
	Mihails Milehins
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-06: <a href="entries/Intro_Dest_Elim.html">IDE: Introduction, Destruction, Elimination</a>
	<br>
	Author:
	Mihails Milehins
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-06: <a href="entries/Conditional_Transfer_Rule.html">Conditional Transfer Rule</a>
	<br>
	Author:
	Mihails Milehins
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-06: <a href="entries/Conditional_Simplification.html">Conditional Simplification</a>
	<br>
	Author:
	Mihails Milehins
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-06: <a href="entries/CZH_Universal_Constructions.html">Category Theory for ZFC in HOL III: Universal Constructions</a>
	<br>
	Author:
	Mihails Milehins
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-06: <a href="entries/CZH_Foundations.html">Category Theory for ZFC in HOL I: Foundations: Design Patterns, Set Theory, Digraphs, Semicategories</a>
	<br>
	Author:
	Mihails Milehins
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-06: <a href="entries/CZH_Elementary_Categories.html">Category Theory for ZFC in HOL II: Elementary Theory of 1-Categories</a>
	<br>
	Author:
	Mihails Milehins
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-05: <a href="entries/Dominance_CHK.html">A data flow analysis algorithm for computing dominators</a>
	<br>
	Author:
	Nan Jiang
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-09-03: <a href="entries/Cubic_Quartic_Equations.html">Solving Cubic and Quartic Equations</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-26: <a href="entries/Logging_Independent_Anonymity.html">Logging-independent Message Anonymity in the Relational Method</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-21: <a href="entries/Three_Circles.html">The Theorem of Three Circles</a>
	<br>
	Authors:
	Fox Thomson
	and <a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-16: <a href="entries/Fresh_Identifiers.html">Fresh identifiers</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and Thomas Bauereiss
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-16: <a href="entries/CoSMed.html">CoSMed: A confidentiality-verified social media platform</a>
	<br>
	Authors:
	Thomas Bauereiss
	and <a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-16: <a href="entries/CoSMeDis.html">CoSMeDis: A confidentiality-verified distributed social media platform</a>
	<br>
	Authors:
	Thomas Bauereiss
	and <a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-16: <a href="entries/CoCon.html">CoCon: A Confidentiality-Verified Conference Management System</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>,
	Peter Lammich
	and Thomas Bauereiss
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-16: <a href="entries/BD_Security_Compositional.html">Compositional BD Security</a>
	<br>
	Authors:
	Thomas Bauereiss
	and <a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-13: <a href="entries/Design_Theory.html">Combinatorial Design Theory</a>
	<br>
	Authors:
	<a href="https://www.cst.cam.ac.uk/people/cle47">Chelsea Edmonds</a>
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-08-03: <a href="entries/Relational_Forests.html">Relational Forests</a>
	<br>
	Author:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-07-27: <a href="entries/Schutz_Spacetime.html">Schutz' Independent Axioms for Minkowski Spacetime</a>
	<br>
	Authors:
	Richard Schmoetten,
	Jake Palmer
	and <a href="https://www.inf.ed.ac.uk/people/staff/Jacques_Fleuriot.html">Jacques Fleuriot</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-07-07: <a href="entries/Finitely_Generated_Abelian_Groups.html">Finitely Generated Abelian Groups</a>
	<br>
	Authors:
	Joseph Thommes
	and <a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-07-01: <a href="entries/SpecCheck.html">SpecCheck - Specification-Based Testing for Isabelle/ML</a>
	<br>
	Authors:
	<a href="https://www21.in.tum.de/team/kappelmk/">Kevin Kappelmann</a>,
	Lukas Bulwahn
	and Sebastian Willenbrink
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-06-22: <a href="entries/Van_der_Waerden.html">Van der Waerden's Theorem</a>
	<br>
	Authors:
	<a href="https://www21.in.tum.de/team/kreuzer/">Katharina Kreuzer</a>
	and <a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-06-18: <a href="entries/MiniSail.html">MiniSail - A kernel language for the ISA specification language SAIL</a>
	<br>
	Author:
	Mark Wassell
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-06-17: <a href="entries/Public_Announcement_Logic.html">Public Announcement Logic</a>
	<br>
	Author:
	<a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-06-04: <a href="entries/IMP_Compiler.html">A Shorter Compiler Correctness Proof for Language IMP</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-05-24: <a href="entries/Combinatorics_Words_Lyndon.html">Lyndon words</a>
	<br>
	Authors:
	<a href="https://www2.karlin.mff.cuni.cz/~holub/">Štěpán Holub</a>
	and <a href="https://users.fit.cvut.cz/~staroste/">Štěpán Starosta</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-05-24: <a href="entries/Combinatorics_Words_Graph_Lemma.html">Graph Lemma</a>
	<br>
	Authors:
	<a href="https://www2.karlin.mff.cuni.cz/~holub/">Štěpán Holub</a>
	and <a href="https://users.fit.cvut.cz/~staroste/">Štěpán Starosta</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-05-24: <a href="entries/Combinatorics_Words.html">Combinatorics on Words Basics</a>
	<br>
	Authors:
	<a href="https://www2.karlin.mff.cuni.cz/~holub/">Štěpán Holub</a>,
	Martin Raška
	and <a href="https://users.fit.cvut.cz/~staroste/">Štěpán Starosta</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-04-30: <a href="entries/Regression_Test_Selection.html">Regression Test Selection</a>
	<br>
	Author:
	Susannah Mansky
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-04-27: <a href="entries/Metalogic_ProofChecker.html">Isabelle's Metalogic: Formalization and Proof Checker</a>
	<br>
	Authors:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	and <a href="http://www21.in.tum.de/~rosskops">Simon Roßkopf</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-04-27: <a href="entries/Lifting_the_Exponent.html">Lifting the Exponent</a>
	<br>
	Author:
	Jakub Kądziołka
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-04-24: <a href="entries/BenOr_Kozen_Reif.html">The BKR Decision Procedure for Univariate Real Arithmetic</a>
	<br>
	Authors:
	Katherine Cordwell,
	<a href="https://www.cs.cmu.edu/~yongkiat/">Yong Kiam Tan</a>
	and André Platzer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-04-23: <a href="entries/GaleStewart_Games.html">Gale-Stewart Games</a>
	<br>
	Author:
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-04-13: <a href="entries/Progress_Tracking.html">Formalization of Timely Dataflow's Progress Tracking Protocol</a>
	<br>
	Authors:
	Matthias Brun,
	Sára Decova,
	<a href="https://andrea.lattuada.me">Andrea Lattuada</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-04-01: <a href="entries/IFC_Tracking.html">Information Flow Control via Dependency Tracking</a>
	<br>
	Author:
	Benedikt Nordhoff
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-03-29: <a href="entries/Grothendieck_Schemes.html">Grothendieck's Schemes in Algebraic Geometry</a>
	<br>
	Authors:
	<a href="https://sites.google.com/site/anthonybordg/">Anthony Bordg</a>,
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence Paulson</a>
	and <a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-03-23: <a href="entries/Padic_Ints.html">Hensel's Lemma for the p-adic Integers</a>
	<br>
	Author:
	Aaron Crighton
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-03-17: <a href="entries/Constructive_Cryptography_CM.html">Constructive Cryptography in HOL: the Communication Modeling Aspect</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and S. Reza Sefidgar
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-03-12: <a href="entries/Modular_arithmetic_LLL_and_HNF_algorithms.html">Two algorithms based on modular arithmetic: lattice basis reduction and Hermite normal form computation</a>
	<br>
	Authors:
	Ralph Bottesch,
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-03-03: <a href="entries/Projective_Measurements.html">Quantum projective measurements and the CHSH inequality</a>
	<br>
	Author:
	Mnacho Echenim
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-03-03: <a href="entries/Hermite_Lindemann.html">The Hermite–Lindemann–Weierstraß Transcendence Theorem</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-03-01: <a href="entries/Mereology.html">Mereology</a>
	<br>
	Author:
	<a href="https://philpeople.org/profiles/ben-blumson">Ben Blumson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-02-25: <a href="entries/Sunflowers.html">The Sunflower Lemma of Erdős and Rado</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-02-24: <a href="entries/BTree.html">A Verified Imperative Implementation of B-Trees</a>
	<br>
	Author:
	Niels Mündler
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-02-17: <a href="entries/Formal_Puiseux_Series.html">Formal Puiseux Series</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-02-10: <a href="entries/Laws_of_Large_Numbers.html">The Laws of Large Numbers</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-01-31: <a href="entries/IsaGeoCoq.html">Tarski's Parallel Postulate implies the 5th Postulate of Euclid, the Postulate of Playfair and the original Parallel Postulate of Euclid</a>
	<br>
	Author:
	Roland Coghetto
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-01-30: <a href="entries/Blue_Eyes.html">Solution to the xkcd Blue Eyes puzzle</a>
	<br>
	Author:
	Jakub Kądziołka
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-01-18: <a href="entries/Hood_Melville_Queue.html">Hood-Melville Queue</a>
	<br>
	Author:
	Alejandro Gómez-Londoño
	</td>
	</tr>
	<tr>
	<td class="entry">
	2021-01-11: <a href="entries/JinjaDCI.html">JinjaDCI: a Java semantics with dynamic class initialization</a>
	<br>
	Author:
	Susannah Mansky
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2020</td>
	</tr>
	<tr>
	<td class="entry">
	2020-12-27: <a href="entries/Delta_System_Lemma.html">Cofinality and the Delta System Lemma</a>
	<br>
	Author:
	<a href="https://cs.famaf.unc.edu.ar/~pedro/home_en.html">Pedro Sánchez Terraf</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-12-17: <a href="entries/Topological_Semantics.html">Topological semantics for paraconsistent and paracomplete logics</a>
	<br>
	Author:
	David Fuenmayor
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-12-08: <a href="entries/Relational_Minimum_Spanning_Trees.html">Relational Minimum Spanning Tree Algorithms</a>
	<br>
	Authors:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	and Nicolas Robinson-O'Brien
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-12-07: <a href="entries/Interpreter_Optimizations.html">Inline Caching and Unboxing Optimization for Interpreters</a>
	<br>
	Author:
	<a href="https://martin.desharnais.me">Martin Desharnais</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-12-05: <a href="entries/Relational_Method.html">The Relational Method with Message Anonymity for the Verification of Cryptographic Protocols</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-11-22: <a href="entries/Isabelle_Marries_Dirac.html">Isabelle Marries Dirac: a Library for Quantum Computation and Quantum Information</a>
	<br>
	Authors:
	<a href="https://sites.google.com/site/anthonybordg/">Anthony Bordg</a>,
	Hanna Lachnitt
	and Yijun He
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-11-19: <a href="entries/CSP_RefTK.html">The HOL-CSP Refinement Toolkit</a>
	<br>
	Authors:
	Safouan Taha,
	<a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	and Lina Ye
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-10-29: <a href="entries/Verified_SAT_Based_AI_Planning.html">Verified SAT-Based AI Planning</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~mansour/">Mohammad Abdulaziz</a>
	and Friedrich Kurz
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-10-29: <a href="entries/AI_Planning_Languages_Semantics.html">AI Planning Languages Semantics</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~mansour/">Mohammad Abdulaziz</a>
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-10-20: <a href="entries/Physical_Quantities.html">A Sound Type System for Physical Quantities, Units, and Measurements</a>
	<br>
	Authors:
	<a href="https://www-users.cs.york.ac.uk/~simonf/">Simon Foster</a>
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-10-12: <a href="entries/Finite-Map-Extras.html">Finite Map Extras</a>
	<br>
	Author:
	Javier Díaz
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-28: <a href="entries/Shadow_SC_DOM.html">A Formal Model of the Safely Composable Document Object Model with Shadow Roots</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>
	and <a href="http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg">Michael Herzberg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-28: <a href="entries/Shadow_DOM.html">A Formal Model of the Document Object Model with Shadow Roots</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>
	and <a href="http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg">Michael Herzberg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-28: <a href="entries/SC_DOM_Components.html">A Formalization of Safely Composable Web Components</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>
	and <a href="http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg">Michael Herzberg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-28: <a href="entries/DOM_Components.html">A Formalization of Web Components</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>
	and <a href="http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg">Michael Herzberg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-28: <a href="entries/Core_SC_DOM.html">The Safely Composable DOM</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>
	and <a href="http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg">Michael Herzberg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-16: <a href="entries/Syntax_Independent_Logic.html">Syntax-Independent Logic Infrastructure</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-16: <a href="entries/Robinson_Arithmetic.html">Robinson Arithmetic</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-16: <a href="entries/Goedel_Incompleteness.html">An Abstract Formalization of Gödel's Incompleteness Theorems</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-16: <a href="entries/Goedel_HFSet_Semanticless.html">From Abstract to Concrete Gödel's Incompleteness Theorems—Part II</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-16: <a href="entries/Goedel_HFSet_Semantic.html">From Abstract to Concrete Gödel's Incompleteness Theorems—Part I</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-07: <a href="entries/Extended_Finite_State_Machines.html">A Formal Model of Extended Finite State Machines</a>
	<br>
	Authors:
	Michael Foster,
	<a href="https://www.brucker.ch">Achim D. Brucker</a>,
	Ramsay G. Taylor
	and John Derrick
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-09-07: <a href="entries/Extended_Finite_State_Machine_Inference.html">Inference of Extended Finite State Machines</a>
	<br>
	Authors:
	Michael Foster,
	<a href="https://www.brucker.ch">Achim D. Brucker</a>,
	Ramsay G. Taylor
	and John Derrick
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-08-31: <a href="entries/PAC_Checker.html">Practical Algebraic Calculus Checker</a>
	<br>
	Authors:
	<a href="http://fmv.jku.at/fleury">Mathias Fleury</a>
	and <a href="http://fmv.jku.at/kaufmann">Daniela Kaufmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-08-31: <a href="entries/Inductive_Inference.html">Some classical results in inductive inference of recursive functions</a>
	<br>
	Author:
	Frank J. Balbach
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-08-26: <a href="entries/Relational_Disjoint_Set_Forests.html">Relational Disjoint-Set Forests</a>
	<br>
	Author:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-08-25: <a href="entries/Saturation_Framework_Extensions.html">Extensions to the Comprehensive Framework for Saturation Theorem Proving</a>
	<br>
	Authors:
	<a href="https://www.cs.vu.nl/~jbe248/">Jasmin Blanchette</a>
	and <a href="https://www.mpi-inf.mpg.de/departments/automation-of-logic/people/sophie-tourret">Sophie Tourret</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-08-25: <a href="entries/BirdKMP.html">Putting the `K' into Bird's derivation of Knuth-Morris-Pratt string matching</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-08-04: <a href="entries/Amicable_Numbers.html">Amicable Numbers</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-08-03: <a href="entries/Ordinal_Partitions.html">Ordinal Partitions</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-07-21: <a href="entries/Chandy_Lamport.html">A Formal Proof of The Chandy--Lamport Distributed Snapshot Algorithm</a>
	<br>
	Authors:
	Ben Fiedler
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-07-13: <a href="entries/Relational_Paths.html">Relational Characterisations of Paths</a>
	<br>
	Authors:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	and <a href="http://www.hoefner-online.de/">Peter Höfner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-06-01: <a href="entries/Safe_Distance.html">A Formally Verified Checker of the Safe Distance Traffic Rules for Autonomous Vehicles</a>
	<br>
	Authors:
	Albert Rizaldi
	and <a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-23: <a href="entries/Smith_Normal_Form.html">A verified algorithm for computing the Smith normal form of a matrix</a>
	<br>
	Author:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-16: <a href="entries/Nash_Williams.html">The Nash-Williams Partition Theorem</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-13: <a href="entries/Knuth_Bendix_Order.html">A Formalization of Knuth–Bendix Orders</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-12: <a href="entries/Irrational_Series_Erdos_Straus.html">Irrationality Criteria for Series by Erdős and Straus</a>
	<br>
	Authors:
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	and <a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-11: <a href="entries/Recursion-Addition.html">Recursion Theorem in ZF</a>
	<br>
	Author:
	Georgy Dunaev
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-08: <a href="entries/LTL_Normal_Form.html">An Efficient Normalisation Procedure for Linear Temporal Logic: Isabelle/HOL Formalisation</a>
	<br>
	Author:
	Salomon Sickert
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-06: <a href="entries/Forcing.html">Formalization of Forcing in Isabelle/ZF</a>
	<br>
	Authors:
	Emmanuel Gunther,
	<a href="https://cs.famaf.unc.edu.ar/~mpagano/">Miguel Pagano</a>
	and <a href="https://cs.famaf.unc.edu.ar/~pedro/home_en.html">Pedro Sánchez Terraf</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-05-02: <a href="entries/Banach_Steinhaus.html">Banach-Steinhaus Theorem</a>
	<br>
	Authors:
	<a href="https://www.ut.ee/~unruh/">Dominique Unruh</a>
	and <a href="https://josephcmac.github.io/">Jose Manuel Rodriguez Caballero</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-27: <a href="entries/Attack_Trees.html">Attack Trees in Isabelle for GDPR compliance of IoT healthcare systems</a>
	<br>
	Author:
	<a href="http://www.cs.mdx.ac.uk/people/florian-kammueller/">Florian Kammueller</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-24: <a href="entries/Power_Sum_Polynomials.html">Power Sum Polynomials</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-24: <a href="entries/Lambert_W.html">The Lambert W Function on the Reals</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-24: <a href="entries/Gaussian_Integers.html">Gaussian Integers</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-19: <a href="entries/Matrices_for_ODEs.html">Matrices for ODEs</a>
	<br>
	Author:
	Jonathan Julian Huerta y Munive
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-16: <a href="entries/ADS_Functor.html">Authenticated Data Structures As Functors</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and Ognjen Marić
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-10: <a href="entries/Sliding_Window_Algorithm.html">Formalization of an Algorithm for Greedily Computing Associative Aggregations on Sliding Windows</a>
	<br>
	Authors:
	Lukas Heimes,
	<a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	and Joshua Schneider
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-09: <a href="entries/Saturation_Framework.html">A Comprehensive Framework for Saturation Theorem Proving</a>
	<br>
	Author:
	<a href="https://www.mpi-inf.mpg.de/departments/automation-of-logic/people/sophie-tourret">Sophie Tourret</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-09: <a href="entries/MFODL_Monitor_Optimized.html">Formalization of an Optimized Monitoring Algorithm for Metric First-Order Dynamic Logic with Aggregations</a>
	<br>
	Authors:
	Thibault Dardinier,
	Lukas Heimes,
	Martin Raszyk,
	Joshua Schneider
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-08: <a href="entries/Stateful_Protocol_Composition_and_Typing.html">Stateful Protocol Composition and Typing</a>
	<br>
	Authors:
	Andreas V. Hess,
	<a href="https://people.compute.dtu.dk/samo/">Sebastian Mödersheim</a>
	and <a href="https://www.brucker.ch">Achim D. Brucker</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-08: <a href="entries/Automated_Stateful_Protocol_Verification.html">Automated Stateful Protocol Verification</a>
	<br>
	Authors:
	Andreas V. Hess,
	<a href="https://people.compute.dtu.dk/samo/">Sebastian Mödersheim</a>,
	<a href="https://www.brucker.ch">Achim D. Brucker</a>
	and <a href="https://people.compute.dtu.dk/andschl/">Anders Schlichtkrull</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-04-07: <a href="entries/Lucas_Theorem.html">Lucas's Theorem</a>
	<br>
	Author:
	<a href="https://www.cst.cam.ac.uk/people/cle47">Chelsea Edmonds</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-03-25: <a href="entries/WOOT_Strong_Eventual_Consistency.html">Strong Eventual Consistency of the Collaborative Editing Framework WOOT</a>
	<br>
	Authors:
	<a href="https://orcid.org/0000-0003-3290-5034">Emin Karayel</a>
	and Edgar Gonzàlez
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-03-22: <a href="entries/Furstenberg_Topology.html">Furstenberg's topology and his proof of the infinitude of primes</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-03-12: <a href="entries/Relational-Incorrectness-Logic.html">An Under-Approximate Relational Logic</a>
	<br>
	Author:
	<a href="https://people.eng.unimelb.edu.au/tobym/">Toby Murray</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-03-07: <a href="entries/Hello_World.html">Hello World</a>
	<br>
	Authors:
	<a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>
	and <a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-02-21: <a href="entries/Goodstein_Lambda.html">Implementing the Goodstein Function in λ-Calculus</a>
	<br>
	Author:
	Bertram Felgenhauer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-02-10: <a href="entries/VeriComp.html">A Generic Framework for Verified Compilers</a>
	<br>
	Author:
	<a href="https://martin.desharnais.me">Martin Desharnais</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-02-01: <a href="entries/Arith_Prog_Rel_Primes.html">Arithmetic progressions and relative primes</a>
	<br>
	Author:
	<a href="https://josephcmac.github.io/">José Manuel Rodríguez Caballero</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-01-31: <a href="entries/Subset_Boolean_Algebras.html">A Hierarchy of Algebras for Boolean Subsets</a>
	<br>
	Authors:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	and <a href="https://www.informatik.uni-augsburg.de/en/chairs/dbis/pmi/staff/moeller/">Bernhard Möller</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-01-17: <a href="entries/Mersenne_Primes.html">Mersenne primes and the Lucas–Lehmer test</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-01-16: <a href="entries/Approximation_Algorithms.html">Verified Approximation Algorithms</a>
	<br>
	Authors:
	Robin Eßmann,
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>,
	<a href="https://simon-robillard.net/">Simon Robillard</a>
	and Ujkan Sulejmani
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-01-13: <a href="entries/Closest_Pair_Points.html">Closest Pair of Points Algorithms</a>
	<br>
	Authors:
	Martin Rau
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-01-09: <a href="entries/Skip_Lists.html">Skip Lists</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Max W. Haslbeck</a>
	and <a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2020-01-06: <a href="entries/Bicategory.html">Bicategories</a>
	<br>
	Author:
	Eugene W. Stark
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2019</td>
	</tr>
	<tr>
	<td class="entry">
	2019-12-27: <a href="entries/Zeta_3_Irrational.html">The Irrationality of ζ(3)</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-12-20: <a href="entries/Hybrid_Logic.html">Formalizing a Seligman-Style Tableau System for Hybrid Logic</a>
	<br>
	Author:
	<a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-12-18: <a href="entries/Poincare_Bendixson.html">The Poincaré-Bendixson Theorem</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	and <a href="https://www.cs.cmu.edu/~yongkiat/">Yong Kiam Tan</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-12-16: <a href="entries/Poincare_Disc.html">Poincaré Disc Model</a>
	<br>
	Authors:
	<a href="http://poincare.matf.bg.ac.rs/~danijela">Danijela Simić</a>,
	Filip Marić
	and Pierre Boutry
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-12-16: <a href="entries/Complex_Geometry.html">Complex Geometry</a>
	<br>
	Authors:
	Filip Marić
	and <a href="http://poincare.matf.bg.ac.rs/~danijela">Danijela Simić</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-12-10: <a href="entries/Gauss_Sums.html">Gauss Sums and the Pólya–Vinogradov Inequality</a>
	<br>
	Authors:
	<a href="https://people.epfl.ch/rodrigo.raya">Rodrigo Raya</a>
	and <a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-12-04: <a href="entries/Generalized_Counting_Sort.html">An Efficient Generalization of Counting Sort for Large, possibly Infinite Key Ranges</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-11-27: <a href="entries/Interval_Arithmetic_Word32.html">Interval Arithmetic on 32-bit Words</a>
	<br>
	Author:
	Brandon Bohrer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-10-24: <a href="entries/ZFC_in_HOL.html">Zermelo Fraenkel Set Theory in Higher-Order Logic</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-10-22: <a href="entries/Isabelle_C.html">Isabelle/C</a>
	<br>
	Authors:
	<a href="https://www.lri.fr/~ftuong/">Frédéric Tuong</a>
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-10-16: <a href="entries/VerifyThis2019.html">VerifyThis 2019 -- Polished Isabelle Solutions</a>
	<br>
	Authors:
	Peter Lammich
	and <a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-10-08: <a href="entries/Aristotles_Assertoric_Syllogistic.html">Aristotle's Assertoric Syllogistic</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-10-07: <a href="entries/Sigma_Commit_Crypto.html">Sigma Protocols and Commitment Schemes</a>
	<br>
	Authors:
	<a href="https://www.turing.ac.uk/people/doctoral-students/david-butler">David Butler</a>
	and <a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-10-04: <a href="entries/Clean.html">Clean - An Abstract Imperative Programming Language and its Theory</a>
	<br>
	Authors:
	<a href="https://www.lri.fr/~ftuong/">Frédéric Tuong</a>
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-09-16: <a href="entries/Generic_Join.html">Formalization of Multiway-Join Algorithms</a>
	<br>
	Author:
	Thibault Dardinier
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-09-10: <a href="entries/Hybrid_Systems_VCs.html">Verification Components for Hybrid Systems</a>
	<br>
	Author:
	Jonathan Julian Huerta y Munive
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-09-06: <a href="entries/Fourier.html">Fourier Series</a>
	<br>
	Author:
	- <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C Paulson</a>
	+ Lawrence C Paulson
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-08-30: <a href="entries/Jacobson_Basic_Algebra.html">A Case Study in Basic Algebra</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~ballarin/">Clemens Ballarin</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-08-16: <a href="entries/Adaptive_State_Counting.html">Formalisation of an Adaptive State Counting Algorithm</a>
	<br>
	Author:
	Robert Sachtleben
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-08-14: <a href="entries/Laplace_Transform.html">Laplace Transform</a>
	<br>
	Author:
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-08-06: <a href="entries/Linear_Programming.html">Linear Programming</a>
	<br>
	Authors:
	<a href="http://www.parsert.com/">Julian Parsert</a>
	and <a href="http://cl-informatik.uibk.ac.at/cek/">Cezary Kaliszyk</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-08-06: <a href="entries/C2KA_DistributedSystems.html">Communicating Concurrent Kleene Algebra for Distributed Systems Specification</a>
	<br>
	Authors:
	Maxime Buyse
	and <a href="https://carleton.ca/jaskolka/">Jason Jaskolka</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-08-05: <a href="entries/IMO2019.html">Selected Problems from the International Mathematical Olympiad 2019</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-08-01: <a href="entries/Stellar_Quorums.html">Stellar Quorum Systems</a>
	<br>
	Author:
	Giuliano Losa
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-07-30: <a href="entries/TESL_Language.html">A Formal Development of a Polychronous Polytimed Coordination Language</a>
	<br>
	Authors:
	Hai Nguyen Van,
	Frédéric Boulanger
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-07-27: <a href="entries/Szpilrajn.html">Order Extension and Szpilrajn's Extension Theorem</a>
	<br>
	Authors:
	Peter Zeller
	and <a href="https://www21.in.tum.de/team/stevensl">Lukas Stevens</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-07-18: <a href="entries/FOL_Seq_Calc1.html">A Sequent Calculus for First-Order Logic</a>
	<br>
	Author:
	<a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-07-08: <a href="entries/CakeML_Codegen.html">A Verified Code Generator from Isabelle/HOL to CakeML</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-07-04: <a href="entries/MFOTL_Monitor.html">Formalization of a Monitoring Algorithm for Metric First-Order Temporal Logic</a>
	<br>
	Authors:
	Joshua Schneider
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-27: <a href="entries/Complete_Non_Orders.html">Complete Non-Orders and Fixed Points</a>
	<br>
	Authors:
	Akihisa Yamada
	and <a href="http://group-mmm.org/~dubut/">Jérémy Dubut</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-25: <a href="entries/Priority_Search_Trees.html">Priority Search Trees</a>
	<br>
	Authors:
	Peter Lammich
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-25: <a href="entries/Prim_Dijkstra_Simple.html">Purely Functional, Simple, and Efficient Implementation of Prim and Dijkstra</a>
	<br>
	Authors:
	Peter Lammich
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-21: <a href="entries/Linear_Inequalities.html">Linear Inequalities</a>
	<br>
	Authors:
	Ralph Bottesch,
	Alban Reynaud
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-16: <a href="entries/Nullstellensatz.html">Hilbert's Nullstellensatz</a>
	<br>
	Author:
	<a href="https://risc.jku.at/m/alexander-maletzky/">Alexander Maletzky</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-15: <a href="entries/Groebner_Macaulay.html">Gröbner Bases, Macaulay Matrices and Dubé's Degree Bounds</a>
	<br>
	Author:
	<a href="https://risc.jku.at/m/alexander-maletzky/">Alexander Maletzky</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-13: <a href="entries/IMP2_Binary_Heap.html">Binary Heaps for IMP2</a>
	<br>
	Author:
	Simon Griebel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-06-03: <a href="entries/Differential_Game_Logic.html">Differential Game Logic</a>
	<br>
	Author:
	André Platzer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-05-30: <a href="entries/KD_Tree.html">Multidimensional Binary Search Trees</a>
	<br>
	Author:
	Martin Rau
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-05-14: <a href="entries/LambdaAuth.html">Formalization of Generic Authenticated Data Structures</a>
	<br>
	Authors:
	Matthias Brun
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-05-09: <a href="entries/Multi_Party_Computation.html">Multi-Party Computation</a>
	<br>
	Authors:
	<a href="http://homepages.inf.ed.ac.uk/da/">David Aspinall</a>
	and <a href="https://www.turing.ac.uk/people/doctoral-students/david-butler">David Butler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-04-26: <a href="entries/HOL-CSP.html">HOL-CSP Version 2.0</a>
	<br>
	Authors:
	Safouan Taha,
	Lina Ye
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-04-16: <a href="entries/LTL_Master_Theorem.html">A Compositional and Unified Translation of LTL into ω-Automata</a>
	<br>
	Authors:
	Benedikt Seidl
	and Salomon Sickert
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-04-06: <a href="entries/Binding_Syntax_Theory.html">A General Theory of Syntax with Bindings</a>
	<br>
	Authors:
	Lorenzo Gheri
	and <a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-03-27: <a href="entries/Transcendence_Series_Hancl_Rucki.html">The Transcendence of Certain Infinite Series</a>
	<br>
	Authors:
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	and <a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-03-24: <a href="entries/QHLProver.html">Quantum Hoare Logic</a>
	<br>
	Authors:
	Junyi Liu,
	<a href="http://lcs.ios.ac.cn/~bzhan/">Bohua Zhan</a>,
	Shuling Wang,
	Shenggang Ying,
	Tao Liu,
	Yangjia Li,
	Mingsheng Ying
	and Naijun Zhan
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-03-09: <a href="entries/Safe_OCL.html">Safe OCL</a>
	<br>
	Author:
	Denis Nikiforov
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-02-21: <a href="entries/Prime_Distribution_Elementary.html">Elementary Facts About the Distribution of Primes</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-02-14: <a href="entries/Kruskal.html">Kruskal's Algorithm for Minimum Spanning Forest</a>
	<br>
	Authors:
	<a href="http://in.tum.de/~haslbema/">Maximilian P.L. Haslbeck</a>,
	Peter Lammich
	and Julian Biendarra
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-02-11: <a href="entries/Probabilistic_Prime_Tests.html">Probabilistic Primality Testing</a>
	<br>
	Authors:
	Daniel Stüwe
	and <a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-02-08: <a href="entries/Universal_Turing_Machine.html">Universal Turing Machine</a>
	<br>
	Authors:
	Jian Xu,
	Xingyuan Zhang,
	<a href="http://www.inf.kcl.ac.uk/staff/urbanc/">Christian Urban</a>
	and Sebastiaan J. C. Joosten
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-02-01: <a href="entries/UTP.html">Isabelle/UTP: Mechanised Theory Engineering for Unifying Theories of Programming</a>
	<br>
	Authors:
	<a href="https://www-users.cs.york.ac.uk/~simonf/">Simon Foster</a>,
	Frank Zeyda,
	Yakoub Nemouchi,
	Pedro Ribeiro
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-02-01: <a href="entries/List_Inversions.html">The Inversions of a List</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-01-17: <a href="entries/Farkas.html">Farkas' Lemma and Motzkin's Transposition Theorem</a>
	<br>
	Authors:
	Ralph Bottesch,
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Max W. Haslbeck</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-01-15: <a href="entries/IMP2.html">IMP2 – Simple Program Verification in Isabelle/HOL</a>
	<br>
	Authors:
	Peter Lammich
	and <a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-01-15: <a href="entries/Higher_Order_Terms.html">An Algebra for Higher-Order Terms</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2019-01-07: <a href="entries/Store_Buffer_Reduction.html">A Reduction Theorem for Store Buffers</a>
	<br>
	Authors:
	Ernie Cohen
	and Norbert Schirmer
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2018</td>
	</tr>
	<tr>
	<td class="entry">
	2018-12-26: <a href="entries/Core_DOM.html">A Formal Model of the Document Object Model</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>
	and <a href="http://www.dcs.shef.ac.uk/cgi-bin/makeperson?M.Herzberg">Michael Herzberg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-12-25: <a href="entries/Concurrent_Revisions.html">Formalization of Concurrent Revisions</a>
	<br>
	Author:
	Roy Overbeek
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-12-21: <a href="entries/Auto2_Imperative_HOL.html">Verifying Imperative Programs using Auto2</a>
	<br>
	Author:
	<a href="http://lcs.ios.ac.cn/~bzhan/">Bohua Zhan</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-12-17: <a href="entries/Constructive_Cryptography.html">Constructive Cryptography in HOL</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and S. Reza Sefidgar
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-12-11: <a href="entries/Transformer_Semantics.html">Transformer Semantics</a>
	<br>
	Author:
	<a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-12-11: <a href="entries/Quantales.html">Quantales</a>
	<br>
	Author:
	<a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-12-11: <a href="entries/Order_Lattice_Props.html">Properties of Orderings and Lattices</a>
	<br>
	Author:
	<a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-11-23: <a href="entries/Graph_Saturation.html">Graph Saturation</a>
	<br>
	Author:
	Sebastiaan J. C. Joosten
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-11-23: <a href="entries/Functional_Ordered_Resolution_Prover.html">A Verified Functional Implementation of Bachmair and Ganzinger's Ordered Resolution Prover</a>
	<br>
	Authors:
	<a href="https://people.compute.dtu.dk/andschl/">Anders Schlichtkrull</a>,
	Jasmin Christian Blanchette
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-11-20: <a href="entries/Auto2_HOL.html">Auto2 Prover</a>
	<br>
	Author:
	<a href="http://lcs.ios.ac.cn/~bzhan/">Bohua Zhan</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-11-16: <a href="entries/Matroids.html">Matroids</a>
	<br>
	Author:
	Jonas Keinholz
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-11-06: <a href="entries/Generic_Deriving.html">Deriving generic class instances for datatypes</a>
	<br>
	Authors:
	Jonas Rädle
	and <a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-10-30: <a href="entries/GewirthPGCProof.html">Formalisation and Evaluation of Alan Gewirth's Proof for the Principle of Generic Consistency in Isabelle/HOL</a>
	<br>
	Authors:
	David Fuenmayor
	and <a href="http://christoph-benzmueller.de">Christoph Benzmüller</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-10-29: <a href="entries/Epistemic_Logic.html">Epistemic Logic: Completeness of Modal Logics</a>
	<br>
	Author:
	<a href="https://people.compute.dtu.dk/ahfrom/">Asta Halkjær From</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-10-22: <a href="entries/Smooth_Manifolds.html">Smooth Manifolds</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	and <a href="http://lcs.ios.ac.cn/~bzhan/">Bohua Zhan</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-10-19: <a href="entries/Randomised_BSTs.html">Randomised Binary Search Trees</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-10-19: <a href="entries/Lambda_Free_EPO.html">Formalization of the Embedding Path Order for Lambda-Free Higher-Order Terms</a>
	<br>
	Author:
	Alexander Bentkamp
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-10-12: <a href="entries/Factored_Transition_System_Bounding.html">Upper Bounding Diameters of State Spaces of Factored Transition Systems</a>
	<br>
	Authors:
	Friedrich Kurz
	and <a href="http://home.in.tum.de/~mansour/">Mohammad Abdulaziz</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-28: <a href="entries/Pi_Transcendental.html">The Transcendence of π</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-25: <a href="entries/Symmetric_Polynomials.html">Symmetric Polynomials</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-20: <a href="entries/Signature_Groebner.html">Signature-Based Gröbner Basis Algorithms</a>
	<br>
	Author:
	<a href="https://risc.jku.at/m/alexander-maletzky/">Alexander Maletzky</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-19: <a href="entries/Prime_Number_Theorem.html">The Prime Number Theorem</a>
	<br>
	Authors:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-15: <a href="entries/Aggregation_Algebras.html">Aggregation Algebras</a>
	<br>
	Author:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-14: <a href="entries/Octonions.html">Octonions</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-05: <a href="entries/Quaternions.html">Quaternions</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-09-02: <a href="entries/Budan_Fourier.html">The Budan-Fourier Theorem and Counting Real Roots with Multiplicity</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-08-24: <a href="entries/Simplex.html">An Incremental Simplex Algorithm with Unsatisfiable Core Generation</a>
	<br>
	Authors:
	Filip Marić,
	Mirko Spasić
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-08-14: <a href="entries/Minsky_Machines.html">Minsky Machines</a>
	<br>
	Author:
	Bertram Felgenhauer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-07-16: <a href="entries/DiscretePricing.html">Pricing in discrete financial models</a>
	<br>
	Author:
	Mnacho Echenim
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-07-04: <a href="entries/Neumann_Morgenstern_Utility.html">Von-Neumann-Morgenstern Utility Theorem</a>
	<br>
	Authors:
	<a href="http://www.parsert.com/">Julian Parsert</a>
	and <a href="http://cl-informatik.uibk.ac.at/cek/">Cezary Kaliszyk</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-06-23: <a href="entries/Pell.html">Pell's Equation</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-06-14: <a href="entries/Projective_Geometry.html">Projective Geometry</a>
	<br>
	Author:
	<a href="https://sites.google.com/site/anthonybordg/">Anthony Bordg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-06-14: <a href="entries/Localization_Ring.html">The Localization of a Commutative Ring</a>
	<br>
	Author:
	<a href="https://sites.google.com/site/anthonybordg/">Anthony Bordg</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-06-05: <a href="entries/Partial_Order_Reduction.html">Partial Order Reduction</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~brunnerj/">Julian Brunner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-27: <a href="entries/Optimal_BST.html">Optimal Binary Search Trees</a>
	<br>
	Authors:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	and Dániel Somogyi
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-25: <a href="entries/Hidden_Markov_Models.html">Hidden Markov Models</a>
	<br>
	Author:
	<a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-24: <a href="entries/Probabilistic_Timed_Automata.html">Probabilistic Timed Automata</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	and <a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-23: <a href="entries/Irrationality_J_Hancl.html">Irrational Rapidly Convergent Series</a>
	<br>
	Authors:
	<a href="https://www.cl.cam.ac.uk/~ak2110/">Angeliki Koutsoukou-Argyraki</a>
	and <a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-23: <a href="entries/AxiomaticCategoryTheory.html">Axiom Systems for Category Theory in Free Logic</a>
	<br>
	Authors:
	<a href="http://christoph-benzmueller.de">Christoph Benzmüller</a>
	and <a href="http://www.cs.cmu.edu/~scott/">Dana Scott</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-22: <a href="entries/Monad_Memo_DP.html">Monadification, Memoization and Dynamic Programming</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>,
	Shuwei Hu
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-10: <a href="entries/OpSets.html">OpSets: Sequential Specifications for Replicated Datatypes</a>
	<br>
	Authors:
	Martin Kleppmann,
	Victor B. F. Gomes,
	Dominic P. Mulligan
	and Alastair R. Beresford
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-05-07: <a href="entries/Modular_Assembly_Kit_Security.html">An Isabelle/HOL Formalization of the Modular Assembly Kit for Security Properties</a>
	<br>
	Authors:
	Oliver Bračevac,
	Richard Gay,
	Sylvia Grewe,
	Heiko Mantel,
	Henning Sudbrock
	and Markus Tasch
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-04-29: <a href="entries/WebAssembly.html">WebAssembly</a>
	<br>
	Author:
	<a href="http://www.cl.cam.ac.uk/~caw77/">Conrad Watt</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-04-27: <a href="entries/VerifyThis2018.html">VerifyThis 2018 - Polished Isabelle Solutions</a>
	<br>
	Authors:
	Peter Lammich
	and <a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-04-24: <a href="entries/BNF_CC.html">Bounded Natural Functors with Covariance and Contravariance</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and Joshua Schneider
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-03-22: <a href="entries/Fishburn_Impossibility.html">The Incompatibility of Fishburn-Strategyproofness and Pareto-Efficiency</a>
	<br>
	Authors:
	<a href="http://dss.in.tum.de/staff/brandt.html">Felix Brandt</a>,
	<a href="https://pruvisto.org">Manuel Eberl</a>,
	<a href="http://dss.in.tum.de/staff/christian-saile.html">Christian Saile</a>
	and <a href="http://dss.in.tum.de/staff/christian-stricker.html">Christian Stricker</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-03-13: <a href="entries/Weight_Balanced_Trees.html">Weight-Balanced Trees</a>
	<br>
	Authors:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	and Stefan Dirix
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-03-12: <a href="entries/CakeML.html">CakeML</a>
	<br>
	Authors:
	<a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	and Yu Zhang
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-03-01: <a href="entries/Architectural_Design_Patterns.html">A Theory of Architectural Design Patterns</a>
	<br>
	Author:
	<a href="http://marmsoler.com">Diego Marmsoler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-26: <a href="entries/Hoare_Time.html">Hoare Logics for Time Bounds</a>
	<br>
	Authors:
	<a href="http://www.in.tum.de/~haslbema">Maximilian P. L. Haslbeck</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-06: <a href="entries/Treaps.html">Treaps</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	<a href="https://pruvisto.org">Manuel Eberl</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-06: <a href="entries/LLL_Factorization.html">A verified factorization algorithm for integer polynomials with polynomial complexity</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-06: <a href="entries/First_Order_Terms.html">First-Order Terms</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-06: <a href="entries/Error_Function.html">The Error Function</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-02: <a href="entries/LLL_Basis_Reduction.html">A verified LLL algorithm</a>
	<br>
	Authors:
	Ralph Bottesch,
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-01-18: <a href="entries/Ordered_Resolution_Prover.html">Formalization of Bachmair and Ganzinger's Ordered Resolution Prover</a>
	<br>
	Authors:
	<a href="https://people.compute.dtu.dk/andschl/">Anders Schlichtkrull</a>,
	Jasmin Christian Blanchette,
	<a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	and Uwe Waldmann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-01-16: <a href="entries/Gromov_Hyperbolicity.html">Gromov Hyperbolicity</a>
	<br>
	Author:
	Sebastien Gouezel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-01-11: <a href="entries/Green.html">An Isabelle/HOL formalisation of Green's Theorem</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~mansour/">Mohammad Abdulaziz</a>
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-01-08: <a href="entries/Taylor_Models.html">Taylor Models</a>
	<br>
	Authors:
	Christoph Traut
	and <a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2017</td>
	</tr>
	<tr>
	<td class="entry">
	2017-12-22: <a href="entries/Falling_Factorial_Sum.html">The Falling Factorial of a Sum</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-12-21: <a href="entries/Median_Of_Medians_Selection.html">The Median-of-Medians Selection Algorithm</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-12-21: <a href="entries/Mason_Stothers.html">The Mason–Stothers Theorem</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-12-21: <a href="entries/Dirichlet_L.html">Dirichlet L-Functions and Dirichlet's Theorem</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-12-19: <a href="entries/BNF_Operations.html">Operations on Bounded Natural Functors</a>
	<br>
	Authors:
	Jasmin Christian Blanchette,
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-12-18: <a href="entries/Knuth_Morris_Pratt.html">The string search algorithm by Knuth, Morris and Pratt</a>
	<br>
	Authors:
	Fabian Hellauer
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-11-22: <a href="entries/Stochastic_Matrices.html">Stochastic Matrices and the Perron-Frobenius Theorem</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-11-09: <a href="entries/IMAP-CRDT.html">The IMAP CmRDT</a>
	<br>
	Authors:
	Tim Jungnickel,
	Lennart Oldenburg
	and Matthias Loibl
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-11-06: <a href="entries/Hybrid_Multi_Lane_Spatial_Logic.html">Hybrid Multi-Lane Spatial Logic</a>
	<br>
	Author:
	Sven Linker
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-26: <a href="entries/Kuratowski_Closure_Complement.html">The Kuratowski Closure-Complement Theorem</a>
	<br>
	Authors:
	<a href="http://peteg.org">Peter Gammie</a>
	and Gianpaolo Gioiosa
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-19: <a href="entries/Transition_Systems_and_Automata.html">Transition Systems and Automata</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~brunnerj/">Julian Brunner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-19: <a href="entries/Buchi_Complementation.html">Büchi Complementation</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~brunnerj/">Julian Brunner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-17: <a href="entries/Winding_Number_Eval.html">Evaluate Winding Numbers through Cauchy Indices</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-17: <a href="entries/Count_Complex_Roots.html">Count the Number of Complex Roots</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-14: <a href="entries/Diophantine_Eqns_Lin_Hom.html">Homogeneous Linear Diophantine Equations</a>
	<br>
	Authors:
	Florian Messner,
	<a href="http://www.parsert.com/">Julian Parsert</a>,
	Jonas Schöpf
	and <a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-12: <a href="entries/Zeta_Function.html">The Hurwitz and Riemann ζ Functions</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-12: <a href="entries/Linear_Recurrences.html">Linear Recurrences</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-10-12: <a href="entries/Dirichlet_Series.html">Dirichlet Series</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-09-21: <a href="entries/Lowe_Ontological_Argument.html">Computer-assisted Reconstruction and Assessment of E. J. Lowe's Modal Ontological Argument</a>
	<br>
	Authors:
	David Fuenmayor
	and <a href="http://christoph-benzmueller.de">Christoph Benzmüller</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-09-17: <a href="entries/PLM.html">Representation and Partial Automation of the Principia Logico-Metaphysica in Isabelle/HOL</a>
	<br>
	Author:
	Daniel Kirchner
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-09-06: <a href="entries/AnselmGod.html">Anselm's God in Isabelle/HOL</a>
	<br>
	Author:
	<a href="https://philpeople.org/profiles/ben-blumson">Ben Blumson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-09-01: <a href="entries/First_Welfare_Theorem.html">Microeconomics and the First Welfare Theorem</a>
	<br>
	Authors:
	<a href="http://www.parsert.com/">Julian Parsert</a>
	and <a href="http://cl-informatik.uibk.ac.at/cek/">Cezary Kaliszyk</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-08-20: <a href="entries/Root_Balanced_Tree.html">Root-Balanced Tree</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-08-20: <a href="entries/Orbit_Stabiliser.html">Orbit-Stabiliser Theorem with Application to Rotational Symmetries</a>
	<br>
	Author:
	Jonas Rädle
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-08-16: <a href="entries/LambdaMu.html">The LambdaMu-calculus</a>
	<br>
	Authors:
	Cristina Matache,
	Victor B. F. Gomes
	and Dominic P. Mulligan
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-31: <a href="entries/Stewart_Apollonius.html">Stewart's Theorem and Apollonius' Theorem</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-28: <a href="entries/DynamicArchitectures.html">Dynamic Architectures</a>
	<br>
	Author:
	<a href="http://marmsoler.com">Diego Marmsoler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-21: <a href="entries/Decl_Sem_Fun_PL.html">Declarative Semantics for Functional Languages</a>
	<br>
	Author:
	<a href="http://homes.soic.indiana.edu/jsiek/">Jeremy Siek</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-15: <a href="entries/HOLCF-Prelude.html">HOLCF-Prelude</a>
	<br>
	Authors:
	Joachim Breitner,
	Brian Huffman,
	Neil Mitchell
	and <a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-13: <a href="entries/Minkowskis_Theorem.html">Minkowski's Theorem</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-09: <a href="entries/Name_Carrying_Type_Inference.html">Verified Metatheory and Type Inference for a Name-Carrying Simply-Typed Lambda Calculus</a>
	<br>
	Author:
	Michael Rawson
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-07: <a href="entries/CRDT.html">A framework for establishing Strong Eventual Consistency for Conflict-free Replicated Datatypes</a>
	<br>
	Authors:
	Victor B. F. Gomes,
	Martin Kleppmann,
	Dominic P. Mulligan
	and Alastair R. Beresford
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-06: <a href="entries/Stone_Kleene_Relation_Algebras.html">Stone-Kleene Relation Algebras</a>
	<br>
	Author:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-06-21: <a href="entries/Propositional_Proof_Systems.html">Propositional Proof Systems</a>
	<br>
	Authors:
	<a href="http://liftm.de/">Julius Michaelis</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-06-13: <a href="entries/PSemigroupsConvolution.html">Partial Semigroups and Convolution Algebras</a>
	<br>
	Authors:
	Brijesh Dongol,
	Victor B. F. Gomes,
	Ian J. Hayes
	and <a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-06-06: <a href="entries/Buffons_Needle.html">Buffon's Needle Problem</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-06-01: <a href="entries/Prpu_Maxflow.html">Formalizing Push-Relabel Algorithms</a>
	<br>
	Authors:
	Peter Lammich
	and S. Reza Sefidgar
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-06-01: <a href="entries/Flow_Networks.html">Flow Networks and the Min-Cut-Max-Flow Theorem</a>
	<br>
	Authors:
	Peter Lammich
	and S. Reza Sefidgar
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-25: <a href="entries/Optics.html">Optics</a>
	<br>
	Authors:
	<a href="https://www-users.cs.york.ac.uk/~simonf/">Simon Foster</a>
	and Frank Zeyda
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-24: <a href="entries/Security_Protocol_Refinement.html">Developing Security Protocols by Refinement</a>
	<br>
	Authors:
	Christoph Sprenger
	and Ivano Somaini
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-24: <a href="entries/Dict_Construction.html">Dictionary Construction</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-08: <a href="entries/Floyd_Warshall.html">The Floyd-Warshall Algorithm for Shortest Paths</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-05: <a href="entries/Probabilistic_While.html">Probabilistic while loop</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-05: <a href="entries/Monomorphic_Monad.html">Effect polymorphism in higher-order logic</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-05: <a href="entries/Monad_Normalisation.html">Monad normalisation</a>
	<br>
	Authors:
	Joshua Schneider,
	<a href="https://pruvisto.org">Manuel Eberl</a>
	and <a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-05: <a href="entries/Game_Based_Crypto.html">Game-based cryptography in HOL</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>,
	S. Reza Sefidgar
	and Bhargav Bhatt
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-05: <a href="entries/CryptHOL.html">CryptHOL</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-04: <a href="entries/MonoidalCategory.html">Monoidal Categories</a>
	<br>
	Author:
	Eugene W. Stark
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-05-01: <a href="entries/Types_Tableaus_and_Goedels_God.html">Types, Tableaus and Gödel’s God in Isabelle/HOL</a>
	<br>
	Authors:
	David Fuenmayor
	and <a href="http://christoph-benzmueller.de">Christoph Benzmüller</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-04-28: <a href="entries/LocalLexing.html">Local Lexing</a>
	<br>
	Author:
	Steven Obua
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-04-19: <a href="entries/Constructor_Funs.html">Constructor Functions</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-04-18: <a href="entries/Lazy_Case.html">Lazifying case constants</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-04-06: <a href="entries/Subresultants.html">Subresultants</a>
	<br>
	Authors:
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-04-04: <a href="entries/Random_BSTs.html">Expected Shape of Random Binary Search Trees</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-03-15: <a href="entries/Quick_Sort_Cost.html">The number of comparisons in QuickSort</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-03-15: <a href="entries/Comparison_Sort_Lower_Bound.html">Lower bound on comparison-based sorting algorithms</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-03-10: <a href="entries/Euler_MacLaurin.html">The Euler–MacLaurin Formula</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-02-28: <a href="entries/Elliptic_Curves_Group_Law.html">The Group Law for Elliptic Curves</a>
	<br>
	Author:
	<a href="http://www.in.tum.de/~berghofe">Stefan Berghofer</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-02-26: <a href="entries/Menger.html">Menger's Theorem</a>
	<br>
	Author:
	<a href="http://logic.las.tu-berlin.de/Members/Dittmann/">Christoph Dittmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-02-13: <a href="entries/Differential_Dynamic_Logic.html">Differential Dynamic Logic</a>
	<br>
	Author:
	Brandon Bohrer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-02-10: <a href="entries/Abstract_Soundness.html">Abstract Soundness</a>
	<br>
	Authors:
	Jasmin Christian Blanchette,
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-02-07: <a href="entries/Stone_Relation_Algebras.html">Stone Relation Algebras</a>
	<br>
	Author:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-31: <a href="entries/Key_Agreement_Strong_Adversaries.html">Refining Authenticated Key Agreement with Strong Adversaries</a>
	<br>
	Authors:
	Joseph Lallemand
	and Christoph Sprenger
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-24: <a href="entries/Bernoulli.html">Bernoulli Numbers</a>
	<br>
	Authors:
	Lukas Bulwahn
	and <a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-17: <a href="entries/Minimal_SSA.html">Minimal Static Single Assignment Form</a>
	<br>
	Authors:
	Max Wagner
	and <a href="http://pp.ipd.kit.edu/person.php?id=88">Denis Lohner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-17: <a href="entries/Bertrands_Postulate.html">Bertrand's postulate</a>
	<br>
	Authors:
	Julian Biendarra
	and <a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-12: <a href="entries/E_Transcendental.html">The Transcendence of e</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-08: <a href="entries/UPF_Firewall.html">Formal Network Models and Their Application to Firewall Policies</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>,
	Lukas Brügger
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-03: <a href="entries/Password_Authentication_Protocol.html">Verification of a Diffie-Hellman Password-based Authentication Protocol by Extending the Inductive Method</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-01-01: <a href="entries/FOL_Harrison.html">First-Order Logic According to Harrison</a>
	<br>
	Authors:
	<a href="https://people.compute.dtu.dk/aleje/">Alexander Birch Jensen</a>,
	<a href="https://people.compute.dtu.dk/andschl/">Anders Schlichtkrull</a>
	and <a href="https://people.compute.dtu.dk/jovi/">Jørgen Villadsen</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2016</td>
	</tr>
	<tr>
	<td class="entry">
	2016-12-30: <a href="entries/Concurrent_Ref_Alg.html">Concurrent Refinement Algebra and Rely Quotients</a>
	<br>
	Authors:
	Julian Fell,
	Ian J. Hayes
	and <a href="http://andrius.velykis.lt">Andrius Velykis</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-12-29: <a href="entries/Twelvefold_Way.html">The Twelvefold Way</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-12-20: <a href="entries/Proof_Strategy_Language.html">Proof Strategy Language</a>
	<br>
	Author:
	Yutaka Nagashima
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-12-07: <a href="entries/Paraconsistency.html">Paraconsistency</a>
	<br>
	Authors:
	<a href="https://people.compute.dtu.dk/andschl/">Anders Schlichtkrull</a>
	and <a href="https://people.compute.dtu.dk/jovi/">Jørgen Villadsen</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-11-29: <a href="entries/Complx.html">COMPLX: A Verification Framework for Concurrent Imperative Programs</a>
	<br>
	Authors:
	Sidney Amani,
	June Andronick,
	Maksym Bortin,
	Corey Lewis,
	Christine Rizkallah
	and Joseph Tuong
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-11-23: <a href="entries/Abs_Int_ITP2012.html">Abstract Interpretation of Annotated Commands</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-11-16: <a href="entries/Separata.html">Separata: Isabelle tactics for Separation Algebra</a>
	<br>
	Authors:
	Zhe Hou,
	David Sanan,
	Alwen Tiu,
	Rajeev Gore
	and Ranald Clouston
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-11-12: <a href="entries/Nested_Multisets_Ordinals.html">Formalization of Nested Multisets, Hereditary Multisets, and Syntactic Ordinals</a>
	<br>
	Authors:
	Jasmin Christian Blanchette,
	<a href="http://fmv.jku.at/fleury">Mathias Fleury</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-11-12: <a href="entries/Lambda_Free_KBOs.html">Formalization of Knuth–Bendix Orders for Lambda-Free Higher-Order Terms</a>
	<br>
	Authors:
	Heiko Becker,
	Jasmin Christian Blanchette,
	Uwe Waldmann
	and Daniel Wand
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-11-10: <a href="entries/Deep_Learning.html">Expressiveness of Deep Learning</a>
	<br>
	Author:
	Alexander Bentkamp
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-25: <a href="entries/Modal_Logics_for_NTS.html">Modal Logics for Nominal Transition Systems</a>
	<br>
	Authors:
	Tjark Weber,
	Lars-Henrik Eriksson,
	Joachim Parrow,
	Johannes Borgström
	and Ramunas Gutkovas
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-24: <a href="entries/Stable_Matching.html">Stable Matching</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-21: <a href="entries/LOFT.html">LOFT — Verified Migration of Linux Firewalls to SDN</a>
	<br>
	Authors:
	<a href="http://liftm.de/">Julius Michaelis</a>
	and <a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-19: <a href="entries/Source_Coding_Theorem.html">Source Coding Theorem</a>
	<br>
	Authors:
	Quentin Hibon
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-19: <a href="entries/SPARCv8.html">A formal model for the SPARCv8 ISA and a proof of non-interference for the LEON3 processor</a>
	<br>
	Authors:
	Zhe Hou,
	David Sanan,
	Alwen Tiu
	and Yang Liu
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-14: <a href="entries/Berlekamp_Zassenhaus.html">The Factorization Algorithm of Berlekamp and Zassenhaus</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-11: <a href="entries/Chord_Segments.html">Intersecting Chords Theorem</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-10-05: <a href="entries/Lp.html">Lp spaces</a>
	<br>
	Author:
	Sebastien Gouezel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-09-30: <a href="entries/Fisher_Yates.html">Fisher–Yates shuffle</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-09-29: <a href="entries/Allen_Calculus.html">Allen's Interval Calculus</a>
	<br>
	Author:
	Fadoua Ghourabi
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-09-23: <a href="entries/Lambda_Free_RPOs.html">Formalization of Recursive Path Orders for Lambda-Free Higher-Order Terms</a>
	<br>
	Authors:
	Jasmin Christian Blanchette,
	Uwe Waldmann
	and Daniel Wand
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-09-09: <a href="entries/Iptables_Semantics.html">Iptables Semantics</a>
	<br>
	Authors:
	<a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>
	and <a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-09-06: <a href="entries/SuperCalc.html">A Variant of the Superposition Calculus</a>
	<br>
	Author:
	<a href="http://membres-lig.imag.fr/peltier/">Nicolas Peltier</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-09-06: <a href="entries/Stone_Algebras.html">Stone Algebras</a>
	<br>
	Author:
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-09-01: <a href="entries/Stirling_Formula.html">Stirling's formula</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-08-31: <a href="entries/Routing.html">Routing</a>
	<br>
	Authors:
	<a href="http://liftm.de/">Julius Michaelis</a>
	and <a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-08-24: <a href="entries/Simple_Firewall.html">Simple Firewall</a>
	<br>
	Authors:
	<a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>,
	<a href="http://liftm.de/">Julius Michaelis</a>
	and <a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-08-18: <a href="entries/InfPathElimination.html">Infeasible Paths Elimination by Symbolic Execution Techniques: Proof of Correctness and Preservation of Paths</a>
	<br>
	Authors:
	Romain Aissat,
	Frederic Voisin
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-08-12: <a href="entries/EdmondsKarp_Maxflow.html">Formalizing the Edmonds-Karp Algorithm</a>
	<br>
	Authors:
	Peter Lammich
	and S. Reza Sefidgar
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-08-08: <a href="entries/Refine_Imperative_HOL.html">The Imperative Refinement Framework</a>
	<br>
	Author:
	Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-08-07: <a href="entries/Ptolemys_Theorem.html">Ptolemy's Theorem</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-07-17: <a href="entries/Surprise_Paradox.html">Surprise Paradox</a>
	<br>
	Author:
	Joachim Breitner
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-07-14: <a href="entries/Pairing_Heap.html">Pairing Heap</a>
	<br>
	Authors:
	Hauke Brinkop
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-07-05: <a href="entries/DFS_Framework.html">A Framework for Verifying Depth-First Search Algorithms</a>
	<br>
	Authors:
	Peter Lammich
	and René Neumann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-07-01: <a href="entries/Buildings.html">Chamber Complexes, Coxeter Systems, and Buildings</a>
	<br>
	Author:
	<a href="http://ualberta.ca/~jsylvest/">Jeremy Sylvestre</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-30: <a href="entries/Rewriting_Z.html">The Z Property</a>
	<br>
	Authors:
	Bertram Felgenhauer,
	Julian Nagele,
	Vincent van Oostrom
	and <a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-30: <a href="entries/Resolution_FOL.html">The Resolution Calculus for First-Order Logic</a>
	<br>
	Author:
	<a href="https://people.compute.dtu.dk/andschl/">Anders Schlichtkrull</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-28: <a href="entries/IP_Addresses.html">IP Addresses</a>
	<br>
	Authors:
	<a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>,
	<a href="http://liftm.de/">Julius Michaelis</a>
	and <a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-28: <a href="entries/Dependent_SIFUM_Refinement.html">Compositional Security-Preserving Refinement for Concurrent Imperative Programs</a>
	<br>
	Authors:
	<a href="https://people.eng.unimelb.edu.au/tobym/">Toby Murray</a>,
	Robert Sison,
	Edward Pierzchalski
	and Christine Rizkallah
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-26: <a href="entries/Category3.html">Category Theory with Adjunctions and Limits</a>
	<br>
	Author:
	Eugene W. Stark
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-26: <a href="entries/Card_Multisets.html">Cardinality of Multisets</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-25: <a href="entries/Dependent_SIFUM_Type_Systems.html">A Dependent Security Type System for Concurrent Imperative Programs</a>
	<br>
	Authors:
	<a href="https://people.eng.unimelb.edu.au/tobym/">Toby Murray</a>,
	Robert Sison,
	Edward Pierzchalski
	and Christine Rizkallah
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-21: <a href="entries/Catalan_Numbers.html">Catalan Numbers</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-18: <a href="entries/Algebraic_VCs.html">Program Construction and Verification Components Based on Kleene Algebra</a>
	<br>
	Authors:
	Victor B. F. Gomes
	and <a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-13: <a href="entries/Noninterference_Concurrent_Composition.html">Conservation of CSP Noninterference Security under Concurrent Composition</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-06-09: <a href="entries/Word_Lib.html">Finite Machine Word Library</a>
	<br>
	Authors:
	Joel Beeren,
	Matthew Fernandez,
	Xin Gao,
	<a href="http://www.cse.unsw.edu.au/~kleing/">Gerwin Klein</a>,
	Rafal Kolanski,
	Japheth Lim,
	Corey Lewis,
	Daniel Matichuk
	and Thomas Sewell
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-31: <a href="entries/Tree_Decomposition.html">Tree Decomposition</a>
	<br>
	Author:
	<a href="http://logic.las.tu-berlin.de/Members/Dittmann/">Christoph Dittmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-24: <a href="entries/Posix-Lexing.html">POSIX Lexing with Derivatives of Regular Expressions</a>
	<br>
	Authors:
	<a href="http://kcl.academia.edu/FahadAusaf">Fahad Ausaf</a>,
	<a href="https://rd.host.cs.st-andrews.ac.uk">Roy Dyckhoff</a>
	and <a href="http://www.inf.kcl.ac.uk/staff/urbanc/">Christian Urban</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-24: <a href="entries/Card_Equiv_Relations.html">Cardinality of Equivalence Relations</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-20: <a href="entries/Perron_Frobenius.html">Perron-Frobenius Theorem for Spectral Radius Analysis</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="http://www21.in.tum.de/~kuncar/">Ondřej Kunčar</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-20: <a href="entries/Incredible_Proof_Machine.html">The meta theory of the Incredible Proof Machine</a>
	<br>
	Authors:
	Joachim Breitner
	and <a href="http://pp.ipd.kit.edu/person.php?id=88">Denis Lohner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-18: <a href="entries/FLP.html">A Constructive Proof for FLP</a>
	<br>
	Authors:
	Benjamin Bisping,
	Paul-David Brodmann,
	Tim Jungnickel,
	Christina Rickmann,
	Henning Seidler,
	Anke Stüber,
	Arno Wilhelm-Weidner,
	Kirstin Peters
	and <a href="https://www.mtv.tu-berlin.de/nestmann/">Uwe Nestmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-09: <a href="entries/MFMC_Countable.html">A Formal Proof of the Max-Flow Min-Cut Theorem for Countable Networks</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-05: <a href="entries/Randomised_Social_Choice.html">Randomised Social Choice Theory</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-04: <a href="entries/SDS_Impossibility.html">The Incompatibility of SD-Efficiency and SD-Strategy-Proofness</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-04: <a href="entries/Bell_Numbers_Spivey.html">Spivey's Generalized Recurrence for Bell Numbers</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-05-02: <a href="entries/Groebner_Bases.html">Gröbner Bases Theory</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	and <a href="https://risc.jku.at/m/alexander-maletzky/">Alexander Maletzky</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-04-28: <a href="entries/No_FTL_observers.html">No Faster-Than-Light Observers</a>
	<br>
	Authors:
	Mike Stannett
	and <a href="http://www.renyi.hu/~nemeti/">István Németi</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-04-27: <a href="entries/ROBDD.html">Algorithms for Reduced Ordered Binary Decision Diagrams</a>
	<br>
	Authors:
	<a href="http://liftm.de/">Julius Michaelis</a>,
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	Peter Lammich
	and <a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-04-27: <a href="entries/CYK.html">A formalisation of the Cocke-Younger-Kasami algorithm</a>
	<br>
	Author:
	Maksym Bortin
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-04-26: <a href="entries/Noninterference_Sequential_Composition.html">Conservation of CSP Noninterference Security under Sequential Composition</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-04-12: <a href="entries/KAD.html">Kleene Algebras with Domain</a>
	<br>
	Authors:
	Victor B. F. Gomes,
	<a href="https://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>,
	<a href="http://www.hoefner-online.de/">Peter Höfner</a>,
	<a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	and Tjark Weber
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-03-11: <a href="entries/PropResPI.html">Propositional Resolution and Prime Implicates Generation</a>
	<br>
	Author:
	<a href="http://membres-lig.imag.fr/peltier/">Nicolas Peltier</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-03-08: <a href="entries/Timed_Automata.html">Timed Automata</a>
	<br>
	Author:
	<a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-03-08: <a href="entries/Cartan_FP.html">The Cartan Fixed Point Theorems</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-03-01: <a href="entries/LTL.html">Linear Temporal Logic</a>
	<br>
	Author:
	Salomon Sickert
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-02-17: <a href="entries/List_Update.html">Analysis of List Update Algorithms</a>
	<br>
	Authors:
	<a href="http://in.tum.de/~haslbema/">Maximilian P.L. Haslbeck</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-02-05: <a href="entries/Formal_SSA.html">Verified Construction of Static Single Assignment Form</a>
	<br>
	Authors:
	Sebastian Ullrich
	and <a href="http://pp.ipd.kit.edu/person.php?id=88">Denis Lohner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-01-29: <a href="entries/Polynomial_Interpolation.html">Polynomial Interpolation</a>
	<br>
	Authors:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-01-29: <a href="entries/Polynomial_Factorization.html">Polynomial Factorization</a>
	<br>
	Authors:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-01-20: <a href="entries/Knot_Theory.html">Knot Theory</a>
	<br>
	Author:
	T.V.H. Prathamesh
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-01-18: <a href="entries/Matrix_Tensor.html">Tensor Product of Matrices</a>
	<br>
	Author:
	T.V.H. Prathamesh
	</td>
	</tr>
	<tr>
	<td class="entry">
	2016-01-14: <a href="entries/Card_Number_Partitions.html">Cardinality of Number Partitions</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2015</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-28: <a href="entries/Triangle.html">Basic Geometric Properties of Triangles</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-28: <a href="entries/Prime_Harmonic_Series.html">The Divergence of the Prime Harmonic Series</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-28: <a href="entries/Liouville_Numbers.html">Liouville numbers</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-28: <a href="entries/Descartes_Sign_Rule.html">Descartes' Rule of Signs</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-22: <a href="entries/Stern_Brocot.html">The Stern-Brocot Tree</a>
	<br>
	Authors:
	<a href="http://peteg.org">Peter Gammie</a>
	and <a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-22: <a href="entries/Applicative_Lifting.html">Applicative Lifting</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and Joshua Schneider
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-22: <a href="entries/Algebraic_Numbers.html">Algebraic Numbers in Isabelle/HOL</a>
	<br>
	Authors:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>,
	+ René Thiemann,
	Akihisa Yamada
	and <a href="https://sjcjoosten.nl">Sebastiaan Joosten</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-12: <a href="entries/Card_Partitions.html">Cardinality of Set Partitions</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-02: <a href="entries/Latin_Square.html">Latin Square</a>
	<br>
	Author:
	Alexander Bentkamp
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-12-01: <a href="entries/Ergodic_Theory.html">Ergodic Theory</a>
	<br>
	Author:
	Sebastien Gouezel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-11-19: <a href="entries/Euler_Partition.html">Euler's Partition Theorem</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-11-18: <a href="entries/TortoiseHare.html">The Tortoise and Hare Algorithm</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-11-11: <a href="entries/Planarity_Certificates.html">Planarity Certificates</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~noschinl/">Lars Noschinski</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-11-02: <a href="entries/Parity_Game.html">Positional Determinacy of Parity Games</a>
	<br>
	Author:
	<a href="http://logic.las.tu-berlin.de/Members/Dittmann/">Christoph Dittmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-09-16: <a href="entries/Isabelle_Meta_Model.html">A Meta-Model for the Isabelle API</a>
	<br>
	Authors:
	<a href="https://www.lri.fr/~ftuong/">Frédéric Tuong</a>
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-09-04: <a href="entries/LTL_to_DRA.html">Converting Linear Temporal Logic to Deterministic (Generalized) Rabin Automata</a>
	<br>
	Author:
	Salomon Sickert
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-08-21: <a href="entries/Jordan_Normal_Form.html">Matrices, Jordan Normal Forms, and Spectral Radius Theory</a>
	<br>
	Authors:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	and Akihisa Yamada
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-08-20: <a href="entries/Decreasing-Diagrams-II.html">Decreasing Diagrams II</a>
	<br>
	Author:
	Bertram Felgenhauer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-08-18: <a href="entries/Noninterference_Inductive_Unwinding.html">The Inductive Unwinding Theorem for CSP Noninterference Security</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-08-12: <a href="entries/Rep_Fin_Groups.html">Representations of Finite Groups</a>
	<br>
	Author:
	<a href="http://ualberta.ca/~jsylvest/">Jeremy Sylvestre</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-08-10: <a href="entries/Encodability_Process_Calculi.html">Analysing and Comparing Encodability Criteria for Process Calculi</a>
	<br>
	Authors:
	Kirstin Peters
	and <a href="http://theory.stanford.edu/~rvg/">Rob van Glabbeek</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-07-21: <a href="entries/Case_Labeling.html">Generating Cases from Labeled Subgoals</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~noschinl/">Lars Noschinski</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-07-14: <a href="entries/Landau_Symbols.html">Landau Symbols</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-07-14: <a href="entries/Akra_Bazzi.html">The Akra-Bazzi theorem and the Master theorem</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-07-07: <a href="entries/Hermite.html">Hermite Normal Form</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="https://www.unirioja.es/cu/jearansa">Jesús Aransay</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-06-27: <a href="entries/Derangements.html">Derangements Formula</a>
	<br>
	Author:
	Lukas Bulwahn
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-06-11: <a href="entries/Noninterference_Ipurge_Unwinding.html">The Ipurge Unwinding Theorem for CSP Noninterference Security</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-06-11: <a href="entries/Noninterference_Generic_Unwinding.html">The Generic Unwinding Theorem for CSP Noninterference Security</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-06-11: <a href="entries/Multirelations.html">Binary Multirelations</a>
	<br>
	Authors:
	<a href="http://www.sci.kagoshima-u.ac.jp/~furusawa/">Hitoshi Furusawa</a>
	and <a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-06-11: <a href="entries/List_Interleaving.html">Reasoning about Lists via List Interleaving</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-06-07: <a href="entries/Dynamic_Tables.html">Parameterized Dynamic Tables</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-05-28: <a href="entries/Formula_Derivatives.html">Derivatives of Logical Formulas</a>
	<br>
	Author:
	<a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-05-27: <a href="entries/Probabilistic_System_Zoo.html">A Zoo of Probabilistic Systems</a>
	<br>
	Authors:
	<a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>,
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-04-30: <a href="entries/Vickrey_Clarke_Groves.html">VCG - Combinatorial Vickrey-Clarke-Groves Auctions</a>
	<br>
	Authors:
	Marco B. Caminati,
	<a href="http://www.cs.bham.ac.uk/~mmk">Manfred Kerber</a>,
	Christoph Lange
	and Colin Rowat
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-04-15: <a href="entries/Residuated_Lattices.html">Residuated Lattices</a>
	<br>
	Authors:
	Victor B. F. Gomes
	and <a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-04-13: <a href="entries/ConcurrentIMP.html">Concurrent IMP</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-04-13: <a href="entries/ConcurrentGC.html">Relaxing Safely: Verified On-the-Fly Garbage Collection for x86-TSO</a>
	<br>
	Authors:
	<a href="http://peteg.org">Peter Gammie</a>,
	<a href="https://www.cs.purdue.edu/homes/hosking/">Tony Hosking</a>
	and Kai Engelhardt
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-03-30: <a href="entries/Trie.html">Trie</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-03-18: <a href="entries/Consensus_Refined.html">Consensus Refined</a>
	<br>
	Authors:
	Ognjen Maric
	and Christoph Sprenger
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-03-11: <a href="entries/Deriving.html">Deriving class instances for datatypes</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-02-20: <a href="entries/Call_Arity.html">The Safety of Call Arity</a>
	<br>
	Author:
	Joachim Breitner
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-02-12: <a href="entries/QR_Decomposition.html">QR Decomposition</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="https://www.unirioja.es/cu/jearansa">Jesús Aransay</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-02-12: <a href="entries/Echelon_Form.html">Echelon Form</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="https://www.unirioja.es/cu/jearansa">Jesús Aransay</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-02-05: <a href="entries/Finite_Automata_HF.html">Finite Automata in Hereditarily Finite Set Theory</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2015-01-28: <a href="entries/UpDown_Scheme.html">Verification of the UpDown Scheme</a>
	<br>
	Author:
	<a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2014</td>
	</tr>
	<tr>
	<td class="entry">
	2014-11-28: <a href="entries/UPF.html">The Unified Policy Framework (UPF)</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>,
	Lukas Brügger
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-23: <a href="entries/AODV.html">Loop freedom of the (untimed) AODV routing protocol</a>
	<br>
	Authors:
	<a href="http://www.tbrk.org">Timothy Bourke</a>
	and <a href="http://www.hoefner-online.de/">Peter Höfner</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-13: <a href="entries/Lifting_Definition_Option.html">Lifting Definition Option</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-10: <a href="entries/Stream_Fusion_Code.html">Stream Fusion in HOL with Code Generation</a>
	<br>
	Authors:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and Alexandra Maximova
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-09: <a href="entries/Density_Compiler.html">A Verified Compiler for Probability Density Functions</a>
	<br>
	Authors:
	<a href="https://pruvisto.org">Manuel Eberl</a>,
	<a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-08: <a href="entries/RefinementReactive.html">Formalization of Refinement Calculus for Reactive Systems</a>
	<br>
	Author:
	Viorel Preoteasa
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-03: <a href="entries/XML.html">XML</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-03: <a href="entries/Certification_Monads.html">Certification Monads</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-09-25: <a href="entries/Imperative_Insertion_Sort.html">Imperative Insertion Sort</a>
	<br>
	Author:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-09-19: <a href="entries/Sturm_Tarski.html">The Sturm-Tarski Theorem</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-09-15: <a href="entries/Cayley_Hamilton.html">The Cayley-Hamilton Theorem</a>
	<br>
	Authors:
	<a href="http://nm.wu.ac.at/nm/sadelsbe">Stephan Adelsberger</a>,
	<a href="http://www.logic.at/people/hetzl/">Stefan Hetzl</a>
	and Florian Pollak
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-09-09: <a href="entries/Jordan_Hoelder.html">The Jordan-Hölder Theorem</a>
	<br>
	Author:
	Jakob von Raumer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-09-04: <a href="entries/Priority_Queue_Braun.html">Priority Queues Based on Braun Trees</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-09-03: <a href="entries/Gauss_Jordan.html">Gauss-Jordan Algorithm and Its Applications</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="https://www.unirioja.es/cu/jearansa">Jesús Aransay</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-08-29: <a href="entries/VectorSpace.html">Vector Spaces</a>
	<br>
	Author:
	Holden Lee
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-08-29: <a href="entries/Special_Function_Bounds.html">Real-Valued Special Functions: Upper and Lower Bounds</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-08-13: <a href="entries/Skew_Heap.html">Skew Heap</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-08-12: <a href="entries/Splay_Tree.html">Splay Tree</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-07-29: <a href="entries/Show.html">Haskell's Show Class in Isabelle/HOL</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-07-18: <a href="entries/CISC-Kernel.html">Formal Specification of a Generic Separation Kernel</a>
	<br>
	Authors:
	Freek Verbeek,
	Sergey Tverdyshev,
	Oto Havle,
	Holger Blasum,
	Bruno Langenstein,
	Werner Stephan,
	Yakoub Nemouchi,
	Abderrahmane Feliachi,
	<a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	and Julien Schmaltz
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-07-13: <a href="entries/pGCL.html">pGCL for Isabelle</a>
	<br>
	Author:
	David Cock
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-07-07: <a href="entries/Amortized_Complexity.html">Amortized Complexity Verified</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-07-04: <a href="entries/Network_Security_Policy_Verification.html">Network Security Policy Verification</a>
	<br>
	Author:
	<a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-07-03: <a href="entries/Pop_Refinement.html">Pop-Refinement</a>
	<br>
	Author:
	<a href="http://www.kestrel.edu/~coglio">Alessandro Coglio</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-06-12: <a href="entries/MSO_Regex_Equivalence.html">Decision Procedures for MSO on Words Based on Derivatives of Regular Expressions</a>
	<br>
	Authors:
	<a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-06-08: <a href="entries/Boolean_Expression_Checkers.html">Boolean Expression Checkers</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-28: <a href="entries/Promela.html">Promela Formalization</a>
	<br>
	Author:
	René Neumann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-28: <a href="entries/LTL_to_GBA.html">Converting Linear-Time Temporal Logic to Generalized Büchi Automata</a>
	<br>
	Authors:
	Alexander Schimpf
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-28: <a href="entries/Gabow_SCC.html">Verified Efficient Implementation of Gabow's Strongly Connected Components Algorithm</a>
	<br>
	Author:
	Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-28: <a href="entries/CAVA_LTL_Modelchecker.html">A Fully Verified Executable LTL Model Checker</a>
	<br>
	Authors:
	<a href="https://www7.in.tum.de/~esparza/">Javier Esparza</a>,
	Peter Lammich,
	René Neumann,
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>,
	Alexander Schimpf
	and <a href="http://www.irit.fr/~Jan-Georg.Smaus">Jan-Georg Smaus</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-28: <a href="entries/CAVA_Automata.html">The CAVA Automata Library</a>
	<br>
	Author:
	Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-23: <a href="entries/Roy_Floyd_Warshall.html">Transitive closure according to Roy-Floyd-Warshall</a>
	<br>
	Author:
	Makarius Wenzel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-23: <a href="entries/Noninterference_CSP.html">Noninterference Security in Communicating Sequential Processes</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-05-21: <a href="entries/Regular_Algebras.html">Regular Algebras</a>
	<br>
	Authors:
	<a href="https://www-users.cs.york.ac.uk/~simonf/">Simon Foster</a>
	and <a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-28: <a href="entries/ComponentDependencies.html">Formalisation and Analysis of Component Dependencies</a>
	<br>
	Author:
	Maria Spichkova
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-23: <a href="entries/WHATandWHERE_Security.html">A Formalization of Declassification with WHAT-and-WHERE-Security</a>
	<br>
	Authors:
	Sylvia Grewe,
	Alexander Lux,
	Heiko Mantel
	and Jens Sauer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-23: <a href="entries/Strong_Security.html">A Formalization of Strong Security</a>
	<br>
	Authors:
	Sylvia Grewe,
	Alexander Lux,
	Heiko Mantel
	and Jens Sauer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-23: <a href="entries/SIFUM_Type_Systems.html">A Formalization of Assumptions and Guarantees for Compositional Noninterference</a>
	<br>
	Authors:
	Sylvia Grewe,
	Heiko Mantel
	and Daniel Schoepe
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-22: <a href="entries/Bounded_Deducibility_Security.html">Bounded-Deducibility Security</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>,
	Peter Lammich
	and Thomas Bauereiss
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-16: <a href="entries/HyperCTL.html">A shallow embedding of HyperCTL*</a>
	<br>
	Authors:
	<a href="http://www.react.uni-saarland.de/people/rabe.html">Markus N. Rabe</a>,
	Peter Lammich
	and <a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-16: <a href="entries/Abstract_Completeness.html">Abstract Completeness</a>
	<br>
	Authors:
	Jasmin Christian Blanchette,
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-13: <a href="entries/Discrete_Summation.html">Discrete Summation</a>
	<br>
	Author:
	<a href="http://isabelle.in.tum.de/~haftmann">Florian Haftmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-03: <a href="entries/GPU_Kernel_PL.html">Syntax and semantics of a GPU kernel programming language</a>
	<br>
	Author:
	John Wickerson
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-03-11: <a href="entries/Probabilistic_Noninterference.html">Probabilistic Noninterference</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-03-08: <a href="entries/AWN.html">Mechanization of the Algebra for Wireless Networks (AWN)</a>
	<br>
	Author:
	<a href="http://www.tbrk.org">Timothy Bourke</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-02-18: <a href="entries/Partial_Function_MR.html">Mutually Recursive Partial Functions</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-02-13: <a href="entries/Random_Graph_Subgraph_Threshold.html">Properties of Random Graphs -- Subgraph Containment</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~hupel/">Lars Hupel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-02-11: <a href="entries/Selection_Heap_Sort.html">Verification of Selection and Heap Sort Using Locales</a>
	<br>
	Author:
	<a href="http://www.matf.bg.ac.rs/~danijela">Danijela Petrovic</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-02-07: <a href="entries/Affine_Arithmetic.html">Affine Arithmetic</a>
	<br>
	Author:
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-02-06: <a href="entries/Real_Impl.html">Implementing field extensions of the form Q[sqrt(b)]</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-01-30: <a href="entries/Regex_Equivalence.html">Unified Decision Procedures for Regular Expression Equivalence</a>
	<br>
	Authors:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	and <a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-01-28: <a href="entries/Secondary_Sylow.html">Secondary Sylow Theorems</a>
	<br>
	Author:
	Jakob von Raumer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-01-25: <a href="entries/Relation_Algebra.html">Relation Algebra</a>
	<br>
	Authors:
	Alasdair Armstrong,
	<a href="https://www-users.cs.york.ac.uk/~simonf/">Simon Foster</a>,
	<a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	and Tjark Weber
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-01-23: <a href="entries/KAT_and_DRA.html">Kleene Algebra with Tests and Demonic Refinement Algebras</a>
	<br>
	Authors:
	Alasdair Armstrong,
	Victor B. F. Gomes
	and <a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-01-16: <a href="entries/Featherweight_OCL.html">Featherweight OCL: A Proposal for a Machine-Checked Formal Semantics for OCL 2.5</a>
	<br>
	Authors:
	<a href="https://www.brucker.ch">Achim D. Brucker</a>,
	<a href="https://www.lri.fr/~ftuong/">Frédéric Tuong</a>
	and <a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-01-11: <a href="entries/Sturm_Sequences.html">Sturm's Theorem</a>
	<br>
	Author:
	<a href="https://pruvisto.org">Manuel Eberl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-01-11: <a href="entries/CryptoBasedCompositionalProperties.html">Compositional Properties of Crypto-Based Components</a>
	<br>
	Author:
	Maria Spichkova
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2013</td>
	</tr>
	<tr>
	<td class="entry">
	2013-12-01: <a href="entries/Tail_Recursive_Functions.html">A General Method for the Proof of Theorems on Tail-recursive Functions</a>
	<br>
	Author:
	Pasquale Noce
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-11-17: <a href="entries/Incompleteness.html">Gödel's Incompleteness Theorems</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-11-17: <a href="entries/HereditarilyFinite.html">The Hereditarily Finite Sets</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-11-15: <a href="entries/Coinductive_Languages.html">A Codatatype of Formal Languages</a>
	<br>
	Author:
	<a href="https://traytel.bitbucket.io/">Dmitriy Traytel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-11-14: <a href="entries/FocusStreamsCaseStudies.html">Stream Processing Components: Isabelle/HOL Formalisation and Case Studies</a>
	<br>
	Author:
	Maria Spichkova
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-11-12: <a href="entries/GoedelGod.html">Gödel's God in Isabelle/HOL</a>
	<br>
	Authors:
	<a href="http://christoph-benzmueller.de">Christoph Benzmüller</a>
	and <a href="http://www.logic.at/staff/bruno/">Bruno Woltzenlogel Paleo</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-11-01: <a href="entries/Decreasing-Diagrams.html">Decreasing Diagrams</a>
	<br>
	Author:
	<a href="http://cl-informatik.uibk.ac.at/users/hzankl">Harald Zankl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-10-02: <a href="entries/Automatic_Refinement.html">Automatic Data Refinement</a>
	<br>
	Author:
	Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-09-17: <a href="entries/Native_Word.html">Native Word</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-07-27: <a href="entries/IEEE_Floating_Point.html">A Formal Model of IEEE Floating Point Arithmetic</a>
	<br>
	Author:
	Lei Yu
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-07-22: <a href="entries/Pratt_Certificate.html">Pratt's Primality Certificates</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	and <a href="http://www21.in.tum.de/~noschinl/">Lars Noschinski</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-07-22: <a href="entries/Lehmer.html">Lehmer's Theorem</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~wimmers/">Simon Wimmer</a>
	and <a href="http://www21.in.tum.de/~noschinl/">Lars Noschinski</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-07-19: <a href="entries/Koenigsberg_Friendship.html">The Königsberg Bridge Problem and the Friendship Theorem</a>
	<br>
	Author:
	<a href="https://www.cl.cam.ac.uk/~wl302/">Wenda Li</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-06-27: <a href="entries/Sort_Encodings.html">Sound and Complete Sort Encodings for First-Order Logic</a>
	<br>
	Authors:
	Jasmin Christian Blanchette
	and <a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-05-22: <a href="entries/ShortestPath.html">An Axiomatic Characterization of the Single-Source Shortest Path Problem</a>
	<br>
	Author:
	Christine Rizkallah
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-04-28: <a href="entries/Graph_Theory.html">Graph Theory</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~noschinl/">Lars Noschinski</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-04-15: <a href="entries/Containers.html">Light-weight Containers</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-02-21: <a href="entries/Nominal2.html">Nominal 2</a>
	<br>
	Authors:
	<a href="http://www.inf.kcl.ac.uk/staff/urbanc/">Christian Urban</a>,
	<a href="http://www.in.tum.de/~berghofe">Stefan Berghofer</a>
	and <a href="http://cl-informatik.uibk.ac.at/cek/">Cezary Kaliszyk</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-01-31: <a href="entries/Launchbury.html">The Correctness of Launchbury's Natural Semantics for Lazy Evaluation</a>
	<br>
	Author:
	Joachim Breitner
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-01-19: <a href="entries/Ribbon_Proofs.html">Ribbon Proofs</a>
	<br>
	Author:
	John Wickerson
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-01-16: <a href="entries/Rank_Nullity_Theorem.html">Rank-Nullity Theorem in Linear Algebra</a>
	<br>
	Authors:
	<a href="https://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="https://www.unirioja.es/cu/jearansa">Jesús Aransay</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-01-15: <a href="entries/Kleene_Algebra.html">Kleene Algebra</a>
	<br>
	Authors:
	Alasdair Armstrong,
	<a href="http://staffwww.dcs.shef.ac.uk/people/G.Struth/">Georg Struth</a>
	and Tjark Weber
	</td>
	</tr>
	<tr>
	<td class="entry">
	2013-01-03: <a href="entries/Sqrt_Babylonian.html">Computing N-th Roots using the Babylonian Method</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2012</td>
	</tr>
	<tr>
	<td class="entry">
	2012-11-14: <a href="entries/Separation_Logic_Imperative_HOL.html">A Separation Logic Framework for Imperative HOL</a>
	<br>
	Authors:
	Peter Lammich
	and Rene Meis
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-11-02: <a href="entries/Open_Induction.html">Open Induction</a>
	<br>
	Authors:
	Mizuhito Ogawa
	and <a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-10-30: <a href="entries/Tarskis_Geometry.html">The independence of Tarski's Euclidean axiom</a>
	<br>
	Author:
	T. J. M. Makarios
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-10-27: <a href="entries/Bondy.html">Bondy's Theorem</a>
	<br>
	Authors:
	<a href="http://www.andrew.cmu.edu/user/avigad/">Jeremy Avigad</a>
	and <a href="http://www.logic.at/people/hetzl/">Stefan Hetzl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-09-10: <a href="entries/Possibilistic_Noninterference.html">Possibilistic Noninterference</a>
	<br>
	Authors:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	and <a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-08-07: <a href="entries/Datatype_Order_Generator.html">Generating linear orders for datatypes</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-08-05: <a href="entries/Impossible_Geometry.html">Proving the Impossibility of Trisecting an Angle and Doubling the Cube</a>
	<br>
	Authors:
	Ralph Romanos
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-07-27: <a href="entries/Heard_Of.html">Verifying Fault-Tolerant Distributed Algorithms in the Heard-Of Model</a>
	<br>
	Authors:
	Henri Debrat
	and <a href="http://www.loria.fr/~merz">Stephan Merz</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-07-01: <a href="entries/PCF.html">Logical Relations for PCF</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-06-26: <a href="entries/Tycon.html">Type Constructor Classes and Monad Transformers</a>
	<br>
	Author:
	Brian Huffman
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-05-29: <a href="entries/Psi_Calculi.html">Psi-calculi in Isabelle</a>
	<br>
	Author:
	<a href="http://www.itu.dk/people/jebe">Jesper Bengtson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-05-29: <a href="entries/Pi_Calculus.html">The pi-calculus in nominal logic</a>
	<br>
	Author:
	<a href="http://www.itu.dk/people/jebe">Jesper Bengtson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-05-29: <a href="entries/CCS.html">CCS in nominal logic</a>
	<br>
	Author:
	<a href="http://www.itu.dk/people/jebe">Jesper Bengtson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-05-27: <a href="entries/Circus.html">Isabelle/Circus</a>
	<br>
	Authors:
	Abderrahmane Feliachi,
	<a href="https://www.lri.fr/~wolff/">Burkhart Wolff</a>
	and Marie-Claude Gaudel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-05-11: <a href="entries/Separation_Algebra.html">Separation Algebra</a>
	<br>
	Authors:
	<a href="http://www.cse.unsw.edu.au/~kleing/">Gerwin Klein</a>,
	Rafal Kolanski
	and Andrew Boyton
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-05-07: <a href="entries/Stuttering_Equivalence.html">Stuttering Equivalence</a>
	<br>
	Author:
	<a href="http://www.loria.fr/~merz">Stephan Merz</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-05-02: <a href="entries/Inductive_Confidentiality.html">Inductive Study of Confidentiality</a>
	<br>
	Author:
	<a href="http://www.dmi.unict.it/~giamp/">Giampaolo Bella</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-04-26: <a href="entries/Ordinary_Differential_Equations.html">Ordinary Differential Equations</a>
	<br>
	Authors:
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	and <a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-04-13: <a href="entries/Well_Quasi_Orders.html">Well-Quasi-Orders</a>
	<br>
	Author:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-03-01: <a href="entries/Abortable_Linearizable_Modules.html">Abortable Linearizable Modules</a>
	<br>
	Authors:
	Rachid Guerraoui,
	<a href="http://lara.epfl.ch/~kuncak/">Viktor Kuncak</a>
	and Giuliano Losa
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-02-29: <a href="entries/Transitive-Closure-II.html">Executable Transitive Closures</a>
	<br>
	Author:
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-02-06: <a href="entries/Girth_Chromatic.html">A Probabilistic Proof of the Girth-Chromatic Number Theorem</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~noschinl/">Lars Noschinski</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-01-30: <a href="entries/Refine_Monadic.html">Refinement for Monadic Programs</a>
	<br>
	Author:
	Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-01-30: <a href="entries/Dijkstra_Shortest_Path.html">Dijkstra's Shortest Path Algorithm</a>
	<br>
	Authors:
	Benedikt Nordhoff
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2012-01-03: <a href="entries/Markov_Models.html">Markov Models</a>
	<br>
	Authors:
	<a href="http://in.tum.de/~hoelzl">Johannes Hölzl</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2011</td>
	</tr>
	<tr>
	<td class="entry">
	2011-11-19: <a href="entries/TLA.html">A Definitional Encoding of TLA* in Isabelle/HOL</a>
	<br>
	Authors:
	<a href="http://homepages.inf.ed.ac.uk/ggrov">Gudmund Grov</a>
	and <a href="http://www.loria.fr/~merz">Stephan Merz</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-11-09: <a href="entries/Efficient-Mergesort.html">Efficient Mergesort</a>
	<br>
	Author:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-09-22: <a href="entries/PseudoHoops.html">Pseudo Hoops</a>
	<br>
	Authors:
	George Georgescu,
	Laurentiu Leustean
	and Viorel Preoteasa
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-09-22: <a href="entries/MonoBoolTranAlgebra.html">Algebra of Monotonic Boolean Transformers</a>
	<br>
	Author:
	Viorel Preoteasa
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-09-22: <a href="entries/LatticeProperties.html">Lattice Properties</a>
	<br>
	Author:
	Viorel Preoteasa
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-08-26: <a href="entries/Myhill-Nerode.html">The Myhill-Nerode Theorem Based on Regular Expressions</a>
	<br>
	Authors:
	Chunhan Wu,
	Xingyuan Zhang
	and <a href="http://www.inf.kcl.ac.uk/staff/urbanc/">Christian Urban</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-08-19: <a href="entries/Gauss-Jordan-Elim-Fun.html">Gauss-Jordan Elimination for Matrices Represented as Functions</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-07-21: <a href="entries/Max-Card-Matching.html">Maximum Cardinality Matching</a>
	<br>
	Author:
	Christine Rizkallah
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-05-17: <a href="entries/KBPs.html">Knowledge-based programs</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-04-01: <a href="entries/General-Triangle.html">The General Triangle Is Unique</a>
	<br>
	Author:
	Joachim Breitner
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-03-14: <a href="entries/Transitive-Closure.html">Executable Transitive Closures of Finite Relations</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-02-23: <a href="entries/Nat-Interval-Logic.html">Interval Temporal Logic on Natural Numbers</a>
	<br>
	Author:
	David Trachtenherz
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-02-23: <a href="entries/List-Infinite.html">Infinite Lists</a>
	<br>
	Author:
	David Trachtenherz
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-02-23: <a href="entries/AutoFocus-Stream.html">AutoFocus Stream Processing for Single-Clocking and Multi-Clocking Semantics</a>
	<br>
	Author:
	David Trachtenherz
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-02-07: <a href="entries/LightweightJava.html">Lightweight Java</a>
	<br>
	Authors:
	<a href="http://rok.strnisa.com/lj/">Rok Strniša</a>
	and <a href="http://research.microsoft.com/people/mattpark/">Matthew Parkinson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-01-10: <a href="entries/RIPEMD-160-SPARK.html">RIPEMD-160</a>
	<br>
	Author:
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2011-01-08: <a href="entries/Lower_Semicontinuous.html">Lower Semicontinuous Functions</a>
	<br>
	Author:
	Bogdan Grechuk
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2010</td>
	</tr>
	<tr>
	<td class="entry">
	2010-12-17: <a href="entries/Marriage.html">Hall's Marriage Theorem</a>
	<br>
	Authors:
	Dongchen Jiang
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-11-16: <a href="entries/Shivers-CFA.html">Shivers' Control Flow Analysis</a>
	<br>
	Author:
	Joachim Breitner
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-10-28: <a href="entries/Finger-Trees.html">Finger Trees</a>
	<br>
	Authors:
	Benedikt Nordhoff,
	Stefan Körner
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-10-28: <a href="entries/Binomial-Queues.html">Functional Binomial Queues</a>
	<br>
	Author:
	René Neumann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-10-28: <a href="entries/Binomial-Heaps.html">Binomial Heaps and Skew Binomial Heaps</a>
	<br>
	Authors:
	Rene Meis,
	Finn Nielsen
	and Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-08-29: <a href="entries/Lam-ml-Normalization.html">Strong Normalization of Moggis's Computational Metalanguage</a>
	<br>
	Author:
	Christian Doczkal
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-08-10: <a href="entries/Polynomials.html">Executable Multivariate Polynomials</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>,
	- <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>,
	+ René Thiemann,
	<a href="https://risc.jku.at/m/alexander-maletzky/">Alexander Maletzky</a>,
	<a href="http://home.in.tum.de/~immler/">Fabian Immler</a>,
	<a href="http://isabelle.in.tum.de/~haftmann">Florian Haftmann</a>,
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	and Alexander Bentkamp
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-08-08: <a href="entries/Statecharts.html">Formalizing Statecharts using Hierarchical Automata</a>
	<br>
	Authors:
	Steffen Helke
	and Florian Kammüller
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-06-24: <a href="entries/Free-Groups.html">Free Groups</a>
	<br>
	Author:
	Joachim Breitner
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-06-20: <a href="entries/Category2.html">Category Theory</a>
	<br>
	Author:
	Alexander Katovsky
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-06-17: <a href="entries/Matrix.html">Executable Matrix Operations on Matrices of Arbitrary Dimensions</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-06-14: <a href="entries/Abstract-Rewriting.html">Abstract Rewriting</a>
	<br>
	Authors:
	<a href="http://cl-informatik.uibk.ac.at/users/griff/">Christian Sternagel</a>
	- and <a href="http://cl-informatik.uibk.ac.at/users/thiemann/">René Thiemann</a>
	+ and René Thiemann
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-05-28: <a href="entries/GraphMarkingIBP.html">Verification of the Deutsch-Schorr-Waite Graph Marking Algorithm using Data Refinement</a>
	<br>
	Authors:
	Viorel Preoteasa
	and <a href="http://users.abo.fi/Ralph-Johan.Back/">Ralph-Johan Back</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-05-28: <a href="entries/DataRefinementIBP.html">Semantics and Data Refinement of Invariant Based Programs</a>
	<br>
	Authors:
	Viorel Preoteasa
	and <a href="http://users.abo.fi/Ralph-Johan.Back/">Ralph-Johan Back</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-05-22: <a href="entries/Robbins-Conjecture.html">A Complete Proof of the Robbins Conjecture</a>
	<br>
	Author:
	Matthew Wampler-Doty
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-05-12: <a href="entries/Regular-Sets.html">Regular Sets and Expressions</a>
	<br>
	Authors:
	<a href="http://www.in.tum.de/~krauss">Alexander Krauss</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-04-30: <a href="entries/Locally-Nameless-Sigma.html">Locally Nameless Sigma Calculus</a>
	<br>
	Authors:
	Ludovic Henrio,
	Florian Kammüller,
	Bianca Lutz
	and Henry Sudhof
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-03-29: <a href="entries/Free-Boolean-Algebra.html">Free Boolean Algebra</a>
	<br>
	Author:
	Brian Huffman
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-03-23: <a href="entries/InformationFlowSlicing_Inter.html">Inter-Procedural Information Flow Noninterference via Slicing</a>
	<br>
	Author:
	<a href="http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php">Daniel Wasserrab</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-03-23: <a href="entries/InformationFlowSlicing.html">Information Flow Noninterference via Slicing</a>
	<br>
	Author:
	<a href="http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php">Daniel Wasserrab</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-02-20: <a href="entries/List-Index.html">List Index</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-02-12: <a href="entries/Coinductive.html">Coinductive</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2009</td>
	</tr>
	<tr>
	<td class="entry">
	2009-12-09: <a href="entries/DPT-SAT-Solver.html">A Fast SAT Solver for Isabelle in Standard ML</a>
	<br>
	Author:
	Armin Heller
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-12-03: <a href="entries/Presburger-Automata.html">Formalizing the Logic-Automaton Connection</a>
	<br>
	Authors:
	<a href="http://www.in.tum.de/~berghofe">Stefan Berghofer</a>
	and Markus Reiter
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-11-25: <a href="entries/Tree-Automata.html">Tree Automata</a>
	<br>
	Author:
	Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-11-25: <a href="entries/Collections.html">Collections Framework</a>
	<br>
	Author:
	Peter Lammich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-11-22: <a href="entries/Perfect-Number-Thm.html">Perfect Number Theorem</a>
	<br>
	Author:
	Mark Ijbema
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-11-13: <a href="entries/HRB-Slicing.html">Backing up Slicing: Verifying the Interprocedural Two-Phase Horwitz-Reps-Binkley Slicer</a>
	<br>
	Author:
	<a href="http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php">Daniel Wasserrab</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-10-30: <a href="entries/WorkerWrapper.html">The Worker/Wrapper Transformation</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-09-01: <a href="entries/Ordinals_and_Cardinals.html">Ordinals and Cardinals</a>
	<br>
	Author:
	<a href="https://www.andreipopescu.uk">Andrei Popescu</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-08-28: <a href="entries/SequentInvertibility.html">Invertibility in Sequent Calculi</a>
	<br>
	Author:
	Peter Chapman
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-08-04: <a href="entries/CofGroups.html">An Example of a Cofinitary Group in Isabelle/HOL</a>
	<br>
	Author:
	<a href="http://kasterma.net">Bart Kastermans</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-05-06: <a href="entries/FinFun.html">Code Generation for Functions as Data</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2009-04-29: <a href="entries/Stream-Fusion.html">Stream Fusion</a>
	<br>
	Author:
	Brian Huffman
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2008</td>
	</tr>
	<tr>
	<td class="entry">
	2008-12-12: <a href="entries/BytecodeLogicJmlTypes.html">A Bytecode Logic for JML and Types</a>
	<br>
	Authors:
	Lennart Beringer
	and <a href="http://www.tcs.informatik.uni-muenchen.de/~mhofmann">Martin Hofmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-11-10: <a href="entries/SIFPL.html">Secure information flow and program logics</a>
	<br>
	Authors:
	Lennart Beringer
	and <a href="http://www.tcs.informatik.uni-muenchen.de/~mhofmann">Martin Hofmann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-11-09: <a href="entries/SenSocialChoice.html">Some classical results in Social Choice Theory</a>
	<br>
	Author:
	<a href="http://peteg.org">Peter Gammie</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-11-07: <a href="entries/FunWithTilings.html">Fun With Tilings</a>
	<br>
	Authors:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	and <a href="https://www.cl.cam.ac.uk/~lp15/">Lawrence C. Paulson</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-10-15: <a href="entries/Huffman.html">The Textbook Proof of Huffman's Algorithm</a>
	<br>
	Author:
	Jasmin Christian Blanchette
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-09-16: <a href="entries/Slicing.html">Towards Certified Slicing</a>
	<br>
	Author:
	<a href="http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php">Daniel Wasserrab</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-09-02: <a href="entries/VolpanoSmith.html">A Correctness Proof for the Volpano/Smith Security Typing System</a>
	<br>
	Authors:
	<a href="http://pp.info.uni-karlsruhe.de/personhp/gregor_snelting.php">Gregor Snelting</a>
	and <a href="http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php">Daniel Wasserrab</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-09-01: <a href="entries/ArrowImpossibilityGS.html">Arrow and Gibbard-Satterthwaite</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-08-26: <a href="entries/FunWithFunctions.html">Fun With Functions</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-07-23: <a href="entries/SATSolverVerification.html">Formal Verification of Modern SAT Solvers</a>
	<br>
	Author:
	Filip Marić
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-04-05: <a href="entries/Recursion-Theory-I.html">Recursion Theory I</a>
	<br>
	Author:
	Michael Nedzelsky
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-02-29: <a href="entries/Simpl.html">A Sequential Imperative Programming Language Syntax, Semantics, Hoare Logics and Verification Environment</a>
	<br>
	Author:
	Norbert Schirmer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-02-29: <a href="entries/BDD.html">BDD Normalisation</a>
	<br>
	Authors:
	Veronika Ortner
	and Norbert Schirmer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-02-18: <a href="entries/NormByEval.html">Normalization by Evaluation</a>
	<br>
	Authors:
	<a href="http://www.linta.de/~aehlig/">Klaus Aehlig</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2008-01-11: <a href="entries/LinearQuantifierElim.html">Quantifier Elimination for Linear Arithmetic</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2007</td>
	</tr>
	<tr>
	<td class="entry">
	2007-12-14: <a href="entries/Program-Conflict-Analysis.html">Formalization of Conflict Analysis of Programs with Procedures, Thread Creation, and Monitors</a>
	<br>
	Authors:
	Peter Lammich
	and <a href="http://cs.uni-muenster.de/u/mmo/">Markus Müller-Olm</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2007-12-03: <a href="entries/JinjaThreads.html">Jinja with Threads</a>
	<br>
	Author:
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2007-11-06: <a href="entries/MuchAdoAboutTwo.html">Much Ado About Two</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~boehmes/">Sascha Böhme</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2007-08-12: <a href="entries/SumSquares.html">Sums of Two and Four Squares</a>
	<br>
	Author:
	Roelof Oosterhuis
	</td>
	</tr>
	<tr>
	<td class="entry">
	2007-08-12: <a href="entries/Fermat3_4.html">Fermat's Last Theorem for Exponents 3 and 4 and the Parametrisation of Pythagorean Triples</a>
	<br>
	Author:
	Roelof Oosterhuis
	</td>
	</tr>
	<tr>
	<td class="entry">
	2007-08-08: <a href="entries/Valuation.html">Fundamental Properties of Valuation Theory and Hensel's Lemma</a>
	<br>
	Author:
	Hidetsune Kobayashi
	</td>
	</tr>
	<tr>
	<td class="entry">
	2007-08-02: <a href="entries/POPLmark-deBruijn.html">POPLmark Challenge Via de Bruijn Indices</a>
	<br>
	Author:
	<a href="http://www.in.tum.de/~berghofe">Stefan Berghofer</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2007-08-02: <a href="entries/FOL-Fitting.html">First-Order Logic According to Fitting</a>
	<br>
	Author:
	<a href="http://www.in.tum.de/~berghofe">Stefan Berghofer</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2006</td>
	</tr>
	<tr>
	<td class="entry">
	2006-09-09: <a href="entries/HotelKeyCards.html">Hotel Key Card System</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2006-08-08: <a href="entries/Abstract-Hoare-Logics.html">Abstract Hoare Logics</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2006-05-22: <a href="entries/Flyspeck-Tame.html">Flyspeck I: Tame Graphs</a>
	<br>
	Authors:
	Gertrud Bauer
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2006-05-15: <a href="entries/CoreC++.html">CoreC++</a>
	<br>
	Author:
	<a href="http://pp.info.uni-karlsruhe.de/personhp/daniel_wasserrab.php">Daniel Wasserrab</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2006-03-31: <a href="entries/FeatherweightJava.html">A Theory of Featherweight Java in Isabelle/HOL</a>
	<br>
	Authors:
	<a href="http://www.cs.cornell.edu/~jnfoster/">J. Nathan Foster</a>
	and <a href="http://research.microsoft.com/en-us/people/dimitris/">Dimitrios Vytiniotis</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2006-03-15: <a href="entries/ClockSynchInst.html">Instances of Schneider's generalized protocol of clock synchronization</a>
	<br>
	Author:
	<a href="http://www.cs.famaf.unc.edu.ar/~damian/">Damián Barsotti</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2006-03-14: <a href="entries/Cauchy.html">Cauchy's Mean Theorem and the Cauchy-Schwarz Inequality</a>
	<br>
	Author:
	Benjamin Porter
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2005</td>
	</tr>
	<tr>
	<td class="entry">
	2005-11-11: <a href="entries/Ordinal.html">Countable Ordinals</a>
	<br>
	Author:
	Brian Huffman
	</td>
	</tr>
	<tr>
	<td class="entry">
	2005-10-12: <a href="entries/FFT.html">Fast Fourier Transform</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~ballarin/">Clemens Ballarin</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2005-06-24: <a href="entries/GenClock.html">Formalization of a Generalized Protocol for Clock Synchronization</a>
	<br>
	Author:
	Alwen Tiu
	</td>
	</tr>
	<tr>
	<td class="entry">
	2005-06-22: <a href="entries/DiskPaxos.html">Proving the Correctness of Disk Paxos</a>
	<br>
	Authors:
	<a href="http://www.fceia.unr.edu.ar/~mauro/">Mauro Jaskelioff</a>
	and <a href="http://www.loria.fr/~merz">Stephan Merz</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2005-06-20: <a href="entries/JiveDataStoreModel.html">Jive Data and Store Model</a>
	<br>
	Authors:
	Nicole Rauch
	and Norbert Schirmer
	</td>
	</tr>
	<tr>
	<td class="entry">
	2005-06-01: <a href="entries/Jinja.html">Jinja is not Java</a>
	<br>
	Authors:
	<a href="http://www.cse.unsw.edu.au/~kleing/">Gerwin Klein</a>
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2005-05-02: <a href="entries/RSAPSS.html">SHA1, RSA, PSS and more</a>
	<br>
	Authors:
	Christina Lindenberg
	and Kai Wirt
	</td>
	</tr>
	<tr>
	<td class="entry">
	2005-04-21: <a href="entries/Category.html">Category Theory to Yoneda's Lemma</a>
	<br>
	Author:
	<a href="http://users.rsise.anu.edu.au/~okeefe/">Greg O'Keefe</a>
	</td>
	</tr>
	</tbody>
	</table>
	<p> </p>

	<table width="80%" class="entries">
	<tbody>
	<tr>
	<td class="head">2004</td>
	</tr>
	<tr>
	<td class="entry">
	2004-12-09: <a href="entries/FileRefinement.html">File Refinement</a>
	<br>
	Authors:
	<a href="http://www.mit.edu/~kkz/">Karen Zee</a>
	and <a href="http://lara.epfl.ch/~kuncak/">Viktor Kuncak</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-11-19: <a href="entries/Integration.html">Integration theory and random variables</a>
	<br>
	Author:
	<a href="http://www-lti.informatik.rwth-aachen.de/~richter/">Stefan Richter</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-09-28: <a href="entries/Verified-Prover.html">A Mechanically Verified, Efficient, Sound and Complete Theorem Prover For First Order Logic</a>
	<br>
	Author:
	Tom Ridge
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-09-20: <a href="entries/Ramsey-Infinite.html">Ramsey's theorem, infinitary version</a>
	<br>
	Author:
	Tom Ridge
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-09-20: <a href="entries/Completeness.html">Completeness theorem</a>
	<br>
	Authors:
	James Margetson
	and Tom Ridge
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-07-09: <a href="entries/Compiling-Exceptions-Correctly.html">Compiling Exceptions Correctly</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-06-24: <a href="entries/Depth-First-Search.html">Depth First Search</a>
	<br>
	Authors:
	Toshiaki Nishihara
	- and Yasuhiko Minamide
	+ and <a href="https://sv.c.titech.ac.jp/minamide/index.en.html">Yasuhiko Minamide</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-05-18: <a href="entries/Group-Ring-Module.html">Groups, Rings and Modules</a>
	<br>
	Authors:
	Hidetsune Kobayashi,
	L. Chen
	and H. Murao
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-04-26: <a href="entries/Topology.html">Topology</a>
	<br>
	Author:
	Stefan Friedrich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-04-26: <a href="entries/Lazy-Lists-II.html">Lazy Lists II</a>
	<br>
	Author:
	Stefan Friedrich
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-04-05: <a href="entries/BinarySearchTree.html">Binary Search Trees</a>
	<br>
	Author:
	<a href="http://lara.epfl.ch/~kuncak/">Viktor Kuncak</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-03-30: <a href="entries/Functional-Automata.html">Functional Automata</a>
	<br>
	Author:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-03-19: <a href="entries/MiniML.html">Mini ML</a>
	<br>
	Authors:
	Wolfgang Naraschewski
	and <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2004-03-19: <a href="entries/AVL-Trees.html">AVL Trees</a>
	<br>
	Authors:
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	and Cornelia Pusch
	</td>
	</tr>
	</tbody>
	</table>


	</div>
	</td>

	</tr>
	</tbody>
	</table>


	</body>
	</html>
	\ 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,618 +1,659 @@
	<?xml version="1.0" encoding="UTF-8" ?>
	<rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom" xmlns:dc="http://purl.org/dc/elements/1.1/">
	<channel>
	<atom:link href="https://www.isa-afp.org/rss.xml" rel="self" type="application/rss+xml" />
	<title>Archive of Formal Proofs</title>
	<link>https://www.isa-afp.org</link>
	<description>
	The Archive of Formal Proofs is a collection of proof libraries, examples,
	and larger scientific developments, mechanically checked
	in the theorem prover Isabelle.
	</description>
	- <pubDate>04 Jan 2022 00:00:00 +0000</pubDate>
	+ <pubDate>20 Feb 2022 00:00:00 +0000</pubDate>
	+ <item>
	+ <title>Universal Hash Families</title>
	+ <link>https://www.isa-afp.org/entries/Universal_Hash_Families.html</link>
	+ <guid>https://www.isa-afp.org/entries/Universal_Hash_Families.html</guid>
	+ <dc:creator> Emin Karayel </dc:creator>
	+ <pubDate>20 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+A <i>k</i>-universal hash family is a probability
	+space of functions, which have uniform distribution and form
	+<i>k</i>-wise independent random variables. They can often be used
	+in place of classic (or cryptographic) hash functions and allow the
	+rigorous analysis of the performance of randomized algorithms and
	+data structures that rely on hash functions. In 1981
	+<a href="https://doi.org/10.1016/0022-0000(81)90033-7">Wegman and Carter</a>
	+introduced a generic construction for such families with arbitrary
	+<i>k</i> using polynomials over a finite field. This entry
	+contains a formalization of them and establishes the property of
	+<i>k</i>-universality. To be useful the formalization also provides
	+an explicit construction of finite fields using the factor ring of
	+integers modulo a prime. Additionally, some generic results about
	+independent families are shown that might be of independent interest.</description>
	+ </item>
	+ <item>
	+ <title>Wetzel's Problem and the Continuum Hypothesis</title>
	+ <link>https://www.isa-afp.org/entries/Wetzels_Problem.html</link>
	+ <guid>https://www.isa-afp.org/entries/Wetzels_Problem.html</guid>
	+ <dc:creator> Lawrence C Paulson </dc:creator>
	+ <pubDate>18 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+Let $F$ be a set of analytic functions on the complex plane such that,
	+for each $z\in\mathbb{C}$, the set $\{f(z) \mid f\in F\}$ is
	+countable; must then $F$ itself be countable? The answer is yes if the
	+Continuum Hypothesis is false, i.e., if the cardinality of
	+$\mathbb{R}$ exceeds $\aleph_1$. But if CH is true then such an $F$,
	+of cardinality $\aleph_1$, can be constructed by transfinite
	+recursion. The formal proof illustrates reasoning about complex
	+analysis (analytic and homomorphic functions) and set theory
	+(transfinite cardinalities) in a single setting. The mathematical text
	+comes from <em>Proofs from THE BOOK</em> by Aigner and
	+Ziegler.</description>
	+ </item>
	+ <item>
	+ <title>First-Order Query Evaluation</title>
	+ <link>https://www.isa-afp.org/entries/Eval_FO.html</link>
	+ <guid>https://www.isa-afp.org/entries/Eval_FO.html</guid>
	+ <dc:creator> Martin Raszyk </dc:creator>
	+ <pubDate>15 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+We formalize first-order query evaluation over an infinite domain with
	+equality. We first define the syntax and semantics of first-order
	+logic with equality. Next we define a locale
	+<i>eval&lowbar;fo</i> abstracting a representation of
	+a potentially infinite set of tuples satisfying a first-order query
	+over finite relations. Inside the locale, we define a function
	+<i>eval</i> checking if the set of tuples satisfying a
	+first-order query over a database (an interpretation of the
	+query's predicates) is finite (i.e., deciding <i>relative
	+safety</i>) and computing the set of satisfying tuples if it is
	+finite. Altogether the function <i>eval</i> solves
	+<i>capturability</i> (Avron and Hirshfeld, 1991) of
	+first-order logic with equality. We also use the function
	+<i>eval</i> to prove a code equation for the semantics of
	+first-order logic, i.e., the function checking if a first-order query
	+over a database is satisfied by a variable assignment.<br/> We provide an
	+interpretation of the locale <i>eval&lowbar;fo</i>
	+based on the approach by Ailamazyan et al. A core notion in the
	+interpretation is the active domain of a query and a database that
	+contains all domain elements that occur in the database or interpret
	+the query's constants. We prove the main theorem of Ailamazyan et
	+al. relating the satisfaction of a first-order query over an infinite
	+domain to the satisfaction of this query over a finite domain
	+consisting of the active domain and a few additional domain elements
	+(outside the active domain) whose number only depends on the query. In
	+our interpretation of the locale
	+<i>eval&lowbar;fo</i>, we use a potentially higher
	+number of the additional domain elements, but their number still only
	+depends on the query and thus has no effect on the data complexity
	+(Vardi, 1982) of query evaluation. Our interpretation yields an
	+<i>executable</i> function <i>eval</i>. The
	+time complexity of <i>eval</i> on a query is linear in the
	+total number of tuples in the intermediate relations for the
	+subqueries. Specifically, we build a database index to evaluate a
	+conjunction. We also optimize the case of a negated subquery in a
	+conjunction. Finally, we export code for the infinite domain of
	+natural numbers.</description>
	+ </item>
	+ <item>
	+ <title>Multi-Head Monitoring of Metric Dynamic Logic</title>
	+ <link>https://www.isa-afp.org/entries/VYDRA_MDL.html</link>
	+ <guid>https://www.isa-afp.org/entries/VYDRA_MDL.html</guid>
	+ <dc:creator> Martin Raszyk </dc:creator>
	+ <pubDate>13 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+Runtime monitoring (or runtime verification) is an approach to
	+checking compliance of a system's execution with a specification
	+(e.g., a temporal query). The system's execution is logged into a
	+trace---a sequence of time-points, each consisting of a time-stamp and
	+observed events. A monitor is an algorithm that produces verdicts on
	+the satisfaction of a temporal query on a trace. We formalize a
	+monitoring algorithm for metric dynamic logic, an extension of metric
	+temporal logic with regular expressions. The monitor computes whether
	+a given query is satisfied at every position in an input trace of
	+time-stamped events. We formalize the time-stamps as an abstract
	+algebraic structure satisfying certain assumptions. Instances of this
	+structure include natural numbers, real numbers, and lexicographic
	+combinations of them. Our monitor follows the multi-head paradigm: it
	+reads the input simultaneously at multiple positions and moves its
	+reading heads asynchronously. This mode of operation results in
	+unprecedented time and space complexity guarantees for metric dynamic
	+logic: The monitor's amortized time complexity to process a
	+time-point and the monitor's space complexity neither depends on
	+the event-rate, i.e., the number of events within a fixed time-unit,
	+nor on the numeric constants occurring in the quantitative temporal
	+constraints in the given query. The multi-head monitoring algorithm
	+for metric dynamic logic is reported in our paper "Multi-Head
	+Monitoring of Metric Dynamic Logic" published at ATVA 2020. We
	+have also formalized unpublished specialized algorithms for the
	+temporal operators of metric temporal logic.</description>
	+ </item>
	+ <item>
	+ <title>Enumeration of Equivalence Relations</title>
	+ <link>https://www.isa-afp.org/entries/Equivalence_Relation_Enumeration.html</link>
	+ <guid>https://www.isa-afp.org/entries/Equivalence_Relation_Enumeration.html</guid>
	+ <dc:creator> Emin Karayel </dc:creator>
	+ <pubDate>04 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+<p>This entry contains a formalization of an algorithm
	+enumerating all equivalence relations on an initial segment of the
	+natural numbers. The approach follows the method described by Stanton
	+and White <a
	+href="https://doi.org/10.1007/978-1-4612-4968-9">[5,§
	+1.5]</a> using restricted growth functions.</p>
	+<p>The algorithm internally enumerates restricted growth
	+functions (as lists), whose equivalence kernels then form the
	+equivalence relations. This has the advantage that the representation
	+is compact and lookup of the relation reduces to a list lookup
	+operation.</p> <p>The algorithm can also be used within a
	+proof and an example application is included, where a sequence of
	+variables is split by the possible partitions they can form.</p></description>
	+ </item>
	+ <item>
	+ <title>Quasi-Borel Spaces</title>
	+ <link>https://www.isa-afp.org/entries/Quasi_Borel_Spaces.html</link>
	+ <guid>https://www.isa-afp.org/entries/Quasi_Borel_Spaces.html</guid>
	+ <dc:creator> Michikazu Hirata, Yasuhiko Minamide, Tetsuya Sato </dc:creator>
	+ <pubDate>03 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+The notion of quasi-Borel spaces was introduced by <a
	+href="https://dl.acm.org/doi/10.5555/3329995.3330072">
	+Heunen et al</a>. The theory provides a suitable
	+denotational model for higher-order probabilistic programming
	+languages with continuous distributions. This entry is a formalization
	+of the theory of quasi-Borel spaces, including construction of
	+quasi-Borel spaces (product, coproduct, function spaces), the
	+adjunction between the category of measurable spaces and the category
	+of quasi-Borel spaces, and the probability monad on quasi-Borel
	+spaces. This entry also contains the formalization of the Bayesian
	+regression presented in the work of Heunen et al. This work is a part
	+of the work by same authors, <i>Program Logic for Higher-Order
	+Probabilistic Programs in Isabelle/HOL</i>, which will be
	+published in the proceedings of the 16th International Symposium on
	+Functional and Logic Programming (FLOPS 2022).</description>
	+ </item>
	+ <item>
	+ <title>Duality of Linear Programming</title>
	+ <link>https://www.isa-afp.org/entries/LP_Duality.html</link>
	+ <guid>https://www.isa-afp.org/entries/LP_Duality.html</guid>
	+ <dc:creator> René Thiemann </dc:creator>
	+ <pubDate>03 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+We formalize the weak and strong duality theorems of linear
	+programming. For the strong duality theorem we provide three
	+sufficient preconditions: both the primal problem and the dual problem
	+are satisfiable, the primal problem is satisfiable and bounded, or the
	+dual problem is satisfiable and bounded. The proofs are based on an
	+existing formalization of Farkas' Lemma.</description>
	+ </item>
	+ <item>
	+ <title>First-Order Theory of Rewriting</title>
	+ <link>https://www.isa-afp.org/entries/FO_Theory_Rewriting.html</link>
	+ <guid>https://www.isa-afp.org/entries/FO_Theory_Rewriting.html</guid>
	+ <dc:creator> Alexander Lochmann, Bertram Felgenhauer </dc:creator>
	+ <pubDate>02 Feb 2022 00:00:00 +0000</pubDate>
	+ <description>
	+The first-order theory of rewriting (FORT) is a decidable theory for
	+linear variable-separated rewrite systems. The decision procedure is
	+based on tree automata technique and an inference system presented in
	+"Certifying Proofs in the First-Order Theory of Rewriting".
	+This AFP entry provides a formalization of the underlying decision
	+procedure. Moreover it allows to generate a function that can verify
	+each inference step via the code generation facility of Isabelle/HOL.
	+Additionally it contains the specification of a certificate language
	+(that allows to state proofs in FORT) and a formalized function that
	+allows to verify the validity of the proof. This gives software tool
	+authors, that implement the decision procedure, the possibility to
	+verify their output.</description>
	+ </item>
	+ <item>
	+ <title>Young's Inequality for Increasing Functions</title>
	+ <link>https://www.isa-afp.org/entries/Youngs_Inequality.html</link>
	+ <guid>https://www.isa-afp.org/entries/Youngs_Inequality.html</guid>
	+ <dc:creator> Lawrence C Paulson </dc:creator>
	+ <pubDate>31 Jan 2022 00:00:00 +0000</pubDate>
	+ <description>
	+Young's inequality states that $$ ab \leq \int_0^a f(x)dx +
	+\int_0^b f^{-1}(y) dy $$ where $a\geq 0$, $b\geq 0$ and $f$ is
	+strictly increasing and continuous. Its proof is formalised following
	+<a href="https://www.jstor.org/stable/2318018">the
	+development</a> by Cunningham and Grossman. Their idea is to
	+make the intuitive, geometric folklore proof rigorous by reasoning
	+about step functions. The lack of the Riemann integral makes the
	+development longer than one would like, but their argument is
	+reproduced faithfully.</description>
	+ </item>
	+ <item>
	+ <title>A Sequent Calculus Prover for First-Order Logic with Functions</title>
	+ <link>https://www.isa-afp.org/entries/FOL_Seq_Calc2.html</link>
	+ <guid>https://www.isa-afp.org/entries/FOL_Seq_Calc2.html</guid>
	+ <dc:creator> Asta Halkjær From, Frederik Krogsdal Jacobsen </dc:creator>
	+ <pubDate>31 Jan 2022 00:00:00 +0000</pubDate>
	+ <description>
	+We formalize an automated theorem prover for first-order logic with
	+functions. The proof search procedure is based on sequent calculus and
	+we verify its soundness and completeness using the Abstract Soundness
	+and Abstract Completeness theories. Our analytic completeness proof
	+covers both open and closed formulas. Since our deterministic prover
	+considers only the subset of terms relevant to proving a given
	+sequent, we do so as well when building a countermodel from a failed
	+proof. We formally connect our prover with the proof system and
	+semantics of the existing SeCaV system. In particular, the
	+prover's output can be post-processed in Haskell to generate
	+human-readable SeCaV proofs which are also machine-verifiable proof
	+certificates.</description>
	+ </item>
	+ <item>
	+ <title>Interpolation Polynomials (in HOL-Algebra)</title>
	+ <link>https://www.isa-afp.org/entries/Interpolation_Polynomials_HOL_Algebra.html</link>
	+ <guid>https://www.isa-afp.org/entries/Interpolation_Polynomials_HOL_Algebra.html</guid>
	+ <dc:creator> Emin Karayel </dc:creator>
	+ <pubDate>29 Jan 2022 00:00:00 +0000</pubDate>
	+ <description>
	+<p>A well known result from algebra is that, on any field, there
	+is exactly one polynomial of degree less than n interpolating n points
	+[<a
	+href="https://doi.org/10.1017/CBO9780511814549">1</a>,
	+§7].</p> <p>This entry contains a formalization of the
	+above result, as well as the following generalization in the case of
	+finite fields <i>F</i>: There are
	+<i>\|F\|<sup>m-n</sup></i> polynomials of degree
	+less than <i>m ≥ n</i> interpolating the same n points,
	+where <i>\|F\|</i> denotes the size of the domain of the
	+field. To establish the result the entry also includes a formalization
	+of Lagrange interpolation, which might be of independent
	+interest.</p> <p>The formalized results are defined on the
	+algebraic structures from HOL-Algebra, which are distinct from the
	+type-class based structures defined in HOL. Note that there is an
	+existing formalization for polynomial interpolation and, in
	+particular, Lagrange interpolation by Thiemann and Yamada [<a
	+href="https://www.isa-afp.org/entries/Polynomial_Interpolation.html">2</a>]
	+on the type-class based structures in HOL.</p></description>
	+ </item>
	+ <item>
	+ <title>Median Method</title>
	+ <link>https://www.isa-afp.org/entries/Median_Method.html</link>
	+ <guid>https://www.isa-afp.org/entries/Median_Method.html</guid>
	+ <dc:creator> Emin Karayel </dc:creator>
	+ <pubDate>25 Jan 2022 00:00:00 +0000</pubDate>
	+ <description>
	+<p>The median method is an amplification result for randomized
	+approximation algorithms described in [<a
	+href="https://doi.org/10.1006/jcss.1997.1545">1</a>].
	+Given an algorithm whose result is in a desired interval with a
	+probability larger than <i>1/2</i>, it is possible to
	+improve the success probability, by running the algorithm multiple
	+times independently and using the median. In contrast to using the
	+mean, the amplification of the success probability grows exponentially
	+with the number of independent runs.</p> <p>This entry
	+contains a formalization of the underlying theorem: Given a sequence
	+of n independent random variables, which are in a desired interval
	+with a probability <i>1/2 + a</i>. Then their median will
	+be in the desired interval with a probability of <i>1 −
	+exp(−2a<sup>2</sup> n)</i>. In particular, the
	+success probability approaches <i>1</i> exponentially with
	+the number of variables.</p> <p>In addition to that, this
	+entry also contains a proof that order-statistics of Borel-measurable
	+random variables are themselves measurable and that generalized
	+intervals in linearly ordered Borel-spaces are measurable.</p></description>
	+ </item>
	+ <item>
	+ <title>Actuarial Mathematics</title>
	+ <link>https://www.isa-afp.org/entries/Actuarial_Mathematics.html</link>
	+ <guid>https://www.isa-afp.org/entries/Actuarial_Mathematics.html</guid>
	+ <dc:creator> Yosuke Ito </dc:creator>
	+ <pubDate>23 Jan 2022 00:00:00 +0000</pubDate>
	+ <description>
	+Actuarial Mathematics is a theory in applied mathematics, which is
	+mainly used for determining the prices of insurance products and
	+evaluating the liability of a company associating with insurance
	+contracts. It is related to calculus, probability theory and financial
	+theory, etc. In this entry, I formalize the very basic part of
	+Actuarial Mathematics in Isabelle/HOL. The first formalization is
	+about the theory of interest which deals with interest rates, present
	+value factors, an annuity certain, etc. I have already formalized the
	+basic part of Actuarial Mathematics in Coq
	+(https://github.com/Yosuke-Ito-345/Actuary). This entry is currently
	+the partial translation and a little generalization of the Coq
	+formalization. The further translation in Isabelle/HOL is now
	+proceeding.</description>
	+ </item>
	+ <item>
	+ <title>Irrational numbers from THE BOOK</title>
	+ <link>https://www.isa-afp.org/entries/Irrationals_From_THEBOOK.html</link>
	+ <guid>https://www.isa-afp.org/entries/Irrationals_From_THEBOOK.html</guid>
	+ <dc:creator> Lawrence C Paulson </dc:creator>
	+ <pubDate>08 Jan 2022 00:00:00 +0000</pubDate>
	+ <description>
	+An elementary proof is formalised: that <em>exp r</em> is irrational for
	+every nonzero rational number <em>r</em>. The mathematical development comes
	+from the well-known volume <em>Proofs from THE BOOK</em>,
	+by Aigner and Ziegler, who credit the idea to Hermite. The development
	+illustrates a number of basic Isabelle techniques: the manipulation of
	+summations, the calculation of quite complicated derivatives and the
	+estimation of integrals. We also see how to import another AFP entry (Stirling's formula).
	+As for the theorem itself, note that a much stronger and more general
	+result (the Hermite--Lindemann--Weierstraß transcendence theorem) is
	+already available in the AFP.</description>
	+ </item>
	<item>
	<title>Knight's Tour Revisited Revisited</title>
	<link>https://www.isa-afp.org/entries/Knights_Tour.html</link>
	<guid>https://www.isa-afp.org/entries/Knights_Tour.html</guid>
	<dc:creator> Lukas Koller </dc:creator>
	<pubDate>04 Jan 2022 00:00:00 +0000</pubDate>
	<description>
	This is a formalization of the article <i>Knight's Tour Revisited</i> by
	Cull and De Curtins where they prove the existence of a Knight's
	path for arbitrary <i>n &times; m</i>-boards with <i>min(n,m) &ge;
	5</i>. If <i>n &middot; m</i> is even, then there exists a Knight's
	circuit. A Knight's Path is a sequence of moves of a Knight on a
	chessboard s.t. the Knight visits every square of a chessboard
	exactly once. Finding a Knight's path is a an instance of the
	Hamiltonian path problem. A Knight's circuit is a Knight's path,
	where additionally the Knight can move from the last square to the
	first square of the path, forming a loop. During the formalization
	two mistakes in the original proof were discovered. These mistakes
	are corrected in this formalization.</description>
	</item>
	<item>
	<title>Hyperdual Numbers and Forward Differentiation</title>
	<link>https://www.isa-afp.org/entries/Hyperdual.html</link>
	<guid>https://www.isa-afp.org/entries/Hyperdual.html</guid>
	<dc:creator> Filip Smola, Jacques Fleuriot </dc:creator>
	<pubDate>31 Dec 2021 00:00:00 +0000</pubDate>
	<description>
	<p>Hyperdual numbers are ones with a real component and a number
	of infinitesimal components, usually written as $a_0 + a_1 \cdot
	\epsilon_1 + a_2 \cdot \epsilon_2 + a_3 \cdot \epsilon_1\epsilon_2$.
	They have been proposed by <a
	href="https://doi.org/10.2514/6.2011-886">Fike and
	Alonso</a> in an approach to automatic
	differentiation.</p> <p>In this entry we formalise
	hyperdual numbers and their application to forward differentiation. We
	show them to be an instance of multiple algebraic structures and then,
	along with facts about twice-differentiability, we define what we call
	the hyperdual extensions of functions on real-normed fields. This
	extension formally represents the proposed way that the first and
	second derivatives of a function can be automatically calculated. We
	demonstrate it on the standard logistic function $f(x) = \frac{1}{1 +
	e^{-x}}$ and also reproduce the example analytic function $f(x) =
	\frac{e^x}{\sqrt{sin(x)^3 + cos(x)^3}}$ used for demonstration by Fike
	and Alonso.</p></description>
	</item>
	<item>
	<title>Gale-Shapley Algorithm</title>
	<link>https://www.isa-afp.org/entries/Gale_Shapley.html</link>
	<guid>https://www.isa-afp.org/entries/Gale_Shapley.html</guid>
	<dc:creator> Tobias Nipkow </dc:creator>
	<pubDate>29 Dec 2021 00:00:00 +0000</pubDate>
	<description>
	This is a stepwise refinement and proof of the Gale-Shapley stable
	matching (or marriage) algorithm down to executable code. Both a
	purely functional implementation based on lists and a functional
	implementation based on efficient arrays (provided by the Collections
	Framework in the AFP) are developed. The latter implementation runs in
	time <i>O(n<sup>2</sup>)</i> where
	<i>n</i> is the cardinality of the two sets to be matched.</description>
	</item>
	<item>
	<title>Roth's Theorem on Arithmetic Progressions</title>
	<link>https://www.isa-afp.org/entries/Roth_Arithmetic_Progressions.html</link>
	<guid>https://www.isa-afp.org/entries/Roth_Arithmetic_Progressions.html</guid>
	<dc:creator> Chelsea Edmonds, Angeliki Koutsoukou-Argyraki, Lawrence C. Paulson </dc:creator>
	<pubDate>28 Dec 2021 00:00:00 +0000</pubDate>
	<description>
	We formalise a proof of Roth's Theorem on Arithmetic
	Progressions, a major result in additive combinatorics on the
	existence of 3-term arithmetic progressions in subsets of natural
	numbers. To this end, we follow a proof using graph regularity. We
	employ our recent formalisation of Szemerédi's Regularity Lemma,
	a major result in extremal graph theory, which we use here to prove
	the Triangle Counting Lemma and the Triangle Removal Lemma. Our
	sources are Yufei Zhao's MIT lecture notes
	"<a href="https://ocw.mit.edu/courses/mathematics/18-217-graph-theory-and-additive-combinatorics-fall-2019/lecture-notes/MIT18_217F19_ch3.pdf">Graph Theory and Additive Combinatorics</a>"
	(revised version <a href="https://yufeizhao.com/gtac/gtac17.pdf">here</a>)
	and W.T. Gowers's Cambridge lecture notes
	"<a href="https://www.dpmms.cam.ac.uk/~par31/notes/tic.pdf">Topics in Combinatorics</a>".
	We also refer to the University of
	Georgia notes by Stephanie Bell and Will Grodzicki,
	"<a href="http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.432.327">Using Szemerédi's Regularity Lemma to Prove Roth's Theorem</a>".</description>
	</item>
	<item>
	<title>Markov Decision Processes with Rewards</title>
	<link>https://www.isa-afp.org/entries/MDP-Rewards.html</link>
	<guid>https://www.isa-afp.org/entries/MDP-Rewards.html</guid>
	<dc:creator> Maximilian Schäffeler, Mohammad Abdulaziz </dc:creator>
	<pubDate>16 Dec 2021 00:00:00 +0000</pubDate>
	<description>
	We present a formalization of Markov Decision Processes with rewards.
	In particular we first build on Hölzl's formalization of MDPs
	(AFP entry: Markov_Models) and extend them with rewards. We proceed
	with an analysis of the expected total discounted reward criterion for
	infinite horizon MDPs. The central result is the construction of the
	iteration rule for the Bellman operator. We prove the optimality
	equations for this operator and show the existence of an optimal
	stationary deterministic solution. The analysis can be used to obtain
	dynamic programming algorithms such as value iteration and policy
	iteration to solve MDPs with formal guarantees. Our formalization is
	based on chapters 5 and 6 in Puterman's book "Markov
	Decision Processes: Discrete Stochastic Dynamic Programming".</description>
	</item>
	<item>
	<title>Verified Algorithms for Solving Markov Decision Processes</title>
	<link>https://www.isa-afp.org/entries/MDP-Algorithms.html</link>
	<guid>https://www.isa-afp.org/entries/MDP-Algorithms.html</guid>
	<dc:creator> Maximilian Schäffeler, Mohammad Abdulaziz </dc:creator>
	<pubDate>16 Dec 2021 00:00:00 +0000</pubDate>
	<description>
	We present a formalization of algorithms for solving Markov Decision
	Processes (MDPs) with formal guarantees on the optimality of their
	solutions. In particular we build on our analysis of the Bellman
	operator for discounted infinite horizon MDPs. From the iterator rule
	on the Bellman operator we directly derive executable value iteration
	and policy iteration algorithms to iteratively solve finite MDPs. We
	also prove correct optimized versions of value iteration that use
	matrix splittings to improve the convergence rate. In particular, we
	formally verify Gauss-Seidel value iteration and modified policy
	iteration. The algorithms are evaluated on two standard examples from
	the literature, namely, inventory management and gridworld. Our
	formalization covers most of chapter 6 in Puterman's book
	"Markov Decision Processes: Discrete Stochastic Dynamic
	Programming".</description>
	</item>
	<item>
	<title>Regular Tree Relations</title>
	<link>https://www.isa-afp.org/entries/Regular_Tree_Relations.html</link>
	<guid>https://www.isa-afp.org/entries/Regular_Tree_Relations.html</guid>
	<dc:creator> Alexander Lochmann, Bertram Felgenhauer, Christian Sternagel, René Thiemann, Thomas Sternagel </dc:creator>
	<pubDate>15 Dec 2021 00:00:00 +0000</pubDate>
	<description>
	Tree automata have good closure properties and therefore a commonly
	used to prove/disprove properties. This formalization contains among
	other things the proofs of many closure properties of tree automata
	(anchored) ground tree transducers and regular relations. Additionally
	it includes the well known pumping lemma and a lifting of the Myhill
	Nerode theorem for regular languages to tree languages. We want to
	mention the existence of a <a
	href="https://www.isa-afp.org/entries/Tree-Automata.html">tree
	automata APF-entry</a> developed by Peter Lammich. His work is
	based on epsilon free top-down tree automata, while this entry builds
	on bottom-up tree auotamta with epsilon transitions. Moreover our
	formalization relies on the <a
	href="https://www.isa-afp.org/entries/Collections.html">Collections
	Framework</a>, also by Peter Lammich, to obtain efficient code.
	All proven constructions of the closure properties are exportable
	using the Isabelle/HOL code generation facilities.</description>
	</item>
	<item>
	<title>Simplicial Complexes and Boolean functions</title>
	<link>https://www.isa-afp.org/entries/Simplicial_complexes_and_boolean_functions.html</link>
	<guid>https://www.isa-afp.org/entries/Simplicial_complexes_and_boolean_functions.html</guid>
	<dc:creator> Jesús Aransay, Alejandro del Campo, Julius Michaelis </dc:creator>
	<pubDate>29 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	In this work we formalise the isomorphism between simplicial complexes
	of dimension $n$ and monotone Boolean functions in $n$ variables,
	mainly following the definitions and results as introduced by N. A.
	Scoville. We also take advantage of the AFP
	representation of <a href="https://www.isa-afp.org/entries/ROBDD.html">ROBDD</a>
	(Reduced Ordered Binary Decision Diagrams) to compute the ROBDD representation of a
	given simplicial complex (by means of the isomorphism to Boolean
	functions). Some examples of simplicial complexes and associated
	Boolean functions are also presented.</description>
	</item>
	<item>
	<title>van Emde Boas Trees</title>
	<link>https://www.isa-afp.org/entries/Van_Emde_Boas_Trees.html</link>
	<guid>https://www.isa-afp.org/entries/Van_Emde_Boas_Trees.html</guid>
	<dc:creator> Thomas Ammer, Peter Lammich </dc:creator>
	<pubDate>23 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	The <em>van Emde Boas tree</em> or <em>van Emde Boas
	priority queue</em> is a data structure supporting membership
	test, insertion, predecessor and successor search, minimum and maximum
	determination and deletion in <em>O(log log U)</em> time, where <em>U =
	0,...,2<sup>n-1</sup></em> is the overall range to be
	considered. <p/> The presented formalization follows Chapter 20
	of the popular <em>Introduction to Algorithms (3rd
	ed.)</em> by Cormen, Leiserson, Rivest and Stein (CLRS),
	extending the list of formally verified CLRS algorithms. Our current
	formalization is based on the first author's bachelor's
	thesis. <p/> First, we prove correct a
	<em>functional</em> implementation, w.r.t. an abstract
	data type for sets. Apart from functional correctness, we show a
	resource bound, and runtime bounds w.r.t. manually defined timing
	functions for the operations. <p/> Next, we refine the
	operations to Imperative HOL with time, and show correctness and
	complexity. This yields a practically more efficient implementation,
	and eliminates the manually defined timing functions from the trusted
	base of the proof.</description>
	</item>
	<item>
	<title>Foundation of geometry in planes, and some complements: Excluding the parallel axioms</title>
	<link>https://www.isa-afp.org/entries/Foundation_of_geometry.html</link>
	<guid>https://www.isa-afp.org/entries/Foundation_of_geometry.html</guid>
	<dc:creator> Fumiya Iwama </dc:creator>
	<pubDate>22 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	"Foundations of Geometry" is a mathematical book written by
	Hilbert in 1899. This entry is a complete formalization of
	"Incidence" (excluding cubic axioms), "Order" and
	"Congruence" (excluding point sequences) of the axioms
	constructed in this book. In addition, the theorem of the problem
	about the part that is treated implicitly and is not clearly stated in
	it is being carried out in parallel.</description>
	</item>
	<item>
	<title>The Hahn and Jordan Decomposition Theorems</title>
	<link>https://www.isa-afp.org/entries/Hahn_Jordan_Decomposition.html</link>
	<guid>https://www.isa-afp.org/entries/Hahn_Jordan_Decomposition.html</guid>
	<dc:creator> Marie Cousin, Mnacho Echenim, Hervé Guiol </dc:creator>
	<pubDate>19 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	In this work we formalize the Hahn decomposition theorem for signed
	measures, namely that any measure space for a signed measure can be
	decomposed into a positive and a negative set, where every measurable
	subset of the positive one has a positive measure, and every
	measurable subset of the negative one has a negative measure. We also
	formalize the Jordan decomposition theorem as a corollary, which
	states that the signed measure under consideration admits a unique
	decomposition into a difference of two positive measures, at least one
	of which is finite.</description>
	</item>
	<item>
	<title>Exploring Simplified Variants of Gödel’s Ontological Argument in Isabelle/HOL</title>
	<link>https://www.isa-afp.org/entries/SimplifiedOntologicalArgument.html</link>
	<guid>https://www.isa-afp.org/entries/SimplifiedOntologicalArgument.html</guid>
	<dc:creator> Christoph Benzmüller </dc:creator>
	<pubDate>08 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	<p>Simplified variants of Gödel's ontological argument are
	explored. Among those is a particularly interesting simplified
	argument which is (i) valid already in basic
	modal logics K or KT, (ii) which does not suffer from modal collapse,
	and (iii) which avoids the rather complex predicates of essence (Ess.)
	and necessary existence (NE) as used by Gödel.
	</p><p>
	Whether the presented variants increase or decrease the
	attractiveness and persuasiveness of the ontological argument is a
	question I would like to pass on to philosophy and theology.
	</p></description>
	</item>
	<item>
	<title>Real Exponents as the Limits of Sequences of Rational Exponents</title>
	<link>https://www.isa-afp.org/entries/Real_Power.html</link>
	<guid>https://www.isa-afp.org/entries/Real_Power.html</guid>
	<dc:creator> Jacques D. Fleuriot </dc:creator>
	<pubDate>08 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	In this formalisation, we construct real exponents as the limits of
	sequences of rational exponents. In particular, if $a \ge 1$ and $x
	\in \mathbb{R}$, we choose an increasing rational sequence $r_n$ such
	that $\lim_{n\to\infty} {r_n} = x$. Then the sequence $a^{r_n}$ is
	increasing and if $r$ is any rational number such that $r > x$,
	$a^{r_n}$ is bounded above by $a^r$. By the convergence criterion for
	monotone sequences, $a^{r_n}$ converges. We define $a^ x =
	\lim_{n\to\infty} a^{r_n}$ and show that it has the expected
	properties (for $a \ge 0$). This particular construction of real
	exponents is needed instead of the usual one using the natural
	logarithm and exponential functions (which already exists in Isabelle)
	to support our mechanical derivation of Euler's exponential
	series as an ``infinite polynomial". Aside from helping us avoid
	circular reasoning, this is, as far as we are aware, the first time
	real exponents are mechanised in this way within a proof assistant.</description>
	</item>
	<item>
	<title>Automating Public Announcement Logic and the Wise Men Puzzle in Isabelle/HOL</title>
	<link>https://www.isa-afp.org/entries/PAL.html</link>
	<guid>https://www.isa-afp.org/entries/PAL.html</guid>
	<dc:creator> Christoph Benzmüller, Sebastian Reiche </dc:creator>
	<pubDate>08 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	We present a shallow embedding of public announcement logic (PAL) with
	relativized general knowledge in HOL. We then use PAL to obtain an
	elegant encoding of the wise men puzzle, which we solve automatically
	using sledgehammer.</description>
	</item>
	<item>
	<title>Factorization of Polynomials with Algebraic Coefficients</title>
	<link>https://www.isa-afp.org/entries/Factor_Algebraic_Polynomial.html</link>
	<guid>https://www.isa-afp.org/entries/Factor_Algebraic_Polynomial.html</guid>
	<dc:creator> Manuel Eberl, René Thiemann </dc:creator>
	<pubDate>08 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	The AFP already contains a verified implementation of algebraic
	numbers. However, it is has a severe limitation in its factorization
	algorithm of real and complex polynomials: the factorization is only
	guaranteed to succeed if the coefficients of the polynomial are
	rational numbers. In this work, we verify an algorithm to factor all
	real and complex polynomials whose coefficients are algebraic. The
	existence of such an algorithm proves in a constructive way that the
	set of complex algebraic numbers is algebraically closed. Internally,
	the algorithm is based on resultants of multivariate polynomials and
	an approximation algorithm using interval arithmetic.</description>
	</item>
	<item>
	<title>Szemerédi's Regularity Lemma</title>
	<link>https://www.isa-afp.org/entries/Szemeredi_Regularity.html</link>
	<guid>https://www.isa-afp.org/entries/Szemeredi_Regularity.html</guid>
	<dc:creator> Chelsea Edmonds, Angeliki Koutsoukou-Argyraki, Lawrence C. Paulson </dc:creator>
	<pubDate>05 Nov 2021 00:00:00 +0000</pubDate>
	<description>
	<a
	href="https://en.wikipedia.org/wiki/Szemerédi_regularity_lemma">Szemerédi's
	regularity lemma</a> is a key result in the study of large
	graphs. It asserts the existence of an upper bound on the number of parts
	the vertices of a graph need to be partitioned into such that the
	edges between the parts are random in a certain sense. This bound
	depends only on the desired precision and not on the graph itself, in
	the spirit of Ramsey's theorem. The formalisation follows online
	course notes by <a
	href="https://www.dpmms.cam.ac.uk/~par31/notes/tic.pdf">Tim
	Gowers</a> and <a
	href="https://yufeizhao.com/gtac/gtac.pdf">Yufei
	Zhao</a>.</description>
	</item>
	- <item>
	- <title>Quantum and Classical Registers</title>
	- <link>https://www.isa-afp.org/entries/Registers.html</link>
	- <guid>https://www.isa-afp.org/entries/Registers.html</guid>
	- <dc:creator> Dominique Unruh </dc:creator>
	- <pubDate>28 Oct 2021 00:00:00 +0000</pubDate>
	- <description>
	-A formalization of the theory of quantum and classical registers as
	-developed by (Unruh, Quantum and Classical Registers). In a nutshell,
	-a register refers to a part of a larger memory or system that can be
	-accessed independently. Registers can be constructed from other
	-registers and several (compatible) registers can be composed. This
	-formalization develops both the generic theory of registers as well as
	-specific instantiations for classical and quantum registers.</description>
	- </item>
	- <item>
	- <title>Belief Revision Theory</title>
	- <link>https://www.isa-afp.org/entries/Belief_Revision.html</link>
	- <guid>https://www.isa-afp.org/entries/Belief_Revision.html</guid>
	- <dc:creator> Valentin Fouillard, Safouan Taha, Frédéric Boulanger, Nicolas Sabouret </dc:creator>
	- <pubDate>19 Oct 2021 00:00:00 +0000</pubDate>
	- <description>
	-The 1985 paper by Carlos Alchourrón, Peter Gärdenfors, and David
	-Makinson (AGM), “On the Logic of Theory Change: Partial Meet
	-Contraction and Revision Functions” launches a large and rapidly
	-growing literature that employs formal models and logics to handle
	-changing beliefs of a rational agent and to take into account new
	-piece of information observed by this agent. In 2011, a review book
	-titled "AGM 25 Years: Twenty-Five Years of Research in Belief
	-Change" was edited to summarize the first twenty five years of
	-works based on AGM. This HOL-based AFP entry is a faithful
	-formalization of the AGM operators (e.g. contraction, revision,
	-remainder ...) axiomatized in the original paper. It also contains the
	-proofs of all the theorems stated in the paper that show how these
	-operators combine. Both proofs of Harper and Levi identities are
	-established.</description>
	- </item>
	- <item>
	- <title>X86 instruction semantics and basic block symbolic execution</title>
	- <link>https://www.isa-afp.org/entries/X86_Semantics.html</link>
	- <guid>https://www.isa-afp.org/entries/X86_Semantics.html</guid>
	- <dc:creator> Freek Verbeek, Abhijith Bharadwaj, Joshua Bockenek, Ian Roessle, Timmy Weerwag, Binoy Ravindran </dc:creator>
	- <pubDate>13 Oct 2021 00:00:00 +0000</pubDate>
	- <description>
	-This AFP entry provides semantics for roughly 120 different X86-64
	-assembly instructions. These instructions include various moves,
	-arithmetic/logical operations, jumps, call/return, SIMD extensions and
	-others. External functions are supported by allowing a user to provide
	-custom semantics for these calls. Floating-point operations are mapped
	-to uninterpreted functions. The model provides semantics for register
	-aliasing and a byte-level little-endian memory model. The semantics
	-are purposefully incomplete, but overapproximative. For example, the
	-precise effect of flags may be undefined for certain instructions, or
	-instructions may simply have no semantics at all. In those cases, the
	-semantics are mapped to universally quantified uninterpreted terms
	-from a locale. Second, this entry provides a method to symbolic
	-execution of basic blocks. The method, called
	-''se_step'' (for: symbolic execution step) fetches
	-an instruction and updates the current symbolic state while keeping
	-track of assumptions made over the memory model. A key component is a
	-set of theorems that prove how reads from memory resolve after writes
	-have occurred. Thirdly, this entry provides a parser that allows the
	-user to copy-paste the output of the standard disassembly tool objdump
	-into Isabelle/HOL. A couple small and explanatory examples are
	-included, including functions from the word count program. Several
	-examples can be supplied upon request (they are not included due to
	-the running time of verification): functions from the floating-point
	-modulo function from FDLIBM, the GLIBC strlen function and the
	-CoreUtils SHA256 implementation.</description>
	- </item>
	- <item>
	- <title>Algebras for Iteration, Infinite Executions and Correctness of Sequential Computations</title>
	- <link>https://www.isa-afp.org/entries/Correctness_Algebras.html</link>
	- <guid>https://www.isa-afp.org/entries/Correctness_Algebras.html</guid>
	- <dc:creator> Walter Guttmann </dc:creator>
	- <pubDate>12 Oct 2021 00:00:00 +0000</pubDate>
	- <description>
	-We study models of state-based non-deterministic sequential
	-computations and describe them using algebras. We propose algebras
	-that describe iteration for strict and non-strict computations. They
	-unify computation models which differ in the fixpoints used to
	-represent iteration. We propose algebras that describe the infinite
	-executions of a computation. They lead to a unified approximation
	-order and results that connect fixpoints in the approximation and
	-refinement orders. This unifies the semantics of recursion for a range
	-of computation models. We propose algebras that describe preconditions
	-and the effect of while-programs under postconditions. They unify
	-correctness statements in two dimensions: one statement applies in
	-various computation models to various correctness claims.</description>
	- </item>
	- <item>
	- <title>Verified Quadratic Virtual Substitution for Real Arithmetic</title>
	- <link>https://www.isa-afp.org/entries/Virtual_Substitution.html</link>
	- <guid>https://www.isa-afp.org/entries/Virtual_Substitution.html</guid>
	- <dc:creator> Matias Scharager, Katherine Cordwell, Stefan Mitsch, André Platzer </dc:creator>
	- <pubDate>02 Oct 2021 00:00:00 +0000</pubDate>
	- <description>
	-This paper presents a formally verified quantifier elimination (QE)
	-algorithm for first-order real arithmetic by linear and quadratic
	-virtual substitution (VS) in Isabelle/HOL. The Tarski-Seidenberg
	-theorem established that the first-order logic of real arithmetic is
	-decidable by QE. However, in practice, QE algorithms are highly
	-complicated and often combine multiple methods for performance. VS is
	-a practically successful method for QE that targets formulas with
	-low-degree polynomials. To our knowledge, this is the first work to
	-formalize VS for quadratic real arithmetic including inequalities. The
	-proofs necessitate various contributions to the existing multivariate
	-polynomial libraries in Isabelle/HOL. Our framework is modularized and
	-easily expandable (to facilitate integrating future optimizations),
	-and could serve as a basis for developing practical general-purpose QE
	-algorithms. Further, as our formalization is designed with
	-practicality in mind, we export our development to SML and test the
	-resulting code on 378 benchmarks from the literature, comparing to
	-Redlog, Z3, Wolfram Engine, and SMT-RAT. This identified
	-inconsistencies in some tools, underscoring the significance of a
	-verified approach for the intricacies of real arithmetic.</description>
	- </item>
	- <item>
	- <title>Soundness and Completeness of an Axiomatic System for First-Order Logic</title>
	- <link>https://www.isa-afp.org/entries/FOL_Axiomatic.html</link>
	- <guid>https://www.isa-afp.org/entries/FOL_Axiomatic.html</guid>
	- <dc:creator> Asta Halkjær From </dc:creator>
	- <pubDate>24 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-This work is a formalization of the soundness and completeness of an
	-axiomatic system for first-order logic. The proof system is based on
	-System Q1 by Smullyan and the completeness proof follows his textbook
	-"First-Order Logic" (Springer-Verlag 1968). The completeness
	-proof is in the Henkin style where a consistent set is extended to a
	-maximal consistent set using Lindenbaum's construction and Henkin
	-witnesses are added during the construction to ensure saturation as
	-well. The resulting set is a Hintikka set which, by the model
	-existence theorem, is satisfiable in the Herbrand universe.</description>
	- </item>
	- <item>
	- <title>Complex Bounded Operators</title>
	- <link>https://www.isa-afp.org/entries/Complex_Bounded_Operators.html</link>
	- <guid>https://www.isa-afp.org/entries/Complex_Bounded_Operators.html</guid>
	- <dc:creator> Jose Manuel Rodriguez Caballero, Dominique Unruh </dc:creator>
	- <pubDate>18 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-We present a formalization of bounded operators on complex vector
	-spaces. Our formalization contains material on complex vector spaces
	-(normed spaces, Banach spaces, Hilbert spaces) that complements and
	-goes beyond the developments of real vectors spaces in the
	-Isabelle/HOL standard library. We define the type of bounded
	-operators between complex vector spaces
	-(<em>cblinfun</em>) and develop the theory of unitaries,
	-projectors, extension of bounded linear functions (BLT theorem),
	-adjoints, Loewner order, closed subspaces and more. For the
	-finite-dimensional case, we provide code generation support by
	-identifying finite-dimensional operators with matrices as formalized
	-in the <a href="Jordan_Normal_Form.html">Jordan_Normal_Form</a> AFP entry.</description>
	- </item>
	- <item>
	- <title>A Formalization of Weighted Path Orders and Recursive Path Orders</title>
	- <link>https://www.isa-afp.org/entries/Weighted_Path_Order.html</link>
	- <guid>https://www.isa-afp.org/entries/Weighted_Path_Order.html</guid>
	- <dc:creator> Christian Sternagel, René Thiemann, Akihisa Yamada </dc:creator>
	- <pubDate>16 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-We define the weighted path order (WPO) and formalize several
	-properties such as strong normalization, the subterm property, and
	-closure properties under substitutions and contexts. Our definition of
	-WPO extends the original definition by also permitting multiset
	-comparisons of arguments instead of just lexicographic extensions.
	-Therefore, our WPO not only subsumes lexicographic path orders (LPO),
	-but also recursive path orders (RPO). We formally prove these
	-subsumptions and therefore all of the mentioned properties of WPO are
	-automatically transferable to LPO and RPO as well. Such a
	-transformation is not required for Knuth&ndash;Bendix orders
	-(KBO), since they have already been formalized. Nevertheless, we still
	-provide a proof that WPO subsumes KBO and thereby underline the
	-generality of WPO.</description>
	- </item>
	- <item>
	- <title>Extension of Types-To-Sets</title>
	- <link>https://www.isa-afp.org/entries/Types_To_Sets_Extension.html</link>
	- <guid>https://www.isa-afp.org/entries/Types_To_Sets_Extension.html</guid>
	- <dc:creator> Mihails Milehins </dc:creator>
	- <pubDate>06 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-In their article titled <i>From Types to Sets by Local Type
	-Definitions in Higher-Order Logic</i> and published in the
	-proceedings of the conference <i>Interactive Theorem
	-Proving</i> in 2016, Ondřej Kunčar and Andrei Popescu propose an
	-extension of the logic Isabelle/HOL and an associated algorithm for
	-the relativization of the <i>type-based theorems</i> to
	-more flexible <i>set-based theorems</i>, collectively
	-referred to as <i>Types-To-Sets</i>. One of the aims of
	-their work was to open an opportunity for the development of a
	-software tool for applied relativization in the implementation of the
	-logic Isabelle/HOL of the proof assistant Isabelle. In this article,
	-we provide a prototype of a software framework for the interactive
	-automated relativization of theorems in Isabelle/HOL, developed as an
	-extension of the proof language Isabelle/Isar. The software framework
	-incorporates the implementation of the proposed extension of the
	-logic, and builds upon some of the ideas for further work expressed in
	-the original article on Types-To-Sets by Ondřej Kunčar and Andrei
	-Popescu and the subsequent article <i>Smooth Manifolds and Types
	-to Sets for Linear Algebra in Isabelle/HOL</i> that was written
	-by Fabian Immler and Bohua Zhan and published in the proceedings of
	-the <i>International Conference on Certified Programs and
	-Proofs</i> in 2019.</description>
	- </item>
	- <item>
	- <title>IDE: Introduction, Destruction, Elimination</title>
	- <link>https://www.isa-afp.org/entries/Intro_Dest_Elim.html</link>
	- <guid>https://www.isa-afp.org/entries/Intro_Dest_Elim.html</guid>
	- <dc:creator> Mihails Milehins </dc:creator>
	- <pubDate>06 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-The article provides the command <b>mk_ide</b> for the
	-object logic Isabelle/HOL of the formal proof assistant Isabelle. The
	-command <b>mk_ide</b> enables the automated synthesis of
	-the introduction, destruction and elimination rules from arbitrary
	-definitions of constant predicates stated in Isabelle/HOL.</description>
	- </item>
	- <item>
	- <title>Conditional Transfer Rule</title>
	- <link>https://www.isa-afp.org/entries/Conditional_Transfer_Rule.html</link>
	- <guid>https://www.isa-afp.org/entries/Conditional_Transfer_Rule.html</guid>
	- <dc:creator> Mihails Milehins </dc:creator>
	- <pubDate>06 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-This article provides a collection of experimental utilities for
	-unoverloading of definitions and synthesis of conditional transfer
	-rules for the object logic Isabelle/HOL of the formal proof assistant
	-Isabelle written in Isabelle/ML.</description>
	- </item>
	- <item>
	- <title>Conditional Simplification</title>
	- <link>https://www.isa-afp.org/entries/Conditional_Simplification.html</link>
	- <guid>https://www.isa-afp.org/entries/Conditional_Simplification.html</guid>
	- <dc:creator> Mihails Milehins </dc:creator>
	- <pubDate>06 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-The article provides a collection of experimental general-purpose
	-proof methods for the object logic Isabelle/HOL of the formal proof
	-assistant Isabelle. The methods in the collection offer functionality
	-that is similar to certain aspects of the functionality provided by
	-the standard proof methods of Isabelle that combine classical
	-reasoning and rewriting, such as the method <i>auto</i>,
	-but use a different approach for rewriting. More specifically, these
	-methods allow for the side conditions of the rewrite rules to be
	-solved via intro-resolution.</description>
	- </item>
	- <item>
	- <title>Category Theory for ZFC in HOL III: Universal Constructions</title>
	- <link>https://www.isa-afp.org/entries/CZH_Universal_Constructions.html</link>
	- <guid>https://www.isa-afp.org/entries/CZH_Universal_Constructions.html</guid>
	- <dc:creator> Mihails Milehins </dc:creator>
	- <pubDate>06 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-The article provides a formalization of elements of the theory of
	-universal constructions for 1-categories (such as limits, adjoints and
	-Kan extensions) in the object logic ZFC in HOL of the formal proof
	-assistant Isabelle. The article builds upon the foundations
	-established in the AFP entry <i>Category Theory for ZFC in HOL
	-II: Elementary Theory of 1-Categories</i>.</description>
	- </item>
	- <item>
	- <title>Category Theory for ZFC in HOL I: Foundations: Design Patterns, Set Theory, Digraphs, Semicategories</title>
	- <link>https://www.isa-afp.org/entries/CZH_Foundations.html</link>
	- <guid>https://www.isa-afp.org/entries/CZH_Foundations.html</guid>
	- <dc:creator> Mihails Milehins </dc:creator>
	- <pubDate>06 Sep 2021 00:00:00 +0000</pubDate>
	- <description>
	-This article provides a foundational framework for the formalization
	-of category theory in the object logic ZFC in HOL of the formal proof
	-assistant Isabelle. More specifically, this article provides a
	-formalization of canonical set-theoretic constructions internalized in
	-the type <i>V</i> associated with the ZFC in HOL,
	-establishes a design pattern for the formalization of mathematical
	-structures using sequences and locales, and showcases the developed
	-infrastructure by providing formalizations of the elementary theories
	-of digraphs and semicategories. The methodology chosen for the
	-formalization of the theories of digraphs and semicategories (and
	-categories in future articles) rests on the ideas that were originally
	-expressed in the article <i>Set-Theoretical Foundations of
	-Category Theory</i> written by Solomon Feferman and Georg
	-Kreisel. Thus, in the context of this work, each of the aforementioned
	-mathematical structures is represented as a term of the type
	-<i>V</i> embedded into a stage of the von Neumann
	-hierarchy.</description>
	- </item>
	</channel>
	</rss>
	diff --git a/web/statistics.html b/web/statistics.html
	--- a/web/statistics.html
	+++ b/web/statistics.html
	@@ -1,303 +1,302 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Archive of Formal Proofs</title>
	<link rel="stylesheet" type="text/css" href="front.css">
	<link rel="icon" href="images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="rss.xml">
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1><font class="first">S</font>tatistics
	</h1>
	<p> </p>

	<table width="80%" class="descr">
	<tbody>
	<tr><td>
	<h2>Statistics</h2>

	<table>
	-<tr><td>Number of Articles:</td><td class="statsnumber">651</td></tr>
	-<tr><td>Number of Authors:</td><td class="statsnumber">419</td></tr>
	-<tr><td>Number of lemmas:</td><td class="statsnumber">~191,700</td></tr>
	-<tr><td>Lines of Code:</td><td class="statsnumber">~3,311,200</td></tr>
	+<tr><td>Number of Articles:</td><td class="statsnumber">665</td></tr>
	+<tr><td>Number of Authors:</td><td class="statsnumber">423</td></tr>
	+<tr><td>Number of lemmas:</td><td class="statsnumber">~194,500</td></tr>
	+<tr><td>Lines of Code:</td><td class="statsnumber">~3,350,900</td></tr>
	</table>
	<h4>Most used AFP articles:</h4>
	<table id="most_used">
	<tr>
	<th></th><th>Name</th><th>Used by ? articles</th>
	</tr>

	<tr><td>1.</td>

	<td><a href="entries/List-Index.html">List-Index</a></td>
	<td>20</td>
	</tr>
	<tr><td>2.</td>

	+ <td><a href="entries/Collections.html">Collections</a></td>
	+ <td>14</td>
	+ </tr>
	+ <td></td>
	<td><a href="entries/Show.html">Show</a></td>
	<td>14</td>
	</tr>
	<tr><td>3.</td>

	- <td><a href="entries/Collections.html">Collections</a></td>
	- <td>13</td>
	- </tr>
	- <tr><td>4.</td>
	-
	<td><a href="entries/Coinductive.html">Coinductive</a></td>
	<td>12</td>
	</tr>
	<td></td>
	<td><a href="entries/Jordan_Normal_Form.html">Jordan_Normal_Form</a></td>
	<td>12</td>
	</tr>
	<td></td>
	<td><a href="entries/Regular-Sets.html">Regular-Sets</a></td>
	<td>12</td>
	</tr>
	- <tr><td>5.</td>
	+ <tr><td>4.</td>

	<td><a href="entries/Landau_Symbols.html">Landau_Symbols</a></td>
	<td>11</td>
	</tr>
	<td></td>
	<td><a href="entries/Polynomial_Factorization.html">Polynomial_Factorization</a></td>
	<td>11</td>
	</tr>
	- <tr><td>6.</td>
	+ <tr><td>5.</td>

	<td><a href="entries/Abstract-Rewriting.html">Abstract-Rewriting</a></td>
	<td>10</td>
	</tr>
	<td></td>
	<td><a href="entries/Automatic_Refinement.html">Automatic_Refinement</a></td>
	<td>10</td>
	</tr>
	<td></td>
	<td><a href="entries/Deriving.html">Deriving</a></td>
	<td>10</td>
	</tr>

	</table>
	<script>
	// DATA
	var years = [2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022];
	-var no_articles = [14, 22, 29, 37, 52, 64, 86, 103, 128, 151, 208, 253, 326, 396, 455, 511, 577, 650, 651];
	-var no_loc = [60600.0, 96900.0, 131500.0, 239000.0, 353800.0, 436000.0, 517100.0, 568200.0, 740500.0, 827800.0, 1039600.0, 1220100.0, 1599100.0, 1855000.0, 2126600.0, 2429900.0, 2825300.0, 3308000.0, 3311200.0 ];
	-var no_authors = [14, 11, 6, 6, 10, 6, 24, 11, 17, 16, 37, 20, 63, 31, 28, 39, 34, 45, 1];
	-var no_authors_series = [14, 25, 31, 37, 47, 53, 77, 88, 105, 121, 158, 178, 241, 272, 300, 339, 373, 418, 419];
	-var all_articles = [ "MiniML","AVL-Trees","Functional-Automata","BinarySearchTree","Lazy-Lists-II","Topology","Group-Ring-Module","Depth-First-Search","Compiling-Exceptions-Correctly","Completeness","Ramsey-Infinite","Verified-Prover","Integration","FileRefinement","Category","RSAPSS","Jinja","JiveDataStoreModel","DiskPaxos","GenClock","FFT","Ordinal","Cauchy","ClockSynchInst","FeatherweightJava","CoreC++","Flyspeck-Tame","Abstract-Hoare-Logics","HotelKeyCards","FOL-Fitting","POPLmark-deBruijn","Valuation","SumSquares","Fermat3_4","MuchAdoAboutTwo","JinjaThreads","Program-Conflict-Analysis","LinearQuantifierElim","NormByEval","Simpl","BDD","Recursion-Theory-I","SATSolverVerification","FunWithFunctions","ArrowImpossibilityGS","VolpanoSmith","Slicing","Huffman","FunWithTilings","SenSocialChoice","SIFPL","BytecodeLogicJmlTypes","Stream-Fusion","FinFun","CofGroups","SequentInvertibility","Ordinals_and_Cardinals","WorkerWrapper","HRB-Slicing","Perfect-Number-Thm","Collections","Tree-Automata","Presburger-Automata","DPT-SAT-Solver","Coinductive","List-Index","InformationFlowSlicing","InformationFlowSlicing_Inter","Free-Boolean-Algebra","Locally-Nameless-Sigma","Regular-Sets","Robbins-Conjecture","DataRefinementIBP","GraphMarkingIBP","Abstract-Rewriting","Matrix","Category2","Free-Groups","Statecharts","Polynomials","Lam-ml-Normalization","Binomial-Queues","Binomial-Heaps","Finger-Trees","Shivers-CFA","Marriage","Lower_Semicontinuous","RIPEMD-160-SPARK","LightweightJava","List-Infinite","AutoFocus-Stream","Nat-Interval-Logic","Transitive-Closure","General-Triangle","KBPs","Max-Card-Matching","Gauss-Jordan-Elim-Fun","Myhill-Nerode","LatticeProperties","MonoBoolTranAlgebra","PseudoHoops","Efficient-Mergesort","TLA","Markov_Models","Dijkstra_Shortest_Path","Refine_Monadic","Girth_Chromatic","Transitive-Closure-II","Abortable_Linearizable_Modules","Well_Quasi_Orders","Ordinary_Differential_Equations","Inductive_Confidentiality","Stuttering_Equivalence","Separation_Algebra","Circus","Psi_Calculi","CCS","Pi_Calculus","Tycon","PCF","Heard_Of","Impossible_Geometry","Datatype_Order_Generator","Possibilistic_Noninterference","Bondy","Tarskis_Geometry","Open_Induction","Separation_Logic_Imperative_HOL","Sqrt_Babylonian","Kleene_Algebra","Rank_Nullity_Theorem","Ribbon_Proofs","Launchbury","Nominal2","Containers","Graph_Theory","ShortestPath","Sort_Encodings","Koenigsberg_Friendship","Lehmer","Pratt_Certificate","IEEE_Floating_Point","Native_Word","Automatic_Refinement","Decreasing-Diagrams","GoedelGod","FocusStreamsCaseStudies","Coinductive_Languages","Incompleteness","HereditarilyFinite","Tail_Recursive_Functions","CryptoBasedCompositionalProperties","Sturm_Sequences","Featherweight_OCL","KAT_and_DRA","Relation_Algebra","Secondary_Sylow","Regex_Equivalence","Real_Impl","Affine_Arithmetic","Selection_Heap_Sort","Random_Graph_Subgraph_Threshold","Partial_Function_MR","AWN","Probabilistic_Noninterference","GPU_Kernel_PL","Discrete_Summation","HyperCTL","Abstract_Completeness","Bounded_Deducibility_Security","SIFUM_Type_Systems","WHATandWHERE_Security","Strong_Security","ComponentDependencies","Regular_Algebras","Noninterference_CSP","Roy_Floyd_Warshall","Gabow_SCC","CAVA_Automata","CAVA_LTL_Modelchecker","LTL_to_GBA","Promela","Boolean_Expression_Checkers","MSO_Regex_Equivalence","Pop_Refinement","Network_Security_Policy_Verification","Amortized_Complexity","pGCL","CISC-Kernel","Show","Splay_Tree","Skew_Heap","VectorSpace","Special_Function_Bounds","Gauss_Jordan","Priority_Queue_Braun","Jordan_Hoelder","Cayley_Hamilton","Sturm_Tarski","Imperative_Insertion_Sort","Certification_Monads","XML","RefinementReactive","Density_Compiler","Stream_Fusion_Code","Lifting_Definition_Option","AODV","UPF","UpDown_Scheme","Finite_Automata_HF","QR_Decomposition","Echelon_Form","Call_Arity","Deriving","Consensus_Refined","Trie","ConcurrentIMP","ConcurrentGC","Residuated_Lattices","Vickrey_Clarke_Groves","Probabilistic_System_Zoo","Formula_Derivatives","Dynamic_Tables","Noninterference_Ipurge_Unwinding","Noninterference_Generic_Unwinding","List_Interleaving","Multirelations","Derangements","Hermite","Akra_Bazzi","Landau_Symbols","Case_Labeling","Encodability_Process_Calculi","Rep_Fin_Groups","Noninterference_Inductive_Unwinding","Decreasing-Diagrams-II","Jordan_Normal_Form","LTL_to_DRA","Isabelle_Meta_Model","Parity_Game","Planarity_Certificates","TortoiseHare","Euler_Partition","Ergodic_Theory","Latin_Square","Card_Partitions","Applicative_Lifting","Algebraic_Numbers","Stern_Brocot","Liouville_Numbers","Triangle","Prime_Harmonic_Series","Descartes_Sign_Rule","Card_Number_Partitions","Matrix_Tensor","Knot_Theory","Polynomial_Factorization","Polynomial_Interpolation","Formal_SSA","List_Update","LTL","Cartan_FP","Timed_Automata","PropResPI","KAD","Noninterference_Sequential_Composition","ROBDD","CYK","No_FTL_observers","Groebner_Bases","Bell_Numbers_Spivey","SDS_Impossibility","Randomised_Social_Choice","MFMC_Countable","FLP","Perron_Frobenius","Incredible_Proof_Machine","Posix-Lexing","Card_Equiv_Relations","Tree_Decomposition","Word_Lib","Noninterference_Concurrent_Composition","Algebraic_VCs","Catalan_Numbers","Dependent_SIFUM_Type_Systems","Card_Multisets","Category3","Dependent_SIFUM_Refinement","IP_Addresses","Rewriting_Z","Resolution_FOL","Buildings","DFS_Framework","Pairing_Heap","Surprise_Paradox","Ptolemys_Theorem","Refine_Imperative_HOL","EdmondsKarp_Maxflow","InfPathElimination","Simple_Firewall","Routing","Stirling_Formula","Stone_Algebras","SuperCalc","Iptables_Semantics","Lambda_Free_RPOs","Allen_Calculus","Fisher_Yates","Lp","Chord_Segments","Berlekamp_Zassenhaus","Source_Coding_Theorem","SPARCv8","LOFT","Stable_Matching","Modal_Logics_for_NTS","Deep_Learning","Lambda_Free_KBOs","Nested_Multisets_Ordinals","Separata","Abs_Int_ITP2012","Complx","Paraconsistency","Proof_Strategy_Language","Twelvefold_Way","Concurrent_Ref_Alg","FOL_Harrison","Password_Authentication_Protocol","UPF_Firewall","E_Transcendental","Bertrands_Postulate","Minimal_SSA","Bernoulli","Key_Agreement_Strong_Adversaries","Stone_Relation_Algebras","Abstract_Soundness","Differential_Dynamic_Logic","Menger","Elliptic_Curves_Group_Law","Euler_MacLaurin","Quick_Sort_Cost","Comparison_Sort_Lower_Bound","Random_BSTs","Subresultants","Lazy_Case","Constructor_Funs","LocalLexing","Types_Tableaus_and_Goedels_God","MonoidalCategory","Game_Based_Crypto","Monomorphic_Monad","Probabilistic_While","Monad_Normalisation","CryptHOL","Floyd_Warshall","Security_Protocol_Refinement","Dict_Construction","Optics","Flow_Networks","Prpu_Maxflow","Buffons_Needle","PSemigroupsConvolution","Propositional_Proof_Systems","Stone_Kleene_Relation_Algebras","CRDT","Name_Carrying_Type_Inference","Minkowskis_Theorem","HOLCF-Prelude","Decl_Sem_Fun_PL","DynamicArchitectures","Stewart_Apollonius","LambdaMu","Orbit_Stabiliser","Root_Balanced_Tree","First_Welfare_Theorem","AnselmGod","PLM","Lowe_Ontological_Argument","Dirichlet_Series","Zeta_Function","Linear_Recurrences","Diophantine_Eqns_Lin_Hom","Winding_Number_Eval","Count_Complex_Roots","Buchi_Complementation","Transition_Systems_and_Automata","Kuratowski_Closure_Complement","Hybrid_Multi_Lane_Spatial_Logic","IMAP-CRDT","Stochastic_Matrices","Knuth_Morris_Pratt","BNF_Operations","Dirichlet_L","Mason_Stothers","Median_Of_Medians_Selection","Falling_Factorial_Sum","Taylor_Models","Green","Gromov_Hyperbolicity","Ordered_Resolution_Prover","LLL_Basis_Reduction","Treaps","First_Order_Terms","Error_Function","LLL_Factorization","Hoare_Time","Architectural_Design_Patterns","CakeML","Weight_Balanced_Trees","Fishburn_Impossibility","BNF_CC","VerifyThis2018","WebAssembly","Modular_Assembly_Kit_Security","OpSets","Monad_Memo_DP","AxiomaticCategoryTheory","Irrationality_J_Hancl","Probabilistic_Timed_Automata","Hidden_Markov_Models","Optimal_BST","Partial_Order_Reduction","Projective_Geometry","Localization_Ring","Pell","Neumann_Morgenstern_Utility","DiscretePricing","Minsky_Machines","Simplex","Budan_Fourier","Quaternions","Octonions","Aggregation_Algebras","Prime_Number_Theorem","Signature_Groebner","Symmetric_Polynomials","Pi_Transcendental","Factored_Transition_System_Bounding","Randomised_BSTs","Lambda_Free_EPO","Smooth_Manifolds","Epistemic_Logic","GewirthPGCProof","Generic_Deriving","Matroids","Auto2_HOL","Functional_Ordered_Resolution_Prover","Graph_Saturation","Transformer_Semantics","Order_Lattice_Props","Quantales","Constructive_Cryptography","Auto2_Imperative_HOL","Concurrent_Revisions","Core_DOM","Store_Buffer_Reduction","Higher_Order_Terms","IMP2","Farkas","List_Inversions","UTP","Universal_Turing_Machine","Probabilistic_Prime_Tests","Kruskal","Prime_Distribution_Elementary","Safe_OCL","QHLProver","Transcendence_Series_Hancl_Rucki","Binding_Syntax_Theory","LTL_Master_Theorem","HOL-CSP","Multi_Party_Computation","LambdaAuth","KD_Tree","Differential_Game_Logic","IMP2_Binary_Heap","Groebner_Macaulay","Nullstellensatz","Linear_Inequalities","Priority_Search_Trees","Prim_Dijkstra_Simple","Complete_Non_Orders","MFOTL_Monitor","CakeML_Codegen","FOL_Seq_Calc1","Szpilrajn","TESL_Language","Stellar_Quorums","IMO2019","C2KA_DistributedSystems","Linear_Programming","Laplace_Transform","Adaptive_State_Counting","Jacobson_Basic_Algebra","Fourier","Hybrid_Systems_VCs","Generic_Join","Clean","Sigma_Commit_Crypto","Aristotles_Assertoric_Syllogistic","VerifyThis2019","Isabelle_C","ZFC_in_HOL","Interval_Arithmetic_Word32","Generalized_Counting_Sort","Gauss_Sums","Complex_Geometry","Poincare_Disc","Poincare_Bendixson","Hybrid_Logic","Zeta_3_Irrational","Bicategory","Skip_Lists","Closest_Pair_Points","Approximation_Algorithms","Mersenne_Primes","Subset_Boolean_Algebras","Arith_Prog_Rel_Primes","VeriComp","Goodstein_Lambda","Hello_World","Relational-Incorrectness-Logic","Furstenberg_Topology","WOOT_Strong_Eventual_Consistency","Lucas_Theorem","Automated_Stateful_Protocol_Verification","Stateful_Protocol_Composition_and_Typing","MFODL_Monitor_Optimized","Saturation_Framework","Sliding_Window_Algorithm","ADS_Functor","Matrices_for_ODEs","Power_Sum_Polynomials","Lambert_W","Gaussian_Integers","Attack_Trees","Banach_Steinhaus","Forcing","LTL_Normal_Form","Recursion-Addition","Irrational_Series_Erdos_Straus","Knuth_Bendix_Order","Nash_Williams","Smith_Normal_Form","Safe_Distance","Relational_Paths","Chandy_Lamport","Ordinal_Partitions","Amicable_Numbers","BirdKMP","Saturation_Framework_Extensions","Relational_Disjoint_Set_Forests","PAC_Checker","Inductive_Inference","Extended_Finite_State_Machine_Inference","Extended_Finite_State_Machines","Goedel_HFSet_Semanticless","Goedel_HFSet_Semantic","Goedel_Incompleteness","Robinson_Arithmetic","Syntax_Independent_Logic","Shadow_SC_DOM","Core_SC_DOM","Shadow_DOM","DOM_Components","SC_DOM_Components","Finite-Map-Extras","Physical_Quantities","Verified_SAT_Based_AI_Planning","AI_Planning_Languages_Semantics","CSP_RefTK","Isabelle_Marries_Dirac","Relational_Method","Interpreter_Optimizations","Relational_Minimum_Spanning_Trees","Topological_Semantics","Delta_System_Lemma","JinjaDCI","Hood_Melville_Queue","Blue_Eyes","IsaGeoCoq","Laws_of_Large_Numbers","Formal_Puiseux_Series","BTree","Sunflowers","Mereology","Projective_Measurements","Hermite_Lindemann","Modular_arithmetic_LLL_and_HNF_algorithms","Constructive_Cryptography_CM","Padic_Ints","Grothendieck_Schemes","IFC_Tracking","Progress_Tracking","GaleStewart_Games","BenOr_Kozen_Reif","Lifting_the_Exponent","Metalogic_ProofChecker","Regression_Test_Selection","Combinatorics_Words_Graph_Lemma","Combinatorics_Words","Combinatorics_Words_Lyndon","IMP_Compiler","Public_Announcement_Logic","MiniSail","Van_der_Waerden","SpecCheck","Finitely_Generated_Abelian_Groups","Schutz_Spacetime","Relational_Forests","Design_Theory","CoCon","Fresh_Identifiers","CoSMed","CoSMeDis","BD_Security_Compositional","Three_Circles","Logging_Independent_Anonymity","Cubic_Quartic_Equations","Dominance_CHK","CZH_Elementary_Categories","Conditional_Simplification","Types_To_Sets_Extension","CZH_Foundations","Conditional_Transfer_Rule","Intro_Dest_Elim","CZH_Universal_Constructions","Weighted_Path_Order","Complex_Bounded_Operators","FOL_Axiomatic","Virtual_Substitution","Correctness_Algebras","X86_Semantics","Belief_Revision","Registers","Szemeredi_Regularity","PAL","SimplifiedOntologicalArgument","Factor_Algebraic_Polynomial","Real_Power","Hahn_Jordan_Decomposition","Foundation_of_geometry","Van_Emde_Boas_Trees","Simplicial_complexes_and_boolean_functions","Regular_Tree_Relations","MDP-Algorithms","MDP-Rewards","Roth_Arithmetic_Progressions","Gale_Shapley","Hyperdual","Knights_Tour"];
	-var years_loc_articles = [ 2004 , , , , , , , , , , , , , ,2005 , , , , , , , ,2006 , , , , , , ,2007 , , , , , , , ,2008 , , , , , , , , , , , , , , ,2009 , , , , , , , , , , , ,2010 , , , , , , , , , , , , , , , , , , , , , ,2011 , , , , , , , , , , , , , , , , ,2012 , , , , , , , , , , , , , , , , , , , , , , , , ,2013 , , , , , , , , , , , , , , , , , , , , , , ,2014 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2015 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2016 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2017 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2018 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2019 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2020 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2021 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2022 ];
	-var loc_articles = [ "1507","839","1542","1096","1058","2419","44195","205","142","1984","209","1110","3792","506","1141","3766","17713","3119","6430","1145","447","2537","1275","1583","1838","12832","13118","2685","1228","3556","4238","9647","970","2847","1740","79761","4738","3396","2185","31122","10664","6726","30332","180","793","1047","14413","2080","254","2221","5959","3463","799","1540","684","6654","8","2627","27490","264","32530","5025","4380","208","9533","447","2380","3399","606","6305","2043","840","713","1024","5632","1427","4078","2230","6003","22620","1602","1587","3370","2451","2591","260","1617","16","2937","7804","6557","6381","992","125","10130","332","239","1831","999","1755","4420","434","4461","11861","2835","8583","1043","408","2940","2613","38083","3243","1480","2612","3141","27588","2580","25274","2266","4107","7701","1249","260","5309","73","9729","719","6674","1512","4355","1249","1908","6214","4977","10086","7261","538","3830","4591","202","853","1777","5475","10304","1524","150","5292","706","10776","2248","1463","1958","3067","11487","1860","1190","1219","2174","1144","14863","2212","1964","166","10685","6419","572","590","1698","465","2338","4134","2138","1403","2280","1959","2467","220","5430","4432","9396","3999","4460","406","5935","1829","12828","3214","9486","4560","926","659","63","2338","1653","9145","753","2113","875","1727","627","931","1201","1296","7880","1922","90","28055","2879","2796","1116","4863","5259","8842","1356","6178","527","2606","6658","1772","5327","1085","4112","952","2446","1089","1064","2362","477","2074","3763","2151","710","16080","8267","908","1063","21041","9679","8661","3142","9156","695","435","13995","478","898","2724","10375","1162","405","498","495","741","838","3622","4616","6264","4102","8166","12108","3178","518","17581","2876","2418","5496","2453","885","1162","17387","509","703","5047","10687","4287","5337","3811","656","329","1057","15202","3257","2582","553","8478","206","24795","8773","3324","398","2960","12822","9483","370","173","384","18990","2545","6119","3774","1018","2415","4344","9356","20053","4051","3419","319","3209","169","19414","541","14667","2652","7058","7590","3898","3243","4704","855","2289","5029","1349","276","4339","1475","3482","7119","9662","601","1728","852","2194","12222","4212","590","13558","1695","4484","1644","835","694","737","3394","105","68","10492","1127","8499","4135","4711","1200","378","11280","2078","14059","639","2319","3930","4869","468","1531","5570","5683","1993","4205","478","4121","3146","3471","88","480","1261","1877","2193","250","10669","854","7466","5302","3107","2784","8844","8203","2324","6164","945","6514","992","489","810","8891","3434","338","854","493","4593","9457","15962","6327","10342","1820","2288","787","3260","8442","3278","12945","592","843","3383","3638","11570","13548","3734","6597","530","965","7711","1042","1221","5297","2755","1390","1622","2173","13358","805","10027","2667","541","1271","2668","5319","9772","2765","934","11918","1743","2205","7917","1224","449","685","1812","1227","3540","3578","1644","2951","2218","5182","4968","2767","17368","34354","3204","6019","1900","373","10303","16875","3018","3298","5306","4576","10508","986","15843","4437","9487","5543","3301","1264","2973","805","10235","2606","5262","472","3365","3603","3199","13339","951","787","4455","527","713","782","2335","2134","9936","2090","3736","5801","2350","4124","3809","176","1726","10933","6912","5069","5729","4561","14098","10292","6402","4470","1907","69492","2355","3937","3485","1699","3154","944","1033","597","370","691","764","2564","332","21109","23314","10943","3059","744","2353","1560","1239","1609","2537","1939","1338","12002","1034","1444","1902","2670","751","12970","3028","5074","9793","6301","1261","2908","2107","5094","9018","12873","4265","4731","11477","426","3546","1295","8100","15453","16384","12763","3523","7798","648","1761","16434","1967","2359","7700","3995","6542","4731","2826","3295","24547","745","365","26525","290","2582","5083","615","4039","4959","3766","17068","8475","15847","6578","4131","7218","1309","10328","384","9264","4094","399","4696","829","666","426","19867","1088","233","4433","8236","1962","4940","11364","303","5913","14638","3003","3758","817","1329","3157","38078","225","17924","28719","1061","176","17957","4239","16040","670","21773","13533","2621","1324","5952","975","133","471","2962","2203","2619","6070","20658","1882","9541","4344","4298","1699","1386","2946","3108"];
	+var no_articles = [14, 22, 29, 37, 52, 64, 86, 103, 128, 151, 208, 253, 326, 396, 455, 511, 577, 650, 665];
	+var no_loc = [60600.0, 96900.0, 131500.0, 239000.0, 353800.0, 436000.0, 517100.0, 568200.0, 740500.0, 827800.0, 1039600.0, 1220100.0, 1599100.0, 1855000.0, 2126700.0, 2430300.0, 2824600.0, 3307900.0, 3350900.0 ];
	+var no_authors = [14, 11, 6, 6, 10, 6, 24, 11, 17, 16, 37, 20, 63, 31, 28, 39, 34, 45, 5];
	+var no_authors_series = [14, 25, 31, 37, 47, 53, 77, 88, 105, 121, 158, 178, 241, 272, 300, 339, 373, 418, 423];
	+var all_articles = [ "MiniML","AVL-Trees","Functional-Automata","BinarySearchTree","Lazy-Lists-II","Topology","Group-Ring-Module","Depth-First-Search","Compiling-Exceptions-Correctly","Completeness","Ramsey-Infinite","Verified-Prover","Integration","FileRefinement","Category","RSAPSS","Jinja","JiveDataStoreModel","DiskPaxos","GenClock","FFT","Ordinal","Cauchy","ClockSynchInst","FeatherweightJava","CoreC++","Flyspeck-Tame","Abstract-Hoare-Logics","HotelKeyCards","FOL-Fitting","POPLmark-deBruijn","Valuation","SumSquares","Fermat3_4","MuchAdoAboutTwo","JinjaThreads","Program-Conflict-Analysis","LinearQuantifierElim","NormByEval","Simpl","BDD","Recursion-Theory-I","SATSolverVerification","FunWithFunctions","ArrowImpossibilityGS","VolpanoSmith","Slicing","Huffman","FunWithTilings","SenSocialChoice","SIFPL","BytecodeLogicJmlTypes","Stream-Fusion","FinFun","CofGroups","SequentInvertibility","Ordinals_and_Cardinals","WorkerWrapper","HRB-Slicing","Perfect-Number-Thm","Collections","Tree-Automata","Presburger-Automata","DPT-SAT-Solver","Coinductive","List-Index","InformationFlowSlicing","InformationFlowSlicing_Inter","Free-Boolean-Algebra","Locally-Nameless-Sigma","Regular-Sets","Robbins-Conjecture","DataRefinementIBP","GraphMarkingIBP","Abstract-Rewriting","Matrix","Category2","Free-Groups","Statecharts","Polynomials","Lam-ml-Normalization","Binomial-Queues","Binomial-Heaps","Finger-Trees","Shivers-CFA","Marriage","Lower_Semicontinuous","RIPEMD-160-SPARK","LightweightJava","List-Infinite","AutoFocus-Stream","Nat-Interval-Logic","Transitive-Closure","General-Triangle","KBPs","Max-Card-Matching","Gauss-Jordan-Elim-Fun","Myhill-Nerode","LatticeProperties","MonoBoolTranAlgebra","PseudoHoops","Efficient-Mergesort","TLA","Markov_Models","Dijkstra_Shortest_Path","Refine_Monadic","Girth_Chromatic","Transitive-Closure-II","Abortable_Linearizable_Modules","Well_Quasi_Orders","Ordinary_Differential_Equations","Inductive_Confidentiality","Stuttering_Equivalence","Separation_Algebra","Circus","Psi_Calculi","CCS","Pi_Calculus","Tycon","PCF","Heard_Of","Impossible_Geometry","Datatype_Order_Generator","Possibilistic_Noninterference","Bondy","Tarskis_Geometry","Open_Induction","Separation_Logic_Imperative_HOL","Sqrt_Babylonian","Kleene_Algebra","Rank_Nullity_Theorem","Ribbon_Proofs","Launchbury","Nominal2","Containers","Graph_Theory","ShortestPath","Sort_Encodings","Koenigsberg_Friendship","Lehmer","Pratt_Certificate","IEEE_Floating_Point","Native_Word","Automatic_Refinement","Decreasing-Diagrams","GoedelGod","FocusStreamsCaseStudies","Coinductive_Languages","Incompleteness","HereditarilyFinite","Tail_Recursive_Functions","CryptoBasedCompositionalProperties","Sturm_Sequences","Featherweight_OCL","KAT_and_DRA","Relation_Algebra","Secondary_Sylow","Regex_Equivalence","Real_Impl","Affine_Arithmetic","Selection_Heap_Sort","Random_Graph_Subgraph_Threshold","Partial_Function_MR","AWN","Probabilistic_Noninterference","GPU_Kernel_PL","Discrete_Summation","HyperCTL","Abstract_Completeness","Bounded_Deducibility_Security","SIFUM_Type_Systems","WHATandWHERE_Security","Strong_Security","ComponentDependencies","Regular_Algebras","Noninterference_CSP","Roy_Floyd_Warshall","Gabow_SCC","CAVA_Automata","CAVA_LTL_Modelchecker","LTL_to_GBA","Promela","Boolean_Expression_Checkers","MSO_Regex_Equivalence","Pop_Refinement","Network_Security_Policy_Verification","Amortized_Complexity","pGCL","CISC-Kernel","Show","Splay_Tree","Skew_Heap","VectorSpace","Special_Function_Bounds","Gauss_Jordan","Priority_Queue_Braun","Jordan_Hoelder","Cayley_Hamilton","Sturm_Tarski","Imperative_Insertion_Sort","Certification_Monads","XML","RefinementReactive","Density_Compiler","Stream_Fusion_Code","Lifting_Definition_Option","AODV","UPF","UpDown_Scheme","Finite_Automata_HF","QR_Decomposition","Echelon_Form","Call_Arity","Deriving","Consensus_Refined","Trie","ConcurrentIMP","ConcurrentGC","Residuated_Lattices","Vickrey_Clarke_Groves","Probabilistic_System_Zoo","Formula_Derivatives","Dynamic_Tables","Noninterference_Ipurge_Unwinding","Noninterference_Generic_Unwinding","List_Interleaving","Multirelations","Derangements","Hermite","Akra_Bazzi","Landau_Symbols","Case_Labeling","Encodability_Process_Calculi","Rep_Fin_Groups","Noninterference_Inductive_Unwinding","Decreasing-Diagrams-II","Jordan_Normal_Form","LTL_to_DRA","Isabelle_Meta_Model","Parity_Game","Planarity_Certificates","TortoiseHare","Euler_Partition","Ergodic_Theory","Latin_Square","Card_Partitions","Applicative_Lifting","Algebraic_Numbers","Stern_Brocot","Liouville_Numbers","Triangle","Prime_Harmonic_Series","Descartes_Sign_Rule","Card_Number_Partitions","Matrix_Tensor","Knot_Theory","Polynomial_Factorization","Polynomial_Interpolation","Formal_SSA","List_Update","LTL","Cartan_FP","Timed_Automata","PropResPI","KAD","Noninterference_Sequential_Composition","ROBDD","CYK","No_FTL_observers","Groebner_Bases","Bell_Numbers_Spivey","SDS_Impossibility","Randomised_Social_Choice","MFMC_Countable","FLP","Perron_Frobenius","Incredible_Proof_Machine","Posix-Lexing","Card_Equiv_Relations","Tree_Decomposition","Word_Lib","Noninterference_Concurrent_Composition","Algebraic_VCs","Catalan_Numbers","Dependent_SIFUM_Type_Systems","Card_Multisets","Category3","Dependent_SIFUM_Refinement","IP_Addresses","Rewriting_Z","Resolution_FOL","Buildings","DFS_Framework","Pairing_Heap","Surprise_Paradox","Ptolemys_Theorem","Refine_Imperative_HOL","EdmondsKarp_Maxflow","InfPathElimination","Simple_Firewall","Routing","Stirling_Formula","Stone_Algebras","SuperCalc","Iptables_Semantics","Lambda_Free_RPOs","Allen_Calculus","Fisher_Yates","Lp","Chord_Segments","Berlekamp_Zassenhaus","Source_Coding_Theorem","SPARCv8","LOFT","Stable_Matching","Modal_Logics_for_NTS","Deep_Learning","Lambda_Free_KBOs","Nested_Multisets_Ordinals","Separata","Abs_Int_ITP2012","Complx","Paraconsistency","Proof_Strategy_Language","Twelvefold_Way","Concurrent_Ref_Alg","FOL_Harrison","Password_Authentication_Protocol","UPF_Firewall","E_Transcendental","Bertrands_Postulate","Minimal_SSA","Bernoulli","Key_Agreement_Strong_Adversaries","Stone_Relation_Algebras","Abstract_Soundness","Differential_Dynamic_Logic","Menger","Elliptic_Curves_Group_Law","Euler_MacLaurin","Quick_Sort_Cost","Comparison_Sort_Lower_Bound","Random_BSTs","Subresultants","Lazy_Case","Constructor_Funs","LocalLexing","Types_Tableaus_and_Goedels_God","MonoidalCategory","Game_Based_Crypto","Monomorphic_Monad","Probabilistic_While","Monad_Normalisation","CryptHOL","Floyd_Warshall","Security_Protocol_Refinement","Dict_Construction","Optics","Flow_Networks","Prpu_Maxflow","Buffons_Needle","PSemigroupsConvolution","Propositional_Proof_Systems","Stone_Kleene_Relation_Algebras","CRDT","Name_Carrying_Type_Inference","Minkowskis_Theorem","HOLCF-Prelude","Decl_Sem_Fun_PL","DynamicArchitectures","Stewart_Apollonius","LambdaMu","Orbit_Stabiliser","Root_Balanced_Tree","First_Welfare_Theorem","AnselmGod","PLM","Lowe_Ontological_Argument","Dirichlet_Series","Zeta_Function","Linear_Recurrences","Diophantine_Eqns_Lin_Hom","Winding_Number_Eval","Count_Complex_Roots","Buchi_Complementation","Transition_Systems_and_Automata","Kuratowski_Closure_Complement","Hybrid_Multi_Lane_Spatial_Logic","IMAP-CRDT","Stochastic_Matrices","Knuth_Morris_Pratt","BNF_Operations","Dirichlet_L","Mason_Stothers","Median_Of_Medians_Selection","Falling_Factorial_Sum","Taylor_Models","Green","Gromov_Hyperbolicity","Ordered_Resolution_Prover","LLL_Basis_Reduction","Treaps","First_Order_Terms","Error_Function","LLL_Factorization","Hoare_Time","Architectural_Design_Patterns","CakeML","Weight_Balanced_Trees","Fishburn_Impossibility","BNF_CC","VerifyThis2018","WebAssembly","Modular_Assembly_Kit_Security","OpSets","Monad_Memo_DP","AxiomaticCategoryTheory","Irrationality_J_Hancl","Probabilistic_Timed_Automata","Hidden_Markov_Models","Optimal_BST","Partial_Order_Reduction","Projective_Geometry","Localization_Ring","Pell","Neumann_Morgenstern_Utility","DiscretePricing","Minsky_Machines","Simplex","Budan_Fourier","Quaternions","Octonions","Aggregation_Algebras","Prime_Number_Theorem","Signature_Groebner","Symmetric_Polynomials","Pi_Transcendental","Factored_Transition_System_Bounding","Randomised_BSTs","Lambda_Free_EPO","Smooth_Manifolds","Epistemic_Logic","GewirthPGCProof","Generic_Deriving","Matroids","Auto2_HOL","Functional_Ordered_Resolution_Prover","Graph_Saturation","Transformer_Semantics","Order_Lattice_Props","Quantales","Constructive_Cryptography","Auto2_Imperative_HOL","Concurrent_Revisions","Core_DOM","Store_Buffer_Reduction","Higher_Order_Terms","IMP2","Farkas","List_Inversions","UTP","Universal_Turing_Machine","Probabilistic_Prime_Tests","Kruskal","Prime_Distribution_Elementary","Safe_OCL","QHLProver","Transcendence_Series_Hancl_Rucki","Binding_Syntax_Theory","LTL_Master_Theorem","HOL-CSP","Multi_Party_Computation","LambdaAuth","KD_Tree","Differential_Game_Logic","IMP2_Binary_Heap","Groebner_Macaulay","Nullstellensatz","Linear_Inequalities","Priority_Search_Trees","Prim_Dijkstra_Simple","Complete_Non_Orders","MFOTL_Monitor","CakeML_Codegen","FOL_Seq_Calc1","Szpilrajn","TESL_Language","Stellar_Quorums","IMO2019","C2KA_DistributedSystems","Linear_Programming","Laplace_Transform","Adaptive_State_Counting","Jacobson_Basic_Algebra","Fourier","Hybrid_Systems_VCs","Generic_Join","Clean","Sigma_Commit_Crypto","Aristotles_Assertoric_Syllogistic","VerifyThis2019","Isabelle_C","ZFC_in_HOL","Interval_Arithmetic_Word32","Generalized_Counting_Sort","Gauss_Sums","Complex_Geometry","Poincare_Disc","Poincare_Bendixson","Hybrid_Logic","Zeta_3_Irrational","Bicategory","Skip_Lists","Closest_Pair_Points","Approximation_Algorithms","Mersenne_Primes","Subset_Boolean_Algebras","Arith_Prog_Rel_Primes","VeriComp","Goodstein_Lambda","Hello_World","Relational-Incorrectness-Logic","Furstenberg_Topology","WOOT_Strong_Eventual_Consistency","Lucas_Theorem","Automated_Stateful_Protocol_Verification","Stateful_Protocol_Composition_and_Typing","MFODL_Monitor_Optimized","Saturation_Framework","Sliding_Window_Algorithm","ADS_Functor","Matrices_for_ODEs","Power_Sum_Polynomials","Lambert_W","Gaussian_Integers","Attack_Trees","Banach_Steinhaus","Forcing","LTL_Normal_Form","Recursion-Addition","Irrational_Series_Erdos_Straus","Knuth_Bendix_Order","Nash_Williams","Smith_Normal_Form","Safe_Distance","Relational_Paths","Chandy_Lamport","Ordinal_Partitions","Amicable_Numbers","BirdKMP","Saturation_Framework_Extensions","Relational_Disjoint_Set_Forests","PAC_Checker","Inductive_Inference","Extended_Finite_State_Machine_Inference","Extended_Finite_State_Machines","Goedel_HFSet_Semanticless","Goedel_HFSet_Semantic","Goedel_Incompleteness","Robinson_Arithmetic","Syntax_Independent_Logic","Shadow_SC_DOM","Core_SC_DOM","Shadow_DOM","DOM_Components","SC_DOM_Components","Finite-Map-Extras","Physical_Quantities","Verified_SAT_Based_AI_Planning","AI_Planning_Languages_Semantics","CSP_RefTK","Isabelle_Marries_Dirac","Relational_Method","Interpreter_Optimizations","Relational_Minimum_Spanning_Trees","Topological_Semantics","Delta_System_Lemma","JinjaDCI","Hood_Melville_Queue","Blue_Eyes","IsaGeoCoq","Laws_of_Large_Numbers","Formal_Puiseux_Series","BTree","Sunflowers","Mereology","Projective_Measurements","Hermite_Lindemann","Modular_arithmetic_LLL_and_HNF_algorithms","Constructive_Cryptography_CM","Padic_Ints","Grothendieck_Schemes","IFC_Tracking","Progress_Tracking","GaleStewart_Games","BenOr_Kozen_Reif","Lifting_the_Exponent","Metalogic_ProofChecker","Regression_Test_Selection","Combinatorics_Words_Graph_Lemma","Combinatorics_Words","Combinatorics_Words_Lyndon","IMP_Compiler","Public_Announcement_Logic","MiniSail","Van_der_Waerden","SpecCheck","Finitely_Generated_Abelian_Groups","Schutz_Spacetime","Relational_Forests","Design_Theory","CoCon","Fresh_Identifiers","CoSMed","CoSMeDis","BD_Security_Compositional","Three_Circles","Logging_Independent_Anonymity","Cubic_Quartic_Equations","Dominance_CHK","CZH_Elementary_Categories","Conditional_Simplification","Types_To_Sets_Extension","CZH_Foundations","Conditional_Transfer_Rule","Intro_Dest_Elim","CZH_Universal_Constructions","Weighted_Path_Order","Complex_Bounded_Operators","FOL_Axiomatic","Virtual_Substitution","Correctness_Algebras","X86_Semantics","Belief_Revision","Registers","Szemeredi_Regularity","PAL","SimplifiedOntologicalArgument","Factor_Algebraic_Polynomial","Real_Power","Hahn_Jordan_Decomposition","Foundation_of_geometry","Van_Emde_Boas_Trees","Simplicial_complexes_and_boolean_functions","Regular_Tree_Relations","MDP-Algorithms","MDP-Rewards","Roth_Arithmetic_Progressions","Gale_Shapley","Hyperdual","Knights_Tour","Irrationals_From_THEBOOK","Actuarial_Mathematics","Median_Method","Interpolation_Polynomials_HOL_Algebra","Youngs_Inequality","FOL_Seq_Calc2","FO_Theory_Rewriting","LP_Duality","Quasi_Borel_Spaces","Equivalence_Relation_Enumeration","VYDRA_MDL","Eval_FO","Wetzels_Problem","Universal_Hash_Families"];
	+var years_loc_articles = [ 2004 , , , , , , , , , , , , , ,2005 , , , , , , , ,2006 , , , , , , ,2007 , , , , , , , ,2008 , , , , , , , , , , , , , , ,2009 , , , , , , , , , , , ,2010 , , , , , , , , , , , , , , , , , , , , , ,2011 , , , , , , , , , , , , , , , , ,2012 , , , , , , , , , , , , , , , , , , , , , , , , ,2013 , , , , , , , , , , , , , , , , , , , , , , ,2014 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2015 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2016 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2017 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2018 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2019 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2020 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2021 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2022 , , , , , , , , , , , , , ,];
	+var loc_articles = [ "1507","839","1542","1096","1058","2419","44195","205","142","1984","209","1110","3792","506","1141","3766","17713","3119","6430","1145","447","2537","1275","1583","1838","12832","13118","2685","1228","3556","4238","9647","970","2847","1740","79761","4738","3396","2185","31122","10664","6726","30332","180","793","1047","14413","2080","254","2221","5959","3463","799","1540","684","6654","8","2627","27490","264","32530","5025","4380","208","9533","447","2380","3399","606","6305","2043","840","713","1024","5632","1427","4078","2230","6003","22604","1602","1587","3370","2451","2591","260","1617","16","2937","7804","6557","6381","992","125","10130","332","239","1831","999","1755","4420","434","4461","11861","2835","8583","1043","408","2940","2613","38083","3243","1480","2612","3141","27588","2580","25274","2266","4107","7701","1249","260","5309","73","9729","719","6674","1512","4355","1249","1908","6214","4977","10086","7261","538","3830","4591","202","853","1777","5484","10304","1524","150","5292","706","10776","2248","1463","1958","3067","11487","1860","1190","1219","2174","1144","14863","2212","1964","166","10685","6419","572","590","1698","465","2338","4134","2138","1403","2280","1959","2467","220","5430","4432","9396","3999","4460","406","5935","1829","12828","3214","9486","4560","926","659","63","2338","1653","9145","753","2113","875","1727","627","931","1201","1296","7880","1922","90","28055","2879","2796","1116","4863","5259","8842","1356","6178","527","2606","6658","1772","5327","1085","4112","952","2446","1089","1064","2362","477","2074","3763","2151","710","16080","8267","908","1063","21067","9679","8661","3142","9156","695","435","13995","478","898","2724","10375","1162","405","498","495","741","838","3622","4616","6264","4102","8166","12108","3178","518","17581","2876","2418","5496","2453","885","1162","17387","509","703","5047","10687","4287","5337","3811","656","329","1057","15164","3257","2582","553","8478","206","24792","8773","3324","398","2960","12822","9483","370","173","384","18990","2545","6119","3774","1018","2415","4344","9356","20053","4051","3419","319","3209","169","19414","541","14667","2652","7058","7590","3898","3243","4703","855","2289","5029","1349","276","4339","1475","3482","7119","9662","601","1728","852","2194","12222","4212","590","13558","1695","4484","1644","835","694","737","3394","105","68","10492","1127","8499","4135","4711","1200","378","11280","2078","14059","639","2319","3930","4869","468","1531","5570","5683","1993","4205","478","4121","3146","3471","88","480","1261","1877","2193","250","10669","854","7466","5302","3107","2784","8844","8203","2324","6164","945","6514","992","489","810","8891","3434","338","854","493","4593","9457","15962","6354","10342","1820","2288","787","3260","8442","3278","12945","672","843","3383","3638","11570","13548","3734","6597","530","965","7711","1042","1221","5297","2755","1390","1622","2173","13358","805","10027","2667","541","1271","2668","5319","9772","2765","934","11918","1743","2205","7917","1209","449","685","1812","1227","3557","3578","1644","2951","2218","5182","4968","2767","17368","34354","3204","6019","1900","373","10303","16875","3018","3298","5306","4576","10508","986","15843","4437","9487","5543","3301","1264","2973","805","10235","2606","5262","472","3365","3603","3199","13339","951","787","4455","527","713","782","2335","2134","9936","2090","3736","5801","2350","4124","3809","176","1726","10933","7251","5069","5729","4561","14098","10292","6402","4470","1907","68347","2355","3937","3485","1699","3154","944","1033","597","370","691","764","2564","332","21109","23314","10943","3059","744","2353","1560","1239","1609","2537","1939","1338","12002","1034","1444","1902","2670","755","12970","3028","5074","9793","6301","1261","2908","2107","5094","9018","12873","4265","4731","11477","426","3546","1295","8100","15453","16384","12763","3523","7798","648","1761","16434","1967","2359","7700","3995","6542","4731","2826","3295","24547","745","365","26525","290","2582","5083","615","4039","4959","3766","17068","8475","15847","6578","4131","7218","1309","10328","384","9264","4094","399","4696","829","666","840","19867","1088","233","4433","8236","1962","4940","11364","303","5913","14638","3003","3758","817","1329","3157","38082","225","17924","28719","1061","176","17957","4239","16030","670","21771","13533","2621","1324","5953","969","133","471","2961","2203","2619","6070","20658","1882","9541","4344","4298","1699","1590","2946","3108","269","948","566","757","807","2594","9208","624","8741","502","7143","5937","765","951"];

	</script>
	<h4>Growth in number of articles:</h4>
	<script src="Chart.js"></script>
	<div class="chart">
	<canvas id="NumberOfArticles" width="400" height="400"></canvas>
	</div>
	<script>
	var ctx = document.getElementById("NumberOfArticles");
	var myChart = new Chart(ctx, {
	type: 'bar',
	data: {
	labels: years,
	datasets: [{
	label: 'size of the AFP in # of articles',
	data: no_articles,
	backgroundColor: "rgba(46, 45, 78, 1)"
	}],
	},
	options: {
	responsive: true,
	maintainAspectRatio: true,
	scales: {
	yAxes: [{
	ticks: {
	beginAtZero:true
	}
	}]
	},
	}
	});
	</script>

	<h4>Growth in lines of code:</h4>
	<div class="chart">
	<canvas id="NumberOfLoc" width="400" height="400"></canvas>
	</div>
	<script>
	var ctx = document.getElementById("NumberOfLoc");
	var myChart = new Chart(ctx, {
	type: 'bar',
	data: {
	labels: years,
	datasets: [{
	label: 'size of the AFP in lines of code',
	data: no_loc,
	backgroundColor: "rgba(101, 99, 136, 1)"
	}],
	},
	options: {
	responsive: true,
	maintainAspectRatio: true,
	scales: {
	yAxes: [{
	ticks: {
	beginAtZero:true
	}
	}]
	},
	}
	});
	</script>

	<h4>Growth in number of authors:</h4>
	<div class="chart">
	<canvas id="NumberOfAuthors" width="400" height="400"></canvas>
	</div>
	<script>
	var ctx = document.getElementById("NumberOfAuthors");
	var myChart = new Chart(ctx, {
	type: 'bar',
	data: {
	labels: years,
	datasets: [{
	label: 'new authors per year',
	data: no_authors,
	backgroundColor: "rgba(101, 99, 136, 1)"
	},
	{
	label: 'number of authors contributing (cumulative)',
	data: no_authors_series,
	backgroundColor: "rgba(0, 15, 48, 1)"
	}],
	},
	options: {
	responsive: true,
	maintainAspectRatio: true,
	scales: {
	yAxes: [{
	ticks: {
	beginAtZero:true
	}
	}]
	},
	}
	});
	</script>

	<h4>Size of articles:</h4>
	<div style="width: 800px" class="chart">
	<canvas id="LocArticles" width="800" height="400"></canvas>
	</div>
	<script>
	var ctx = document.getElementById("LocArticles");
	var myChart = new Chart(ctx, {
	type: 'bar',
	data: {
	labels: years_loc_articles,
	datasets: [{
	label: 'loc per article',
	data: loc_articles,
	backgroundColor: "rgba(101, 99, 136, 1)"
	}]
	},
	options: {
	responsive: true,
	maintainAspectRatio: true,
	scales: {
	xAxes: [{
	categoryPercentage: 1,
	barPercentage: 0.9,
	ticks: {
	autoSkip: false
	}
	}],
	yAxes: [{
	ticks: {
	beginAtZero:true
	}
	}]
	},
	tooltips: {
	callbacks: {
	title: function(tooltipItem, data) {
	return all_articles[tooltipItem[0].index];
	}
	}
	}
	}
	});
	</script>

	</td></tr>

	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>

	<script src="Chart.js"></script>

	</body>
	</html>
	\ 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,1027 +1,1048 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Archive of Formal Proofs</title>
	<link rel="stylesheet" type="text/css" href="front.css">
	<link rel="icon" href="images/favicon.ico" type="image/icon">
	<link rel="alternate" type="application/rss+xml" title="RSS" href="rss.xml">
	</head>

	<body class="mathjax_ignore">

	<table width="100%">
	<tbody>
	<tr>

	<!-- Navigation -->
	<td width="20%" align="center" valign="top">
	<p> </p>
	<a href="https://www.isa-afp.org/">
	<img src="images/isabelle.png" width="100" height="88" border=0>
	</a>
	<p> </p>
	<p> </p>
	<table class="nav" width="80%">
	<tr>
	<td class="nav" width="100%"><a href="index.html">Home</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="about.html">About</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="submitting.html">Submission</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="updating.html">Updating Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="using.html">Using Entries</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="search.html">Search</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="statistics.html">Statistics</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="topics.html">Index</a></td>
	</tr>
	<tr>
	<td class="nav"><a href="download.html">Download</a></td>
	</tr>
	</table>
	<p> </p>
	<p> </p>
	</td>


	<!-- Content -->
	<td width="80%" valign="top">
	<div align="center">
	<p> </p>
	<h1><font class="first">I</font>ndex by <font class="first">T</font>opic
	</h1>
	<p> </p>

	<table width="80%" class="descr">
	<tbody>
	<tr>
	<td>
	<h2>Computer science</h2>
	<div class="list">
	</div>
	<h3>Artificial intelligence</h3>
	<div class="list">
	<a href="entries/AI_Planning_Languages_Semantics.html">AI_Planning_Languages_Semantics</a>
	<a href="entries/Verified_SAT_Based_AI_Planning.html">Verified_SAT_Based_AI_Planning</a>
	</div>
	<h3>Automata and formal languages</h3>
	<div class="list">
	<a href="entries/Partial_Order_Reduction.html">Partial_Order_Reduction</a>
	<a href="entries/C2KA_DistributedSystems.html">C2KA_DistributedSystems</a>
	<a href="entries/Posix-Lexing.html">Posix-Lexing</a>
	<a href="entries/LocalLexing.html">LocalLexing</a>
	<a href="entries/KBPs.html">KBPs</a>
	<a href="entries/Regular-Sets.html">Regular-Sets</a>
	<a href="entries/Regex_Equivalence.html">Regex_Equivalence</a>
	<a href="entries/MSO_Regex_Equivalence.html">MSO_Regex_Equivalence</a>
	<a href="entries/Formula_Derivatives.html">Formula_Derivatives</a>
	<a href="entries/Myhill-Nerode.html">Myhill-Nerode</a>
	<a href="entries/Universal_Turing_Machine.html">Universal_Turing_Machine</a>
	<a href="entries/CYK.html">CYK</a>
	<a href="entries/Presburger-Automata.html">Presburger-Automata</a>
	<a href="entries/Functional-Automata.html">Functional-Automata</a>
	<a href="entries/Statecharts.html">Statecharts</a>
	<a href="entries/Stuttering_Equivalence.html">Stuttering_Equivalence</a>
	<a href="entries/Coinductive_Languages.html">Coinductive_Languages</a>
	<a href="entries/Tree-Automata.html">Tree-Automata</a>
	<a href="entries/Kleene_Algebra.html">Kleene_Algebra</a>
	<a href="entries/KAT_and_DRA.html">KAT_and_DRA</a>
	<a href="entries/KAD.html">KAD</a>
	<a href="entries/Regular_Algebras.html">Regular_Algebras</a>
	<a href="entries/Markov_Models.html">Markov_Models</a>
	<a href="entries/Probabilistic_System_Zoo.html">Probabilistic_System_Zoo</a>
	<a href="entries/CAVA_Automata.html">CAVA_Automata</a>
	<a href="entries/LTL.html">LTL</a>
	<a href="entries/LTL_to_GBA.html">LTL_to_GBA</a>
	<a href="entries/CAVA_LTL_Modelchecker.html">CAVA_LTL_Modelchecker</a>
	<a href="entries/Probabilistic_Timed_Automata.html">Probabilistic_Timed_Automata</a>
	<a href="entries/Finite_Automata_HF.html">Finite_Automata_HF</a>
	<a href="entries/LTL_to_DRA.html">LTL_to_DRA</a>
	<a href="entries/Timed_Automata.html">Timed_Automata</a>
	<a href="entries/Stochastic_Matrices.html">Stochastic_Matrices</a>
	<a href="entries/Buchi_Complementation.html">Buchi_Complementation</a>
	<a href="entries/Transition_Systems_and_Automata.html">Transition_Systems_and_Automata</a>
	<a href="entries/Factored_Transition_System_Bounding.html">Factored_Transition_System_Bounding</a>
	<a href="entries/LTL_Master_Theorem.html">LTL_Master_Theorem</a>
	<a href="entries/MFOTL_Monitor.html">MFOTL_Monitor</a>
	<a href="entries/Adaptive_State_Counting.html">Adaptive_State_Counting</a>
	<a href="entries/MFODL_Monitor_Optimized.html">MFODL_Monitor_Optimized</a>
	<a href="entries/LTL_Normal_Form.html">LTL_Normal_Form</a>
	<a href="entries/Extended_Finite_State_Machines.html">Extended_Finite_State_Machines</a>
	<a href="entries/Extended_Finite_State_Machine_Inference.html">Extended_Finite_State_Machine_Inference</a>
	<a href="entries/Combinatorics_Words.html">Combinatorics_Words</a>
	<a href="entries/Combinatorics_Words_Lyndon.html">Combinatorics_Words_Lyndon</a>
	<a href="entries/Combinatorics_Words_Graph_Lemma.html">Combinatorics_Words_Graph_Lemma</a>
	<a href="entries/Regular_Tree_Relations.html">Regular_Tree_Relations</a>
	+ <a href="entries/FO_Theory_Rewriting.html">FO_Theory_Rewriting</a>
	</div>
	<h3>Algorithms</h3>
	<div class="list">
	<a href="entries/Knuth_Morris_Pratt.html">Knuth_Morris_Pratt</a>
	<a href="entries/Probabilistic_While.html">Probabilistic_While</a>
	<a href="entries/Comparison_Sort_Lower_Bound.html">Comparison_Sort_Lower_Bound</a>
	<a href="entries/Quick_Sort_Cost.html">Quick_Sort_Cost</a>
	<a href="entries/TortoiseHare.html">TortoiseHare</a>
	<a href="entries/Selection_Heap_Sort.html">Selection_Heap_Sort</a>
	<a href="entries/VerifyThis2018.html">VerifyThis2018</a>
	<a href="entries/CYK.html">CYK</a>
	<a href="entries/Boolean_Expression_Checkers.html">Boolean_Expression_Checkers</a>
	<a href="entries/Efficient-Mergesort.html">Efficient-Mergesort</a>
	<a href="entries/SATSolverVerification.html">SATSolverVerification</a>
	<a href="entries/MuchAdoAboutTwo.html">MuchAdoAboutTwo</a>
	<a href="entries/First_Order_Terms.html">First_Order_Terms</a>
	<a href="entries/MDP-Algorithms.html">MDP-Algorithms</a>
	<a href="entries/Monad_Memo_DP.html">Monad_Memo_DP</a>
	<a href="entries/Hidden_Markov_Models.html">Hidden_Markov_Models</a>
	<a href="entries/Imperative_Insertion_Sort.html">Imperative_Insertion_Sort</a>
	<a href="entries/Formal_SSA.html">Formal_SSA</a>
	<a href="entries/ROBDD.html">ROBDD</a>
	<a href="entries/Median_Of_Medians_Selection.html">Median_Of_Medians_Selection</a>
	<a href="entries/Fisher_Yates.html">Fisher_Yates</a>
	<a href="entries/Optimal_BST.html">Optimal_BST</a>
	<a href="entries/IMP2.html">IMP2</a>
	<a href="entries/Auto2_Imperative_HOL.html">Auto2_Imperative_HOL</a>
	<a href="entries/List_Inversions.html">List_Inversions</a>
	<a href="entries/IMP2_Binary_Heap.html">IMP2_Binary_Heap</a>
	<a href="entries/MFOTL_Monitor.html">MFOTL_Monitor</a>
	<a href="entries/Adaptive_State_Counting.html">Adaptive_State_Counting</a>
	<a href="entries/Generic_Join.html">Generic_Join</a>
	<a href="entries/VerifyThis2019.html">VerifyThis2019</a>
	<a href="entries/Generalized_Counting_Sort.html">Generalized_Counting_Sort</a>
	<a href="entries/MFODL_Monitor_Optimized.html">MFODL_Monitor_Optimized</a>
	<a href="entries/Sliding_Window_Algorithm.html">Sliding_Window_Algorithm</a>
	<a href="entries/PAC_Checker.html">PAC_Checker</a>
	<a href="entries/Regression_Test_Selection.html">Regression_Test_Selection</a>
	<a href="entries/Gale_Shapley.html">Gale_Shapley</a>
	+ <a href="entries/VYDRA_MDL.html">VYDRA_MDL</a>
	+ <a href="entries/Universal_Hash_Families.html">Universal_Hash_Families</a>
	<strong>Graph:</strong>
	<a href="entries/DFS_Framework.html">DFS_Framework</a>
	<a href="entries/Prpu_Maxflow.html">Prpu_Maxflow</a>
	<a href="entries/Floyd_Warshall.html">Floyd_Warshall</a>
	<a href="entries/Roy_Floyd_Warshall.html">Roy_Floyd_Warshall</a>
	<a href="entries/Dijkstra_Shortest_Path.html">Dijkstra_Shortest_Path</a>
	<a href="entries/EdmondsKarp_Maxflow.html">EdmondsKarp_Maxflow</a>
	<a href="entries/Depth-First-Search.html">Depth-First-Search</a>
	<a href="entries/GraphMarkingIBP.html">GraphMarkingIBP</a>
	<a href="entries/Transitive-Closure.html">Transitive-Closure</a>
	<a href="entries/Transitive-Closure-II.html">Transitive-Closure-II</a>
	<a href="entries/Gabow_SCC.html">Gabow_SCC</a>
	<a href="entries/Kruskal.html">Kruskal</a>
	<a href="entries/Prim_Dijkstra_Simple.html">Prim_Dijkstra_Simple</a>
	<a href="entries/Relational_Minimum_Spanning_Trees.html">Relational_Minimum_Spanning_Trees</a>
	<strong>Distributed:</strong>
	<a href="entries/DiskPaxos.html">DiskPaxos</a>
	<a href="entries/GenClock.html">GenClock</a>
	<a href="entries/ClockSynchInst.html">ClockSynchInst</a>
	<a href="entries/Heard_Of.html">Heard_Of</a>
	<a href="entries/Consensus_Refined.html">Consensus_Refined</a>
	<a href="entries/Abortable_Linearizable_Modules.html">Abortable_Linearizable_Modules</a>
	<a href="entries/IMAP-CRDT.html">IMAP-CRDT</a>
	<a href="entries/CRDT.html">CRDT</a>
	<a href="entries/Chandy_Lamport.html">Chandy_Lamport</a>
	<a href="entries/OpSets.html">OpSets</a>
	<a href="entries/Stellar_Quorums.html">Stellar_Quorums</a>
	<a href="entries/WOOT_Strong_Eventual_Consistency.html">WOOT_Strong_Eventual_Consistency</a>
	<a href="entries/Progress_Tracking.html">Progress_Tracking</a>
	<strong>Concurrent:</strong>
	<a href="entries/ConcurrentGC.html">ConcurrentGC</a>
	<strong>Online:</strong>
	<a href="entries/List_Update.html">List_Update</a>
	<strong>Geometry:</strong>
	<a href="entries/Closest_Pair_Points.html">Closest_Pair_Points</a>
	<strong>Approximation:</strong>
	<a href="entries/Approximation_Algorithms.html">Approximation_Algorithms</a>
	<strong>Mathematical:</strong>
	<a href="entries/FFT.html">FFT</a>
	<a href="entries/Gauss-Jordan-Elim-Fun.html">Gauss-Jordan-Elim-Fun</a>
	<a href="entries/UpDown_Scheme.html">UpDown_Scheme</a>
	<a href="entries/Polynomials.html">Polynomials</a>
	<a href="entries/Gauss_Jordan.html">Gauss_Jordan</a>
	<a href="entries/Echelon_Form.html">Echelon_Form</a>
	<a href="entries/QR_Decomposition.html">QR_Decomposition</a>
	<a href="entries/Hermite.html">Hermite</a>
	<a href="entries/Groebner_Bases.html">Groebner_Bases</a>
	<a href="entries/Diophantine_Eqns_Lin_Hom.html">Diophantine_Eqns_Lin_Hom</a>
	<a href="entries/Taylor_Models.html">Taylor_Models</a>
	<a href="entries/LLL_Basis_Reduction.html">LLL_Basis_Reduction</a>
	<a href="entries/Signature_Groebner.html">Signature_Groebner</a>
	<a href="entries/BenOr_Kozen_Reif.html">BenOr_Kozen_Reif</a>
	<a href="entries/Smith_Normal_Form.html">Smith_Normal_Form</a>
	<a href="entries/Safe_Distance.html">Safe_Distance</a>
	<a href="entries/Modular_arithmetic_LLL_and_HNF_algorithms.html">Modular_arithmetic_LLL_and_HNF_algorithms</a>
	<a href="entries/Virtual_Substitution.html">Virtual_Substitution</a>
	+ <a href="entries/Equivalence_Relation_Enumeration.html">Equivalence_Relation_Enumeration</a>
	<strong>Optimization:</strong>
	<a href="entries/Simplex.html">Simplex</a>
	<strong>Quantum computing:</strong>
	<a href="entries/Isabelle_Marries_Dirac.html">Isabelle_Marries_Dirac</a>
	<a href="entries/Projective_Measurements.html">Projective_Measurements</a>
	<a href="entries/Registers.html">Registers</a>
	</div>
	<h3>Concurrency</h3>
	<div class="list">
	<a href="entries/FLP.html">FLP</a>
	<a href="entries/Concurrent_Ref_Alg.html">Concurrent_Ref_Alg</a>
	<a href="entries/Concurrent_Revisions.html">Concurrent_Revisions</a>
	<a href="entries/Store_Buffer_Reduction.html">Store_Buffer_Reduction</a>
	<a href="entries/TESL_Language.html">TESL_Language</a>
	<strong>Process calculi:</strong>
	<a href="entries/Noninterference_Generic_Unwinding.html">Noninterference_Generic_Unwinding</a>
	<a href="entries/AODV.html">AODV</a>
	<a href="entries/AWN.html">AWN</a>
	<a href="entries/CCS.html">CCS</a>
	<a href="entries/Pi_Calculus.html">Pi_Calculus</a>
	<a href="entries/Psi_Calculi.html">Psi_Calculi</a>
	<a href="entries/Encodability_Process_Calculi.html">Encodability_Process_Calculi</a>
	<a href="entries/Circus.html">Circus</a>
	<a href="entries/Noninterference_Sequential_Composition.html">Noninterference_Sequential_Composition</a>
	<a href="entries/Noninterference_Concurrent_Composition.html">Noninterference_Concurrent_Composition</a>
	<a href="entries/Modal_Logics_for_NTS.html">Modal_Logics_for_NTS</a>
	<a href="entries/HOL-CSP.html">HOL-CSP</a>
	<a href="entries/CSP_RefTK.html">CSP_RefTK</a>
	</div>
	<h3>Data structures</h3>
	<div class="list">
	<a href="entries/Generic_Deriving.html">Generic_Deriving</a>
	<a href="entries/Random_BSTs.html">Random_BSTs</a>
	<a href="entries/Randomised_BSTs.html">Randomised_BSTs</a>
	<a href="entries/List_Interleaving.html">List_Interleaving</a>
	<a href="entries/Refine_Imperative_HOL.html">Refine_Imperative_HOL</a>
	<a href="entries/Amortized_Complexity.html">Amortized_Complexity</a>
	<a href="entries/Dynamic_Tables.html">Dynamic_Tables</a>
	<a href="entries/AVL-Trees.html">AVL-Trees</a>
	<a href="entries/BDD.html">BDD</a>
	<a href="entries/BinarySearchTree.html">BinarySearchTree</a>
	<a href="entries/Splay_Tree.html">Splay_Tree</a>
	<a href="entries/Root_Balanced_Tree.html">Root_Balanced_Tree</a>
	<a href="entries/Skew_Heap.html">Skew_Heap</a>
	<a href="entries/Pairing_Heap.html">Pairing_Heap</a>
	<a href="entries/Priority_Queue_Braun.html">Priority_Queue_Braun</a>
	<a href="entries/Binomial-Queues.html">Binomial-Queues</a>
	<a href="entries/Binomial-Heaps.html">Binomial-Heaps</a>
	<a href="entries/Finger-Trees.html">Finger-Trees</a>
	<a href="entries/Trie.html">Trie</a>
	<a href="entries/FinFun.html">FinFun</a>
	<a href="entries/Collections.html">Collections</a>
	<a href="entries/Containers.html">Containers</a>
	<a href="entries/FileRefinement.html">FileRefinement</a>
	<a href="entries/Datatype_Order_Generator.html">Datatype_Order_Generator</a>
	<a href="entries/Deriving.html">Deriving</a>
	<a href="entries/List-Index.html">List-Index</a>
	<a href="entries/List-Infinite.html">List-Infinite</a>
	<a href="entries/Matrix.html">Matrix</a>
	<a href="entries/Matrix_Tensor.html">Matrix_Tensor</a>
	<a href="entries/Huffman.html">Huffman</a>
	<a href="entries/Lazy-Lists-II.html">Lazy-Lists-II</a>
	<a href="entries/IEEE_Floating_Point.html">IEEE_Floating_Point</a>
	<a href="entries/Native_Word.html">Native_Word</a>
	<a href="entries/XML.html">XML</a>
	<a href="entries/ROBDD.html">ROBDD</a>
	<a href="entries/IMAP-CRDT.html">IMAP-CRDT</a>
	<a href="entries/Word_Lib.html">Word_Lib</a>
	<a href="entries/CRDT.html">CRDT</a>
	<a href="entries/KD_Tree.html">KD_Tree</a>
	<a href="entries/Taylor_Models.html">Taylor_Models</a>
	<a href="entries/Treaps.html">Treaps</a>
	<a href="entries/Skip_Lists.html">Skip_Lists</a>
	<a href="entries/Weight_Balanced_Trees.html">Weight_Balanced_Trees</a>
	<a href="entries/OpSets.html">OpSets</a>
	<a href="entries/Optimal_BST.html">Optimal_BST</a>
	<a href="entries/Core_DOM.html">Core_DOM</a>
	<a href="entries/Core_SC_DOM.html">Core_SC_DOM</a>
	<a href="entries/Shadow_SC_DOM.html">Shadow_SC_DOM</a>
	<a href="entries/SC_DOM_Components.html">SC_DOM_Components</a>
	<a href="entries/Auto2_Imperative_HOL.html">Auto2_Imperative_HOL</a>
	<a href="entries/IMP2_Binary_Heap.html">IMP2_Binary_Heap</a>
	<a href="entries/Priority_Search_Trees.html">Priority_Search_Trees</a>
	<a href="entries/Interval_Arithmetic_Word32.html">Interval_Arithmetic_Word32</a>
	<a href="entries/ADS_Functor.html">ADS_Functor</a>
	<a href="entries/Relational_Disjoint_Set_Forests.html">Relational_Disjoint_Set_Forests</a>
	<a href="entries/Shadow_DOM.html">Shadow_DOM</a>
	<a href="entries/DOM_Components.html">DOM_Components</a>
	<a href="entries/Finite-Map-Extras.html">Finite-Map-Extras</a>
	<a href="entries/Hood_Melville_Queue.html">Hood_Melville_Queue</a>
	<a href="entries/BTree.html">BTree</a>
	<a href="entries/Fresh_Identifiers.html">Fresh_Identifiers</a>
	<a href="entries/Van_Emde_Boas_Trees.html">Van_Emde_Boas_Trees</a>
	</div>
	<h3>Functional programming</h3>
	<div class="list">
	<a href="entries/Optics.html">Optics</a>
	<a href="entries/CryptHOL.html">CryptHOL</a>
	<a href="entries/Probabilistic_While.html">Probabilistic_While</a>
	<a href="entries/Monad_Normalisation.html">Monad_Normalisation</a>
	<a href="entries/Monomorphic_Monad.html">Monomorphic_Monad</a>
	<a href="entries/Show.html">Show</a>
	<a href="entries/Certification_Monads.html">Certification_Monads</a>
	<a href="entries/Partial_Function_MR.html">Partial_Function_MR</a>
	<a href="entries/Lifting_Definition_Option.html">Lifting_Definition_Option</a>
	<a href="entries/Coinductive.html">Coinductive</a>
	<a href="entries/Stream-Fusion.html">Stream-Fusion</a>
	<a href="entries/Tycon.html">Tycon</a>
	<a href="entries/Monad_Memo_DP.html">Monad_Memo_DP</a>
	<a href="entries/XML.html">XML</a>
	<a href="entries/Tail_Recursive_Functions.html">Tail_Recursive_Functions</a>
	<a href="entries/Stream_Fusion_Code.html">Stream_Fusion_Code</a>
	<a href="entries/Applicative_Lifting.html">Applicative_Lifting</a>
	<a href="entries/HOLCF-Prelude.html">HOLCF-Prelude</a>
	<a href="entries/BNF_CC.html">BNF_CC</a>
	<a href="entries/Binding_Syntax_Theory.html">Binding_Syntax_Theory</a>
	<a href="entries/Generalized_Counting_Sort.html">Generalized_Counting_Sort</a>
	<a href="entries/Hello_World.html">Hello_World</a>
	<a href="entries/BirdKMP.html">BirdKMP</a>
	</div>
	<h3>Hardware</h3>
	<div class="list">
	<a href="entries/SPARCv8.html">SPARCv8</a>
	<a href="entries/X86_Semantics.html">X86_Semantics</a>
	</div>
	<h3>Machine learning</h3>
	<div class="list">
	<a href="entries/Deep_Learning.html">Deep_Learning</a>
	<a href="entries/Inductive_Inference.html">Inductive_Inference</a>
	</div>
	<h3>Networks</h3>
	<div class="list">
	<a href="entries/UPF_Firewall.html">UPF_Firewall</a>
	<a href="entries/IP_Addresses.html">IP_Addresses</a>
	<a href="entries/Simple_Firewall.html">Simple_Firewall</a>
	<a href="entries/Iptables_Semantics.html">Iptables_Semantics</a>
	<a href="entries/Routing.html">Routing</a>
	<a href="entries/LOFT.html">LOFT</a>
	</div>
	<h3>Programming languages</h3>
	<div class="list">
	<a href="entries/Clean.html">Clean</a>
	<a href="entries/Decl_Sem_Fun_PL.html">Decl_Sem_Fun_PL</a>
	<strong>Language definitions:</strong>
	<a href="entries/CakeML.html">CakeML</a>
	<a href="entries/WebAssembly.html">WebAssembly</a>
	<a href="entries/pGCL.html">pGCL</a>
	<a href="entries/GPU_Kernel_PL.html">GPU_Kernel_PL</a>
	<a href="entries/LightweightJava.html">LightweightJava</a>
	<a href="entries/CoreC++.html">CoreC++</a>
	<a href="entries/FeatherweightJava.html">FeatherweightJava</a>
	<a href="entries/Jinja.html">Jinja</a>
	<a href="entries/JinjaThreads.html">JinjaThreads</a>
	<a href="entries/Locally-Nameless-Sigma.html">Locally-Nameless-Sigma</a>
	<a href="entries/AutoFocus-Stream.html">AutoFocus-Stream</a>
	<a href="entries/FocusStreamsCaseStudies.html">FocusStreamsCaseStudies</a>
	<a href="entries/Isabelle_Meta_Model.html">Isabelle_Meta_Model</a>
	<a href="entries/Simpl.html">Simpl</a>
	<a href="entries/Complx.html">Complx</a>
	<a href="entries/Safe_OCL.html">Safe_OCL</a>
	<a href="entries/Isabelle_C.html">Isabelle_C</a>
	<a href="entries/JinjaDCI.html">JinjaDCI</a>
	<strong>Lambda calculi:</strong>
	<a href="entries/Higher_Order_Terms.html">Higher_Order_Terms</a>
	<a href="entries/Launchbury.html">Launchbury</a>
	<a href="entries/PCF.html">PCF</a>
	<a href="entries/POPLmark-deBruijn.html">POPLmark-deBruijn</a>
	<a href="entries/Lam-ml-Normalization.html">Lam-ml-Normalization</a>
	<a href="entries/LambdaMu.html">LambdaMu</a>
	<a href="entries/Binding_Syntax_Theory.html">Binding_Syntax_Theory</a>
	<a href="entries/LambdaAuth.html">LambdaAuth</a>
	<strong>Type systems:</strong>
	<a href="entries/Name_Carrying_Type_Inference.html">Name_Carrying_Type_Inference</a>
	<a href="entries/MiniML.html">MiniML</a>
	<a href="entries/Possibilistic_Noninterference.html">Possibilistic_Noninterference</a>
	<a href="entries/SIFUM_Type_Systems.html">SIFUM_Type_Systems</a>
	<a href="entries/Dependent_SIFUM_Type_Systems.html">Dependent_SIFUM_Type_Systems</a>
	<a href="entries/Strong_Security.html">Strong_Security</a>
	<a href="entries/WHATandWHERE_Security.html">WHATandWHERE_Security</a>
	<a href="entries/VolpanoSmith.html">VolpanoSmith</a>
	<a href="entries/Physical_Quantities.html">Physical_Quantities</a>
	<a href="entries/MiniSail.html">MiniSail</a>
	<strong>Logics:</strong>
	<a href="entries/ConcurrentIMP.html">ConcurrentIMP</a>
	<a href="entries/Refine_Monadic.html">Refine_Monadic</a>
	<a href="entries/Automatic_Refinement.html">Automatic_Refinement</a>
	<a href="entries/MonoBoolTranAlgebra.html">MonoBoolTranAlgebra</a>
	<a href="entries/Simpl.html">Simpl</a>
	<a href="entries/Separation_Algebra.html">Separation_Algebra</a>
	<a href="entries/Separation_Logic_Imperative_HOL.html">Separation_Logic_Imperative_HOL</a>
	<a href="entries/Relational-Incorrectness-Logic.html">Relational-Incorrectness-Logic</a>
	<a href="entries/Abstract-Hoare-Logics.html">Abstract-Hoare-Logics</a>
	<a href="entries/Kleene_Algebra.html">Kleene_Algebra</a>
	<a href="entries/KAT_and_DRA.html">KAT_and_DRA</a>
	<a href="entries/KAD.html">KAD</a>
	<a href="entries/BytecodeLogicJmlTypes.html">BytecodeLogicJmlTypes</a>
	<a href="entries/DataRefinementIBP.html">DataRefinementIBP</a>
	<a href="entries/RefinementReactive.html">RefinementReactive</a>
	<a href="entries/SIFPL.html">SIFPL</a>
	<a href="entries/TLA.html">TLA</a>
	<a href="entries/Ribbon_Proofs.html">Ribbon_Proofs</a>
	<a href="entries/Separata.html">Separata</a>
	<a href="entries/Complx.html">Complx</a>
	<a href="entries/Differential_Dynamic_Logic.html">Differential_Dynamic_Logic</a>
	<a href="entries/Hoare_Time.html">Hoare_Time</a>
	<a href="entries/IMP2.html">IMP2</a>
	<a href="entries/UTP.html">UTP</a>
	<a href="entries/QHLProver.html">QHLProver</a>
	<a href="entries/Differential_Game_Logic.html">Differential_Game_Logic</a>
	<a href="entries/Correctness_Algebras.html">Correctness_Algebras</a>
	<a href="entries/Registers.html">Registers</a>
	<strong>Compiling:</strong>
	<a href="entries/CakeML_Codegen.html">CakeML_Codegen</a>
	<a href="entries/Compiling-Exceptions-Correctly.html">Compiling-Exceptions-Correctly</a>
	<a href="entries/NormByEval.html">NormByEval</a>
	<a href="entries/Density_Compiler.html">Density_Compiler</a>
	<a href="entries/VeriComp.html">VeriComp</a>
	<a href="entries/IMP_Compiler.html">IMP_Compiler</a>
	<strong>Static analysis:</strong>
	<a href="entries/RIPEMD-160-SPARK.html">RIPEMD-160-SPARK</a>
	<a href="entries/Program-Conflict-Analysis.html">Program-Conflict-Analysis</a>
	<a href="entries/Shivers-CFA.html">Shivers-CFA</a>
	<a href="entries/Slicing.html">Slicing</a>
	<a href="entries/HRB-Slicing.html">HRB-Slicing</a>
	<a href="entries/InfPathElimination.html">InfPathElimination</a>
	<a href="entries/Abs_Int_ITP2012.html">Abs_Int_ITP2012</a>
	<a href="entries/Dominance_CHK.html">Dominance_CHK</a>
	<strong>Transformations:</strong>
	<a href="entries/Call_Arity.html">Call_Arity</a>
	<a href="entries/Refine_Imperative_HOL.html">Refine_Imperative_HOL</a>
	<a href="entries/WorkerWrapper.html">WorkerWrapper</a>
	<a href="entries/Monad_Memo_DP.html">Monad_Memo_DP</a>
	<a href="entries/Formal_SSA.html">Formal_SSA</a>
	<a href="entries/Minimal_SSA.html">Minimal_SSA</a>
	<strong>Misc:</strong>
	<a href="entries/JiveDataStoreModel.html">JiveDataStoreModel</a>
	<a href="entries/Pop_Refinement.html">Pop_Refinement</a>
	<a href="entries/Case_Labeling.html">Case_Labeling</a>
	<a href="entries/Interpreter_Optimizations.html">Interpreter_Optimizations</a>
	</div>
	<h3>Security</h3>
	<div class="list">
	<a href="entries/Multi_Party_Computation.html">Multi_Party_Computation</a>
	<a href="entries/Noninterference_Generic_Unwinding.html">Noninterference_Generic_Unwinding</a>
	<a href="entries/Noninterference_Ipurge_Unwinding.html">Noninterference_Ipurge_Unwinding</a>
	<a href="entries/Relational_Method.html">Relational_Method</a>
	<a href="entries/UPF.html">UPF</a>
	<a href="entries/UPF_Firewall.html">UPF_Firewall</a>
	<a href="entries/CISC-Kernel.html">CISC-Kernel</a>
	<a href="entries/Noninterference_CSP.html">Noninterference_CSP</a>
	<a href="entries/Key_Agreement_Strong_Adversaries.html">Key_Agreement_Strong_Adversaries</a>
	<a href="entries/Security_Protocol_Refinement.html">Security_Protocol_Refinement</a>
	<a href="entries/Attack_Trees.html">Attack_Trees</a>
	<a href="entries/Inductive_Confidentiality.html">Inductive_Confidentiality</a>
	<a href="entries/Possibilistic_Noninterference.html">Possibilistic_Noninterference</a>
	<a href="entries/SIFUM_Type_Systems.html">SIFUM_Type_Systems</a>
	<a href="entries/Dependent_SIFUM_Type_Systems.html">Dependent_SIFUM_Type_Systems</a>
	<a href="entries/Dependent_SIFUM_Refinement.html">Dependent_SIFUM_Refinement</a>
	<a href="entries/Relational-Incorrectness-Logic.html">Relational-Incorrectness-Logic</a>
	<a href="entries/Strong_Security.html">Strong_Security</a>
	<a href="entries/WHATandWHERE_Security.html">WHATandWHERE_Security</a>
	<a href="entries/VolpanoSmith.html">VolpanoSmith</a>
	<a href="entries/SIFPL.html">SIFPL</a>
	<a href="entries/HotelKeyCards.html">HotelKeyCards</a>
	<a href="entries/InformationFlowSlicing.html">InformationFlowSlicing</a>
	<a href="entries/InformationFlowSlicing_Inter.html">InformationFlowSlicing_Inter</a>
	<a href="entries/CryptoBasedCompositionalProperties.html">CryptoBasedCompositionalProperties</a>
	<a href="entries/Probabilistic_Noninterference.html">Probabilistic_Noninterference</a>
	<a href="entries/HyperCTL.html">HyperCTL</a>
	<a href="entries/Bounded_Deducibility_Security.html">Bounded_Deducibility_Security</a>
	<a href="entries/Network_Security_Policy_Verification.html">Network_Security_Policy_Verification</a>
	<a href="entries/Noninterference_Inductive_Unwinding.html">Noninterference_Inductive_Unwinding</a>
	<a href="entries/Password_Authentication_Protocol.html">Password_Authentication_Protocol</a>
	<a href="entries/Noninterference_Sequential_Composition.html">Noninterference_Sequential_Composition</a>
	<a href="entries/Noninterference_Concurrent_Composition.html">Noninterference_Concurrent_Composition</a>
	<a href="entries/SPARCv8.html">SPARCv8</a>
	<a href="entries/Modular_Assembly_Kit_Security.html">Modular_Assembly_Kit_Security</a>
	<a href="entries/LambdaAuth.html">LambdaAuth</a>
	<a href="entries/Stateful_Protocol_Composition_and_Typing.html">Stateful_Protocol_Composition_and_Typing</a>
	<a href="entries/Automated_Stateful_Protocol_Verification.html">Automated_Stateful_Protocol_Verification</a>
	<a href="entries/IFC_Tracking.html">IFC_Tracking</a>
	<a href="entries/CoCon.html">CoCon</a>
	<a href="entries/BD_Security_Compositional.html">BD_Security_Compositional</a>
	<a href="entries/CoSMed.html">CoSMed</a>
	<a href="entries/CoSMeDis.html">CoSMeDis</a>
	<a href="entries/Logging_Independent_Anonymity.html">Logging_Independent_Anonymity</a>
	<strong>Cryptography:</strong>
	<a href="entries/Game_Based_Crypto.html">Game_Based_Crypto</a>
	<a href="entries/Sigma_Commit_Crypto.html">Sigma_Commit_Crypto</a>
	<a href="entries/CryptHOL.html">CryptHOL</a>
	<a href="entries/Constructive_Cryptography.html">Constructive_Cryptography</a>
	<a href="entries/RSAPSS.html">RSAPSS</a>
	<a href="entries/Elliptic_Curves_Group_Law.html">Elliptic_Curves_Group_Law</a>
	<a href="entries/Constructive_Cryptography_CM.html">Constructive_Cryptography_CM</a>
	</div>
	<h3>Semantics</h3>
	<div class="list">
	<a href="entries/Launchbury.html">Launchbury</a>
	<a href="entries/Clean.html">Clean</a>
	<a href="entries/Transformer_Semantics.html">Transformer_Semantics</a>
	<a href="entries/HOL-CSP.html">HOL-CSP</a>
	<a href="entries/QHLProver.html">QHLProver</a>
	<a href="entries/TESL_Language.html">TESL_Language</a>
	<a href="entries/Isabelle_C.html">Isabelle_C</a>
	<a href="entries/CSP_RefTK.html">CSP_RefTK</a>
	<a href="entries/X86_Semantics.html">X86_Semantics</a>
	<a href="entries/Registers.html">Registers</a>
	+ <a href="entries/Quasi_Borel_Spaces.html">Quasi_Borel_Spaces</a>
	</div>
	<h3>System description languages</h3>
	<div class="list">
	<a href="entries/Circus.html">Circus</a>
	<a href="entries/ComponentDependencies.html">ComponentDependencies</a>
	<a href="entries/Promela.html">Promela</a>
	<a href="entries/Featherweight_OCL.html">Featherweight_OCL</a>
	<a href="entries/DynamicArchitectures.html">DynamicArchitectures</a>
	<a href="entries/Architectural_Design_Patterns.html">Architectural_Design_Patterns</a>
	<a href="entries/TESL_Language.html">TESL_Language</a>
	</div>
	<h2>Logic</h2>
	<div class="list">
	</div>
	<h3>Philosophical aspects</h3>
	<div class="list">
	<a href="entries/GoedelGod.html">GoedelGod</a>
	<a href="entries/Types_Tableaus_and_Goedels_God.html">Types_Tableaus_and_Goedels_God</a>
	<a href="entries/GewirthPGCProof.html">GewirthPGCProof</a>
	<a href="entries/Lowe_Ontological_Argument.html">Lowe_Ontological_Argument</a>
	<a href="entries/AnselmGod.html">AnselmGod</a>
	<a href="entries/PLM.html">PLM</a>
	<a href="entries/Aristotles_Assertoric_Syllogistic.html">Aristotles_Assertoric_Syllogistic</a>
	<a href="entries/Mereology.html">Mereology</a>
	<a href="entries/SimplifiedOntologicalArgument.html">SimplifiedOntologicalArgument</a>
	</div>
	<h3>General logic</h3>
	<div class="list">
	<a href="entries/Topological_Semantics.html">Topological_Semantics</a>
	<a href="entries/Metalogic_ProofChecker.html">Metalogic_ProofChecker</a>
	<strong>Classical propositional logic:</strong>
	<a href="entries/Free-Boolean-Algebra.html">Free-Boolean-Algebra</a>
	<strong>Classical first-order logic:</strong>
	<a href="entries/FOL-Fitting.html">FOL-Fitting</a>
	+ <a href="entries/FOL_Seq_Calc2.html">FOL_Seq_Calc2</a>
	<a href="entries/FOL_Axiomatic.html">FOL_Axiomatic</a>
	+ <a href="entries/Eval_FO.html">Eval_FO</a>
	<strong>Decidability of theories:</strong>
	<a href="entries/MSO_Regex_Equivalence.html">MSO_Regex_Equivalence</a>
	<a href="entries/Formula_Derivatives.html">Formula_Derivatives</a>
	<a href="entries/Presburger-Automata.html">Presburger-Automata</a>
	<a href="entries/LinearQuantifierElim.html">LinearQuantifierElim</a>
	<strong>Mechanization of proofs:</strong>
	<a href="entries/Boolean_Expression_Checkers.html">Boolean_Expression_Checkers</a>
	<a href="entries/Verified-Prover.html">Verified-Prover</a>
	<a href="entries/Sort_Encodings.html">Sort_Encodings</a>
	<a href="entries/PropResPI.html">PropResPI</a>
	<a href="entries/Resolution_FOL.html">Resolution_FOL</a>
	<a href="entries/FOL_Harrison.html">FOL_Harrison</a>
	<a href="entries/Ordered_Resolution_Prover.html">Ordered_Resolution_Prover</a>
	<a href="entries/Functional_Ordered_Resolution_Prover.html">Functional_Ordered_Resolution_Prover</a>
	<a href="entries/Binding_Syntax_Theory.html">Binding_Syntax_Theory</a>
	+ <a href="entries/FOL_Seq_Calc2.html">FOL_Seq_Calc2</a>
	<a href="entries/Saturation_Framework.html">Saturation_Framework</a>
	<a href="entries/Saturation_Framework_Extensions.html">Saturation_Framework_Extensions</a>
	<strong>Lambda calculus:</strong>
	<a href="entries/LambdaMu.html">LambdaMu</a>
	<strong>Logics of knowledge and belief:</strong>
	<a href="entries/Epistemic_Logic.html">Epistemic_Logic</a>
	<a href="entries/Blue_Eyes.html">Blue_Eyes</a>
	<a href="entries/Public_Announcement_Logic.html">Public_Announcement_Logic</a>
	<a href="entries/Belief_Revision.html">Belief_Revision</a>
	<a href="entries/PAL.html">PAL</a>
	<strong>Temporal logic:</strong>
	<a href="entries/Nat-Interval-Logic.html">Nat-Interval-Logic</a>
	<a href="entries/LTL.html">LTL</a>
	<a href="entries/HyperCTL.html">HyperCTL</a>
	<a href="entries/Allen_Calculus.html">Allen_Calculus</a>
	<a href="entries/MFOTL_Monitor.html">MFOTL_Monitor</a>
	<a href="entries/LTL_Normal_Form.html">LTL_Normal_Form</a>
	<strong>Modal logic:</strong>
	<a href="entries/Modal_Logics_for_NTS.html">Modal_Logics_for_NTS</a>
	<a href="entries/Differential_Dynamic_Logic.html">Differential_Dynamic_Logic</a>
	<a href="entries/Hybrid_Multi_Lane_Spatial_Logic.html">Hybrid_Multi_Lane_Spatial_Logic</a>
	<a href="entries/Hybrid_Logic.html">Hybrid_Logic</a>
	<a href="entries/MFODL_Monitor_Optimized.html">MFODL_Monitor_Optimized</a>
	<a href="entries/SimplifiedOntologicalArgument.html">SimplifiedOntologicalArgument</a>
	<strong>Paraconsistent logics:</strong>
	<a href="entries/Paraconsistency.html">Paraconsistency</a>
	</div>
	<h3>Computability</h3>
	<div class="list">
	<a href="entries/Universal_Turing_Machine.html">Universal_Turing_Machine</a>
	<a href="entries/Recursion-Theory-I.html">Recursion-Theory-I</a>
	<a href="entries/Inductive_Inference.html">Inductive_Inference</a>
	<a href="entries/Minsky_Machines.html">Minsky_Machines</a>
	</div>
	<h3>Set theory</h3>
	<div class="list">
	<a href="entries/Ordinal.html">Ordinal</a>
	<a href="entries/Ordinals_and_Cardinals.html">Ordinals_and_Cardinals</a>
	<a href="entries/HereditarilyFinite.html">HereditarilyFinite</a>
	<a href="entries/ZFC_in_HOL.html">ZFC_in_HOL</a>
	<a href="entries/Forcing.html">Forcing</a>
	<a href="entries/Delta_System_Lemma.html">Delta_System_Lemma</a>
	<a href="entries/Recursion-Addition.html">Recursion-Addition</a>
	<a href="entries/Ordinal_Partitions.html">Ordinal_Partitions</a>
	<a href="entries/CZH_Foundations.html">CZH_Foundations</a>
	+ <a href="entries/Wetzels_Problem.html">Wetzels_Problem</a>
	</div>
	<h3>Proof theory</h3>
	<div class="list">
	<a href="entries/Propositional_Proof_Systems.html">Propositional_Proof_Systems</a>
	<a href="entries/Completeness.html">Completeness</a>
	<a href="entries/SequentInvertibility.html">SequentInvertibility</a>
	<a href="entries/Incompleteness.html">Incompleteness</a>
	<a href="entries/Abstract_Completeness.html">Abstract_Completeness</a>
	<a href="entries/SuperCalc.html">SuperCalc</a>
	<a href="entries/Incredible_Proof_Machine.html">Incredible_Proof_Machine</a>
	<a href="entries/Surprise_Paradox.html">Surprise_Paradox</a>
	<a href="entries/Abstract_Soundness.html">Abstract_Soundness</a>
	<a href="entries/Syntax_Independent_Logic.html">Syntax_Independent_Logic</a>
	<a href="entries/Goedel_Incompleteness.html">Goedel_Incompleteness</a>
	<a href="entries/Goedel_HFSet_Semantic.html">Goedel_HFSet_Semantic</a>
	<a href="entries/Goedel_HFSet_Semanticless.html">Goedel_HFSet_Semanticless</a>
	<a href="entries/Robinson_Arithmetic.html">Robinson_Arithmetic</a>
	<a href="entries/FOL_Seq_Calc1.html">FOL_Seq_Calc1</a>
	+ <a href="entries/FOL_Seq_Calc2.html">FOL_Seq_Calc2</a>
	<a href="entries/FOL_Axiomatic.html">FOL_Axiomatic</a>
	+ <a href="entries/FO_Theory_Rewriting.html">FO_Theory_Rewriting</a>
	</div>
	<h3>Rewriting</h3>
	<div class="list">
	<a href="entries/CakeML_Codegen.html">CakeML_Codegen</a>
	<a href="entries/Monad_Normalisation.html">Monad_Normalisation</a>
	<a href="entries/Lambda_Free_RPOs.html">Lambda_Free_RPOs</a>
	<a href="entries/Lambda_Free_KBOs.html">Lambda_Free_KBOs</a>
	<a href="entries/Lambda_Free_EPO.html">Lambda_Free_EPO</a>
	<a href="entries/Nested_Multisets_Ordinals.html">Nested_Multisets_Ordinals</a>
	<a href="entries/Abstract-Rewriting.html">Abstract-Rewriting</a>
	<a href="entries/First_Order_Terms.html">First_Order_Terms</a>
	<a href="entries/Decreasing-Diagrams.html">Decreasing-Diagrams</a>
	<a href="entries/Decreasing-Diagrams-II.html">Decreasing-Diagrams-II</a>
	<a href="entries/Rewriting_Z.html">Rewriting_Z</a>
	<a href="entries/Graph_Saturation.html">Graph_Saturation</a>
	<a href="entries/Goodstein_Lambda.html">Goodstein_Lambda</a>
	<a href="entries/Knuth_Bendix_Order.html">Knuth_Bendix_Order</a>
	<a href="entries/Weighted_Path_Order.html">Weighted_Path_Order</a>
	+ <a href="entries/FO_Theory_Rewriting.html">FO_Theory_Rewriting</a>
	</div>
	<h2>Mathematics</h2>
	<div class="list">
	</div>
	<h3>Order</h3>
	<div class="list">
	<a href="entries/LatticeProperties.html">LatticeProperties</a>
	<a href="entries/Stone_Algebras.html">Stone_Algebras</a>
	<a href="entries/Allen_Calculus.html">Allen_Calculus</a>
	<a href="entries/Order_Lattice_Props.html">Order_Lattice_Props</a>
	<a href="entries/Complete_Non_Orders.html">Complete_Non_Orders</a>
	<a href="entries/Szpilrajn.html">Szpilrajn</a>
	</div>
	<h3>Algebra</h3>
	<div class="list">
	<a href="entries/Optics.html">Optics</a>
	<a href="entries/Subresultants.html">Subresultants</a>
	<a href="entries/Buildings.html">Buildings</a>
	<a href="entries/Algebraic_VCs.html">Algebraic_VCs</a>
	<a href="entries/C2KA_DistributedSystems.html">C2KA_DistributedSystems</a>
	<a href="entries/Multirelations.html">Multirelations</a>
	<a href="entries/Residuated_Lattices.html">Residuated_Lattices</a>
	<a href="entries/PseudoHoops.html">PseudoHoops</a>
	<a href="entries/Impossible_Geometry.html">Impossible_Geometry</a>
	<a href="entries/Gauss-Jordan-Elim-Fun.html">Gauss-Jordan-Elim-Fun</a>
	<a href="entries/Matrix_Tensor.html">Matrix_Tensor</a>
	<a href="entries/Kleene_Algebra.html">Kleene_Algebra</a>
	<a href="entries/KAT_and_DRA.html">KAT_and_DRA</a>
	<a href="entries/KAD.html">KAD</a>
	<a href="entries/Regular_Algebras.html">Regular_Algebras</a>
	<a href="entries/Free-Groups.html">Free-Groups</a>
	<a href="entries/CofGroups.html">CofGroups</a>
	<a href="entries/Finitely_Generated_Abelian_Groups.html">Finitely_Generated_Abelian_Groups</a>
	<a href="entries/Group-Ring-Module.html">Group-Ring-Module</a>
	<a href="entries/Robbins-Conjecture.html">Robbins-Conjecture</a>
	<a href="entries/Valuation.html">Valuation</a>
	<a href="entries/Rank_Nullity_Theorem.html">Rank_Nullity_Theorem</a>
	<a href="entries/Polynomials.html">Polynomials</a>
	<a href="entries/Relation_Algebra.html">Relation_Algebra</a>
	<a href="entries/PSemigroupsConvolution.html">PSemigroupsConvolution</a>
	<a href="entries/Secondary_Sylow.html">Secondary_Sylow</a>
	<a href="entries/Jordan_Hoelder.html">Jordan_Hoelder</a>
	<a href="entries/Cayley_Hamilton.html">Cayley_Hamilton</a>
	<a href="entries/VectorSpace.html">VectorSpace</a>
	<a href="entries/Echelon_Form.html">Echelon_Form</a>
	<a href="entries/QR_Decomposition.html">QR_Decomposition</a>
	<a href="entries/Hermite.html">Hermite</a>
	<a href="entries/Rep_Fin_Groups.html">Rep_Fin_Groups</a>
	<a href="entries/Jordan_Normal_Form.html">Jordan_Normal_Form</a>
	<a href="entries/Algebraic_Numbers.html">Algebraic_Numbers</a>
	<a href="entries/Polynomial_Interpolation.html">Polynomial_Interpolation</a>
	<a href="entries/Polynomial_Factorization.html">Polynomial_Factorization</a>
	<a href="entries/Perron_Frobenius.html">Perron_Frobenius</a>
	<a href="entries/Stochastic_Matrices.html">Stochastic_Matrices</a>
	<a href="entries/Groebner_Bases.html">Groebner_Bases</a>
	<a href="entries/Nullstellensatz.html">Nullstellensatz</a>
	<a href="entries/Mason_Stothers.html">Mason_Stothers</a>
	<a href="entries/Berlekamp_Zassenhaus.html">Berlekamp_Zassenhaus</a>
	<a href="entries/Stone_Relation_Algebras.html">Stone_Relation_Algebras</a>
	<a href="entries/Stone_Kleene_Relation_Algebras.html">Stone_Kleene_Relation_Algebras</a>
	<a href="entries/Orbit_Stabiliser.html">Orbit_Stabiliser</a>
	<a href="entries/Dirichlet_L.html">Dirichlet_L</a>
	<a href="entries/Symmetric_Polynomials.html">Symmetric_Polynomials</a>
	<a href="entries/Taylor_Models.html">Taylor_Models</a>
	<a href="entries/LLL_Basis_Reduction.html">LLL_Basis_Reduction</a>
	<a href="entries/LLL_Factorization.html">LLL_Factorization</a>
	<a href="entries/Localization_Ring.html">Localization_Ring</a>
	<a href="entries/Quaternions.html">Quaternions</a>
	<a href="entries/Octonions.html">Octonions</a>
	<a href="entries/Aggregation_Algebras.html">Aggregation_Algebras</a>
	<a href="entries/Signature_Groebner.html">Signature_Groebner</a>
	<a href="entries/Quantales.html">Quantales</a>
	<a href="entries/Transformer_Semantics.html">Transformer_Semantics</a>
	<a href="entries/Farkas.html">Farkas</a>
	<a href="entries/Groebner_Macaulay.html">Groebner_Macaulay</a>
	<a href="entries/Linear_Inequalities.html">Linear_Inequalities</a>
	<a href="entries/Linear_Programming.html">Linear_Programming</a>
	<a href="entries/Jacobson_Basic_Algebra.html">Jacobson_Basic_Algebra</a>
	<a href="entries/Hybrid_Systems_VCs.html">Hybrid_Systems_VCs</a>
	<a href="entries/Subset_Boolean_Algebras.html">Subset_Boolean_Algebras</a>
	<a href="entries/Power_Sum_Polynomials.html">Power_Sum_Polynomials</a>
	<a href="entries/Formal_Puiseux_Series.html">Formal_Puiseux_Series</a>
	<a href="entries/Matrices_for_ODEs.html">Matrices_for_ODEs</a>
	<a href="entries/Smith_Normal_Form.html">Smith_Normal_Form</a>
	<a href="entries/Grothendieck_Schemes.html">Grothendieck_Schemes</a>
	<a href="entries/Factor_Algebraic_Polynomial.html">Factor_Algebraic_Polynomial</a>
	<a href="entries/Hyperdual.html">Hyperdual</a>
	+ <a href="entries/Interpolation_Polynomials_HOL_Algebra.html">Interpolation_Polynomials_HOL_Algebra</a>
	+ <a href="entries/LP_Duality.html">LP_Duality</a>
	</div>
	<h3>Analysis</h3>
	<div class="list">
	<a href="entries/Banach_Steinhaus.html">Banach_Steinhaus</a>
	<a href="entries/Fourier.html">Fourier</a>
	<a href="entries/E_Transcendental.html">E_Transcendental</a>
	<a href="entries/Liouville_Numbers.html">Liouville_Numbers</a>
	<a href="entries/Descartes_Sign_Rule.html">Descartes_Sign_Rule</a>
	<a href="entries/Euler_MacLaurin.html">Euler_MacLaurin</a>
	<a href="entries/Real_Impl.html">Real_Impl</a>
	<a href="entries/Lower_Semicontinuous.html">Lower_Semicontinuous</a>
	<a href="entries/Affine_Arithmetic.html">Affine_Arithmetic</a>
	<a href="entries/Laplace_Transform.html">Laplace_Transform</a>
	<a href="entries/Cauchy.html">Cauchy</a>
	<a href="entries/Integration.html">Integration</a>
	<a href="entries/Ordinary_Differential_Equations.html">Ordinary_Differential_Equations</a>
	<a href="entries/Polynomials.html">Polynomials</a>
	<a href="entries/Sqrt_Babylonian.html">Sqrt_Babylonian</a>
	<a href="entries/Sturm_Sequences.html">Sturm_Sequences</a>
	<a href="entries/Sturm_Tarski.html">Sturm_Tarski</a>
	<a href="entries/Special_Function_Bounds.html">Special_Function_Bounds</a>
	<a href="entries/Landau_Symbols.html">Landau_Symbols</a>
	<a href="entries/Error_Function.html">Error_Function</a>
	<a href="entries/Akra_Bazzi.html">Akra_Bazzi</a>
	<a href="entries/Zeta_Function.html">Zeta_Function</a>
	<a href="entries/Linear_Recurrences.html">Linear_Recurrences</a>
	<a href="entries/Lambert_W.html">Lambert_W</a>
	<a href="entries/Cartan_FP.html">Cartan_FP</a>
	<a href="entries/Deep_Learning.html">Deep_Learning</a>
	<a href="entries/Cubic_Quartic_Equations.html">Cubic_Quartic_Equations</a>
	<a href="entries/Real_Power.html">Real_Power</a>
	<a href="entries/Stirling_Formula.html">Stirling_Formula</a>
	<a href="entries/Lp.html">Lp</a>
	<a href="entries/Bernoulli.html">Bernoulli</a>
	<a href="entries/Winding_Number_Eval.html">Winding_Number_Eval</a>
	<a href="entries/Count_Complex_Roots.html">Count_Complex_Roots</a>
	<a href="entries/Taylor_Models.html">Taylor_Models</a>
	<a href="entries/Green.html">Green</a>
	<a href="entries/Irrationality_J_Hancl.html">Irrationality_J_Hancl</a>
	<a href="entries/Budan_Fourier.html">Budan_Fourier</a>
	<a href="entries/Smooth_Manifolds.html">Smooth_Manifolds</a>
	<a href="entries/Transcendence_Series_Hancl_Rucki.html">Transcendence_Series_Hancl_Rucki</a>
	<a href="entries/Hybrid_Systems_VCs.html">Hybrid_Systems_VCs</a>
	<a href="entries/Poincare_Bendixson.html">Poincare_Bendixson</a>
	<a href="entries/Matrices_for_ODEs.html">Matrices_for_ODEs</a>
	<a href="entries/Irrational_Series_Erdos_Straus.html">Irrational_Series_Erdos_Straus</a>
	<a href="entries/Three_Circles.html">Three_Circles</a>
	<a href="entries/Complex_Bounded_Operators.html">Complex_Bounded_Operators</a>
	<a href="entries/Hyperdual.html">Hyperdual</a>
	+ <a href="entries/Youngs_Inequality.html">Youngs_Inequality</a>
	+ <a href="entries/Wetzels_Problem.html">Wetzels_Problem</a>
	</div>
	<h3>Measure theory</h3>
	<div class="list">
	<a href="entries/Hahn_Jordan_Decomposition.html">Hahn_Jordan_Decomposition</a>
	</div>
	<h3>Probability theory</h3>
	<div class="list">
	<a href="entries/DiscretePricing.html">DiscretePricing</a>
	<a href="entries/CryptHOL.html">CryptHOL</a>
	<a href="entries/Constructive_Cryptography.html">Constructive_Cryptography</a>
	<a href="entries/Probabilistic_While.html">Probabilistic_While</a>
	<a href="entries/Markov_Models.html">Markov_Models</a>
	<a href="entries/MDP-Rewards.html">MDP-Rewards</a>
	<a href="entries/MDP-Algorithms.html">MDP-Algorithms</a>
	<a href="entries/Density_Compiler.html">Density_Compiler</a>
	<a href="entries/Probabilistic_Timed_Automata.html">Probabilistic_Timed_Automata</a>
	<a href="entries/Hidden_Markov_Models.html">Hidden_Markov_Models</a>
	<a href="entries/Random_Graph_Subgraph_Threshold.html">Random_Graph_Subgraph_Threshold</a>
	<a href="entries/Ergodic_Theory.html">Ergodic_Theory</a>
	<a href="entries/Source_Coding_Theorem.html">Source_Coding_Theorem</a>
	<a href="entries/Buffons_Needle.html">Buffons_Needle</a>
	<a href="entries/Laws_of_Large_Numbers.html">Laws_of_Large_Numbers</a>
	<a href="entries/Constructive_Cryptography_CM.html">Constructive_Cryptography_CM</a>
	+ <a href="entries/Median_Method.html">Median_Method</a>
	+ <a href="entries/Universal_Hash_Families.html">Universal_Hash_Families</a>
	</div>
	<h3>Number theory</h3>
	<div class="list">
	<a href="entries/Arith_Prog_Rel_Primes.html">Arith_Prog_Rel_Primes</a>
	<a href="entries/Pell.html">Pell</a>
	<a href="entries/Minkowskis_Theorem.html">Minkowskis_Theorem</a>
	<a href="entries/E_Transcendental.html">E_Transcendental</a>
	<a href="entries/Pi_Transcendental.html">Pi_Transcendental</a>
	<a href="entries/Hermite_Lindemann.html">Hermite_Lindemann</a>
	<a href="entries/Liouville_Numbers.html">Liouville_Numbers</a>
	<a href="entries/Prime_Harmonic_Series.html">Prime_Harmonic_Series</a>
	<a href="entries/Fermat3_4.html">Fermat3_4</a>
	<a href="entries/Perfect-Number-Thm.html">Perfect-Number-Thm</a>
	<a href="entries/SumSquares.html">SumSquares</a>
	<a href="entries/Lehmer.html">Lehmer</a>
	<a href="entries/Pratt_Certificate.html">Pratt_Certificate</a>
	<a href="entries/Dirichlet_Series.html">Dirichlet_Series</a>
	<a href="entries/Gauss_Sums.html">Gauss_Sums</a>
	<a href="entries/Zeta_Function.html">Zeta_Function</a>
	<a href="entries/Stern_Brocot.html">Stern_Brocot</a>
	<a href="entries/Bertrands_Postulate.html">Bertrands_Postulate</a>
	<a href="entries/Bernoulli.html">Bernoulli</a>
	<a href="entries/Diophantine_Eqns_Lin_Hom.html">Diophantine_Eqns_Lin_Hom</a>
	<a href="entries/Dirichlet_L.html">Dirichlet_L</a>
	<a href="entries/Mersenne_Primes.html">Mersenne_Primes</a>
	<a href="entries/Irrationality_J_Hancl.html">Irrationality_J_Hancl</a>
	<a href="entries/Prime_Number_Theorem.html">Prime_Number_Theorem</a>
	<a href="entries/Probabilistic_Prime_Tests.html">Probabilistic_Prime_Tests</a>
	<a href="entries/Prime_Distribution_Elementary.html">Prime_Distribution_Elementary</a>
	<a href="entries/Transcendence_Series_Hancl_Rucki.html">Transcendence_Series_Hancl_Rucki</a>
	<a href="entries/Zeta_3_Irrational.html">Zeta_3_Irrational</a>
	<a href="entries/Furstenberg_Topology.html">Furstenberg_Topology</a>
	<a href="entries/Lucas_Theorem.html">Lucas_Theorem</a>
	<a href="entries/Gaussian_Integers.html">Gaussian_Integers</a>
	<a href="entries/Irrational_Series_Erdos_Straus.html">Irrational_Series_Erdos_Straus</a>
	<a href="entries/Amicable_Numbers.html">Amicable_Numbers</a>
	<a href="entries/Padic_Ints.html">Padic_Ints</a>
	<a href="entries/Lifting_the_Exponent.html">Lifting_the_Exponent</a>
	+ <a href="entries/Irrationals_From_THEBOOK.html">Irrationals_From_THEBOOK</a>
	</div>
	<h3>Games and economics</h3>
	<div class="list">
	<a href="entries/DiscretePricing.html">DiscretePricing</a>
	<a href="entries/ArrowImpossibilityGS.html">ArrowImpossibilityGS</a>
	<a href="entries/SenSocialChoice.html">SenSocialChoice</a>
	<a href="entries/Vickrey_Clarke_Groves.html">Vickrey_Clarke_Groves</a>
	+ <a href="entries/Actuarial_Mathematics.html">Actuarial_Mathematics</a>
	<a href="entries/Parity_Game.html">Parity_Game</a>
	<a href="entries/First_Welfare_Theorem.html">First_Welfare_Theorem</a>
	<a href="entries/Randomised_Social_Choice.html">Randomised_Social_Choice</a>
	<a href="entries/SDS_Impossibility.html">SDS_Impossibility</a>
	<a href="entries/Stable_Matching.html">Stable_Matching</a>
	<a href="entries/Fishburn_Impossibility.html">Fishburn_Impossibility</a>
	<a href="entries/Neumann_Morgenstern_Utility.html">Neumann_Morgenstern_Utility</a>
	<a href="entries/GaleStewart_Games.html">GaleStewart_Games</a>
	<a href="entries/Gale_Shapley.html">Gale_Shapley</a>
	</div>
	<h3>Geometry</h3>
	<div class="list">
	<a href="entries/Complex_Geometry.html">Complex_Geometry</a>
	<a href="entries/Poincare_Disc.html">Poincare_Disc</a>
	<a href="entries/Minkowskis_Theorem.html">Minkowskis_Theorem</a>
	<a href="entries/Buildings.html">Buildings</a>
	<a href="entries/Chord_Segments.html">Chord_Segments</a>
	<a href="entries/Triangle.html">Triangle</a>
	<a href="entries/Impossible_Geometry.html">Impossible_Geometry</a>
	<a href="entries/Tarskis_Geometry.html">Tarskis_Geometry</a>
	<a href="entries/IsaGeoCoq.html">IsaGeoCoq</a>
	<a href="entries/General-Triangle.html">General-Triangle</a>
	<a href="entries/Schutz_Spacetime.html">Schutz_Spacetime</a>
	<a href="entries/Nullstellensatz.html">Nullstellensatz</a>
	<a href="entries/Ptolemys_Theorem.html">Ptolemys_Theorem</a>
	<a href="entries/Buffons_Needle.html">Buffons_Needle</a>
	<a href="entries/Stewart_Apollonius.html">Stewart_Apollonius</a>
	<a href="entries/Gromov_Hyperbolicity.html">Gromov_Hyperbolicity</a>
	<a href="entries/Projective_Geometry.html">Projective_Geometry</a>
	<a href="entries/Quaternions.html">Quaternions</a>
	<a href="entries/Octonions.html">Octonions</a>
	<a href="entries/Grothendieck_Schemes.html">Grothendieck_Schemes</a>
	<a href="entries/Foundation_of_geometry.html">Foundation_of_geometry</a>
	</div>
	<h3>Topology</h3>
	<div class="list">
	<a href="entries/Topology.html">Topology</a>
	<a href="entries/Knot_Theory.html">Knot_Theory</a>
	<a href="entries/Kuratowski_Closure_Complement.html">Kuratowski_Closure_Complement</a>
	<a href="entries/Smooth_Manifolds.html">Smooth_Manifolds</a>
	<a href="entries/Simplicial_complexes_and_boolean_functions.html">Simplicial_complexes_and_boolean_functions</a>
	</div>
	<h3>Graph theory</h3>
	<div class="list">
	<a href="entries/Flow_Networks.html">Flow_Networks</a>
	<a href="entries/Prpu_Maxflow.html">Prpu_Maxflow</a>
	<a href="entries/MFMC_Countable.html">MFMC_Countable</a>
	<a href="entries/ShortestPath.html">ShortestPath</a>
	<a href="entries/Gabow_SCC.html">Gabow_SCC</a>
	<a href="entries/Graph_Theory.html">Graph_Theory</a>
	<a href="entries/Planarity_Certificates.html">Planarity_Certificates</a>
	<a href="entries/Max-Card-Matching.html">Max-Card-Matching</a>
	<a href="entries/Girth_Chromatic.html">Girth_Chromatic</a>
	<a href="entries/Random_Graph_Subgraph_Threshold.html">Random_Graph_Subgraph_Threshold</a>
	<a href="entries/Flyspeck-Tame.html">Flyspeck-Tame</a>
	<a href="entries/Koenigsberg_Friendship.html">Koenigsberg_Friendship</a>
	<a href="entries/Tree_Decomposition.html">Tree_Decomposition</a>
	<a href="entries/Menger.html">Menger</a>
	<a href="entries/Parity_Game.html">Parity_Game</a>
	<a href="entries/Factored_Transition_System_Bounding.html">Factored_Transition_System_Bounding</a>
	<a href="entries/Graph_Saturation.html">Graph_Saturation</a>
	<a href="entries/Relational_Paths.html">Relational_Paths</a>
	<a href="entries/Relational_Forests.html">Relational_Forests</a>
	<a href="entries/Szemeredi_Regularity.html">Szemeredi_Regularity</a>
	<a href="entries/Roth_Arithmetic_Progressions.html">Roth_Arithmetic_Progressions</a>
	<a href="entries/Knights_Tour.html">Knights_Tour</a>
	</div>
	<h3>Combinatorics</h3>
	<div class="list">
	<a href="entries/Card_Equiv_Relations.html">Card_Equiv_Relations</a>
	<a href="entries/Twelvefold_Way.html">Twelvefold_Way</a>
	<a href="entries/Card_Multisets.html">Card_Multisets</a>
	<a href="entries/Card_Partitions.html">Card_Partitions</a>
	<a href="entries/Card_Number_Partitions.html">Card_Number_Partitions</a>
	<a href="entries/Well_Quasi_Orders.html">Well_Quasi_Orders</a>
	<a href="entries/Marriage.html">Marriage</a>
	<a href="entries/Bondy.html">Bondy</a>
	<a href="entries/Ramsey-Infinite.html">Ramsey-Infinite</a>
	<a href="entries/Derangements.html">Derangements</a>
	<a href="entries/Euler_Partition.html">Euler_Partition</a>
	<a href="entries/Discrete_Summation.html">Discrete_Summation</a>
	<a href="entries/Open_Induction.html">Open_Induction</a>
	<a href="entries/Van_der_Waerden.html">Van_der_Waerden</a>
	<a href="entries/Latin_Square.html">Latin_Square</a>
	<a href="entries/Bell_Numbers_Spivey.html">Bell_Numbers_Spivey</a>
	<a href="entries/Catalan_Numbers.html">Catalan_Numbers</a>
	<a href="entries/Falling_Factorial_Sum.html">Falling_Factorial_Sum</a>
	<a href="entries/Matroids.html">Matroids</a>
	<a href="entries/Delta_System_Lemma.html">Delta_System_Lemma</a>
	<a href="entries/Nash_Williams.html">Nash_Williams</a>
	<a href="entries/Ordinal_Partitions.html">Ordinal_Partitions</a>
	<a href="entries/Sunflowers.html">Sunflowers</a>
	<a href="entries/Design_Theory.html">Design_Theory</a>
	<a href="entries/Szemeredi_Regularity.html">Szemeredi_Regularity</a>
	<a href="entries/Roth_Arithmetic_Progressions.html">Roth_Arithmetic_Progressions</a>
	+ <a href="entries/Equivalence_Relation_Enumeration.html">Equivalence_Relation_Enumeration</a>
	</div>
	<h3>Category theory</h3>
	<div class="list">
	<a href="entries/Category3.html">Category3</a>
	<a href="entries/MonoidalCategory.html">MonoidalCategory</a>
	<a href="entries/Category.html">Category</a>
	<a href="entries/Category2.html">Category2</a>
	<a href="entries/AxiomaticCategoryTheory.html">AxiomaticCategoryTheory</a>
	<a href="entries/Bicategory.html">Bicategory</a>
	<a href="entries/CZH_Foundations.html">CZH_Foundations</a>
	<a href="entries/CZH_Elementary_Categories.html">CZH_Elementary_Categories</a>
	<a href="entries/CZH_Universal_Constructions.html">CZH_Universal_Constructions</a>
	</div>
	<h3>Physics</h3>
	<div class="list">
	<a href="entries/No_FTL_observers.html">No_FTL_observers</a>
	<a href="entries/Schutz_Spacetime.html">Schutz_Spacetime</a>
	<a href="entries/Safe_Distance.html">Safe_Distance</a>
	<a href="entries/Physical_Quantities.html">Physical_Quantities</a>
	<strong>Quantum information:</strong>
	<a href="entries/Isabelle_Marries_Dirac.html">Isabelle_Marries_Dirac</a>
	<a href="entries/Projective_Measurements.html">Projective_Measurements</a>
	</div>
	<h3>Misc</h3>
	<div class="list">
	<a href="entries/FunWithFunctions.html">FunWithFunctions</a>
	<a href="entries/FunWithTilings.html">FunWithTilings</a>
	<a href="entries/IMO2019.html">IMO2019</a>
	</div>
	<h2>Tools</h2>
	<div class="list">
	<a href="entries/Monad_Normalisation.html">Monad_Normalisation</a>
	<a href="entries/Constructor_Funs.html">Constructor_Funs</a>
	<a href="entries/Lazy_Case.html">Lazy_Case</a>
	<a href="entries/Dict_Construction.html">Dict_Construction</a>
	<a href="entries/Case_Labeling.html">Case_Labeling</a>
	<a href="entries/DPT-SAT-Solver.html">DPT-SAT-Solver</a>
	<a href="entries/Nominal2.html">Nominal2</a>
	<a href="entries/Separata.html">Separata</a>
	<a href="entries/Proof_Strategy_Language.html">Proof_Strategy_Language</a>
	<a href="entries/Diophantine_Eqns_Lin_Hom.html">Diophantine_Eqns_Lin_Hom</a>
	<a href="entries/BNF_Operations.html">BNF_Operations</a>
	<a href="entries/BNF_CC.html">BNF_CC</a>
	<a href="entries/Auto2_HOL.html">Auto2_HOL</a>
	<a href="entries/Isabelle_C.html">Isabelle_C</a>
	<a href="entries/Automated_Stateful_Protocol_Verification.html">Automated_Stateful_Protocol_Verification</a>
	<a href="entries/SpecCheck.html">SpecCheck</a>
	<a href="entries/Conditional_Simplification.html">Conditional_Simplification</a>
	<a href="entries/Intro_Dest_Elim.html">Intro_Dest_Elim</a>
	<a href="entries/Conditional_Transfer_Rule.html">Conditional_Transfer_Rule</a>
	<a href="entries/Types_To_Sets_Extension.html">Types_To_Sets_Extension</a>
	</div>
	</td>
	</tr>
	</tbody>
	</table>

	</div>
	</td>

	</tr>
	</tbody>
	</table>


	</body>
	</html>
	\ No newline at end of file

File Metadata

Mime Type: application/octet-stream
Expires: Sat, May 11, 1:29 AM (1 d, 23 h)
Storage Engine: chunks
Storage Format: Chunks
Storage Handle: _lbDay1Osr3W
Default Alt Text: (7 MB)

Offset	End	Complete
0	4194304	Yes
4194304	8159981	Yes

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions